}
STATIC void
-S_no_bareword_allowed(pTHX_ const OP *o)
+S_no_bareword_allowed(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
SVfARG(cSVOPo_sv)));
+ o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
}
/* "register" allocation */
PERL_ARGS_ASSERT_ALLOCMY;
- if (flags)
+ if (flags & ~SVf_UTF8)
Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
(UV)flags);
if (len &&
!(is_our ||
isALPHA(name[1]) ||
- (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
+ ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
(name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name, len,
- is_our ? padadd_OUR :
- PL_parser->in_my == KEY_state ? padadd_STATE : 0,
+ off = pad_add_name_pvn(name, len,
+ (is_our ? padadd_OUR :
+ PL_parser->in_my == KEY_state ? padadd_STATE : 0)
+ | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
- /* not an OP_PADAV replacement */
+ {
GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
#ifdef USE_ITHREADS
&& PL_curpad
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- scalar(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
scalar(kid);
kid = sib;
}
dVAR;
OP *kid;
const char* useless = NULL;
+ U32 useless_is_utf8 = 0;
SV* sv;
U8 want;
case OP_SPRINTF:
case OP_AELEM:
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
case OP_ASLICE:
case OP_HELEM:
case OP_HSLICE:
SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
"a constant (%"SVf")", sv));
useless = SvPV_nolen(msv);
+ useless_is_utf8 = SvUTF8(msv);
}
else
useless = "a constant (undef)";
- if (o->op_private & OPpCONST_ARYBASE)
- useless = NULL;
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
break;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
+
case OP_OR:
case OP_AND:
kid = cLOGOPo->op_first;
return scalar(o);
}
if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
+ newSVpvn_flags(useless, strlen(useless),
+ SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
return o;
}
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN) {
- if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
- list(kid);
- scalarvoid(sib);
- break;
- } else
- scalarvoid(kid);
- } else
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ scalarvoid(kid);
+ else
list(kid);
kid = sib;
}
}
/*
+=for apidoc finalize_optree
+
+This function finalizes the optree. Should be called directly after
+the complete optree is built. It does some additional
+checking which can't be done in the normal ck_xxx functions and makes
+the tree thread-safe.
+
+=cut
+*/
+void
+Perl_finalize_optree(pTHX_ OP* o)
+{
+ PERL_ARGS_ASSERT_FINALIZE_OPTREE;
+
+ ENTER;
+ SAVEVPTR(PL_curcop);
+
+ finalize_op(o);
+
+ LEAVE;
+}
+
+STATIC void
+S_finalize_op(pTHX_ OP* o)
+{
+ PERL_ARGS_ASSERT_FINALIZE_OP;
+
+#if defined(PERL_MAD) && defined(USE_ITHREADS)
+ {
+ /* Make sure mad ops are also thread-safe */
+ MADPROP *mp = o->op_madprop;
+ while (mp) {
+ if (mp->mad_type == MAD_OP && mp->mad_vlen) {
+ OP *prop_op = (OP *) mp->mad_val;
+ /* We only need "Relocate sv to the pad for thread safety.", but this
+ easiest way to make sure it traverses everything */
+ if (prop_op->op_type == OP_CONST)
+ cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
+ finalize_op(prop_op);
+ }
+ mp = mp->mad_next;
+ }
+ }
+#endif
+
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
+ case OP_EXEC:
+ if ( o->op_sibling
+ && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
+ && ckWARN(WARN_SYNTAX))
+ {
+ if (o->op_sibling->op_sibling) {
+ const OPCODE type = o->op_sibling->op_sibling->op_type;
+ if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
+ const line_t oldline = CopLINE(PL_curcop);
+ CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "Statement unlikely to be reached");
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
+ "\t(Maybe you meant system() when you said exec()?)\n");
+ CopLINE_set(PL_curcop, oldline);
+ }
+ }
+ }
+ break;
+
+ case OP_GV:
+ if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
+ GV * const gv = cGVOPo_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
+ /* XXX could check prototype here instead of just carping */
+ SV * const sv = sv_newmortal();
+ gv_efullname3(sv, gv, NULL);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "%"SVf"() called too early to check prototype",
+ SVfARG(sv));
+ }
+ }
+ break;
+
+ case OP_CONST:
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ /* FALLTHROUGH */
+#ifdef USE_ITHREADS
+ case OP_HINTSEVAL:
+ case OP_METHOD_NAMED:
+ /* Relocate sv to the pad for thread safety.
+ * Despite being a "constant", the SV is written to,
+ * for reference counts, sv_upgrade() etc. */
+ if (cSVOPo->op_sv) {
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ if (o->op_type != OP_METHOD_NAMED &&
+ (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
+ {
+ /* If op_sv is already a PADTMP/MY then it is being used by
+ * some pad, so make a copy. */
+ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
+ SvREADONLY_on(PAD_SVl(ix));
+ SvREFCNT_dec(cSVOPo->op_sv);
+ }
+ else if (o->op_type != OP_METHOD_NAMED
+ && cSVOPo->op_sv == &PL_sv_undef) {
+ /* PL_sv_undef is hack - it's unsafe to store it in the
+ AV that is the pad, because av_fetch treats values of
+ PL_sv_undef as a "free" AV entry and will merrily
+ replace them with a new SV, causing pad_alloc to think
+ that this pad slot is free. (When, clearly, it is not)
+ */
+ SvOK_off(PAD_SVl(ix));
+ SvPADTMP_on(PAD_SVl(ix));
+ SvREADONLY_on(PAD_SVl(ix));
+ }
+ else {
+ SvREFCNT_dec(PAD_SVl(ix));
+ SvPADTMP_on(cSVOPo->op_sv);
+ PAD_SETSV(ix, cSVOPo->op_sv);
+ /* XXX I don't know how this isn't readonly already. */
+ SvREADONLY_on(PAD_SVl(ix));
+ }
+ cSVOPo->op_sv = NULL;
+ o->op_targ = ix;
+ }
+#endif
+ break;
+
+ case OP_HELEM: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp, *sv;
+ const char *key = NULL;
+ STRLEN keylen;
+
+ if (((BINOP*)o)->op_last->op_type != OP_CONST)
+ break;
+
+ /* Make the CONST have a shared SV */
+ svp = cSVOPx_svp(((BINOP*)o)->op_last);
+ if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
+ && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
+ key = SvPV_const(sv, keylen);
+ lexname = newSVpvn_share(key,
+ SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
+ 0);
+ SvREFCNT_dec(sv);
+ *svp = lexname;
+ }
+
+ if ((o->op_private & (OPpLVAL_INTRO)))
+ break;
+
+ rop = (UNOP*)((BINOP*)o)->op_first;
+ if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ break;
+ lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+ if (!SvPAD_TYPED(lexname))
+ break;
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ key = SvPV_const(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
+ }
+ break;
+ }
+
+ case OP_HSLICE: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp;
+ const char *key;
+ STRLEN keylen;
+ SVOP *first_key_op, *key_op;
+
+ if ((o->op_private & (OPpLVAL_INTRO))
+ /* I bet there's always a pushmark... */
+ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+ /* hmmm, no optimization if list contains only one key. */
+ break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
+ if (rop->op_type != OP_RV2HV)
+ break;
+ if (rop->op_first->op_type == OP_PADSV)
+ /* @$hash{qw(keys here)} */
+ rop = (UNOP*)rop->op_first;
+ else {
+ /* @{$hash}{qw(keys here)} */
+ if (rop->op_first->op_type == OP_SCOPE
+ && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
+ {
+ rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
+ }
+ else
+ break;
+ }
+
+ lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
+ if (!SvPAD_TYPED(lexname))
+ break;
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ /* Again guessing that the pushmark can be jumped over.... */
+ first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+ ->op_first->op_sibling;
+ for (key_op = first_key_op; key_op;
+ key_op = (SVOP*)key_op->op_sibling) {
+ if (key_op->op_type != OP_CONST)
+ continue;
+ svp = cSVOPx_svp(key_op);
+ key = SvPV_const(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
+ }
+ }
+ break;
+ }
+ case OP_SUBST: {
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
+ }
+ default:
+ break;
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ finalize_op(kid);
+ }
+}
+
+/*
=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
Propagate lvalue ("modifiable") context to an op and its children.
*/
OP *
-Perl_op_lvalue(pTHX_ OP *o, I32 type)
+Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
OP *kid;
return o;
}
+ assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
+
switch (o->op_type) {
case OP_UNDEF:
localize = 0;
PL_modcount++;
return o;
- case OP_CONST:
- if (!(o->op_private & OPpCONST_ARYBASE))
- goto nomod;
- localize = 0;
- if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
- CopARYBASE_set(&PL_compiling,
- (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
- PL_eval_start = 0;
- }
- else if (!type) {
- SAVECOPARYBASE(&PL_compiling);
- CopARYBASE_set(&PL_compiling, 0);
- }
- else if (type == OP_REFGEN)
- goto nomod;
- else
- Perl_croak(aTHX_ "That use of $[ is unsupported");
- break;
case OP_STUB:
if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
goto nomod;
case OP_ENTERSUB:
- if ((type == OP_UNDEF || type == OP_REFGEN) &&
+ if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* The default is to set op_private to the number of children,
- which for a UNOP such as RV2CV is always 1. And w're using
- the bit for a flag in RV2CV, so we need it clear. */
+ /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+ poses, so we need it clear. */
o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
- else if (o->op_private & OPpENTERSUB_NOMOD)
- return o;
else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO;
+ o->op_private |= OPpLVAL_INTRO
+ |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
/* Backward compatibility mode: */
/* FALL THROUGH */
default:
nomod:
+ if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
localize = -1;
PL_modcount++;
break;
case OP_PADSV:
PL_modcount++;
if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %s",
- PAD_COMPNAME_PV(o->op_targ));
+ Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
+ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
case OP_KEYS:
case OP_RKEYS:
- if (type != OP_SASSIGN)
+ if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
+ lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
case OP_LIST:
localize = 0;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- op_lvalue(kid, type);
+ /* elements might be in void context because the list is
+ in scalar context or because they are attribute sub calls */
+ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
+ op_lvalue(kid, type);
break;
case OP_RETURN:
return o;
}
-/* Do not use this. It will be removed after 5.14. */
-OP *
-Perl_mod(pTHX_ OP *o, I32 type)
-{
- return op_lvalue(o,type);
-}
-
-
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
- PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
+ assert(o || type != OP_SASSIGN);
switch (type) {
case OP_SASSIGN:
switch (o->op_type) {
case OP_ENTERSUB:
- if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
+ if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
o->op_flags |= OPf_SPECIAL;
o->op_private &= ~1;
}
+ else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+
break;
case OP_COND_EXPR:
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, pack, list(arg)),
newSVOP(OP_METHOD_NAMED, 0, meth)));
- imop->op_private |= OPpENTERSUB_NOMOD;
/* Combine the ops. */
*imopsp = op_append_elem(OP_LIST, *imopsp, imop);
o = scalar(op_append_list(OP_LIST, rops, o));
o->op_private |= OPpLVAL_INTRO;
}
- else
+ else {
+ /* The listop in rops might have a pushmark at the beginning,
+ which will mess up list assignment. */
+ LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+ if (rops->op_type == OP_LIST &&
+ lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+ {
+ OP * const pushmark = lrops->op_first;
+ lrops->op_first = pushmark->op_sibling;
+ op_free(pushmark);
+ }
o = op_append_list(OP_LIST, o, rops);
+ }
}
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
S_newDEFSVOP(pTHX)
{
dVAR;
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
+ PERL_CONTEXT *cx;
if (PL_eval_root)
return;
PL_eval_root = newUNOP(OP_LEAVEEVAL,
((PL_in_eval & EVAL_KEEPERR)
? OPf_SPECIAL : 0), o);
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+
+ if ((cx->blk_gimme & G_WANT) == G_VOID)
+ scalarvoid(PL_eval_root);
+ else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
+ list(PL_eval_root);
+ else
+ scalar(PL_eval_root);
+
/* don't use LINKLIST, since PL_eval_root might indirect through
* a rather expensive function call and LINKLIST evaluates its
* argument more than once */
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
CALL_PEEP(PL_eval_start);
+ finalize_optree(PL_eval_root);
+
}
else {
if (o->op_type == OP_STUB) {
OpREFCNT_set(PL_main_root, 1);
PL_main_root->op_next = 0;
CALL_PEEP(PL_main_start);
+ finalize_optree(PL_main_root);
PL_compcv = 0;
/* Register with debugger */
return o;
}
+PERL_STATIC_INLINE OP *
+S_op_std_init(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_STD_INIT;
+
+ if (PL_opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (PL_opargs[type] & OA_TARGET && !o->op_targ)
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+
+ return o;
+}
+
+PERL_STATIC_INLINE OP *
+S_op_integerize(pTHX_ OP *o)
+{
+ I32 type = o->op_type;
+
+ PERL_ARGS_ASSERT_OP_INTEGERIZE;
+
+ /* integerize op, unless it happens to be C<-foo>.
+ * XXX should pp_i_negate() do magic string negation instead? */
+ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
+ && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
+ && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
+ {
+ dVAR;
+ o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
+ }
+
+ if (type == OP_NEGATE)
+ /* XXX might want a ck_negate() for this */
+ cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
+
+ return o;
+}
+
static OP *
S_fold_constants(pTHX_ register OP *o)
{
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
- if (PL_opargs[type] & OA_RETSCALAR)
- scalar(o);
- if (PL_opargs[type] & OA_TARGET && !o->op_targ)
- o->op_targ = pad_alloc(type, SVs_PADTMP);
-
- /* integerize op, unless it happens to be C<-foo>.
- * XXX should pp_i_negate() do magic string negation instead? */
- if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
- && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
- && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
- {
- o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
- }
-
if (!(PL_opargs[type] & OA_FOLDCONST))
goto nope;
switch (type) {
- case OP_NEGATE:
- /* XXX might want a ck_negate() for this */
- cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
- break;
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, NULL);
else
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
+ else {
+ OP * const kid2 = cLISTOPo->op_first->op_sibling;
+ if (kid2 && kid2->op_type == OP_COREARGS) {
+ op_null(cLISTOPo->op_first);
+ kid2->op_private |= OPpCOREARGS_PUSHMARK;
+ }
+ }
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
if (o->op_type != (unsigned)type)
return o;
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
/*
if (unop->op_next)
return (OP*)unop;
- return fold_constants((OP *) unop);
+ return fold_constants(op_integerize(op_std_init((OP *) unop)));
}
/*
binop->op_last = binop->op_first->op_sibling;
- return fold_constants((OP *)binop);
+ return fold_constants(op_integerize(op_std_init((OP *)binop)));
}
static int uvcompare(const void *a, const void *b)
PERL_ARGS_ASSERT_PACKAGE;
- save_hptr(&PL_curstash);
+ SAVEGENERICSV(PL_curstash);
save_item(PL_curstname);
- PL_curstash = gv_stashsv(sv, GV_ADD);
+ PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
sv_setsv(PL_curstname, sv);
}
/*
+ Helper function for newASSIGNOP to detection commonality between the
+ lhs and the rhs. Marks all variables with PL_generation. If it
+ returns TRUE the assignment must be able to handle common variables.
+*/
+PERL_STATIC_INLINE bool
+S_aassign_common_vars(pTHX_ OP* o)
+{
+ OP *curop;
+ for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
+ if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_GV) {
+ GV *gv = cGVOPx_gv(curop);
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY)
+ {
+ if (PAD_COMPNAME_GEN(curop->op_targ)
+ == (STRLEN)PL_generation)
+ return TRUE;
+ PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
+
+ }
+ else if (curop->op_type == OP_RV2CV)
+ return TRUE;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
+ return TRUE;
+ }
+ else if (curop->op_type == OP_PUSHRE) {
+#ifdef USE_ITHREADS
+ if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
+ GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#else
+ GV *const gv
+ = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+ if (gv) {
+ if (gv == PL_defgv
+ || (int)GvASSIGN_GENERATION(gv) == PL_generation)
+ return TRUE;
+ GvASSIGN_GENERATION_set(gv, PL_generation);
+ }
+#endif
+ }
+ else
+ return TRUE;
+ }
+
+ if (curop->op_flags & OPf_KIDS) {
+ if (aassign_common_vars(curop))
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
Constructs, checks, and returns an assignment op. I<left> and I<right>
bool maybe_common_vars = TRUE;
PL_modcount = 0;
- /* Grandfathering $[ assignment here. Bletch.*/
- /* Only simple assignments like C<< ($[) = 1 >> are allowed */
- PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
left = op_lvalue(left, OP_AASSIGN);
- if (PL_eval_start)
- PL_eval_start = 0;
- else if (left->op_type == OP_CONST) {
- deprecate("assignment to $[");
- /* FIXME for MAD */
- /* Result of assignment is always 1 (or we'd be dead already) */
- return newSVOP(OP_CONST, 0, newSViv(1));
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
*/
if (maybe_common_vars) {
- OP *lastop = o;
PL_generation++;
- for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
- if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV) {
- GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- if (PAD_COMPNAME_GEN(curop->op_targ)
- == (STRLEN)PL_generation)
- break;
- PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
-
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop->op_type != OP_GV) /* funny deref? */
- break;
- }
- else if (curop->op_type == OP_PUSHRE) {
-#ifdef USE_ITHREADS
- if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
- GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
-#else
- GV *const gv
- = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
- if (gv) {
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- break;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
-#endif
- }
- else
- break;
- }
- lastop = curop;
- }
- if (curop != o)
+ if (aassign_common_vars(o))
o->op_private |= OPpASSIGN_COMMON;
+ LINKLIST(o);
}
if (right && right->op_type == OP_SPLIT && !PL_madskills) {
scalar(right));
}
else {
- PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
o = newBINOP(OP_SASSIGN, flags,
scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
- if (PL_eval_start)
- PL_eval_start = 0;
- else {
- if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
- deprecate("assignment to $[");
- op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
- }
- }
}
return o;
}
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
- /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
- CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
- */
cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
if (label) {
- Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
+ Perl_cop_store_label(aTHX_ cop, label, strlen(label), 0);
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH)
{
warnop = ((k1->op_type == OP_NULL)
? (OPCODE)k1->op_targ : k1->op_type);
flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+ /* check barewords before they might be optimized aways */
+ if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(left);
+ if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(right);
+
flip->op_next = o;
if (!flip->op_private || !flop->op_private)
LINKLIST(o); /* blow off optimizer unless constant */
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
}
}
else {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
scalar(ref_array_or_hash(cond)));
}
- return newGIVWHENOP(
- cond_op,
- op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
- OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+ return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
void
-Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
- const STRLEN len)
-{
- PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
-
- /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
- relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
- if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
- || (p && (len != SvCUR(cv) /* Not the same length. */
- || memNE(p, SvPVX_const(cv), len))))
+Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len, const U32 flags)
+{
+ const char * const cvp = CvPROTO(cv);
+ const STRLEN clen = CvPROTOLEN(cv);
+
+ PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
+
+ if (((!p != !cvp) /* One has prototype, one has not. */
+ || (p && (
+ (flags & SVf_UTF8) == SvUTF8(cv)
+ ? len != clen || memNE(cvp, p, len)
+ : flags & SVf_UTF8
+ ? bytes_cmp_utf8((const U8 *)cvp, clen,
+ (const U8 *)p, len)
+ : bytes_cmp_utf8((const U8 *)p, len,
+ (const U8 *)cvp, clen)
+ )
+ )
+ )
&& ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
+ SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
+ );
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
+ Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
else
sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
GV *gv;
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+ U32 ps_utf8 = 0;
register CV *cv = NULL;
SV *const_sv;
/* If the subroutine has no body, no attributes, and no builtin attributes
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
bool has_name;
+ bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
}
else
ps = NULL;
{
Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
+ cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
}
- if (ps)
+ 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);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto_len(cv, gv, ps, ps_len);
+ cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if ((!block
#ifdef PERL_MAD
|| block->op_type == OP_NULL
#endif
- )&& !attrs) {
+ )) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
}
+ if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
+ CvCONST(cv) ? "Constant subroutine %"SVf" redefined"
+ : "Subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
CopLINE_set(PL_curcop, oldline);
}
#ifdef PERL_MAD
}
}
if (const_sv) {
+ HV *stash;
SvREFCNT_inc_simple_void_NN(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
}
else {
GvCV_set(gv, NULL);
- cv = newCONSTSUB(NULL, name, const_sv);
+ cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
}
- mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+ stash =
(CvGV(cv) && GvSTASH(CvGV(cv)))
? GvSTASH(CvGV(cv))
: CvSTASH(cv)
? CvSTASH(cv)
- : PL_curstash
- );
+ : PL_curstash;
+ if (HvENAME_HEK(stash))
+ mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
if (PL_madskills)
goto install_block;
op_free(block);
CvOUTSIDE(PL_compcv) = temp_cv;
CvPADLIST(PL_compcv) = temp_av;
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
-#endif
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
}
GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
+ if (HvENAME_HEK(GvSTASH(gv)))
+ /* sub Foo::bar { (shift)+1 } */
+ mro_method_changed_in(GvSTASH(gv));
}
}
if (!CvGV(cv)) {
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
- if (attrs) {
- /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
- }
- if (ps)
+ if (ps) {
sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+ if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+ }
if (PL_parser && PL_parser->error_count) {
op_free(block);
}
install_block:
if (!block)
- goto done;
+ 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
exit. */
PL_breakable_sub_gen++;
- if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV));
- block->op_attached = 1;
- }
- else {
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
op_free(block);
#endif
block = newblock;
- }
- else
- block->op_attached = 1;
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
+ else block->op_attached = 1;
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 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));
/* now that optimizer has done its work, adjust pad values */
CvCONST_on(cv);
}
- if (has_name) {
+ attrs:
+ if (attrs) {
+ /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+ HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ }
+
+ if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",
(long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
- SvCUR(tmpstr), sv, 0);
+ SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
dSP;
/*
=for apidoc newCONSTSUB
+See L</newCONSTSUB_flags>.
+
+=cut
+*/
+
+CV *
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+{
+ return newCONSTSUB_flags(stash, name, 0, sv);
+}
+
+/*
+=for apidoc newCONSTSUB_flags
+
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Currently, the only useful value for C<flags> is SVf_UTF8.
+
Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
which won't be called if used as a destructor, but will suppress the overhead
of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
*/
CV *
-Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
{
dVAR;
CV* cv;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash) {
- SAVESPTR(PL_curstash);
+ SAVEGENERICSV(PL_curstash);
SAVECOPSTASH(PL_curcop);
- PL_curstash = stash;
+ PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
CopSTASH_set(PL_curcop,stash);
}
- /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
+ /* file becomes the CvFILE. For an XS, it's usually static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
- XS_DYNAMIC_FILENAME);
+ XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
const char *const filename, const char *const proto,
U32 flags)
{
- CV *cv = newXS(name, subaddr, filename);
+ CV *cv;
PERL_ARGS_ASSERT_NEWXS_FLAGS;
- if (flags & XS_DYNAMIC_FILENAME) {
- /* We need to "make arrangements" (ie cheat) to ensure that the
- filename lasts as long as the PVCV we just created, but also doesn't
- leak */
- STRLEN filename_len = strlen(filename);
- STRLEN proto_and_file_len = filename_len;
- char *proto_and_file;
- STRLEN proto_len;
-
- if (proto) {
- proto_len = strlen(proto);
- proto_and_file_len += proto_len;
-
- Newx(proto_and_file, proto_and_file_len + 1, char);
- Copy(proto, proto_and_file, proto_len, char);
- Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
- } else {
- proto_len = 0;
- proto_and_file = savepvn(filename, filename_len);
- }
+ {
+ GV * const gv = gv_fetchpv(name ? name :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI | flags, SVt_PVCV);
+
+ if (!subaddr)
+ Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
+
+ if ((cv = (name ? GvCV(gv) : NULL))) {
+ if (GvCVGEN(gv)) {
+ /* just a cached method */
+ SvREFCNT_dec(cv);
+ cv = NULL;
+ }
+ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+ /* already defined (or promised) */
+ if (ckWARN(WARN_REDEFINE)) {
+ GV * const gvcv = CvGV(cv);
+ if (gvcv) {
+ HV * const stash = GvSTASH(gvcv);
+ if (stash) {
+ const char *redefined_name = HvNAME_get(stash);
+ if ( redefined_name &&
+ strEQ(redefined_name,"autouse") ) {
+ const line_t oldline = CopLINE(PL_curcop);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ CvCONST(cv) ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined"
+ ,name);
+ CopLINE_set(PL_curcop, oldline);
+ }
+ }
+ }
+ }
+ SvREFCNT_dec(cv);
+ cv = NULL;
+ }
+ }
+
+ if (cv) /* must reuse cv if autoloaded */
+ cv_undef(cv);
+ else {
+ cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ if (name) {
+ GvCV_set(gv,cv);
+ GvCVGEN(gv) = 0;
+ if (HvENAME_HEK(GvSTASH(gv)))
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ }
+ }
+ if (!name)
+ CvANON_on(cv);
+ CvGV_set(cv, gv);
+ (void)gv_fetchfile(filename);
+ CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
+ an external constant string */
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ CvISXSUB_on(cv);
+ CvXSUB(cv) = subaddr;
+
+ if (name)
+ process_special_blocks(name, gv, cv);
+ }
- /* This gets free()d. :-) */
- sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
- SV_HAS_TRAILING_NUL);
- if (proto) {
- /* This gives us the correct prototype, rather than one with the
- file name appended. */
- SvCUR_set(cv, proto_len);
- } else {
- SvPOK_off(cv);
- }
- CvFILE(cv) = proto_and_file + proto_len;
- } else {
- sv_setpv(MUTABLE_SV(cv), proto);
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvFILE(cv) = savepv(filename);
+ CvDYNFILE_on(cv);
}
+ sv_setpv(MUTABLE_SV(cv), proto);
return cv;
}
CV *
Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
- dVAR;
- GV * const gv = gv_fetchpv(name ? name :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI, SVt_PVCV);
- register CV *cv;
-
PERL_ARGS_ASSERT_NEWXS;
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
- if ((cv = (name ? GvCV(gv) : NULL))) {
- if (GvCVGEN(gv)) {
- /* just a cached method */
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
- /* already defined (or promised) */
- /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
- if (ckWARN(WARN_REDEFINE)) {
- GV * const gvcv = CvGV(cv);
- if (gvcv) {
- HV * const stash = GvSTASH(gvcv);
- if (stash) {
- const char *redefined_name = HvNAME_get(stash);
- if ( strEQ(redefined_name,"autouse") ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv) ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined"
- ,name);
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
- }
- SvREFCNT_dec(cv);
- cv = NULL;
- }
- }
-
- if (cv) /* must reuse cv if autoloaded */
- cv_undef(cv);
- else {
- cv = MUTABLE_CV(newSV_type(SVt_PVCV));
- if (name) {
- GvCV_set(gv,cv);
- GvCVGEN(gv) = 0;
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
- }
- }
- if (!name)
- CvANON_on(cv);
- CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- CvISXSUB_on(cv);
- CvXSUB(cv) = subaddr;
-
- if (name)
- process_special_blocks(name, gv, cv);
-
- return cv;
+ return newXS_flags(name, subaddr, filename, NULL, 0);
}
#ifdef PERL_MAD
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
CALL_PEEP(CvSTART(cv));
+ finalize_optree(CvROOT(cv));
#ifdef PERL_MAD
op_getmad(o,pegop,'n');
op_getmad_weak(block, pegop, 'b');
{
PERL_ARGS_ASSERT_CK_ANONCODE;
- cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
+ cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
if (!PL_madskills)
cSVOPo->op_sv = NULL;
return o;
PERL_ARGS_ASSERT_CK_BITOP;
-#define OP_IS_NUMCOMPARE(op) \
- ((op) == OP_LT || (op) == OP_I_LT || \
- (op) == OP_GT || (op) == OP_I_GT || \
- (op) == OP_LE || (op) == OP_I_LE || \
- (op) == OP_GE || (op) == OP_I_GE || \
- (op) == OP_EQ || (op) == OP_I_EQ || \
- (op) == OP_NE || (op) == OP_I_NE || \
- (op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_INTEGER);
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& (o->op_type == OP_BIT_OR
if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == Perl_ck_ftst
- && kidtype != OP_STAT && kidtype != OP_LSTAT)
+ && kidtype != OP_STAT && kidtype != OP_LSTAT) {
o->op_private |= OPpFT_STACKED;
+ kid->op_private |= OPpFT_STACKING;
+ }
}
else {
#ifdef PERL_MAD
register OP *kid = cLISTOPo->op_first;
OP *sibl;
I32 numargs = 0;
+ bool seen_optional = FALSE;
if (kid->op_type == OP_PUSHMARK ||
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
tokid = &kid->op_sibling;
kid = kid->op_sibling;
}
- if (!kid && PL_opargs[type] & OA_DEFGV)
- *tokid = kid = newDEFSVOP();
+ if (kid && kid->op_type == OP_COREARGS) {
+ bool optional = FALSE;
+ while (oa) {
+ numargs++;
+ if (oa & OA_OPTIONAL) optional = TRUE;
+ oa = oa >> 4;
+ }
+ if (optional) o->op_private |= numargs;
+ return o;
+ }
+
+ while (oa) {
+ if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
+ if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
+ *tokid = kid = newDEFSVOP();
+ seen_optional = TRUE;
+ }
+ if (!kid) break;
- while (oa && kid) {
numargs++;
sibl = kid->op_sibling;
#ifdef PERL_MAD
if (is_handle_constructor(o,numargs)) {
const char *name = NULL;
STRLEN len = 0;
+ U32 name_utf8 = 0;
flags = 0;
/* Set a flag to tell rv2gv to vivify
SV *const namesv
= PAD_COMPNAME_SV(kid->op_targ);
name = SvPV_const(namesv, len);
+ name_utf8 = SvUTF8(namesv);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
+ name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
}
if (tmpstr) {
name = SvPV_const(tmpstr, len);
+ name_utf8 = SvUTF8(tmpstr);
sv_2mortal(tmpstr);
}
}
if (*name != '$')
sv_setpvs(namesv, "$");
sv_catpvn(namesv, name, len);
+ if ( name_utf8 ) SvUTF8_on(namesv);
}
}
kid->op_sibling = 0;
{
dVAR;
GV *gv;
+ const bool core = o->op_flags & OPf_SPECIAL;
PERL_ARGS_ASSERT_CK_GLOB;
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
- if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
+ if (core) gv = NULL;
+ else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
}
#if !defined(PERL_EXTERNAL_GLOB)
- /* XXX this can be tightened up and made more failsafe. */
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV *glob_gv;
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs("File::Glob"), NULL, NULL, NULL);
- if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV_set(gv, GvCV(glob_gv));
- SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
- GvIMPORTED_CV_on(gv);
- }
LEAVE;
}
-#endif /* PERL_EXTERNAL_GLOB */
+#endif /* !PERL_EXTERNAL_GLOB */
- assert(!(o->op_flags & OPf_SPECIAL));
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
+ else o->op_flags &= ~OPf_SPECIAL;
gv = newGVgen("main");
gv_IOadd(gv);
+#ifndef PERL_EXTERNAL_GLOB
+ sv_setiv(GvSVn(gv),PL_glob_index++);
+#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
scalarkids(o);
return o;
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
- offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
o->op_private = gwop->op_private = 0;
gwop->op_targ = pad_alloc(type, SVs_PADTMP);
OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (kid)
kid = kid->op_sibling; /* get past "big" */
- if (kid && kid->op_type == OP_CONST)
+ if (kid && kid->op_type == OP_CONST) {
+ const bool save_taint = PL_tainted;
fbm_compile(((SVOP*)kid)->op_sv, 0);
+ PL_tainted = save_taint;
+ }
}
return ck_fun(o);
}
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(method, SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
kSVOP->op_sv = NULL;
if (CvLVALUE(PL_compcv)) {
for (; kid; kid = kid->op_sibling)
op_lvalue(kid, OP_LEAVESUBLV);
- } else {
- for (; kid; kid = kid->op_sibling)
- if ((kid->op_type == OP_NULL)
- && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
- /* This is a do block */
- OP *op = kUNOP->op_first;
- if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
- op = cUNOPx(op)->op_first;
- assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
- /* Force the use of the caller's context */
- op->op_flags |= OPf_SPECIAL;
- }
- }
}
return o;
o->op_type = OP_SSELECT;
o->op_ppaddr = PL_ppaddr[OP_SSELECT];
o = ck_fun(o);
- return fold_constants(o);
+ return fold_constants(op_integerize(op_std_init(o)));
}
}
o = ck_fun(o);
Perl_croak(aTHX_ "panic: ck_split");
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
- cLISTOPo->op_first = kid;
- if (!kid) {
+ if (kid)
+ cLISTOPo->op_first = kid;
+ else {
cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
- proto = SvPV(protosv, proto_len);
+ if (SvTYPE(protosv) == SVt_PVCV)
+ proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
+ else proto = SvPV(protosv, proto_len);
proto_end = proto + proto_len;
aop = cUNOPx(entersubop)->op_first;
if (!aop->op_sibling)
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[') {}
+ while (*--p != '[')
+ /* \[$] accepts any scalar lvalue */
+ if (*p == '$'
+ && Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
gv_ename(namegv), o3);
o3->op_type == OP_HELEM ||
o3->op_type == OP_AELEM)
goto wrapref;
- if (!contextclass)
+ if (!contextclass) {
+ /* \$ accepts any scalar lvalue */
+ if (Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, "scalar", gv_ename(namegv), o3);
+ }
break;
case '@':
if (o3->op_type == OP_RV2AV ||
proto++;
continue;
default:
- oops:
- Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), SVfARG(protosv));
+ oops: {
+ SV* const tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, namegv, NULL);
+ Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
+ SVfARG(tmpsv), SVfARG(protosv));
+ }
}
op_lvalue(aop, OP_ENTERSUB);
return ck_entersub_args_list(entersubop);
}
+OP *
+Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
+{
+ int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
+ OP *aop = cUNOPx(entersubop)->op_first;
+
+ PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
+
+ if (!opnum) {
+ OP *cvop;
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+ aop = aop->op_sibling;
+ for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
+ aop = aop->op_sibling;
+ continue;
+ }
+ if (aop != cvop)
+ (void)too_many_arguments(entersubop, GvNAME(namegv));
+
+ op_free(entersubop);
+ switch(GvNAME(namegv)[2]) {
+ 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)
+ )
+ );
+ case 'P': return newSVOP(OP_CONST, 0,
+ (PL_curstash
+ ? newSVhek(HvNAME_HEK(PL_curstash))
+ : &PL_sv_undef
+ )
+ );
+ }
+ assert(0);
+ }
+ else {
+ OP *prev, *cvop;
+ U32 paren;
+#ifdef PERL_MAD
+ bool seenarg = FALSE;
+#endif
+ if (!aop->op_sibling)
+ aop = cUNOPx(aop)->op_first;
+
+ prev = aop;
+ aop = aop->op_sibling;
+ prev->op_sibling = NULL;
+ for (cvop = aop;
+ cvop->op_sibling;
+ prev=cvop, cvop = cvop->op_sibling)
+#ifdef PERL_MAD
+ if (PL_madskills && cvop->op_sibling
+ && cvop->op_type != OP_STUB) seenarg = TRUE
+#endif
+ ;
+ prev->op_sibling = NULL;
+ paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
+ op_free(cvop);
+ if (aop == cvop) aop = NULL;
+ op_free(entersubop);
+
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_UNOP:
+ case OA_BASEOP_OR_UNOP:
+ case OA_FILESTATOP:
+ return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren);
+ case OA_BASEOP:
+ if (aop) {
+#ifdef PERL_MAD
+ if (!PL_madskills || seenarg)
+#endif
+ (void)too_many_arguments(aop, GvNAME(namegv));
+ op_free(aop);
+ }
+ return newOP(opnum,0);
+ default:
+ return convert(opnum,0,aop);
+ }
+ }
+ assert(0);
+ return entersubop;
+}
+
/*
=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
}
OP *
-Perl_ck_unpack(pTHX_ OP *o)
-{
- OP *kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_UNPACK;
-
- if (kid->op_sibling) {
- kid = kid->op_sibling;
- if (!kid->op_sibling)
- kid->op_sibling = newDEFSVOP();
- }
- return ck_fun(o);
-}
-
-OP *
Perl_ck_substr(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_SUBSTR;
return (OP*)unop;
}
-/* Checks if o acts as an in-place operator on an array. oright points to the
- * beginning of the right-hand side. Returns the left-hand side of the
- * assignment if o acts in-place, or NULL otherwise. */
+/* Check for in place reverse and sort assignments like "@a = reverse @a"
+ and modify the optree to make them work inplace */
-STATIC OP *
-S_is_inplace_av(pTHX_ OP *o, OP *oright) {
- OP *o2;
- OP *oleft = NULL;
+STATIC void
+S_inplace_aassign(pTHX_ OP *o) {
- PERL_ARGS_ASSERT_IS_INPLACE_AV;
+ OP *modop, *modop_pushmark;
+ OP *oright;
+ OP *oleft, *oleft_pushmark;
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- return NULL;
+ PERL_ARGS_ASSERT_INPLACE_AASSIGN;
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
- )
- return NULL;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- return NULL;
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
- /* check that the sort is the first arg on RHS of assign */
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
+ assert(modop_pushmark->op_type == OP_PUSHMARK);
+ modop = modop_pushmark->op_sibling;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- return NULL;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- return NULL;
- if (o2->op_sibling != o)
- return NULL;
+ if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
+ return;
+
+ /* no other operation except sort/reverse */
+ if (modop->op_sibling)
+ return;
+
+ assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
+ oright = cUNOPx(modop)->op_first->op_sibling;
+
+ if (modop->op_flags & OPf_STACKED) {
+ /* skip sort subroutine/block */
+ assert(oright->op_type == OP_NULL);
+ oright = oright->op_sibling;
+ }
+
+ assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+ assert(oleft_pushmark->op_type == OP_PUSHMARK);
+ oleft = oleft_pushmark->op_sibling;
+
+ /* Check the lhs is an array */
+ if (!oleft ||
+ (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
+ || oleft->op_sibling
+ || (oleft->op_private & OPpLVAL_INTRO)
+ )
+ return;
+
+ /* Only one thing on the rhs */
+ if (oright->op_sibling)
+ return;
/* check the array is the same on both sides */
if (oleft->op_type == OP_RV2AV) {
|| cGVOPx_gv(cUNOPx(oleft)->op_first) !=
cGVOPx_gv(cUNOPx(oright)->op_first)
)
- return NULL;
+ return;
}
else if (oright->op_type != OP_PADAV
|| oright->op_targ != oleft->op_targ
)
- return NULL;
+ return;
+
+ /* This actually is an inplace assignment */
+
+ modop->op_private |= OPpSORT_INPLACE;
- return oleft;
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+
+ /* remove the aassign op and the lhs */
+ op_null(o);
+ op_null(oleft_pushmark);
+ if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
+ op_null(cUNOPx(oleft)->op_first);
+ op_null(oleft);
}
+#define MAX_DEFERRED 4
+
+#define DEFER(o) \
+ if (defer_ix == (MAX_DEFERRED-1)) { \
+ CALL_RPEEP(defer_queue[defer_base]); \
+ defer_base = (defer_base + 1) % MAX_DEFERRED; \
+ defer_ix--; \
+ } \
+ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
{
dVAR;
register OP* oldop = NULL;
+ OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
+ int defer_base = 0;
+ int defer_ix = -1;
if (!o || o->op_opt)
return;
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
- for (; o; o = o->op_next) {
-#if defined(PERL_MAD) && defined(USE_ITHREADS)
- MADPROP *mp = o->op_madprop;
- while (mp) {
- if (mp->mad_type == MAD_OP && mp->mad_vlen) {
- OP *prop_op = (OP *) mp->mad_val;
- /* I *think* that this is roughly the right thing to do. It
- seems that sometimes the optree hooked into the madprops
- doesn't have its next pointers set, so it's not possible to
- use them to locate all the OPs needing a fixup. Possibly
- it's a bit overkill calling LINKLIST to do this, when we
- could instead iterate over the OPs (without changing them)
- the way op_linklist does internally. However, I'm not sure
- if there are corner cases where we have a chain of partially
- linked OPs. Or even if we do, does that matter? Or should
- we always iterate on op_first,op_next? */
- LINKLIST(prop_op);
- do {
- if (prop_op->op_opt)
- break;
- prop_op->op_opt = 1;
- switch (prop_op->op_type) {
- case OP_CONST:
- case OP_HINTSEVAL:
- case OP_METHOD_NAMED:
- /* Duplicate the "relocate sv to the pad for thread
- safety" code, as otherwise an opfree of this madprop
- in the wrong thread will free the SV to the wrong
- interpreter. */
- if (((SVOP *)prop_op)->op_sv) {
- const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
- SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
- ((SVOP *)prop_op)->op_sv = NULL;
- }
- break;
- }
- } while ((prop_op = prop_op->op_next));
- }
- mp = mp->mad_next;
- }
-#endif
- if (o->op_opt)
+ for (;; o = o->op_next) {
+ if (o && o->op_opt)
+ o = NULL;
+ if (!o) {
+ while (defer_ix >= 0)
+ CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
break;
+ }
+
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
}
break;
- case OP_CONST:
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
-#ifdef USE_ITHREADS
- case OP_HINTSEVAL:
- case OP_METHOD_NAMED:
- /* Relocate sv to the pad for thread safety.
- * Despite being a "constant", the SV is written to,
- * for reference counts, sv_upgrade() etc. */
- if (cSVOP->op_sv) {
- const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
- /* If op_sv is already a PADTMP then it is being used by
- * some pad, so make a copy. */
- sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- SvREADONLY_on(PAD_SVl(ix));
- SvREFCNT_dec(cSVOPo->op_sv);
- }
- else if (o->op_type != OP_METHOD_NAMED
- && cSVOPo->op_sv == &PL_sv_undef) {
- /* PL_sv_undef is hack - it's unsafe to store it in the
- AV that is the pad, because av_fetch treats values of
- PL_sv_undef as a "free" AV entry and will merrily
- replace them with a new SV, causing pad_alloc to think
- that this pad slot is free. (When, clearly, it is not)
- */
- SvOK_off(PAD_SVl(ix));
- SvPADTMP_on(PAD_SVl(ix));
- SvREADONLY_on(PAD_SVl(ix));
- }
- else {
- SvREFCNT_dec(PAD_SVl(ix));
- SvPADTMP_on(cSVOPo->op_sv);
- PAD_SETSV(ix, cSVOPo->op_sv);
- /* XXX I don't know how this isn't readonly already. */
- SvREADONLY_on(PAD_SVl(ix));
- }
- cSVOPo->op_sv = NULL;
- o->op_targ = ix;
- }
-#endif
- break;
-
case OP_CONCAT:
if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
if (o->op_next->op_private & OPpTARGET_MY) {
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
- <= 255 &&
- i >= 0)
+ (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
{
GV *gv;
if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
if (o->op_type == OP_GV) {
gv = cGVOPo_gv;
GvAVn(gv);
+ o->op_type = OP_AELEMFAST;
}
else
- o->op_flags |= OPf_SPECIAL;
- o->op_type = OP_AELEMFAST;
+ o->op_type = OP_AELEMFAST_LEX;
}
break;
}
o->op_ppaddr = PL_ppaddr[OP_GVSV];
}
}
- else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV * const gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
- /* XXX could check prototype here instead of just carping */
- SV * const sv = sv_newmortal();
- gv_efullname3(sv, gv, NULL);
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%"SVf"() called too early to check prototype",
- SVfARG(sv));
- }
- }
else if (o->op_next->op_type == OP_READLINE
&& o->op_next->op_next->op_type == OP_CONCAT
&& (o->op_next->op_next->op_flags & OPf_STACKED))
sop = fop->op_sibling;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ while (o->op_next && ( o->op_type == o->op_next->op_type
+ || o->op_next->op_type == OP_NULL))
+ o->op_next = o->op_next->op_next;
+ DEFER(cLOGOP->op_other);
stitch_keys:
o->op_opt = 1;
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- CALL_RPEEP(cLOGOP->op_other);
+ DEFER(cLOGOP->op_other);
break;
case OP_ENTERLOOP:
case OP_ENTERITER:
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
- CALL_RPEEP(cLOOP->op_redoop);
while (cLOOP->op_nextop->op_type == OP_NULL)
cLOOP->op_nextop = cLOOP->op_nextop->op_next;
- CALL_RPEEP(cLOOP->op_nextop);
while (cLOOP->op_lastop->op_type == OP_NULL)
cLOOP->op_lastop = cLOOP->op_lastop->op_next;
- CALL_RPEEP(cLOOP->op_lastop);
+ /* a while(1) loop doesn't have an op_next that escapes the
+ * loop, so we have to explicitly follow the op_lastop to
+ * process the rest of the code */
+ DEFER(cLOOP->op_lastop);
break;
case OP_SUBST:
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmstashstartu.op_pmreplstart
= cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
- CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
- break;
-
- case OP_EXEC:
- if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
- && ckWARN(WARN_SYNTAX))
- {
- if (o->op_next->op_sibling) {
- const OPCODE type = o->op_next->op_sibling->op_type;
- if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
- const line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "Statement unlikely to be reached");
- Perl_warner(aTHX_ packWARN(WARN_EXEC),
- "\t(Maybe you meant system() when you said exec()?)\n");
- CopLINE_set(PL_curcop, oldline);
- }
- }
- }
+ DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
- case OP_HELEM: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, *sv;
- const char *key = NULL;
- STRLEN keylen;
-
- if (((BINOP*)o)->op_last->op_type != OP_CONST)
- break;
-
- /* Make the CONST have a shared SV */
- svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
- && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
- key = SvPV_const(sv, keylen);
- lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
- 0);
- SvREFCNT_dec(sv);
- *svp = lexname;
- }
-
- if ((o->op_private & (OPpLVAL_INTRO)))
- break;
-
- rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!SvPAD_TYPED(lexname))
- break;
- fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
- if (!fields || !GvHV(*fields))
- break;
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
- {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
- }
-
- break;
- }
-
- case OP_HSLICE: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp;
- const char *key;
- STRLEN keylen;
- SVOP *first_key_op, *key_op;
-
- if ((o->op_private & (OPpLVAL_INTRO))
- /* I bet there's always a pushmark... */
- || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
- /* hmmm, no optimization if list contains only one key. */
- break;
- rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV)
- break;
- if (rop->op_first->op_type == OP_PADSV)
- /* @$hash{qw(keys here)} */
- rop = (UNOP*)rop->op_first;
- else {
- /* @{$hash}{qw(keys here)} */
- if (rop->op_first->op_type == OP_SCOPE
- && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
- {
- rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
- }
- else
- break;
- }
-
- lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
- if (!SvPAD_TYPED(lexname))
- break;
- fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
- if (!fields || !GvHV(*fields))
- break;
- /* Again guessing that the pushmark can be jumped over.... */
- first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
- ->op_first->op_sibling;
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
- if (key_op->op_type != OP_CONST)
- continue;
- svp = cSVOPx_svp(key_op);
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
- {
- Perl_croak(aTHX_ "No such class field \"%s\" "
- "in variable %s of type %s",
- key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
- }
- }
- break;
- }
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (oldop
- && ( oldop->op_type == OP_AELEM
- || oldop->op_type == OP_PADSV
- || oldop->op_type == OP_RV2SV
- || oldop->op_type == OP_RV2GV
- || oldop->op_type == OP_HELEM
- )
- && (oldop->op_private & OPpDEREF)
- ) {
- o->op_private |= OPpDEREFed;
- }
-
case OP_SORT: {
- /* will point to RV2AV or PADAV op on LHS/RHS of assign */
- OP *oleft;
- OP *o2;
-
/* check that RHS of sort is a single plain array */
OP *oright = cUNOPo->op_first;
if (!oright || oright->op_type != OP_PUSHMARK)
break;
+ if (o->op_private & OPpSORT_INPLACE)
+ break;
+
/* reverse sort ... can be optimised. */
if (!cUNOPo->op_sibling) {
/* Nothing follows us on the list. */
}
}
- /* make @a = sort @a act in-place */
-
- oright = cUNOPx(oright)->op_sibling;
- if (!oright)
- break;
- if (oright->op_type == OP_NULL) { /* skip sort block/sub */
- oright = cUNOPx(oright)->op_sibling;
- }
-
- oleft = is_inplace_av(o, oright);
- if (!oleft)
- break;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpSORT_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
-
break;
}
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
- OP *oleft, *oright;
LISTOP *enter, *exlist;
- /* @a = reverse @a */
- if ((oright = cLISTOPo->op_first)
- && (oright->op_type == OP_PUSHMARK)
- && (oright = oright->op_sibling)
- && (oleft = is_inplace_av(o, oright))) {
- OP *o2;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
- o->op_private |= OPpREVERSE_INPLACE;
-
- /* excise push->gv->rv2av->null->aassign */
- o2 = o->op_next->op_next;
- op_null(o2); /* PUSHMARK */
- o2 = o2->op_next;
- if (o2->op_type == OP_GV) {
- op_null(o2); /* GV */
- o2 = o2->op_next;
- }
- op_null(o2); /* RV2AV or PADAV */
- o2 = o2->op_next->op_next;
- op_null(o2); /* AASSIGN */
-
- o->op_next = o2->op_next;
+ if (o->op_private & OPpSORT_INPLACE)
break;
- }
enter = (LISTOP *) o->op_next;
if (!enter)
break;
}
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
-
- if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
-
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
-
- refgen = (UNOP *)((BINOP *)o)->op_first;
-
- if (!refgen || refgen->op_type != OP_REFGEN)
- break;
-
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
-
- if (exlist->op_first->op_type != OP_PUSHMARK)
- break;
-
- rv2cv = (UNOP*)exlist->op_last;
-
- if (rv2cv->op_type != OP_RV2CV)
- break;
-
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
-
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
-
- break;
- }
-
-
case OP_QR:
case OP_MATCH:
if (!(cPMOP->op_pmflags & PMf_ONCE)) {
Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
}
+/*
+=head1 Functions in file op.c
+
+=for apidoc core_prototype
+This function assigns the prototype of the named core function to C<sv>, or
+to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
+NULL if the core function has no prototype. C<code> is a code as returned
+by C<keyword()>. It must be negative and unequal to -KEY_CORE.
+
+=cut
+*/
+
+SV *
+Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
+ int * const opnum)
+{
+ int i = 0, n = 0, seen_question = 0, defgv = 0;
+ I32 oa;
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+ char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ bool nullret = FALSE;
+
+ PERL_ARGS_ASSERT_CORE_PROTOTYPE;
+
+ assert (code < 0 && code != -KEY_CORE);
+
+ if (!sv) sv = sv_newmortal();
+
+#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
+
+ switch (-code) {
+ case KEY_and : case KEY_chop: case KEY_chomp:
+ case KEY_cmp : case KEY_exec: case KEY_eq :
+ case KEY_ge : case KEY_gt : case KEY_le :
+ case KEY_lt : case KEY_ne : case KEY_or :
+ case KEY_select: case KEY_system: case KEY_x : case KEY_xor:
+ if (!opnum) return NULL; nullret = TRUE; goto findopnum;
+ case KEY_keys: retsetpvs("+", OP_KEYS);
+ case KEY_values: retsetpvs("+", OP_VALUES);
+ case KEY_each: retsetpvs("+", OP_EACH);
+ case KEY_push: retsetpvs("+@", OP_PUSH);
+ case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
+ case KEY_pop: retsetpvs(";+", OP_POP);
+ case KEY_shift: retsetpvs(";+", OP_SHIFT);
+ case KEY_splice:
+ retsetpvs("+;$$@", OP_SPLICE);
+ case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
+ retsetpvs("", 0);
+ case KEY_readpipe:
+ name = "backtick";
+ }
+
+#undef retsetpvs
+
+ findopnum:
+ while (i < MAXO) { /* The slow way. */
+ if (strEQ(name, PL_op_name[i])
+ || strEQ(name, PL_op_desc[i]))
+ {
+ if (nullret) { assert(opnum); *opnum = i; return NULL; }
+ goto found;
+ }
+ i++;
+ }
+ assert(0); return NULL; /* Should not happen... */
+ found:
+ defgv = PL_opargs[i] & OA_DEFGV;
+ oa = PL_opargs[i] >> OASHIFT;
+ while (oa) {
+ if (oa & OA_OPTIONAL && !seen_question && (
+ !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
+ )) {
+ seen_question = 1;
+ str[n++] = ';';
+ }
+ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+ && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
+ /* But globs are already references (kinda) */
+ && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
+ ) {
+ str[n++] = '\\';
+ }
+ if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
+ && !scalar_mod_type(NULL, i)) {
+ str[n++] = '[';
+ str[n++] = '$';
+ str[n++] = '@';
+ str[n++] = '%';
+ if (i == OP_LOCK) str[n++] = '&';
+ str[n++] = '*';
+ str[n++] = ']';
+ }
+ else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+ if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
+ str[n-1] = '_'; defgv = 0;
+ }
+ oa = oa >> 4;
+ }
+ if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
+ str[n++] = '\0';
+ sv_setpvn(sv, str, n - 1);
+ if (opnum) *opnum = i;
+ return sv;
+}
+
+OP *
+Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
+ const int opnum)
+{
+ OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+ OP *o;
+
+ PERL_ARGS_ASSERT_CORESUB_OP;
+
+ switch(opnum) {
+ case 0:
+ return op_append_elem(OP_LINESEQ,
+ argop,
+ newSLICEOP(0,
+ newSVOP(OP_CONST, 0, newSViv(-code % 3)),
+ newOP(OP_CALLER,0)
+ )
+ );
+ case OP_SELECT: /* which represents OP_SSELECT as well */
+ if (code)
+ return newCONDOP(
+ 0,
+ newBINOP(OP_GT, 0,
+ newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
+ newSVOP(OP_CONST, 0, newSVuv(1))
+ ),
+ coresub_op(newSVuv((UV)OP_SSELECT), 0,
+ OP_SSELECT),
+ coresub_op(coreargssv, 0, OP_SELECT)
+ );
+ /* FALL THROUGH */
+ default:
+ switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return op_append_elem(
+ OP_LINESEQ, argop,
+ newOP(opnum,
+ opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
+ );
+ case OA_BASEOP_OR_UNOP:
+ o = newUNOP(opnum,0,argop);
+ if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
+ else {
+ onearg:
+ if (is_handle_constructor(o, 1))
+ argop->op_private |= OPpCOREARGS_DEREF1;
+ }
+ return o;
+ default:
+ o = convert(opnum,0,argop);
+ if (is_handle_constructor(o, 2))
+ argop->op_private |= OPpCOREARGS_DEREF2;
+ if (scalar_mod_type(NULL, opnum))
+ argop->op_private |= OPpCOREARGS_SCALARMOD;
+ if (opnum == OP_SUBSTR) {
+ o->op_private |= OPpMAYBE_LVSUB;
+ return o;
+ }
+ else goto onearg;
+ }
+ }
+}
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
https://perl5.git.perl.org / perl5.git / blobdiff