# define PerlMemShared PerlMem
#endif
+/* make freed ops die if they're inadvertently executed */
+#ifdef DEBUGGING
+static OP *
+S_pp_freed(pTHX)
+{
+ DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
+}
+#endif
+
void
Perl_Slab_Free(pTHX_ void *op)
{
PERL_ARGS_ASSERT_SLAB_FREE;
+#ifdef DEBUGGING
+ o->op_ppaddr = S_pp_freed;
+#endif
+
if (!o->op_slabbed) {
if (!o->op_static)
PerlMemShared_free(op);
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])
&& (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
+ /* diag_listed_as: Can't use global %s in "%s" */
yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
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);
SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
cMETHOPx(o)->op_rclass_sv = NULL;
#endif
+ /* FALLTHROUGH */
case OP_METHOD_NAMED:
case OP_METHOD_SUPER:
SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
/* 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 MDEREF_HV_padhv_helem:
is_hash = TRUE;
+ /* FALLTHROUGH */
case MDEREF_AV_padav_aelem:
pad_free((++items)->pad_offset);
goto do_elem;
case MDEREF_HV_gvhv_helem:
is_hash = TRUE;
+ /* FALLTHROUGH */
case MDEREF_AV_gvav_aelem:
#ifdef USE_ITHREADS
S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
case MDEREF_HV_gvsv_vivify_rv2hv_helem:
is_hash = TRUE;
+ /* FALLTHROUGH */
case MDEREF_AV_gvsv_vivify_rv2av_aelem:
#ifdef USE_ITHREADS
S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
case MDEREF_HV_padsv_vivify_rv2hv_helem:
is_hash = TRUE;
+ /* FALLTHROUGH */
case MDEREF_AV_padsv_vivify_rv2av_aelem:
pad_free((++items)->pad_offset);
goto do_vivify_rv2xv_elem;
case MDEREF_HV_pop_rv2hv_helem:
case MDEREF_HV_vivify_rv2hv_helem:
is_hash = TRUE;
+ /* FALLTHROUGH */
do_vivify_rv2xv_elem:
case MDEREF_AV_pop_rv2av_aelem:
case MDEREF_AV_vivify_rv2av_aelem:
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));
}
}
case OP_CONST:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
- /* FALLTHROUGH */
#ifdef USE_ITHREADS
+ /* FALLTHROUGH */
case OP_HINTSEVAL:
op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#endif
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;
goto nomod;
case OP_AVHVSWITCH:
if (type == OP_LEAVESUBLV
- && (o->op_private & 3) + OP_EACH == OP_KEYS)
+ && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
o->op_private |= OPpMAYBE_LVSUB;
goto nomod;
case OP_AV2ARYLEN:
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:
}
STATIC void
-S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
+ bool curstash)
{
OP *new_proto = NULL;
STRLEN pvlen;
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);
}
else
svname = (SV *)name;
if (ckWARN(WARN_ILLEGALPROTO))
- (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
+ curstash);
if (*proto && ckWARN(WARN_PROTOTYPE)) {
STRLEN old_len, new_len;
const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
+ if (curstash && svname == (SV *)name
+ && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
+ svname = sv_2mortal(newSVsv(PL_curstname));
+ sv_catpvs(svname, "::");
+ sv_catsv(svname, (SV *)name);
+ }
+
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;
+ OP * volatile curop;
OP *newop;
- VOL I32 type = o->op_type;
+ volatile I32 type = o->op_type;
bool is_stringify;
- SV * VOL sv = NULL;
+ SV * volatile sv = NULL;
int ret = 0;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
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);
spot = (CV **)svspot;
if (!(PL_parser && PL_parser->error_count))
- move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
+ move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
if (proto) {
assert(proto->op_type == OP_CONST);
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);
if (!ec) {
if (isGV(gv)) {
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs, gv, 0);
} else {
assert(cSVOPo);
- move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
+ move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
}
}
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);
SvROK_on(gv);
}
SvRV_set(gv, (SV *)cv);
+ if (HvENAME_HEK(PL_curstash))
+ mro_method_changed_in(PL_curstash);
}
}
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_RV2SV:
case OP_RV2AV:
OpTYPE_set(o, OP_RV2HV);
+ /* rv2hv steals the bottom bit for its own uses */
+ o->op_private &= ~OPpARG1_MASK;
ref(o, OP_RV2HV);
break;
&& strEQ(GvNAME(cGVOPx_gv(kid)), "[");
}
+/* for lt, gt, le, ge, eq, ne and their i_ variants */
+
OP *
Perl_ck_cmp(pTHX_ OP *o)
{
+ bool is_eq;
+ bool neg;
+ bool reverse;
+ bool iv0;
+ OP *indexop, *constop, *start;
+ SV *sv;
+ IV iv;
+
PERL_ARGS_ASSERT_CK_CMP;
- if (ckWARN(WARN_SYNTAX)) {
+
+ is_eq = ( o->op_type == OP_EQ
+ || o->op_type == OP_NE
+ || o->op_type == OP_I_EQ
+ || o->op_type == OP_I_NE);
+
+ if (!is_eq && ckWARN(WARN_SYNTAX)) {
const OP *kid = cUNOPo->op_first;
if (kid &&
(
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"$[ used in %s (did you mean $] ?)", OP_DESC(o));
}
- return o;
+
+ /* convert (index(...) == -1) and variations into
+ * (r)index/BOOL(,NEG)
+ */
+
+ reverse = FALSE;
+
+ indexop = cUNOPo->op_first;
+ constop = OpSIBLING(indexop);
+ start = NULL;
+ if (indexop->op_type == OP_CONST) {
+ constop = indexop;
+ indexop = OpSIBLING(constop);
+ start = constop;
+ reverse = TRUE;
+ }
+
+ if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
+ return o;
+
+ /* ($lex = index(....)) == -1 */
+ if (indexop->op_private & OPpTARGET_MY)
+ return o;
+
+ if (constop->op_type != OP_CONST)
+ return o;
+
+ sv = cSVOPx_sv(constop);
+ if (!(sv && SvIOK_notUV(sv)))
+ return o;
+
+ iv = SvIVX(sv);
+ if (iv != -1 && iv != 0)
+ return o;
+ iv0 = (iv == 0);
+
+ if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
+ if (!(iv0 ^ reverse))
+ return o;
+ neg = iv0;
+ }
+ else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
+ if (iv0 ^ reverse)
+ return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
+ if (!(iv0 ^ reverse))
+ return o;
+ neg = !iv0;
+ }
+ else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
+ if (iv0 ^ reverse)
+ return o;
+ neg = iv0;
+ }
+ else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
+ if (iv0)
+ return o;
+ neg = TRUE;
+ }
+ else {
+ assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
+ if (iv0)
+ return o;
+ neg = FALSE;
+ }
+
+ indexop->op_flags &= ~OPf_PARENS;
+ indexop->op_flags |= (o->op_flags & OPf_PARENS);
+ indexop->op_private |= OPpTRUEBOOL;
+ if (neg)
+ indexop->op_private |= OPpINDEX_BOOLNEG;
+ /* cut out the index op and free the eq,const ops */
+ (void)op_sibling_splice(o, start, 1, NULL);
+ op_free(o);
+
+ return indexop;
}
+
OP *
Perl_ck_concat(pTHX_ OP *o)
{
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");
return o;
}
+
OP *
Perl_ck_eval(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_RVCONST;
+ if (o->op_type == OP_RV2HV)
+ /* rv2hv steals the bottom bit for its own uses */
+ o->op_private &= ~OPpARG1_MASK;
+
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
}
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);
}
o->op_private |= OPpSORT_QSORT;
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
+ if ((sorthints & HINT_SORT_UNSTABLE) != 0)
+ o->op_private |= OPpSORT_UNSTABLE;
}
}
}
/* 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 (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
- if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
- && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
+ if (flags & RV2CVOPCV_RETURN_NAME_GV) {
+ if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
gv = CvGV(cv);
return (CV*)gv;
+ }
+ else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
+ if (CvLEXICAL(cv) || CvNAMED(cv))
+ return NULL;
+ if (!CvANON(cv) || !gv)
+ gv = CvGV(cv);
+ return (CV*)gv;
+
} else {
return cv;
}
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;
OP *
Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
- int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+ IV cvflags = SvIVX(protosv);
+ int opnum = cvflags & 0xffff;
OP *aop = cUNOPx(entersubop)->op_first;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
aop = cUNOPx(aop)->op_first;
aop = OpSIBLING(aop);
for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
- if (aop != cvop)
- (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
+ if (aop != cvop) {
+ SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ }
op_free(entersubop);
- switch(GvNAME(namegv)[2]) {
+ switch(cvflags >> 16) {
case 'F': return newSVOP(OP_CONST, 0,
newSVpv(CopFILE(PL_curcop),0));
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,
op_sibling_splice(parent, first, -1, NULL);
op_free(entersubop);
- if (opnum == OP_ENTEREVAL
- && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
+ if (cvflags == (OP_ENTEREVAL | (1<<16)))
flags |= OPpEVAL_BYTES <<8;
switch (PL_opargs[opnum] & OA_CLASS_MASK) {
return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
case OA_BASEOP:
if (aop) {
- (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
+ SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
op_free(aop);
}
return opnum == OP_RUNCV
}
/*
-=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+=for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
Retrieves the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
subroutine call, not marked with C<&>, where the callee can be identified
at compile time as C<cv>.
-The C-level function pointer is returned in C<*ckfun_p>, and an SV
-argument for it is returned in C<*ckobj_p>. The function is intended
-to be called in this manner:
+The C-level function pointer is returned in C<*ckfun_p>, an SV argument
+for it is returned in C<*ckobj_p>, and control flags are returned in
+C<*ckflags_p>. The function is intended to be called in this manner:
entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
In this call, C<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and C<namegv> is a GV
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and C<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> op if it needs to emit any diagnostics.
It is permitted to apply the check function in non-standard situations,
such as to a call to a different subroutine or to a method call.
-By default, the function is
+C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
+bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
+instead, anything that can be used as the first argument to L</cv_name>.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
+check function requires C<namegv> to be a genuine GV.
+
+By default, the check function is
L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
-and the SV parameter is C<cv> itself. This implements standard
-prototype processing. It can be changed, for a particular subroutine,
-by L</cv_set_call_checker>.
+the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
+flag is clear. This implements standard prototype processing. It can
+be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
+
+If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
+indicates that the caller only knows about the genuine GV version of
+C<namegv>, and accordingly the corresponding bit will always be set in
+C<*ckflags_p>, regardless of the check function's recorded requirements.
+If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
+indicates the caller knows about the possibility of passing something
+other than a GV as C<namegv>, and accordingly the corresponding bit may
+be either set or clear in C<*ckflags_p>, indicating the check function's
+recorded requirements.
+
+C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
+only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
+(for which see above). All other bits should be clear.
+
+=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
+
+The original form of L</cv_get_call_checker_flags>, which does not return
+checker flags. When using a checker function returned by this function,
+it is only safe to call it with a genuine GV as its C<namegv> argument.
=cut
*/
-static void
-S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
- U8 *flagsp)
+void
+Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
+ Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
{
MAGIC *callmg;
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
+ PERL_UNUSED_CONTEXT;
callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
if (callmg) {
*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
*ckobj_p = callmg->mg_obj;
- if (flagsp) *flagsp = callmg->mg_flags;
+ *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
- if (flagsp) *flagsp = 0;
+ *ckflags_p = gflags & MGf_REQUIRE_GV;
}
}
void
Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
{
+ U32 ckflags;
PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
PERL_UNUSED_CONTEXT;
- S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+ cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
+ &ckflags);
}
/*
-=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
Sets the function that will be used to fix up a call to C<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
subroutine call, not marked with C<&>, where the callee can be identified
at compile time as C<cv>.
-The C-level function pointer is supplied in C<ckfun>, and an SV argument
-for it is supplied in C<ckobj>. The function should be defined like this:
+The C-level function pointer is supplied in C<ckfun>, an SV argument for
+it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
+The function should be defined like this:
STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
C<namegv> may not actually be a GV. For efficiency, perl may pass a
CV or other SV instead. Whatever is passed can be used as the first
argument to L</cv_name>. You can force perl to pass a GV by including
-C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
+C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
+
+C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
+bit currently has a defined meaning (for which see above). All other
+bits should be clear.
The current setting for a particular CV can be retrieved by
-L</cv_get_call_checker>.
+L</cv_get_call_checker_flags>.
=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
The original form of L</cv_set_call_checker_flags>, which passes it the
-C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
+of that flag setting is that the check function is guaranteed to get a
+genuine GV as its C<namegv> argument.
=cut
*/
void
Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
- SV *ckobj, U32 flags)
+ SV *ckobj, U32 ckflags)
{
PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
callmg->mg_flags |= MGf_REFCOUNTED;
}
callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
- | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
+ | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
} else {
Perl_call_checker ckfun;
SV *ckobj;
- U8 flags;
- S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ U32 ckflags;
+ cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
if (CvISXSUB(cv) || !CvROOT(cv))
S_entersub_alloc_targ(aTHX_ o);
if (!namegv) {
the CV’s GV, unless this is an anonymous sub. This is not
ideal for lexical subs, as its stringification will include
the package. But it is the best we can do. */
- if (flags & MGf_REQUIRE_GV) {
+ if (ckflags & CALL_CHECKER_REQUIRE_GV) {
if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
namegv = CvGV(cv);
}
}
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;
+ U8 flag = 0;
+
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
+
+ /* OPpTARGET_MY and boolean context probably don't mix well.
+ * If someone finds a valid use case, maybe add an extra flag to this
+ * function which indicates its safe to do so for this op? */
+ assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
+ && (o->op_private & OPpTARGET_MY)));
+
+ 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:
+ flag = 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) {
+ flag = bool_flag;
+ lop = NULL;
+ break;
+ }
+ /* FALLTHROUGH */
+ case OP_OR:
+ case OP_DOR:
+ if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
+ flag = bool_flag;
+ lop = NULL;
+ }
+ else if (!(lop->op_flags & OPf_WANT)) {
+ /* unknown context - decide at runtime */
+ flag = maybe_flag;
+ lop = NULL;
+ }
+ break;
+
+ default:
+ lop = NULL;
+ break;
+ }
+
+ if (lop)
+ lop = lop->op_next;
+ }
+
+ o->op_private |= flag;
+}
+
/* 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_RV2AV:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ break;
+
+ case OP_RV2HV:
+ case OP_PADHV:
+ /*'keys %h' in void or scalar context: skip the OP_KEYS
+ * and perform the functionality directly in the RV2HV/PADHV
+ * op
+ */
+ if (o->op_flags & OPf_REF) {
+ OP *k = o->op_next;
+ U8 want = (k->op_flags & OPf_WANT);
+ if ( k
+ && k->op_type == OP_KEYS
+ && ( want == OPf_WANT_VOID
+ || want == OPf_WANT_SCALAR)
+ && !(k->op_private & OPpMAYBE_LVSUB)
+ && !(k->op_flags & OPf_MOD)
+ ) {
+ o->op_next = k->op_next;
+ o->op_flags &= ~(OPf_REF|OPf_WANT);
+ o->op_flags |= want;
+ o->op_private |= (o->op_type == OP_PADHV ?
+ OPpRV2HV_ISKEYS : OPpRV2HV_ISKEYS);
+ /* for keys(%lex), hold onto the OP_KEYS's targ
+ * since padhv doesn't have its own targ to return
+ * an int with */
+ if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
+ op_null(k);
+ }
+ }
+
+ /* 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:
+ if ( o->op_type == OP_PADAV
+ && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
+ )
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ /* FALLTHROUGH */
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_GREPWHILE:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ /* FALLTHROUGH */
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_ORASSIGN:
case OP_DORASSIGN:
break;
case OP_SUBST:
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
assert(!(cPMOP->op_pmflags & PMf_ONCE));
while (cPMOP->op_pmstashstartu.op_pmreplstart &&
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
&& ( 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;
}
}
o->op_private &=
~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
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_LENGTH:
+ /* see if the op is used in known boolean context,
+ * but not if OA_TARGLEX optimisation is enabled */
+ if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
+ && !(o->op_private & OPpTARGET_MY)
+ )
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ break;
+
+ case OP_POS:
+ /* see if the op is used in known boolean context */
+ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
+ S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
+ 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));
}
is a pointer to the C function that is to be added to that opcode's
check chain, and C<old_checker_p> points to the storage location where a
pointer to the next function in the chain will be stored. The value of
-C<new_pointer> is written into the L</PL_check> array, while the value
+C<new_checker> is written into the L</PL_check> array, while the value
previously stored there is written to C<*old_checker_p>.
-The function should be defined like this:
-
- static OP *new_checker(pTHX_ OP *op) { ... }
-
-It is intended to be called in this manner:
-
- new_checker(aTHX_ op)
-
-C<old_checker_p> should be defined like this:
-
- static Perl_check_t old_checker_p;
-
L</PL_check> is global to an entire process, and a module wishing to
hook op checking may find itself invoked more than once per process,
typically in different threads. To handle that situation, this function
is the usual case for most uses of op check hooking), it must chain the
check function referenced by C<*old_checker_p>.
+Taken all together, XS code to hook an op checker should typically look
+something like this:
+
+ static Perl_check_t nxck_frob;
+ static OP *myck_frob(pTHX_ OP *op) {
+ ...
+ op = nxck_frob(aTHX_ op);
+ ...
+ return op;
+ }
+ BOOT:
+ wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
+
If you want to influence compilation of calls to a specific subroutine,
-then use L</cv_set_call_checker> rather than hooking checking of all
-C<entersub> ops.
+then use L</cv_set_call_checker_flags> rather than hooking checking of
+all C<entersub> ops.
=cut
*/
https://perl5.git.perl.org / perl5.git / blobdiff