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);
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;
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:
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 */
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 for now. Otherwise op_free() etc will crash.
+ * for now. Otherwise op_free() etc will crash.
*/
OpTYPE_set(o, type);
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)
*
- * Flags currently has 2 bits or meaning:
+ * 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
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 */
=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 */
{
/* @pkg or @lex or local @pkg' or 'my @lex' */
OP *tmpop;
- PMOP * const pm = (PMOP*)right;
if (gvop) {
#ifdef USE_ITHREADS
- pm->op_pmreplrootu.op_pmtargetoff
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
= cPADOPx(gvop)->op_padix;
cPADOPx(gvop)->op_padix = 0; /* steal it */
#else
- pm->op_pmreplrootu.op_pmtargetgv
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
= MUTABLE_GV(cSVOPx(gvop)->op_sv);
cSVOPx(gvop)->op_sv = NULL; /* steal it */
#endif
left->op_private & OPpOUR_INTRO;
}
else {
- pm->op_pmreplrootu.op_pmtargetoff = left->op_targ;
+ ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
left->op_targ = 0; /* steal it */
right->op_private |= OPpSPLIT_LEX;
}
&& !(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);
}
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_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;
kid = cLISTOPo->op_first;
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
- /* remove match expression, and replace with new optree with
+ /* remove match expression, and replace with new optree with
* a match op at its head */
op_sibling_splice(o, NULL, 1, NULL);
/* pmruntime will handle split " " behavior with flag==2 */
* 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
+ * | | |
+ * MATCH - A - B - C => R - A - B - C => R - A - B - C
+ * | | |
+ * R X - Y X - Y
* |
* X - Y
*
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));
- assert(!(kid->op_private & ~OPpRUNTIME));
- kid->op_private = (o->op_private | (kid->op_private & OPpRUNTIME));
+ kid->op_private = o->op_private;
op_free(o);
o = kid;
kid = sibs; /* kid is now the string arg of the split */
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 (1) { /* XXX this condition is wrong - fix later
- 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 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 );
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