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;
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;
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;
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 */
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 */
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;
}
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);
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_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);
#ifdef PERL_DEBUG_READONLY_OPS
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:
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);
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));
}
}
}
|| 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));
}
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_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);
#ifdef PERL_DEBUG_READONLY_OPS
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:
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);
}
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_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);
}
{
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,
}
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;
&& ( (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 used by later ops with SvTRUE(sv) or similar.
+ * If so, set a suitable private flag on o. Normally this will be
+ * bool_flag; but if it's only possible to determine booleaness at run
+ * time (e.g. sub f { ....; (%h || $y) }), then set maybe_flag instead.
+ */
+
+static void
+S_check_for_bool_cxt(OP*o, 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_OR:
+ case OP_DOR:
+ case OP_AND:
+ 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 );
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, 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, 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));
}