From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

/* vi: set ft=c inde=: */
#ifndef scalarseq
#define scalarseq(A) S_scalarseq(aTHX_ A)
/* Check for in place reverse and sort assignments like "@a = reverse @a"
and modify the optree to make them work inplace */
static void S_inplace_aassign(pTHX_ OP *o) {
OP *modop, *modop_pushmark;
OP *oright;
OP *oleft, *oleft_pushmark;
/* PERL_ARGS_ASSERT_INPLACE_AASSIGN; */
assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
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;
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);
if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
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) {
if (oright->op_type != OP_RV2AV
|| !cUNOPx(oright)->op_first
|| cUNOPx(oright)->op_first->op_type != OP_GV
|| cUNOPx(oleft )->op_first->op_type != OP_GV
|| cGVOPx_gv(cUNOPx(oleft)->op_first) !=
cGVOPx_gv(cUNOPx(oright)->op_first)
)
return;
}
else if (oright->op_type != OP_PADAV
|| oright->op_targ != oleft->op_targ
)
return;
/* This actually is an inplace assignment */
modop->op_private |= OPpSORT_INPLACE;
/* 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);
}
#if HAVE_PERL_VERSION(5, 19, 4)
/* varname(): return the name of a variable, optionally with a subscript.
* If gv is non-zero, use the name of that global, along with gvtype (one
* of "$", "@", "%"); otherwise use the name of the lexical at pad offset
* targ. Depending on the value of the subscript_type flag, return:
*/
#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
static SV *S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) {
SV * const name = sv_newmortal();
if (gv && isGV(gv)) {
char buffer[2];
buffer[0] = gvtype;
buffer[1] = 0;
/* as gv_fullname4(), but add literal '^' for $^FOO names */
gv_fullname4(name, gv, buffer, 0);
if ((unsigned int)SvPVX(name)[1] <= 26) {
buffer[0] = '^';
buffer[1] = SvPVX(name)[1] + 'A' - 1;
/* Swap the 1 unprintable control character for the 2 byte pretty
version - ie substr($name, 1, 1) = $buffer; */
sv_insert(name, 1, 1, buffer, 2);
}
}
else {
CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
SV *sv;
AV *av;
assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
if (!cv || !CvPADLIST(cv))
return NULL;
av = *PadlistARRAY(CvPADLIST(cv));
sv = *av_fetch(av, targ, FALSE);
sv_setsv_flags(name, sv, 0);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
SV * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
SvREFCNT_dec_NN(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
/* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
}
return name;
}
static SV *S_op_varname(pTHX_ const OP *o) {
assert(o);
assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
{
const char funny = o->op_type == OP_PADAV
|| o->op_type == OP_RV2AV ? '@' : '%';
if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
GV *gv;
if (cUNOPo->op_first->op_type != OP_GV
|| !(gv = cGVOPx_gv(cUNOPo->op_first)))
return NULL;
return S_varname(aTHX_ gv, funny, 0, NULL, 0, 1);
}
return
S_varname(aTHX_ MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
}
}
static void
S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) {
/* or not so pretty :-) */
if (o->op_type == OP_CONST) {
*retsv = cSVOPo_sv;
if (SvPOK(*retsv)) {
SV *sv = *retsv;
*retsv = sv_newmortal();
pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
}
else if (!SvOK(*retsv))
*retpv = "undef";
}
else *retpv = "...";
}
#endif
static OP *S_scalarvoid(pTHX_ OP *);
static OP *S_scalar(pTHX_ OP *o) {
dVAR;
OP *kid;
/* assumes no premature commitment */
if (!o || (PL_parser && PL_parser->error_count)
|| (o->op_flags & OPf_WANT)
|| o->op_type == OP_RETURN)
{
return o;
}
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
switch (o->op_type) {
case OP_REPEAT:
S_scalar(aTHX_ cBINOPo->op_first);
break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
S_scalar(aTHX_ kid);
break;
/* FALL THROUGH */
case OP_SPLIT:
case OP_MATCH:
case OP_QR:
case OP_SUBST:
case OP_NULL:
default:
if (o->op_flags & OPf_KIDS) {
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
S_scalar(aTHX_ kid);
}
break;
case OP_LEAVE:
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
S_scalar(aTHX_ kid);
kid = kid->op_sibling;
do_kids:
while (kid) {
OP *sib = kid->op_sibling;
if (sib && kid->op_type != OP_LEAVEWHEN)
S_scalarvoid(aTHX_ kid);
else
S_scalar(aTHX_ kid);
kid = sib;
}
PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
kid = cLISTOPo->op_first;
goto do_kids;
case OP_SORT:
Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
#if HAVE_PERL_VERSION(5, 19, 4)
case OP_KVHSLICE:
case OP_KVASLICE:
{
/* Warn about scalar context */
const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
SV *name;
SV *keysv = NULL;
const char *key = NULL;
/* This warning can be nonsensical when there is a syntax error. */
if (PL_parser && PL_parser->error_count)
break;
if (!ckWARN(WARN_SYNTAX)) break;
kid = cLISTOPo->op_first;
kid = kid->op_sibling; /* get past pushmark */
assert(kid->op_sibling);
name = S_op_varname(aTHX_ kid->op_sibling);
if (!name) /* XS module fiddling with the op tree */
break;
S_op_pretty(aTHX_ kid, &keysv, &key);
assert(SvPOK(name));
sv_chop(name,SvPVX(name)+1);
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",
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",
SVfARG(name), lbrack, keysv, rbrack,
SVfARG(name), lbrack, keysv, rbrack);
}
#endif
}
return o;
}
static OP *S_scalarkids(pTHX_ OP *o) {
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
S_scalar(aTHX_ kid);
}
return o;
}
static OP *S_scalarvoid(pTHX_ OP *o) {
dVAR;
OP *kid;
SV *useless_sv = NULL;
const char *useless = NULL;
SV *sv;
U8 want;
PERL_ARGS_ASSERT_SCALARVOID;
if (o->op_type == OP_NEXTSTATE
|| o->op_type == OP_DBSTATE
|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
|| o->op_targ == OP_DBSTATE)))
PL_curcop = (COP*)o; /* for warning below */
/* assumes no premature commitment */
want = o->op_flags & OPf_WANT;
if ((want && want != OPf_WANT_SCALAR)
|| (PL_parser && PL_parser->error_count)
|| o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
{
return o;
}
if ((o->op_private & OPpTARGET_MY)
&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
{
return S_scalar(aTHX_ o); /* As if inside SASSIGN */
}
o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
switch (o->op_type) {
default:
if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
break;
/* FALL THROUGH */
case OP_REPEAT:
if (o->op_flags & OPf_STACKED)
break;
goto func_ops;
case OP_SUBSTR:
if (o->op_private == 4)
break;
/* FALL THROUGH */
case OP_GVSV:
case OP_WANTARRAY:
case OP_GV:
case OP_SMARTMATCH:
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
case OP_PADANY:
case OP_AV2ARYLEN:
case OP_REF:
case OP_REFGEN:
case OP_SREFGEN:
case OP_DEFINED:
case OP_HEX:
case OP_OCT:
case OP_LENGTH:
case OP_VEC:
case OP_INDEX:
case OP_RINDEX:
case OP_SPRINTF:
case OP_AELEM:
case OP_AELEMFAST:
IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, )
case OP_ASLICE:
IF_HAVE_PERL_5_19_4(case OP_KVASLICE:, )
case OP_HELEM:
case OP_HSLICE:
IF_HAVE_PERL_5_19_4(case OP_KVHSLICE:, )
case OP_UNPACK:
case OP_PACK:
case OP_JOIN:
case OP_LSLICE:
case OP_ANONLIST:
case OP_ANONHASH:
case OP_SORT:
case OP_REVERSE:
case OP_RANGE:
case OP_FLIP:
case OP_FLOP:
case OP_CALLER:
case OP_FILENO:
case OP_EOF:
case OP_TELL:
case OP_GETSOCKNAME:
case OP_GETPEERNAME:
case OP_READLINK:
case OP_TELLDIR:
case OP_GETPPID:
case OP_GETPGRP:
case OP_GETPRIORITY:
case OP_TIME:
case OP_TMS:
case OP_LOCALTIME:
case OP_GMTIME:
case OP_GHBYNAME:
case OP_GHBYADDR:
case OP_GHOSTENT:
case OP_GNBYNAME:
case OP_GNBYADDR:
case OP_GNETENT:
case OP_GPBYNAME:
case OP_GPBYNUMBER:
case OP_GPROTOENT:
case OP_GSBYNAME:
case OP_GSBYPORT:
case OP_GSERVENT:
case OP_GPWNAM:
case OP_GPWUID:
case OP_GGRNAM:
case OP_GGRGID:
case OP_GETLOGIN:
case OP_PROTOTYPE:
IF_HAVE_PERL_5_16(case OP_RUNCV:, )
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
/* Otherwise it's "Useless use of grep iterator" */
useless = OP_DESC(o);
break;
case OP_SPLIT:
kid = cLISTOPo->op_first;
if (kid && kid->op_type == OP_PUSHRE
#ifdef USE_ITHREADS
&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
#else
&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
#endif
)
useless = OP_DESC(o);
break;
case OP_NOT:
kid = cUNOPo->op_first;
if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
goto func_ops;
}
useless = "negative pattern binding (!~)";
break;
case OP_SUBST:
if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
useless = "non-destructive substitution (s///r)";
break;
case OP_TRANSR:
useless = "non-destructive transliteration (tr///r)";
break;
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
case OP_RV2HV:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
(!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
useless = "a variable";
break;
case OP_CONST:
sv = cSVOPo_sv;
if (cSVOPo->op_private & OPpCONST_STRICT) {
/* no_bareword_allowed(o); */
croak("%s: internal error: what even are birds", MY_PKG);
} else {
if (ckWARN(WARN_VOID)) {
/* don't warn on optimised away booleans, eg
* use constant Foo, 5; Foo || print; */
if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
useless = NULL;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = NULL;
else if (SvPOK(sv)) {
SV * const dsv = newSVpvs("");
useless_sv
= Perl_newSVpvf(aTHX_
"a constant (%s)",
pv_pretty(dsv, SvPVX_const(sv),
SvCUR(sv), 32, NULL, NULL,
PERL_PV_PRETTY_DUMP
| PERL_PV_ESCAPE_NOCLEAR
| PERL_PV_ESCAPE_UNI_DETECT));
SvREFCNT_dec_NN(dsv);
}
else if (SvOK(sv)) {
useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
}
else
useless = "a constant (undef)";
}
}
op_null(o); /* don't execute or even remember it */
break;
case OP_POSTINC:
o->op_type = OP_PREINC; /* pre-increment is faster */
o->op_ppaddr = PL_ppaddr[OP_PREINC];
break;
case OP_POSTDEC:
o->op_type = OP_PREDEC; /* pre-decrement is faster */
o->op_ppaddr = PL_ppaddr[OP_PREDEC];
break;
case OP_I_POSTINC:
o->op_type = OP_I_PREINC; /* pre-increment is faster */
o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
break;
case OP_I_POSTDEC:
o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
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: {
S_inplace_aassign(aTHX_ o);
break;
}
case OP_OR:
case OP_AND:
kid = cLOGOPo->op_first;
if (kid->op_type == OP_NOT
&& (kid->op_flags & OPf_KIDS)) {
if (o->op_type == OP_AND) {
o->op_type = OP_OR;
o->op_ppaddr = PL_ppaddr[OP_OR];
} else {
o->op_type = OP_AND;
o->op_ppaddr = PL_ppaddr[OP_AND];
}
op_null(kid);
}
case OP_DOR:
case OP_COND_EXPR:
case OP_ENTERGIVEN:
case OP_ENTERWHEN:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
S_scalarvoid(aTHX_ kid);
break;
case OP_NULL:
if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
case OP_ENTERTRY:
case OP_ENTER:
if (!(o->op_flags & OPf_KIDS))
break;
/* FALL THROUGH */
case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
case OP_LEAVEGIVEN:
case OP_LEAVEWHEN:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
S_scalarvoid(aTHX_ kid);
break;
case OP_ENTEREVAL:
S_scalarkids(aTHX_ o);
break;
case OP_SCALAR:
return S_scalar(aTHX_ o);
}
if (useless_sv) {
/* mortalise it, in case warnings are fatal. */
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Useless use of %"SVf" in void context",
sv_2mortal(useless_sv));
}
else if (useless) {
Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
"Useless use of %s in void context",
useless);
}
return o;
}
static OP *S_scalarseq(pTHX_ OP *o) {
dVAR;
if (o) {
const OPCODE type = o->op_type;
if (type == OP_LINESEQ || type == OP_SCOPE ||
type == OP_LEAVE || type == OP_LEAVETRY)
{
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
S_scalarvoid(aTHX_ kid);
}
}
PL_curcop = &PL_compiling;
}
o->op_flags &= ~OPf_PARENS;
if (PL_hints & HINT_BLOCK_SCOPE)
o->op_flags |= OPf_PARENS;
}
else
o = newOP(OP_STUB, 0);
return o;
}
#endif