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_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
+ case OP_ARGDEFELEM: /* Was holding signature index. */
o->op_targ = 0;
break;
default:
/* 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:
break;
+ case OP_ARGCHECK:
+ PerlMemShared_free(cUNOP_AUXo->op_aux);
+ break;
+
case OP_MULTIDEREF:
{
UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
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);
* being spread throughout this file.
*/
-STATIC LOGOP *
-S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
+LOGOP *
+Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
dVAR;
LOGOP *logop;
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
{
PERL_ARGS_ASSERT_FINALIZE_OP;
+ assert(o->op_type != OP_FREED);
switch (o->op_type) {
case OP_NEXTSTATE:
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 */
);
? "do block"
: OP_DESC(o),
PL_op_desc[type]));
+ return;
}
OpTYPE_set(o, OP_LVREF);
o->op_private &=
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:
goto nomod;
case OP_SREFGEN:
+ if (type == OP_NULL) { /* local */
+ local_refgen:
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ op_lvalue(cUNOPo->op_first, OP_NULL);
+ return o;
+ }
if (type != OP_AASSIGN && type != OP_SASSIGN
&& type != OP_ENTERLOOP)
goto nomod;
assert (!OpHAS_SIBLING(kid));
goto kid_2lvref;
case OP_REFGEN:
+ if (type == OP_NULL) /* local */
+ goto local_refgen;
if (type != OP_AASSIGN) goto nomod;
kid = cUNOPo->op_first;
kid_2lvref:
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;
goto nomod;
}
- /* [20011101.069] File test operators interpret OPf_REF to mean that
+ /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_REFGEN &&
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));
type = o->op_type;
- if (type == OP_LIST) {
+ if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
my_kid(kid, attrs, imopsp);
o->op_private |= OPpOUR_INTRO;
return o;
}
+ else if (type == OP_REFGEN || type == OP_SREFGEN) {
+ if (!FEATURE_MYREF_IS_ENABLED)
+ Perl_croak(aTHX_ "The experimental declared_refs "
+ "feature is not enabled");
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
+ "Declaring references is experimental");
+ /* Kid is a nulled OP_LIST, handled above. */
+ my_kid(cUNOPo->op_first, attrs, imopsp);
+ return o;
+ }
else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
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)
+ 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:
+ 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
expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
}
- rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
+ rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
+ rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
rcop->op_private = 1;
/* establish postfix order */
=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)
}
}
- logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
+ logop = alloc_LOGOP(type, first, LINKLIST(other));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
live->op_folded = 1;
return live;
}
- logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
+ logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
- range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
+ range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
PERL_ARGS_ASSERT_NEWGIVWHENOP;
PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
- enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
+ enterop = alloc_LOGOP(enter_opcode, block, NULL);
enterop->op_targ = 0;
enterop->op_private = 0;
}
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:
op_sibling_splice(o, NULL, -1, NULL);
op_free(o);
- enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
+ enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
/* establish postfix order */
enter->op_next = (OP*)enter;
}
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);
}
Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
- gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
+ gwop = alloc_LOGOP(type, o, LINKLIST(kid));
kid->op_next = (OP*)gwop;
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
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,
{
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;
&& SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
)
goto bad;
+ /* FALLTHROUGH */
default:
qerror(Perl_mess(aTHX_
"Experimental %s on scalar is now forbidden",
}
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))
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)));
is_last = TRUE;
index_skip = action_count;
action |= MDEREF_FLAG_last;
+ if (index_type != MDEREF_INDEX_none)
+ arg--;
}
if (pass)
} /* 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(pTHX_ 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;
+
+ assert(o->op_type != OP_FREED);
+
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
/* XXX: We avoid setting op_seq here to prevent later calls
to rpeep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
- though (See 20010220.007). AMS 20010719 */
+ though (See 20010220.007 (#5874)). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
o->op_opt = 0;
/* FALLTHROUGH */
&& 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(aTHX_ 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:
case OP_DORASSIGN:
case OP_RANGE:
case OP_ONCE:
+ case OP_ARGDEFELEM:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
DEFER(cLOGOP->op_other);
&& ( 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;
}
}
)
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
is_const
- ? "Constant subroutine %"SVf" redefined"
- : "Subroutine %"SVf" redefined",
+ ? "Constant subroutine %" SVf " redefined"
+ : "Subroutine %" SVf " redefined",
SVfARG(name));
}
XSRETURN(AvFILLp(av)+1);
}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/