Perl_opslab_force_free(pTHX_ OPSLAB *slab)
{
OPSLAB *slab2;
- OPSLOT *slot;
#ifdef DEBUGGING
size_t savestack_count = 0;
#endif
PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
slab2 = slab;
do {
+ OPSLOT *slot;
for (slot = slab2->opslab_first;
slot->opslot_next;
slot = slot->opslot_next) {
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)",
+ yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
(int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
}
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
qerror(Perl_mess(aTHX_
- "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
+ "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}
(UV)flags);
/* complain about "my $<special_var>" etc etc */
- if (len &&
- !(is_our ||
- isALPHA(name[1]) ||
- ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
- (name[1] == '_' && len > 2)))
+ if ( len
+ && !( is_our
+ || isALPHA(name[1])
+ || ( (flags & SVf_UTF8)
+ && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
+ || (name[1] == '_' && len > 2)))
{
if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
&& isASCII(name[1])
op_clear(o);
FreeOp(o);
-#ifdef DEBUG_LEAKING_SCALARS
if (PL_op == o)
PL_op = NULL;
-#endif
} while ( (o = POP_DEFERRED_OP()) );
Safefree(defer_stack);
/* FALLTHROUGH */
case OP_TRANS:
case OP_TRANSR:
- if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
+ if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
+ && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
+ {
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
pad_swipe(cPADOPo->op_padix, TRUE);
case OP_SUBST:
op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
goto clear_pmop;
- case OP_PUSHRE:
+
+ case OP_SPLIT:
+ if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
+ && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
+ {
+ if (o->op_private & OPpSPLIT_LEX)
+ pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
+ else
#ifdef USE_ITHREADS
- if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
- pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
- }
+ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
#else
- SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
+ SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
#endif
+ }
/* FALLTHROUGH */
case OP_MATCH:
case OP_QR:
while (kid) {
switch (kid->op_type) {
case OP_SUBST:
- case OP_PUSHRE:
+ case OP_SPLIT:
case OP_MATCH:
case OP_QR:
forget_pmop((PMOP*)kid);
S_scalar_slice_warning(pTHX_ const OP *o)
{
OP *kid;
+ const bool h = o->op_type == OP_HSLICE
+ || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
const char lbrack =
- o->op_type == OP_HSLICE ? '{' : '[';
+ h ? '{' : '[';
const char rbrack =
- o->op_type == OP_HSLICE ? '}' : ']';
+ h ? '}' : ']';
SV *name;
SV *keysv = NULL; /* just to silence compiler warnings */
const char *key = NULL;
if (key)
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Scalar value @%"SVf"%c%s%c better written as $%"SVf
+ "Scalar value @%" SVf "%c%s%c better written as $%" SVf
"%c%s%c",
SVfARG(name), lbrack, key, rbrack, SVfARG(name),
lbrack, key, rbrack);
else
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
- SVf"%c%"SVf"%c",
+ "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
+ SVf "%c%" SVf "%c",
SVfARG(name), lbrack, SVfARG(keysv), rbrack,
SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
if (key)
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%"SVf"%c%s%c in scalar context better written "
- "as $%"SVf"%c%s%c",
+ "%%%" SVf "%c%s%c in scalar context better written "
+ "as $%" SVf "%c%s%c",
SVfARG(name), lbrack, key, rbrack, SVfARG(name),
lbrack, key, rbrack);
else
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "%%%"SVf"%c%"SVf"%c in scalar context better "
- "written as $%"SVf"%c%"SVf"%c",
+ "%%%" SVf "%c%" SVf "%c in scalar context better "
+ "written as $%" SVf "%c%" SVf "%c",
SVfARG(name), lbrack, SVfARG(keysv), rbrack,
SVfARG(name), lbrack, SVfARG(keysv), rbrack);
}
dVAR;
OP *kid;
SV* sv;
- U8 want;
SSize_t defer_stack_alloc = 0;
SSize_t defer_ix = -1;
OP **defer_stack = NULL;
PERL_ARGS_ASSERT_SCALARVOID;
do {
+ U8 want;
SV *useless_sv = NULL;
const char* useless = NULL;
break;
case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
-#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
-#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
-#endif
- )
+ if (!(o->op_private & OPpSPLIT_ASSIGN))
useless = OP_DESC(o);
break;
SvREFCNT_dec_NN(dsv);
}
else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
}
else
useless = "a constant (undef)";
if (useless_sv) {
/* mortalise it, in case warnings are fatal. */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %"SVf" in void context",
+ "Useless use of %" SVf " in void context",
SVfARG(sv_2mortal(useless_sv)));
}
else if (useless) {
if ( check_fields
&& !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
{
- Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
- "in variable %"PNf" of type %"HEKf,
+ Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
+ "in variable %" PNf " of type %" HEKf,
SVfARG(*svp), PNfARG(lexname),
HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
}
}
+/* do all the final processing on an optree (e.g. running the peephole
+ * optimiser on it), then attach it to cv (if cv is non-null)
+ */
+
+static void
+S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
+{
+ OP **startp;
+
+ /* XXX for some reason, evals, require and main optrees are
+ * never attached to their CV; instead they just hang off
+ * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
+ * and get manually freed when appropriate */
+ if (cv)
+ startp = &CvSTART(cv);
+ else
+ startp = PL_in_eval? &PL_eval_start : &PL_main_start;
+
+ *startp = start;
+ optree->op_private |= OPpREFCOUNTED;
+ OpREFCNT_set(optree, 1);
+ CALL_PEEP(*startp);
+ finalize_optree(optree);
+ S_prune_chain_head(startp);
+
+ if (cv) {
+ /* now that optimizer has done its work, adjust pad values */
+ pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
+ : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ }
+}
+
+
/*
=for apidoc finalize_optree
SV * const sv = sv_newmortal();
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%"SVf"() called too early to check prototype",
+ "%" SVf "() called too early to check prototype",
SVfARG(sv));
}
}
S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
break;
}
+ case OP_NULL:
+ if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
+ break;
+ /* FALLTHROUGH */
case OP_ASLICE:
S_scalar_slice_warning(aTHX_ o);
break;
|| family == OA_FILESTATOP
|| family == OA_LOOPEXOP
|| family == OA_METHOP
- /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
- || type == OP_SASSIGN
|| type == OP_CUSTOM
|| type == OP_NULL /* new_logop does this */
);
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "args: type/targ %ld:%"UVuf,
+ "args: type/targ %ld:%" UVuf,
(long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
}
if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
- "entry via type/targ %ld:%"UVuf,
+ "entry via type/targ %ld:%" UVuf,
(long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
break;
namesv = cv_name(cv, NULL, 0);
yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
- "subroutine call of &%"SVf" in %s",
+ "subroutine call of &%" SVf " in %s",
SVfARG(namesv), PL_op_desc[type]),
SvUTF8(namesv));
return o;
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
+ Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
PNfARG(PAD_COMPNAME(o->op_targ)));
if (!(o->op_private & OPpLVAL_INTRO)
|| ( type != OP_SASSIGN && type != OP_AASSIGN
goto nomod;
else if (!(o->op_flags & OPf_KIDS))
break;
+
if (o->op_targ != OP_LIST) {
- op_lvalue(cBINOPo->op_first, type);
- break;
+ OP *sib = OpSIBLING(cLISTOPo->op_first);
+ /* OP_TRANS and OP_TRANSR with argument have a weird optree
+ * that looks like
+ *
+ * null
+ * arg
+ * trans
+ *
+ * compared with things like OP_MATCH which have the argument
+ * as a child:
+ *
+ * match
+ * arg
+ *
+ * so handle specially to correctly get "Can't modify" croaks etc
+ */
+
+ if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
+ {
+ /* this should trigger a "Can't modify transliteration" err */
+ op_lvalue(sib, type);
+ }
+ op_lvalue(cBINOPo->op_first, type);
+ break;
}
/* FALLTHROUGH */
case OP_LIST:
return o;
case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE &&
- ( kid->op_targ
- || o->op_flags & OPf_STACKED
-#ifdef USE_ITHREADS
- || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
-#else
- || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
-#endif
- )) {
+ if ((o->op_private & OPpSPLIT_ASSIGN)) {
/* This is actually @array = split. */
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
o->op_flags |= OPf_MOD;
if (type == OP_AASSIGN || type == OP_SASSIGN)
- o->op_flags |= OPf_SPECIAL|OPf_REF;
+ o->op_flags |= OPf_SPECIAL
+ |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
else if (!type) { /* local() */
switch (localize) {
case 1:
}
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB
- && type != OP_LEAVESUBLV)
+ && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
return o;
}
STRLEN new_len;
const char * newp = SvPV(cSVOPo_sv, new_len);
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
+ "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
op_free(new_proto);
}
const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
- " in %"SVf,
+ "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
+ " in %" SVf,
UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
SVfARG(svname));
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
- (type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
- type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
+ (type == OP_RV2SV ? GvSVn(gv) :
+ type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
+ type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
attrs);
}
o->op_private |= OPpOUR_INTRO;
S_op_varname(aTHX_ left);
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Applying %s to %"SVf" will act on scalar(%"SVf")",
+ "Applying %s to %" SVf " will act on scalar(%" SVf ")",
desc, SVfARG(name), SVfARG(name));
else {
const char * const sample = (isary
void
Perl_newPROG(pTHX_ OP *o)
{
+ OP *start;
+
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
else
scalar(PL_eval_root);
- PL_eval_start = op_linklist(PL_eval_root);
- PL_eval_root->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(PL_eval_root, 1);
+ start = op_linklist(PL_eval_root);
PL_eval_root->op_next = 0;
i = PL_savestack_ix;
SAVEFREEOP(o);
ENTER;
- CALL_PEEP(PL_eval_start);
- finalize_optree(PL_eval_root);
- S_prune_chain_head(&PL_eval_start);
+ S_process_optree(aTHX_ NULL, PL_eval_root, start);
LEAVE;
PL_savestack_ix = i;
}
}
PL_main_root = op_scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
- PL_main_start = LINKLIST(PL_main_root);
- PL_main_root->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(PL_main_root, 1);
+ start = LINKLIST(PL_main_root);
PL_main_root->op_next = 0;
- CALL_PEEP(PL_main_start);
- finalize_optree(PL_main_root);
- S_prune_chain_head(&PL_main_start);
+ S_process_optree(aTHX_ NULL, PL_main_root, start);
cv_forget_slab(PL_compcv);
PL_compcv = 0;
}
static OP *
-S_fold_constants(pTHX_ OP *o)
+S_fold_constants(pTHX_ OP *const o)
{
dVAR;
OP * VOL curop;
S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
- OP *curop;
- const SSize_t oldtmps_floor = PL_tmps_floor;
+ OP *curop, *old_next;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
+ COP *old_curcop;
+ U8 oldwarn = PL_dowarn;
SV **svp;
AV *av;
+ I32 old_cxix;
+ COP not_compiling;
+ int ret = 0;
+ dJMPENV;
+ bool op_was_null;
list(o);
if (PL_parser && PL_parser->error_count)
return o; /* Don't attempt to run with errors */
curop = LINKLIST(o);
+ old_next = o->op_next;
o->op_next = 0;
+ op_was_null = o->op_type == OP_NULL;
+ if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
+ o->op_type = OP_CUSTOM;
CALL_PEEP(curop);
+ if (op_was_null)
+ o->op_type = OP_NULL;
S_prune_chain_head(&curop);
PL_op = curop;
- Perl_pp_pushmark(aTHX);
- CALLRUNOPS(aTHX);
- PL_op = curop;
- assert (!(curop->op_flags & OPf_SPECIAL));
- assert(curop->op_type == OP_RANGE);
- Perl_pp_anonlist(aTHX);
- PL_tmps_floor = oldtmps_floor;
+
+ old_cxix = cxstack_ix;
+ create_eval_scope(NULL, G_FAKINGEVAL);
+
+ old_curcop = PL_curcop;
+ StructCopy(old_curcop, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ current COP, but that IN_PERL_RUNTIME is true. */
+ assert(IN_PERL_RUNTIME);
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ 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:
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
+#endif
+ Perl_pp_pushmark(aTHX);
+ CALLRUNOPS(aTHX);
+ PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
+ Perl_pp_anonlist(aTHX);
+ break;
+ case 3:
+ CLEAR_ERRSV();
+ o->op_next = old_next;
+ break;
+ default:
+ JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
+ ret);
+ }
+
+ JMPENV_POP;
+ PL_dowarn = oldwarn;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ PL_curcop = old_curcop;
+
+ if (cxstack_ix > old_cxix) {
+ assert(cxstack_ix == old_cxix + 1);
+ assert(CxTYPE(CX_CUR()) == CXt_EVAL);
+ delete_eval_scope();
+ }
+ if (ret)
+ return o;
OpTYPE_set(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
}
}
- OpTYPE_set(o, type);
+ if (type != OP_SPLIT)
+ /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
+ * ck_split() create a real PMOP and leave the op's type as listop
+ * for now. Otherwise op_free() etc will crash.
+ */
+ OpTYPE_set(o, type);
+
o->op_flags |= flags;
if (flags & OPf_FOLDED)
o->op_folded = 1;
BINOP *binop;
ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
- || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
+ || type == OP_NULL || type == OP_CUSTOM);
NewOp(1101, binop, 1, BINOP);
tbl[i] = (short)i;
}
else {
- if (i < 128 && r[j] >= 128)
+ if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
grows = 1;
tbl[i] = r[j++];
}
--j;
}
if (tbl[t[i]] == -1) {
- if (t[i] < 128 && r[j] >= 128)
+ if ( UVCHR_IS_INVARIANT(t[i])
+ && ! UVCHR_IS_INVARIANT(r[j]))
grows = 1;
tbl[t[i]] = r[j];
}
* constant), or convert expr into a runtime regcomp op sequence (if it's
* not)
*
- * isreg indicates that the pattern is part of a regex construct, eg
+ * Flags currently has 2 bits of meaning:
+ * 1: isreg indicates that the pattern is part of a regex construct, eg
* $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
* split "pattern", which aren't. In the former case, expr will be a list
* if the pattern contains more than one term (eg /a$b/).
+ * 2: The pattern is for a split.
*
* When the pattern has been compiled within a new anon CV (for
* qr/(?{...})/ ), then floor indicates the savestack level just before
*/
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
{
PMOP *pm;
LOGOP *rcop;
bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
bool is_compiletime;
bool has_code;
+ bool isreg = cBOOL(flags & 1);
+ bool is_split = cBOOL(flags & 2);
PERL_ARGS_ASSERT_PMRUNTIME;
U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
regexp_engine const *eng = current_re_engine();
- if (o->op_flags & OPf_SPECIAL)
+ if (is_split) {
+ /* make engine handle split ' ' specially */
+ pm->op_pmflags |= PMf_SPLIT;
rx_flags |= RXf_SPLIT;
+ }
+
+ /* Skip compiling if parser found an error for this pattern */
+ if (pm->op_pmflags & PMf_HAS_ERROR) {
+ return o;
+ }
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
SSize_t i = 0;
assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
while (++i <= AvFILLp(PL_comppad)) {
+# ifdef USE_PAD_RESET
+ /* under USE_PAD_RESET, pad swipe replaces a swiped
+ * folded constant with a fresh padtmp */
+ assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
+# else
assert(!PL_curpad[i]);
+# endif
}
#endif
/* But we know that one op is using this CV's slab. */
pm->op_pmflags |= PMf_CODELIST_PRIVATE;
}
- if (o->op_flags & OPf_SPECIAL)
+ if (is_split)
+ /* make engine handle split ' ' specially */
pm->op_pmflags |= PMf_SPLIT;
/* the OP_REGCMAYBE is a placeholder in the non-threaded case
=for apidoc load_module
-Loads the module whose name is pointed to by the string part of name.
+Loads the module whose name is pointed to by the string part of C<name>.
Note that the actual module name, not its filename, should be given.
-Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
+Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
+provides version semantics similar to C<use Foo::Bar VERSION>. The optional
+trailing arguments can be used to specify arguments to the module's C<import()>
+method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
+on the flags. The flags argument is a bitwise-ORed collection of any of
C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
-(or 0 for no flags). ver, if specified
-and not NULL, provides version semantics
-similar to C<use Foo::Bar VERSION>. The optional trailing SV*
-arguments can be used to specify arguments to the module's C<import()>
-method, similar to C<use Foo::Bar VERSION LIST>. They must be
-terminated with a final C<NULL> pointer. Note that this list can only
-be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
-Otherwise at least a single C<NULL> pointer to designate the default
-import list is required.
-
-The reference count for each specified C<SV*> parameter is decremented.
+(or 0 for no flags).
+
+If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
+import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
+the trailing optional arguments may be omitted entirely. Otherwise, if
+C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
+exactly one C<OP*>, containing the op tree that produces the relevant import
+arguments. Otherwise, the trailing arguments must all be C<SV*> values that
+will be used as import arguments; and the list must be terminated with C<(SV*)
+NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
+set, the trailing C<NULL> pointer is needed even if no import arguments are
+desired. The reference count for each specified C<SV*> argument is
+decremented. In addition, the C<name> argument is modified.
+
+If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
+than C<use>.
=cut */
if (optype) {
if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
+ right = scalar(right);
return newLOGOP(optype, 0,
op_lvalue(scalar(left), optype),
- newUNOP(OP_SASSIGN, 0, scalar(right)));
+ newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
}
else {
return newBINOP(optype, OPf_STACKED,
yyerror(no_list_state);
}
- if (right && right->op_type == OP_SPLIT
- && !(right->op_flags & OPf_STACKED)) {
- OP* tmpop = ((LISTOP*)right)->op_first;
- PMOP * const pm = (PMOP*)tmpop;
- assert (tmpop && (tmpop->op_type == OP_PUSHRE));
- if (
-#ifdef USE_ITHREADS
- !pm->op_pmreplrootu.op_pmtargetoff
-#else
- !pm->op_pmreplrootu.op_pmtargetgv
-#endif
- && !pm->op_targ
- ) {
- if (!(left->op_private & OPpLVAL_INTRO) &&
- ( (left->op_type == OP_RV2AV &&
- (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
- || left->op_type == OP_PADAV )
- ) {
- if (tmpop != (OP *)pm) {
+ /* optimise @a = split(...) into:
+ * @{expr}: split(..., @{expr}) (where @a is not flattened)
+ * @a, my @a, local @a: split(...) (where @a is attached to
+ * the split op itself)
+ */
+
+ if ( right
+ && right->op_type == OP_SPLIT
+ /* don't do twice, e.g. @b = (@a = split) */
+ && !(right->op_private & OPpSPLIT_ASSIGN))
+ {
+ OP *gvop = NULL;
+
+ if ( ( left->op_type == OP_RV2AV
+ && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
+ || left->op_type == OP_PADAV)
+ {
+ /* @pkg or @lex or local @pkg' or 'my @lex' */
+ OP *tmpop;
+ if (gvop) {
#ifdef USE_ITHREADS
- pm->op_pmreplrootu.op_pmtargetoff
- = cPADOPx(tmpop)->op_padix;
- cPADOPx(tmpop)->op_padix = 0; /* steal it */
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
+ = cPADOPx(gvop)->op_padix;
+ cPADOPx(gvop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplrootu.op_pmtargetgv
- = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
- cSVOPx(tmpop)->op_sv = NULL; /* steal it */
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
+ = MUTABLE_GV(cSVOPx(gvop)->op_sv);
+ cSVOPx(gvop)->op_sv = NULL; /* steal it */
#endif
- right->op_private |=
- left->op_private & OPpOUR_INTRO;
- }
- else {
- pm->op_targ = left->op_targ;
- left->op_targ = 0; /* filch it */
- }
- detach_split:
- tmpop = cUNOPo->op_first; /* to list (nulled) */
- tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
- /* detach rest of siblings from o subtree,
- * and free subtree */
- op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
- op_free(o); /* blow off assign */
- right->op_flags &= ~OPf_WANT;
- /* "I don't know and I don't care." */
- return right;
- }
- else if (left->op_type == OP_RV2AV
- || left->op_type == OP_PADAV)
- {
- /* Detach the array. */
-#ifdef DEBUGGING
- OP * const ary =
-#endif
- op_sibling_splice(cBINOPo->op_last,
- cUNOPx(cBINOPo->op_last)
- ->op_first, 1, NULL);
- assert(ary == left);
- /* Attach it to the split. */
- op_sibling_splice(right, cLISTOPx(right)->op_last,
- 0, left);
- right->op_flags |= OPf_STACKED;
- /* Detach split and expunge aassign as above. */
- goto detach_split;
- }
- else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
- ((LISTOP*)right)->op_last->op_type == OP_CONST)
- {
- SV ** const svp =
- &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
- SV * const sv = *svp;
- if (SvIOK(sv) && SvIVX(sv) == 0)
- {
- if (right->op_private & OPpSPLIT_IMPLIM) {
- /* our own SV, created in ck_split */
- SvREADONLY_off(sv);
- sv_setiv(sv, PL_modcount+1);
- }
- else {
- /* SV may belong to someone else */
- SvREFCNT_dec(sv);
- *svp = newSViv(PL_modcount+1);
- }
- }
- }
- }
+ right->op_private |=
+ left->op_private & OPpOUR_INTRO;
+ }
+ else {
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
+ left->op_targ = 0; /* steal it */
+ right->op_private |= OPpSPLIT_LEX;
+ }
+ right->op_private |= left->op_private & OPpLVAL_INTRO;
+
+ detach_split:
+ tmpop = cUNOPo->op_first; /* to list (nulled) */
+ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
+ assert(OpSIBLING(tmpop) == right);
+ assert(!OpHAS_SIBLING(right));
+ /* detach the split subtreee from the o tree,
+ * then free the residual o tree */
+ op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
+ op_free(o); /* blow off assign */
+ right->op_private |= OPpSPLIT_ASSIGN;
+ right->op_flags &= ~OPf_WANT;
+ /* "I don't know and I don't care." */
+ return right;
+ }
+ else if (left->op_type == OP_RV2AV) {
+ /* @{expr} */
+
+ OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
+ assert(OpSIBLING(pushop) == left);
+ /* Detach the array ... */
+ op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
+ /* ... and attach it to the split. */
+ op_sibling_splice(right, cLISTOPx(right)->op_last,
+ 0, left);
+ right->op_flags |= OPf_STACKED;
+ /* Detach split and expunge aassign as above. */
+ goto detach_split;
+ }
+ else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
+ ((LISTOP*)right)->op_last->op_type == OP_CONST)
+ {
+ /* convert split(...,0) to split(..., PL_modcount+1) */
+ SV ** const svp =
+ &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ SV * const sv = *svp;
+ if (SvIOK(sv) && SvIVX(sv) == 0)
+ {
+ if (right->op_private & OPpSPLIT_IMPLIM) {
+ /* our own SV, created in ck_split */
+ SvREADONLY_off(sv);
+ sv_setiv(sv, PL_modcount+1);
+ }
+ else {
+ /* SV may belong to someone else */
+ SvREFCNT_dec(sv);
+ *svp = newSViv(PL_modcount+1);
+ }
+ }
+ }
}
return o;
}
&& !(o2->op_private & OPpPAD_STATE))
{
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional");
+ "Deprecated use of my() in false conditional. "
+ "This will be a fatal error in Perl 5.30");
}
*otherp = NULL;
}
}
- if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
- other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
-
/* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
&& (first->op_flags & OPf_KIDS)
}
sv_setpvs(msg, "Prototype mismatch:");
if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
+ Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
if (cvp)
- Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
+ Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
UTF8fARG(SvUTF8(cv),clen,cvp)
);
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
+ Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
}
static void const_sv_xsub(pTHX_ CV* cv);
return sv;
}
-static bool
+static void
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
- )) {
+ if (!block) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
& ~(CVf_LVALUE * pureperl));
}
- return FALSE;
+ return;
}
/* redundant check for speed: */
CopLINE_set(PL_curcop, oldline);
}
SAVEFREESV(cv);
- return TRUE;
+ return;
}
CV *
outside, as in:
my sub foo; sub { sub foo { } }
*/
- redo:
+ redo:
name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
pax = PARENT_PAD_INDEX(name);
ps_utf8);
/* already defined? */
if (exists) {
- if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
+ S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
reusable = TRUE;
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
CvSTASH_set(cv, PL_curstash);
*spot = cv;
}
- sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
PL_compcv = NULL;
goto setname;
}
+
/* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
determine whether this sub definition is in the same scope as its
declaration. If this sub definition is inside an inner named pack-
CvWEAKOUTSIDE_on(compcv);
}
/* XXX else do we have a circular reference? */
+
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
- if (block
- ) {
+ if (block) {
cv_flags_t preserved_flags =
CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(cv);
/* inner references to compcv must be fixed up ... */
pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
cv = compcv;
*spot = cv;
}
- setname:
+
+ setname:
CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
if (hek) (void)share_hek_hek(hek);
}
CvNAME_HEK_set(cv, hek);
}
- if (const_sv) goto clone;
+
+ if (const_sv)
+ goto clone;
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(cv));
}
- if (!block)
- goto attrs;
-
- /* If we assign an optree to a PVCV, then we've defined a subroutine that
- the debugger could be able to set a breakpoint in, so signal to
- pp_entereval that it should not throw away any saved lines at scope
- exit. */
-
- PL_breakable_sub_gen++;
- CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- /* The cv no longer needs to hold a refcount on the slab, as CvROOT
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* If we assign an optree to a PVCV, then we've defined a
+ * subroutine that the debugger could be able to set a breakpoint
+ * in, so signal to pp_entereval that it should not throw away any
+ * saved lines at scope exit. */
+
+ PL_breakable_sub_gen++;
+ CvROOT(cv) = block;
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
-
- /* now that optimizer has done its work, adjust pad values */
-
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ S_process_optree(aTHX_ cv, block, start);
+ }
attrs:
if (attrs) {
sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
sv_catpvs(tmpstr, "::");
}
- else sv_setpvs(tmpstr, "__ANON__::");
+ else
+ sv_setpvs(tmpstr, "__ANON__::");
+
sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
assert(CvDEPTH(outcv));
spot = (CV **)
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
- if (reusable) cv_clone_into(clonee, *spot);
+ if (reusable)
+ cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
SvREFCNT_dec_NN(clonee);
cv = *spot;
}
+
if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
PADOFFSET depth = CvDEPTH(outcv);
while (--depth) {
return cv;
}
+
/* _x = extended */
CV *
Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- CV *cv = NULL;
+ CV *cv = NULL; /* the previous CV with this name, if any */
SV *const_sv;
const bool ec = PL_parser && PL_parser->error_count;
/* If the subroutine has no body, no attributes, and no builtin attributes
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
+ Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
has_name = FALSE;
}
+
if (!ec) {
if (isGV(gv)) {
move_proto_attr(&proto, &attrs, gv);
if (ec) {
op_free(block);
- if (name) SvREFCNT_dec(PL_compcv);
- else cv = PL_compcv;
+
+ if (name)
+ SvREFCNT_dec(PL_compcv);
+ else
+ cv = PL_compcv;
+
PL_compcv = 0;
if (name && block) {
const char *s = strrchr(name, ':');
SV * const errsv = ERRSV;
/* force display of errors found but not reported */
sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
- Perl_croak_nocontext("%"SVf, SVfARG(errsv));
+ Perl_croak_nocontext("%" SVf, SVfARG(errsv));
}
}
}
}
if (!block && SvTYPE(gv) != SVt_PVGV) {
- /* If we are not defining a new sub and the existing one is not a
- full GV + CV... */
- if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
- /* We are applying attributes to an existing sub, so we need it
- upgraded if it is a constant. */
- if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
- gv_init_pvn(gv, PL_curstash, name, namlen,
- SVf_UTF8 * name_is_utf8);
- }
- else { /* Maybe prototype now, and had at maximum
- a prototype or const/sub ref before. */
- if (SvTYPE(gv) > SVt_NULL) {
- cv_ckproto_len_flags((const CV *)gv,
- o ? (const GV *)cSVOPo->op_sv : NULL, ps,
- ps_len, ps_utf8);
- }
- if (!SvROK(gv)) {
- if (ps) {
- sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
- sv_setiv(MUTABLE_SV(gv), -1);
- }
+ /* If we are not defining a new sub and the existing one is not a
+ full GV + CV... */
+ if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+ /* We are applying attributes to an existing sub, so we need it
+ upgraded if it is a constant. */
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_init_pvn(gv, PL_curstash, name, namlen,
+ SVf_UTF8 * name_is_utf8);
+ }
+ else { /* Maybe prototype now, and had at maximum
+ a prototype or const/sub ref before. */
+ if (SvTYPE(gv) > SVt_NULL) {
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8);
+ }
- SvREFCNT_dec(PL_compcv);
- cv = PL_compcv = NULL;
- goto done;
- }
+ if (!SvROK(gv)) {
+ if (ps) {
+ sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
+ if (ps_utf8)
+ SvUTF8_on(MUTABLE_SV(gv));
+ }
+ else
+ sv_setiv(MUTABLE_SV(gv), -1);
+ }
+
+ SvREFCNT_dec(PL_compcv);
+ cv = PL_compcv = NULL;
+ goto done;
+ }
}
cv = (!name || (isGV(gv) && GvCVGEN(gv)))
|| sv_cmp(SvRV(gv), const_sv) ))) {
assert(cSVOPo);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- "Constant subroutine %"SVf" redefined",
+ "Constant subroutine %" SVf " redefined",
SVfARG(cSVOPo->op_sv));
}
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || (isGV(gv) && GvASSUMECV(gv))) {
- if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
+ if (block)
cv = NULL;
else {
- if (attrs) goto attrs;
+ if (attrs)
+ goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
}
}
+
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
SvFLAGS(const_sv) |= SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
- sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
+ SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
CvXSUBANY(cv).any_ptr = const_sv;
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
PL_compcv = NULL;
goto done;
}
+
+ /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
+ if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
+ cv = NULL;
+
if (cv) { /* must reuse cv if autoloaded */
/* transfer PL_compcv to cv */
- if (block
- ) {
+ if (block) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
PADLIST *const temp_av = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
- }
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
/* inner references to PL_compcv must be fixed up ... */
pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
- ++PL_sub_generation;
+ ++PL_sub_generation;
}
else {
/* Might have had built-in attributes applied -- propagate them. */
SvRV_set(gv, (SV *)cv);
}
}
+
if (!CvHASGV(cv)) {
- if (isGV(gv)) CvGV_set(cv, gv);
+ if (isGV(gv))
+ CvGV_set(cv, gv);
else {
dVAR;
U32 hash;
if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ if ( ps_utf8 )
+ SvUTF8_on(MUTABLE_SV(cv));
}
- if (!block)
- goto attrs;
-
- /* If we assign an optree to a PVCV, then we've defined a subroutine that
- the debugger could be able to set a breakpoint in, so signal to
- pp_entereval that it should not throw away any saved lines at scope
- exit. */
-
- PL_breakable_sub_gen++;
- CvROOT(cv) = block;
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- /* The cv no longer needs to hold a refcount on the slab, as CvROOT
- itself has a refcount. */
- CvSLABBED_off(cv);
- OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+ if (block) {
+ /* If we assign an optree to a PVCV, then we've defined a
+ * subroutine that the debugger could be able to set a breakpoint
+ * in, so signal to pp_entereval that it should not throw away any
+ * saved lines at scope exit. */
+
+ PL_breakable_sub_gen++;
+ CvROOT(cv) = block;
+ /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+ itself has a refcount. */
+ CvSLABBED_off(cv);
+ OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
#ifdef PERL_DEBUG_READONLY_OPS
- slab = (OPSLAB *)CvSTART(cv);
+ slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = start;
- CALL_PEEP(start);
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
-
- /* now that optimizer has done its work, adjust pad values */
-
- pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+ S_process_optree(aTHX_ cv, block, start);
+ }
attrs:
if (attrs) {
HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
? GvSTASH(CvGV(cv))
: PL_curstash;
- if (!name) SAVEFREESV(cv);
+ if (!name)
+ SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
- if (!name) SvREFCNT_inc_simple_void_NN(cv);
+ if (!name)
+ SvREFCNT_inc_simple_void_NN(cv);
}
if (block && has_name) {
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+
if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
- if (slab)
+ if (slab)
Slab_to_ro(slab);
#endif
- if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
+ if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
pad_add_weakref(cv);
}
return cv;
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
CV *cv;
-
GV *gv;
+ OP *root;
+ OP *start;
if (PL_parser && PL_parser->error_count) {
op_free(block);
CopLINE_set(PL_curcop, PL_parser->copline);
if (o) {
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
+ "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
} else {
/* diag_listed_as: Format %s redefined */
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvFILE_set_from_cop(cv, PL_curcop);
- pad_tidy(padtidy_FORMAT);
- CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
- CvROOT(cv)->op_private |= OPpREFCOUNTED;
- OpREFCNT_set(CvROOT(cv), 1);
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
- finalize_optree(CvROOT(cv));
- S_prune_chain_head(&CvSTART(cv));
+ root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
+ CvROOT(cv) = root;
+ start = LINKLIST(root);
+ root->op_next = 0;
+ S_process_optree(aTHX_ cv, root, start);
cv_forget_slab(cv);
finish:
case OP_HELEM:
break;
case OP_KVASLICE:
- Perl_croak(aTHX_ "delete argument is index/value array slice,"
- " use array slice");
+ o->op_flags |= OPf_SPECIAL;
+ /* FALLTHROUGH */
case OP_KVHSLICE:
- Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
- " hash slice");
+ o->op_private |= OPpKVSLICE;
+ break;
default:
Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
"element or slice");
}
if (badthing)
Perl_croak(aTHX_
- "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
SVfARG(kidsv), badthing);
}
/*
if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
else
- sv_setpvs(namesv, "");
+ SvPVCLEAR(namesv);
sv_catpvn(namesv, name, len);
if ( name_utf8 ) SvUTF8_on(namesv);
}
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
SV *sv = kSVOP->op_sv;
- if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
+ if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
+ && SvOK(sv) && !SvROK(sv))
+ {
sv = newSV(0);
sv_copypv(sv, kSVOP->op_sv);
SvREFCNT_dec_NN(kSVOP->op_sv);
case OP_PADAV:
Perl_croak(aTHX_ "Can't use 'defined(@array)'"
" (Maybe you should just omit the defined()?)");
- break;
+ NOT_REACHED; /* NOTREACHED */
+ break;
case OP_RV2HV:
case OP_PADHV:
Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
" (Maybe you should just omit the defined()?)");
+ NOT_REACHED; /* NOTREACHED */
break;
default:
/* no warning */
op_sibling_splice(o, NULL, 0, first);
/* Implicitly take a reference to a regular expression */
- if (first->op_type == OP_MATCH) {
+ if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
OpTYPE_set(first, OP_QR);
}
- if (second->op_type == OP_MATCH) {
+ if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
OpTYPE_set(second, OP_QR);
}
}
Perl_ck_sassign(pTHX_ OP *o)
{
dVAR;
- OP * const kid = cLISTOPo->op_first;
+ OP * const kid = cBINOPo->op_first;
PERL_ARGS_ASSERT_CK_SASSIGN;
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_CK_MATCH;
- if (o->op_type == OP_MATCH || o->op_type == OP_QR)
- o->op_private |= OPpRUNTIME;
return o;
}
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
- HEK *hek;
U32 hash;
char *s;
STRLEN len;
if (kid->op_private & OPpCONST_BARE) {
dVAR;
const char *end;
+ HEK *hek;
if (was_readonly) {
SvREADONLY_off(sv);
}
else {
dVAR;
+ HEK *hek;
if (was_readonly) SvREADONLY_off(sv);
PERL_HASH(hash, s, len);
hek = share_hek(s,
PERL_ARGS_ASSERT_CK_RETURN;
kid = OpSIBLING(cLISTOPo->op_first);
- if (CvLVALUE(PL_compcv)) {
+ if (PL_compcv && CvLVALUE(PL_compcv)) {
for (; kid; kid = OpSIBLING(kid))
op_lvalue(kid, OP_LEAVESUBLV);
}
}
/* for sort { X } ..., where X is one of
- * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
+ * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
* elide the second child of the sort (the one containing X),
* and set these flags as appropriate
OPpSORT_NUMERIC;
{
dVAR;
OP *kid;
+ OP *sibs;
PERL_ARGS_ASSERT_CK_SPLIT;
+ assert(o->op_type == OP_LIST);
+
if (o->op_flags & OPf_STACKED)
return no_fh_allowed(o);
kid = cLISTOPo->op_first;
- if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
/* delete leading NULL node, then add a CONST if no other nodes */
+ assert(kid->op_type == OP_NULL);
op_sibling_splice(o, NULL, 1,
OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
op_free(kid);
kid = cLISTOPo->op_first;
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- /* remove kid, and replace with new optree */
+ /* remove match expression, and replace with new optree with
+ * a match op at its head */
op_sibling_splice(o, NULL, 1, NULL);
- /* OPf_SPECIAL is used to trigger split " " behavior */
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
+ /* pmruntime will handle split " " behavior with flag==2 */
+ kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
op_sibling_splice(o, NULL, 0, kid);
}
- OpTYPE_set(kid, OP_PUSHRE);
- /* target implies @ary=..., so wipe it */
- kid->op_targ = 0;
- scalar(kid);
+
+ assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
+
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
"Use of /g modifier is meaningless in split");
}
- if (!OpHAS_SIBLING(kid))
- op_append_elem(OP_SPLIT, o, newDEFSVOP());
+ /* eliminate the split op, and move the match op (plus any children)
+ * into its place, then convert the match op into a split op. i.e.
+ *
+ * SPLIT MATCH SPLIT(ex-MATCH)
+ * | | |
+ * MATCH - A - B - C => R - A - B - C => R - A - B - C
+ * | | |
+ * R X - Y X - Y
+ * |
+ * X - Y
+ *
+ * (R, if it exists, will be a regcomp op)
+ */
- kid = OpSIBLING(kid);
- assert(kid);
- scalar(kid);
+ op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
+ sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
+ op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
+ OpTYPE_set(kid, OP_SPLIT);
+ kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
+ kid->op_private = o->op_private;
+ op_free(o);
+ o = kid;
+ kid = sibs; /* kid is now the string arg of the split */
- if (!OpHAS_SIBLING(kid))
- {
- op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
- o->op_private |= OPpSPLIT_IMPLIM;
+ if (!kid) {
+ kid = newDEFSVOP();
+ op_append_elem(OP_SPLIT, o, kid);
}
- assert(OpHAS_SIBLING(kid));
+ scalar(kid);
kid = OpSIBLING(kid);
+ if (!kid) {
+ kid = newSVOP(OP_CONST, 0, newSViv(0));
+ op_append_elem(OP_SPLIT, o, kid);
+ o->op_private |= OPpSPLIT_IMPLIM;
+ }
scalar(kid);
if (OpHAS_SIBLING(kid))
SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
: newSVpvs_flags( "STRING", SVs_TEMP );
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "/%"SVf"/ should probably be written as \"%"SVf"\"",
+ "/%" SVf "/ should probably be written as \"%" SVf "\"",
SVfARG(msg), SVfARG(msg));
}
}
if (proto >= proto_end)
{
SV * const namesv = cv_name((CV *)namegv, NULL, 0);
- yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
return entersubop;
}
continue;
default:
oops: {
- Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
+ Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
SVfARG(cv_name((CV *)namegv, NULL, 0)),
SVfARG(protosv));
}
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
{
SV * const namesv = cv_name((CV *)namegv, NULL, 0);
- yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
SVfARG(namesv)), SvUTF8(namesv));
}
return entersubop;
case 'L': return newSVOP(
OP_CONST, 0,
Perl_newSVpvf(aTHX_
- "%"IVdf, (IV)CopLINE(PL_curcop)
+ "%" IVdf, (IV)CopLINE(PL_curcop)
)
);
case 'P': return newSVOP(OP_CONST, 0,
case OP_METHOD_SUPER:
case OP_METHOD_REDIR:
case OP_METHOD_REDIR_SUPER:
+ o->op_flags |= OPf_REF;
if (aop->op_type == OP_CONST) {
aop->op_private &= ~OPpCONST_STRICT;
const_class = &cSVOPx(aop)->op_sv;
}
if (name)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
+ "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
")\"?)",
SVfARG(name), hash ? "keys " : "", SVfARG(name)
);
case OP_PADAV:
case OP_PADHV:
(*scalars_p) += 2;
+ /* if !top, could be e.g. @a[0,1] */
if (top && (o->op_flags & OPf_REF))
return (o->op_private & OPpLVAL_INTRO)
? AAS_MY_AGG : AAS_LEX_AGG;
if (cUNOPx(o)->op_first->op_type != OP_GV)
return AAS_DANGEROUS; /* @{expr}, %{expr} */
/* @pkg, %pkg */
+ /* if !top, could be e.g. @a[0,1] */
if (top && (o->op_flags & OPf_REF))
return AAS_PKG_AGG;
return AAS_DANGEROUS;
return AAS_PKG_SCALAR; /* $pkg */
case OP_SPLIT:
- if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
- /* "@foo = split... " optimises away the aassign and stores its
- * destination array in the OP_PUSHRE that precedes it.
- * A flattened array is always dangerous.
+ if (o->op_private & OPpSPLIT_ASSIGN) {
+ /* the assign in @a = split() has been optimised away
+ * and the @a attached directly to the split op
+ * Treat the array as appearing on the RHS, i.e.
+ * ... = (@a = split)
+ * is treated like
+ * ... = @a;
*/
+
+ if (o->op_flags & OPf_STACKED)
+ /* @{expr} = split() - the array expression is tacked
+ * on as an extra child to split - process kid */
+ return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
+ top, scalars_p);
+
+ /* ... else array is directly attached to split op */
(*scalars_p) += 2;
- return AAS_DANGEROUS;
+ if (PL_op->op_private & OPpSPLIT_LEX)
+ return (o->op_private & OPpLVAL_INTRO)
+ ? AAS_MY_AGG : AAS_LEX_AGG;
+ else
+ return AAS_PKG_AGG;
}
- break;
+ (*scalars_p)++;
+ /* other args of split can't be returned */
+ return AAS_SAFE_SCALAR;
case OP_UNDEF:
/* undef counts as a scalar on the RHS:
break;
}
+ /* XXX this assumes that all other ops are "transparent" - i.e. that
+ * they can return some of their children. While this true for e.g.
+ * sort and grep, it's not true for e.g. map. We really need a
+ * 'transparent' flag added to regen/opcodes
+ */
if (o->op_flags & OPf_KIDS) {
OP *kid;
for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
case OP_GV:
/* it may be a package var index */
- ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
+ ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
- if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
+ if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
|| o->op_private != 0
)
break;
if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
&& PL_check[o->op_type] != Perl_ck_null)
return;
+ /* similarly for customised exists and delete */
+ if ( (o->op_type == OP_EXISTS)
+ && PL_check[o->op_type] != Perl_ck_exists)
+ return;
+ if ( (o->op_type == OP_DELETE)
+ && PL_check[o->op_type] != Perl_ck_delete)
+ return;
if ( o->op_type != OP_AELEM
|| (o->op_private &
&& ( (o->op_private & OPpDEREF) == OPpDEREF_AV
|| (o->op_private & OPpDEREF) == OPpDEREF_HV);
+ /* This doesn't make much sense but is legal:
+ * @{ local $x[0][0] } = 1
+ * Since scope exit will undo the autovivification,
+ * don't bother in the first place. The OP_LEAVE
+ * assertion is in case there are other cases of both
+ * OPpLVAL_INTRO and OPpDEREF which don't include a scope
+ * exit that would undo the local - in which case this
+ * block of code would need rethinking.
+ */
+ if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
+#ifdef DEBUGGING
+ OP *n = o->op_next;
+ while (n && ( n->op_type == OP_NULL
+ || n->op_type == OP_LIST))
+ n = n->op_next;
+ assert(n && n->op_type == OP_LEAVE);
+#endif
+ o->op_private &= ~OPpDEREF;
+ is_deref = FALSE;
+ }
+
if (is_deref) {
ASSUME(!(o->op_flags &
~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
} /* for (pass = ...) */
}
+/* See if the ops following o are such that o will always be executed in
+ * boolean context: that is, the SV which o pushes onto the stack will
+ * only ever be consumed by later ops via SvTRUE(sv) or similar.
+ * If so, set a suitable private flag on o. Normally this will be
+ * bool_flag; but see below why maybe_flag is needed too.
+ *
+ * Typically the two flags you pass will be the generic OPpTRUEBOOL and
+ * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
+ * already be taken, so you'll have to give that op two different flags.
+ *
+ * More explanation of 'maybe_flag' and 'safe_and' parameters.
+ * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
+ * those underlying ops) short-circuit, which means that rather than
+ * necessarily returning a truth value, they may return the LH argument,
+ * which may not be boolean. For example in $x = (keys %h || -1), keys
+ * should return a key count rather than a boolean, even though its
+ * sort-of being used in boolean context.
+ *
+ * So we only consider such logical ops to provide boolean context to
+ * their LH argument if they themselves are in void or boolean context.
+ * However, sometimes the context isn't known until run-time. In this
+ * case the op is marked with the maybe_flag flag it.
+ *
+ * Consider the following.
+ *
+ * sub f { ....; if (%h) { .... } }
+ *
+ * This is actually compiled as
+ *
+ * sub f { ....; %h && do { .... } }
+ *
+ * Here we won't know until runtime whether the final statement (and hence
+ * the &&) is in void context and so is safe to return a boolean value.
+ * So mark o with maybe_flag rather than the bool_flag.
+ * Note that there is cost associated with determining context at runtime
+ * (e.g. a call to block_gimme()), so it may not be worth setting (at
+ * compile time) and testing (at runtime) maybe_flag if the scalar verses
+ * boolean costs savings are marginal.
+ *
+ * However, we can do slightly better with && (compared to || and //):
+ * this op only returns its LH argument when that argument is false. In
+ * this case, as long as the op promises to return a false value which is
+ * valid in both boolean and scalar contexts, we can mark an op consumed
+ * by && with bool_flag rather than maybe_flag.
+ * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
+ * than &PL_sv_no for a false result in boolean context, then it's safe. An
+ * op which promises to handle this case is indicated by setting safe_and
+ * to true.
+ */
+
+static void
+S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
+{
+ OP *lop;
+
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
+
+ lop = o->op_next;
+
+ while (lop) {
+ switch (lop->op_type) {
+ case OP_NULL:
+ case OP_SCALAR:
+ break;
+
+ /* these two consume the stack argument in the scalar case,
+ * and treat it as a boolean in the non linenumber case */
+ case OP_FLIP:
+ case OP_FLOP:
+ if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ || (lop->op_private & OPpFLIP_LINENUM))
+ {
+ lop = NULL;
+ break;
+ }
+ /* FALLTHROUGH */
+ /* these never leave the original value on the stack */
+ case OP_NOT:
+ case OP_XOR:
+ case OP_COND_EXPR:
+ case OP_GREPWHILE:
+ o->op_private |= bool_flag;
+ lop = NULL;
+ break;
+
+ /* OR DOR and AND evaluate their arg as a boolean, but then may
+ * leave the original scalar value on the stack when following the
+ * op_next route. If not in void context, we need to ensure
+ * that whatever follows consumes the arg only in boolean context
+ * too.
+ */
+ case OP_AND:
+ if (safe_and) {
+ o->op_private |= bool_flag;
+ lop = NULL;
+ break;
+ }
+ /* FALLTHROUGH */
+ case OP_OR:
+ case OP_DOR:
+ if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
+ o->op_private |= bool_flag;
+ lop = NULL;
+ }
+ else if (!(lop->op_flags & OPf_WANT)) {
+ /* unknown context - decide at runtime */
+ o->op_private |= maybe_flag;
+ lop = NULL;
+ }
+ break;
+
+ default:
+ lop = NULL;
+ break;
+ }
+
+ if (lop)
+ lop = lop->op_next;
+ }
+}
+
/* mechanism for deferring recursion in rpeep() */
OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
- OP *fop;
- OP *sop;
if (!o || o->op_opt)
return;
&& kid->op_next->op_type == OP_REPEAT
&& kid->op_next->op_private & OPpREPEAT_DOLIST
&& (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
- && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
+ && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
+ && oldop)
{
o = kid->op_next; /* repeat */
- assert(oldop);
oldop->op_next = o;
op_free(cBINOPo->op_first);
op_free(cBINOPo->op_last );
if ( intro
&& (8*sizeof(base) >
8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
- ? base
+ ? (Size_t)base
: (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
) >
(UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
break;
}
+ case OP_RV2HV:
+ case OP_PADHV:
+ /* see if %h is used in boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ if (o->op_type != OP_PADHV)
+ break;
+ /* FALLTHROUGH */
case OP_PADAV:
case OP_PADSV:
- case OP_PADHV:
- /* Skip over state($x) in void context. */
- if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
- && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
- {
- oldop->op_next = o->op_next;
- goto redo_nextstate;
- }
- if (o->op_type != OP_PADAV)
- break;
- /* FALLTHROUGH */
+ /* Skip over state($x) in void context. */
+ if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
+ && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
+ {
+ oldop->op_next = o->op_next;
+ goto redo_nextstate;
+ }
+ if (o->op_type != OP_PADAV)
+ break;
+ /* FALLTHROUGH */
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
OP* const pop = (o->op_type == OP_PADAV) ?
break;
-#define HV_OR_SCALARHV(op) \
- ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
- ? (op) \
- : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
- && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
- || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
- ? cUNOPx(op)->op_first \
- : NULL)
-
case OP_NOT:
- if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
- fop->op_private |= OPpTRUEBOOL;
break;
case OP_AND:
case OP_OR:
case OP_DOR:
- fop = cLOGOP->op_first;
- sop = OpSIBLING(fop);
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
while (o->op_next && ( o->op_type == o->op_next->op_type
o->op_next = ((LOGOP*)o->op_next)->op_other;
}
DEFER(cLOGOP->op_other);
-
o->op_opt = 1;
- fop = HV_OR_SCALARHV(fop);
- if (sop) sop = HV_OR_SCALARHV(sop);
- if (fop || sop
- ){
- OP * nop = o;
- OP * lop = o;
- if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
- while (nop && nop->op_next) {
- switch (nop->op_next->op_type) {
- case OP_NOT:
- case OP_AND:
- case OP_OR:
- case OP_DOR:
- lop = nop = nop->op_next;
- break;
- case OP_NULL:
- nop = nop->op_next;
- break;
- default:
- nop = NULL;
- break;
- }
- }
- }
- if (fop) {
- if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
- || o->op_type == OP_AND )
- fop->op_private |= OPpTRUEBOOL;
- else if (!(lop->op_flags & OPf_WANT))
- fop->op_private |= OPpMAYBE_TRUEBOOL;
- }
- if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
- && sop)
- sop->op_private |= OPpTRUEBOOL;
- }
-
-
break;
case OP_COND_EXPR:
- if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
- fop->op_private |= OPpTRUEBOOL;
-#undef HV_OR_SCALARHV
- /* GERONIMO! */ /* FALLTHROUGH */
-
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_ANDASSIGN:
&& ( kid->op_targ == OP_NEXTSTATE
|| kid->op_targ == OP_DBSTATE ))
|| kid->op_type == OP_STUB
- || kid->op_type == OP_ENTER);
- nullop->op_next = kLISTOP->op_next;
+ || kid->op_type == OP_ENTER
+ || (PL_parser && PL_parser->error_count));
+ nullop->op_next = kid->op_next;
DEFER(nullop->op_next);
}
oldop = ourlast;
o = oldop->op_next;
goto redo;
-
+ NOT_REACHED; /* NOTREACHED */
break;
}
NOOP;
}
else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
+ /* if there are only lexicals on the LHS and no
+ * common ones on the RHS, then we assume that the
+ * only way those lexicals could also get
+ * on the RHS is via some sort of dereffing or
+ * closure, e.g.
+ * $r = \$lex;
+ * ($lex, $x) = (1, $$r)
+ * and in this case we assume the var must have
+ * a bumped ref count. So if its ref count is 1,
+ * it must only be on the LHS.
+ */
o->op_private |= OPpASSIGN_COMMON_RC1;
}
}
break;
}
+ case OP_REF:
+ /* see if ref() is used in boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
+ break;
+
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
XopENTRYCUSTOM(o, xop_peep);
)
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
is_const
- ? "Constant subroutine %"SVf" redefined"
- : "Subroutine %"SVf" redefined",
+ ? "Constant subroutine %" SVf " redefined"
+ : "Subroutine %" SVf " redefined",
SVfARG(name));
}
https://perl5.git.perl.org / perl5.git / blobdiff