/* Destructor */
+/*
+=for apidoc Am|void|op_free|OP *o
+
+Free an op. Only use this when an op is no longer linked to from any optree.
+
+=cut
+*/
+
void
Perl_op_free(pTHX_ OP *o)
{
}
}
+/*
+=for apidoc Am|void|op_null|OP *o
+
+Neutralizes an op when it is no longer needed, but is still linked to from
+other ops.
+
+=cut
+*/
+
void
Perl_op_null(pTHX_ OP *o)
{
=head1 Optree Manipulation Functions
=for apidoc Am|OP*|op_linklist|OP *o
-This function is the implementation of the L</LINKLIST> macro. It should
+This function is the implementation of the L</LINKLIST> macro. It should
not be called directly.
=cut
return scalar(o);
}
+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 varname(gv, funny, 0, NULL, 0, 1);
+ }
+ return
+ varname(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 = "...";
+}
+
+static void
+S_scalar_slice_warning(pTHX_ const OP *o)
+{
+ OP *kid;
+ const char lbrack =
+ o->op_type == OP_HSLICE ? '{' : '[';
+ const char rbrack =
+ o->op_type == OP_HSLICE ? '}' : ']';
+ SV *name;
+ SV *keysv = NULL; /* just to silence compiler warnings */
+ const char *key = NULL;
+
+ if (!(o->op_private & OPpSLICEWARNING))
+ return;
+ if (PL_parser && PL_parser->error_count)
+ /* This warning can be nonsensical when there is a syntax error. */
+ return;
+
+ kid = cLISTOPo->op_first;
+ kid = kid->op_sibling; /* get past pushmark */
+ /* weed out false positives: any ops that can return lists */
+ switch (kid->op_type) {
+ case OP_BACKTICK:
+ case OP_GLOB:
+ case OP_READLINE:
+ case OP_MATCH:
+ case OP_RV2AV:
+ case OP_EACH:
+ case OP_VALUES:
+ case OP_KEYS:
+ case OP_SPLIT:
+ case OP_LIST:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_ENTERSUB:
+ case OP_CALLER:
+ case OP_LSTAT:
+ case OP_STAT:
+ case OP_READDIR:
+ case OP_SYSTEM:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_ENTEREVAL:
+ case OP_REACH:
+ case OP_RKEYS:
+ case OP_RVALUES:
+ return;
+ }
+ assert(kid->op_sibling);
+ name = S_op_varname(aTHX_ kid->op_sibling);
+ if (!name) /* XS module fiddling with the op tree */
+ return;
+ S_op_pretty(aTHX_ kid, &keysv, &key);
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ 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
+ "%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",
+ SVfARG(name), lbrack, keysv, rbrack,
+ SVfARG(name), lbrack, keysv, rbrack);
+}
+
OP *
Perl_scalar(pTHX_ OP *o)
{
case OP_SORT:
Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
+ 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;
+ 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);
+ }
}
return o;
}
case OP_AELEMFAST:
case OP_AELEMFAST_LEX:
case OP_ASLICE:
+ case OP_KVASLICE:
case OP_HELEM:
case OP_HSLICE:
+ case OP_KVHSLICE:
case OP_UNPACK:
case OP_PACK:
case OP_JOIN:
/*
=for apidoc finalize_optree
-This function finalizes the optree. Should be called directly after
-the complete optree is built. It does some additional
+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.
* for reference counts, sv_upgrade() etc. */
if (cSVOPo->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
- 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));
- PAD_SETSV(ix, cSVOPo->op_sv);
- /* XXX I don't know how this isn't readonly already. */
- if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
- }
+ SvREFCNT_dec(PAD_SVl(ix));
+ PAD_SETSV(ix, cSVOPo->op_sv);
+ /* XXX I don't know how this isn't readonly already. */
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
cSVOPo->op_sv = NULL;
o->op_targ = ix;
}
UNOP *rop;
SV *lexname;
GV **fields;
- SV **svp, *sv;
- const char *key = NULL;
- STRLEN keylen;
+ SVOP *key_op;
+ OP *kid;
+ bool check_fields;
- if (((BINOP*)o)->op_last->op_type != OP_CONST)
+ if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
break;
- /* Make the CONST have a shared SV */
- svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvIsCOW_shared_hash(sv = *svp))
- && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
- key = SvPV_const(sv, keylen);
- lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
- 0);
- SvREFCNT_dec_NN(sv);
- *svp = lexname;
- }
+ rop = (UNOP*)((BINOP*)o)->op_first;
- if ((o->op_private & (OPpLVAL_INTRO)))
- break;
+ goto check_keys;
- 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 \"%"SVf"\" "
- "in variable %"SVf" of type %"HEKf,
- SVfARG(*svp), SVfARG(lexname),
- HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
- }
- break;
- }
+ case OP_HSLICE:
+ S_scalar_slice_warning(aTHX_ o);
- 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. */
+ case OP_KVHSLICE:
+ if (/* I bet there's always a pushmark... */
+ (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST
+ && kid->op_type != OP_CONST)
break;
+
+ key_op = (SVOP*)(kid->op_type == OP_CONST
+ ? kid
+ : kLISTOP->op_first->op_sibling);
+
rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV)
- break;
- if (rop->op_first->op_type == OP_PADSV)
+
+ check_keys:
+ if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
+ rop = NULL;
+ else if (rop->op_first->op_type == OP_PADSV)
/* @$hash{qw(keys here)} */
rop = (UNOP*)rop->op_first;
else {
rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
}
else
- break;
+ rop = NULL;
}
- 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;
+ lexname = NULL; /* just to silence compiler warnings */
+ fields = NULL; /* just to silence compiler warnings */
+
+ check_fields =
+ rop
+ && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
+ SvPAD_TYPED(lexname))
+ && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
+ && isGV(*fields) && GvHV(*fields);
+ for (; key_op;
key_op = (SVOP*)key_op->op_sibling) {
+ SV **svp, *sv;
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)) {
+
+ /* Make the CONST have a shared SV */
+ if ((!SvIsCOW_shared_hash(sv = *svp))
+ && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
+ SSize_t keylen;
+ const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
+ SV *nsv = newSVpvn_share(key,
+ SvUTF8(sv) ? -keylen : keylen, 0);
+ SvREFCNT_dec_NN(sv);
+ *svp = nsv;
+ }
+
+ if (check_fields
+ && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
"in variable %"SVf" of type %"HEKf,
SVfARG(*svp), SVfARG(lexname),
}
break;
}
+ case OP_ASLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ break;
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
the lvalue op).
This function detects things that can't be modified, such as C<$x+1>, and
-generates errors for them. For example, C<$x+1 = 2> would cause it to be
+generates errors for them. For example, C<$x+1 = 2> would cause it to be
called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
It also flags things that need to behave specially in an lvalue context,
localize = 1;
/* FALL THROUGH */
case OP_AASSIGN:
- if (type == OP_LEAVESUBLV)
+ /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
+ if (type == OP_LEAVESUBLV && (
+ (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
+ || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
+ ))
o->op_private |= OPpMAYBE_LVSUB;
/* FALL THROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ goto nomod;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
return o; /* Treat \(@foo) like ordinary list. */
if (scalar_mod_type(o, type))
goto nomod;
- if (type == OP_LEAVESUBLV)
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
+ && type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
/* FALL THROUGH */
case OP_PADSV:
PL_modcount++;
break;
- case OP_SCOPE:
case OP_LEAVE:
+ case OP_LEAVELOOP:
+ o->op_private |= OPpLVALUE;
+ case OP_SCOPE:
case OP_ENTER:
case OP_LINESEQ:
localize = 0;
case OP_COREARGS:
return o;
+
+ case OP_AND:
+ case OP_OR:
+ op_lvalue(cLOGOPo->op_first, type);
+ op_lvalue(cLOGOPo->op_first->op_sibling, type);
+ goto nomod;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
PERL_ARGS_ASSERT_APPLY_ATTRS;
/* fake up C<use attributes $pkg,$rv,@attrs> */
- ENTER; /* need to protect against side-effects of 'use' */
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
newSVOP(OP_CONST, 0,
newRV(target)),
dup_attrlist(attrs))));
- LEAVE;
}
STATIC void
target->op_type == OP_PADAV);
/* Ensure that attributes.pm is loaded. */
- ENTER; /* need to protect against side-effects of 'use' */
/* Don't force the C<use> if we don't need it. */
svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs(ATTRSMODULE), NULL);
- LEAVE;
/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
attrs)));
}
+STATIC void
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+{
+ OP *new_proto = NULL;
+ STRLEN pvlen;
+ char *pv;
+ OP *o;
+
+ PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
+
+ if (!*attrs)
+ return;
+
+ o = *attrs;
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ new_proto = o;
+ *attrs = NULL;
+ }
+ } else if (o->op_type == OP_LIST) {
+ OP * lasto = NULL;
+ assert(o->op_flags & OPf_KIDS);
+ assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
+ /* Counting on the first op to hit the lasto = o line */
+ for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ if (new_proto && ckWARN(WARN_MISC)) {
+ 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",
+ UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
+ op_free(new_proto);
+ }
+ else if (new_proto)
+ op_free(new_proto);
+ new_proto = o;
+ lasto->op_sibling = o->op_sibling;
+ continue;
+ }
+ }
+ lasto = o;
+ }
+ /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
+ would get pulled in with no real need */
+ if (!cLISTOPx(*attrs)->op_first->op_sibling) {
+ op_free(*attrs);
+ *attrs = NULL;
+ }
+ }
+
+ if (new_proto) {
+ SV *svname;
+ if (isGV(name)) {
+ svname = sv_newmortal();
+ gv_efullname3(svname, name, NULL);
+ }
+ else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
+ svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
+ else
+ svname = (SV *)name;
+ if (ckWARN(WARN_ILLEGALPROTO))
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ 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);
+
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "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));
+ }
+ if (*proto)
+ op_free(*proto);
+ *proto = new_proto;
+ }
+}
+
+static void
+S_cant_declare(pTHX_ OP *o)
+{
+ if (o->op_type == OP_NULL
+ && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
+ o = cUNOPo->op_first;
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
+ o->op_type == OP_NULL
+ && o->op_flags & OPf_SPECIAL
+ ? "do block"
+ : OP_DESC(o),
+ PL_parser->in_my == KEY_our ? "our" :
+ PL_parser->in_my == KEY_state ? "state" :
+ "my"));
+}
+
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
- OP_DESC(o),
- PL_parser->in_my == KEY_our
- ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
+ S_cant_declare(aTHX_ o);
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_parser->in_my = FALSE;
type != OP_PADHV &&
type != OP_PUSHMARK)
{
- yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
- OP_DESC(o),
- PL_parser->in_my == KEY_our
- ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
+ S_cant_declare(aTHX_ o);
return o;
}
else if (attrs && type != OP_PUSHMARK) {
)
? (int)rtype : OP_MATCH];
const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
- GV *gv;
SV * const name =
- (ltype == OP_RV2AV || ltype == OP_RV2HV)
- ? cUNOPx(left)->op_first->op_type == OP_GV
- && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
- ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
- : NULL
- : varname(
- (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
- );
+ S_op_varname(aTHX_ left);
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %"SVf" will act on scalar(%"SVf")",
/* !~ doesn't make sense with /r, so error on it for now */
if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
type == OP_NOT)
+ /* diag_listed_as: Using !~ with %s doesn't make sense */
yyerror("Using !~ with s///r doesn't make sense");
if (rtype == OP_TRANSR && type == OP_NOT)
+ /* diag_listed_as: Using !~ with %s doesn't make sense */
yyerror("Using !~ with tr///r doesn't make sense");
ismatchop = (rtype == OP_MATCH ||
=for apidoc Aox||blockhook_register
Register a set of hooks to be called when the Perl lexical scope changes
-at compile time. See L<perlguts/"Compile-time scope hooks">.
+at compile time.
See L<perlguts/"Compile-time scope hooks">.
=cut
*/
if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
{
dVAR;
- o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
+ o->op_ppaddr = PL_ppaddr[++(o->op_type)];
}
if (type == OP_NEGATE)
break;
case OP_REPEAT:
if (o->op_private & OPpREPEAT_DOLIST) goto nope;
+ break;
+ case OP_SREFGEN:
+ if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
+ || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
+ goto nope;
}
if (PL_parser && PL_parser->error_count)
#endif
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
- else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
+ else if (!SvIMMORTAL(sv)) {
+ SvPADTMP_on(sv);
+ SvREADONLY_on(sv);
+ }
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
{
- newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
- newop->op_folded = 1;
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ if (type != OP_STRINGIFY) newop->op_folded = 1;
}
op_getmad(o,newop,'f');
return newop;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
if (AvFILLp(av) != -1)
for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
+ {
SvPADTMP_on(*svp);
+ SvREADONLY_on(*svp);
+ }
#ifdef PERL_MAD
op_getmad(curop,o,'O');
#else
dVAR;
BINOP *binop;
- assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
+ ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
|| type == OP_SASSIGN || type == OP_NULL );
NewOp(1101, binop, 1, BINOP);
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
PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
-(or 0 for no flags). ver, if specified and not NULL, provides version semantics
+(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 import()
method, similar to C<use Foo::Bar VERSION LIST>. They must be
* that it has a PL_parser to play with while doing that, and also
* that it doesn't mess with any existing parser, by creating a tmp
* new parser with lex_start(). This won't actually be used for much,
- * since pp_require() will create another parser for the real work. */
+ * since pp_require() will create another parser for the real work.
+ * The ENTER/LEAVE pair protect callers from any side effects of use. */
ENTER;
SAVEVPTR(PL_curcop);
LEAVE;
}
+PERL_STATIC_INLINE OP *
+S_new_entersubop(pTHX_ GV *gv, OP *arg)
+{
+ return newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newLISTOP(OP_LIST, 0, arg,
+ newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv))));
+}
+
OP *
Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
dVAR;
OP *doop;
- GV *gv = NULL;
+ GV *gv;
PERL_ARGS_ASSERT_DOFILE;
- if (!force_builtin) {
- gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
- gv = gvp ? *gvp : NULL;
- }
- }
-
- if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
- doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, term,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)))));
+ if (!force_builtin && (gv = gv_override("do", 2))) {
+ doop = S_new_entersubop(aTHX_ gv, term);
}
else {
doop = newUNOP(OP_DOFILE, 0, scalar(term));
if (type == OP_LIST || flags & OPf_PARENS ||
type == OP_RV2AV || type == OP_RV2HV ||
- type == OP_ASLICE || type == OP_HSLICE)
+ type == OP_ASLICE || type == OP_HSLICE ||
+ type == OP_KVASLICE || type == OP_KVHSLICE)
return TRUE;
if (type == OP_PADAV || type == OP_PADHV)
OP *curop;
bool maybe_common_vars = TRUE;
+ if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
+ left->op_private &= ~ OPpSLICEWARNING;
+
PL_modcount = 0;
left = op_lvalue(left, OP_AASSIGN);
curop = list(force_list(left));
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
+#ifdef VMS
+ if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
+#endif
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
SAVEFREEPV(label);
}
- if (PL_parser->copline == NOLINE)
+ if (PL_parser->preambling != NOLINE) {
+ CopLINE_set(cop, PL_parser->preambling);
+ PL_parser->copline = NOLINE;
+ }
+ else if (PL_parser->copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
else {
CopLINE_set(cop, PL_parser->copline);
#endif
CopSTASH_set(cop, PL_curstash);
- if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
+ if (cop->op_type == OP_DBSTATE) {
/* this line can have a breakpoint - store the cop in IV */
AV *av = CopFILEAVx(PL_curcop);
if (av) {
first = *firstp;
other = *otherp;
+ /* [perl #59802]: Warn about things like "return $a or $b", which
+ is parsed as "(return $a) or $b" rather than "return ($a or
+ $b)". NB: This also applies to xor, which is why we do it
+ here.
+ */
+ switch (first->op_type) {
+ case OP_NEXT:
+ case OP_LAST:
+ case OP_REDO:
+ /* XXX: Perhaps we should emit a stronger warning for these.
+ Even with the high-precedence operator they don't seem to do
+ anything sensible.
+
+ But until we do, fall through here.
+ */
+ case OP_RETURN:
+ case OP_EXIT:
+ case OP_DIE:
+ case OP_GOTO:
+ /* XXX: Currently we allow people to "shoot themselves in the
+ foot" by explicitly writing "(return $a) or $b".
+
+ Warn unless we are looking at the result from folding or if
+ the programmer explicitly grouped the operators like this.
+ The former can occur with e.g.
+
+ use constant FEATURE => ( $] >= ... );
+ sub { not FEATURE and return or do_stuff(); }
+ */
+ if (!first->op_folded && !(first->op_flags & OPf_PARENS))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Possible precedence issue with control flow operator");
+ /* XXX: Should we optimze this to "return $a;" (i.e. remove
+ the "or $b" part)?
+ */
+ break;
+ }
+
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
- else if (other->op_type == OP_CONST)
- other->op_private |= OPpCONST_FOLDED;
other->op_folded = 1;
return other;
|| live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
- else if (live->op_type == OP_CONST)
- live->op_private |= OPpCONST_FOLDED;
live->op_folded = 1;
return live;
}
OP* listop;
OP* o;
const bool once = block && block->op_flags & OPf_SPECIAL &&
- (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
+ block->op_type == OP_NULL;
PERL_UNUSED_ARG(debuggable);
if (expr) {
- if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+ if (once && (
+ (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+ || ( expr->op_type == OP_NOT
+ && cUNOPx(expr)->op_first->op_type == OP_CONST
+ && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
+ )
+ ))
+ /* Return the block now, so that S_new_logop does not try to
+ fold it away. */
return block; /* do {} while 0 does once */
if (expr->op_type == OP_READLINE
|| expr->op_type == OP_READDIR
listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
o = new_logop(OP_AND, 0, &expr, &listop);
+ if (once) {
+ ASSUME(listop);
+ }
+
if (listop)
((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
if (once && o != listop)
+ {
+ assert(cUNOPo->op_first->op_type == OP_AND
+ || cUNOPo->op_first->op_type == OP_OR);
o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
+ }
if (o == listop)
o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
else if(cond
&& (cond->op_type == OP_ASLICE
- || cond->op_type == OP_HSLICE)) {
+ || cond->op_type == OP_KVASLICE
+ || cond->op_type == OP_HSLICE
+ || cond->op_type == OP_KVHSLICE)) {
/* anonlist now needs a list from this op, was previously used in
* scalar context */
=for apidoc cv_const_sv
-If C<cv> is a constant sub eligible for inlining. returns the constant
+If C<cv> is a constant sub eligible for inlining, returns the constant
value returned by the sub. Otherwise, returns NULL.
Constant subs can be created with C<newCONSTSUB> or as described in
#endif
{
/* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
+ SAVEFREESV(cv);
}
return TRUE;
}
[CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
spot = (CV **)svspot;
+ if (!(PL_parser && PL_parser->error_count))
+ move_proto_attr(&proto, &attrs, (GV *)name);
+
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
/* already defined? */
if (exists) {
- if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+ if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
cv = NULL;
else {
if (attrs) goto attrs;
return cv;
}
+/* _x = extended */
CV *
-Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
-{
- return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
-}
-
-CV *
-Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
- OP *block, U32 flags)
+Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
+ OP *block, bool o_is_gv)
{
dVAR;
GV *gv;
|| PL_madskills)
? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
STRLEN namlen = 0;
- const bool o_is_gv = flags & 1;
const char * const name =
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
OPSLAB *slab = NULL;
#endif
- 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;
-
if (o_is_gv) {
gv = (GV*)o;
o = NULL;
has_name = FALSE;
}
+ if (!ec)
+ move_proto_attr(&proto, &attrs, gv);
+
+ 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;
+
if (!PL_madskills) {
if (o)
SAVEFREEOP(o);
if (*name == 'B') {
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
+ dSP;
if (floor) LEAVE_SCOPE(floor);
ENTER;
+ PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
SAVEVPTR(PL_curcop);
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
+ POPSTACK;
LEAVE;
}
else
U32 flags)
{
CV *cv;
+ bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
),
cv, const_svp);
}
- SvREFCNT_dec_NN(cv);
+ interleave = TRUE;
+ ENTER;
+ SAVEFREESV(cv);
cv = NULL;
}
}
CvDYNFILE_on(cv);
}
sv_setpv(MUTABLE_SV(cv), proto);
+ if (interleave) LEAVE;
return cv;
}
switch (o->op_type) {
case OP_PADSV:
+ case OP_PADHV:
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
case OP_RV2SV:
+ case OP_RV2HV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
ref(o, OP_RV2AV);
return o;
}
+static void
+S_io_hints(pTHX_ OP *o)
+{
+ HV * const table =
+ PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
+ if (table) {
+ SV **svp = hv_fetchs(table, "open_IN", FALSE);
+ if (svp && *svp) {
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
+ if (mode & O_BINARY)
+ o->op_private |= OPpOPEN_IN_RAW;
+ else if (mode & O_TEXT)
+ o->op_private |= OPpOPEN_IN_CRLF;
+ }
+
+ svp = hv_fetchs(table, "open_OUT", FALSE);
+ if (svp && *svp) {
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
+ if (mode & O_BINARY)
+ o->op_private |= OPpOPEN_OUT_RAW;
+ else if (mode & O_TEXT)
+ o->op_private |= OPpOPEN_OUT_CRLF;
+ }
+ }
+}
+
+OP *
+Perl_ck_backtick(pTHX_ OP *o)
+{
+ GV *gv;
+ OP *newop = NULL;
+ PERL_ARGS_ASSERT_CK_BACKTICK;
+ /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
+ if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
+ && (gv = gv_override("readpipe",8))) {
+ newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
+ cUNOPo->op_first->op_sibling = NULL;
+ }
+ else if (!(o->op_flags & OPf_KIDS))
+ newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+ if (newop) {
+#ifdef PERL_MAD
+ op_getmad(o,newop,'O');
+#else
+ op_free(o);
+#endif
+ return newop;
+ }
+ S_io_hints(aTHX_ o);
+ return o;
+}
+
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
/* FALL THROUGH */
case OP_HELEM:
break;
+ case OP_KVASLICE:
+ Perl_croak(aTHX_ "delete argument is index/value array slice,"
+ " use array slice");
+ case OP_KVHSLICE:
+ Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
+ " hash slice");
default:
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
- OP_DESC(o));
+ Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
+ "element or slice");
}
if (kid->op_private & OPpLVAL_INTRO)
o->op_private |= OPpLVAL_INTRO;
}
OP *
-Perl_ck_die(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_DIE;
-
-#ifdef VMS
- if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
-#endif
- return ck_fun(o);
-}
-
-OP *
Perl_ck_eof(pTHX_ OP *o)
{
dVAR;
}
OP *
-Perl_ck_exit(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_EXIT;
-
-#ifdef VMS
- HV * const table = GvHV(PL_hintgv);
- if (table) {
- SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
- if (svp && *svp && SvTRUE(*svp))
- o->op_private |= OPpEXIT_VMSISH;
- }
- if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
-#endif
- return ck_fun(o);
-}
-
-OP *
Perl_ck_exec(pTHX_ OP *o)
{
PERL_ARGS_ASSERT_CK_EXEC;
(void) ref(kid, o->op_type);
if (kid->op_type != OP_RV2CV
&& !(PL_parser && PL_parser->error_count))
- Perl_croak(aTHX_ "%s argument is not a subroutine name",
- OP_DESC(o));
+ Perl_croak(aTHX_
+ "exists argument is not a subroutine name");
o->op_private |= OPpEXISTS_SUB;
}
else if (kid->op_type == OP_AELEM)
o->op_flags |= OPf_SPECIAL;
else if (kid->op_type != OP_HELEM)
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
- OP_DESC(o));
+ Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
+ "element or a subroutine");
op_null(kid);
}
return o;
{
return too_many_arguments_pv(o,PL_op_desc[type], 0);
}
- scalar(kid);
+ if (type != OP_DELETE) scalar(kid);
break;
case OA_LIST:
if (oa < 16) {
/* Defer checks to run-time if we have a scalar arg */
if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
op_lvalue(kid, type);
- else scalar(kid);
+ else {
+ scalar(kid);
+ /* diag_listed_as: push on reference is experimental */
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
+ "%s on reference is experimental",
+ PL_op_desc[type]);
+ }
break;
case OA_HVREF:
if (kid->op_type == OP_CONST &&
{
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 (core) gv = NULL;
- else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
- && GvCVu(gv) && GvIMPORTED_CV(gv)))
+ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
{
- GV * const * const gvp =
- (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
- gv = gvp ? *gvp : NULL;
- }
-
- if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
/* convert
* glob
* \ null - const(wildcard)
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- o = newLISTOP(OP_LIST, 0, o, NULL);
- o = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, o,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0, gv)))));
+ o = S_new_entersubop(aTHX_ gv, o);
o = newUNOP(OP_NULL, 0, o);
o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
Perl_ck_open(pTHX_ OP *o)
{
dVAR;
- HV * const table = GvHV(PL_hintgv);
PERL_ARGS_ASSERT_CK_OPEN;
- if (table) {
- SV **svp = hv_fetchs(table, "open_IN", FALSE);
- if (svp && *svp) {
- STRLEN len = 0;
- const char *d = SvPV_const(*svp, len);
- const I32 mode = mode_from_discipline(d, len);
- if (mode & O_BINARY)
- o->op_private |= OPpOPEN_IN_RAW;
- else if (mode & O_TEXT)
- o->op_private |= OPpOPEN_IN_CRLF;
- }
-
- svp = hv_fetchs(table, "open_OUT", FALSE);
- if (svp && *svp) {
- STRLEN len = 0;
- const char *d = SvPV_const(*svp, len);
- const I32 mode = mode_from_discipline(d, len);
- if (mode & O_BINARY)
- o->op_private |= OPpOPEN_OUT_RAW;
- else if (mode & O_TEXT)
- o->op_private |= OPpOPEN_OUT_CRLF;
- }
- }
- if (o->op_type == OP_BACKTICK) {
- if (!(o->op_flags & OPf_KIDS)) {
- OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
-#ifdef PERL_MAD
- op_getmad(o,newop,'O');
-#else
- op_free(o);
-#endif
- return newop;
- }
- return o;
- }
+ S_io_hints(aTHX_ o);
{
/* In case of three-arg dup open remove strictness
* from the last arg if it is a bareword. */
Perl_ck_require(pTHX_ OP *o)
{
dVAR;
- GV* gv = NULL;
+ GV* gv;
PERL_ARGS_ASSERT_CK_REQUIRE;
}
}
- if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
+ if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
/* handle override, if any */
- gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
- if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
- gv = gvp ? *gvp : NULL;
- }
- }
-
- if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
+ && (gv = gv_override("require", 7))) {
OP *kid, *newop;
if (o->op_flags & OPf_KIDS) {
kid = cUNOPo->op_first;
#ifndef PERL_MAD
op_free(o);
#endif
- newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, kid,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv)))));
+ newop = S_new_entersubop(aTHX_ gv, kid);
op_getmad(o,newop,'O');
return newop;
}
PERL_ARGS_ASSERT_SIMPLIFY_SORT;
- GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
- GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
if (!(have_scopeop = kid->op_type == OP_SCOPE)
&& kid->op_type != OP_LEAVE)
)
);
}
- assert(0);
+ NOT_REACHED;
}
else {
OP *prev, *cvop;
if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
SvIsCOW_on(sv);
CowREFCNT(sv) = 0;
+# ifdef PERL_DEBUG_READONLY_COW
+ sv_buf_to_ro(sv);
+# endif
}
#endif
SvREADONLY_on(sv);
}
}
/* if treating as a reference, defer additional checks to runtime */
- return o->op_type == ref_type ? o : ck_fun(o);
+ if (o->op_type == ref_type) {
+ /* diag_listed_as: keys on reference is experimental */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
+ "%s is experimental", PL_op_desc[ref_type]);
+ return o;
+ }
+ return ck_fun(o);
}
OP *
switch (kid->op_type) {
case OP_PADHV:
case OP_PADAV:
- name = varname(
- (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
- NULL, 0, 1
- );
- break;
case OP_RV2HV:
case OP_RV2AV:
- if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
- {
- GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
- if (!gv) break;
- name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
- }
+ name = S_op_varname(aTHX_ kid);
break;
default:
return o;
defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
} STMT_END
+#define IS_AND_OP(o) (o->op_type == OP_AND)
+#define IS_OR_OP(o) (o->op_type == OP_OR)
+
/* 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 */
case OP_NEXTSTATE:
PL_curcop = ((COP*)o); /* for warnings */
+ /* Optimise a "return ..." at the end of a sub to just be "...".
+ * This saves 2 ops. Before:
+ * 1 <;> nextstate(main 1 -e:1) v ->2
+ * 4 <@> return K ->5
+ * 2 <0> pushmark s ->3
+ * - <1> ex-rv2sv sK/1 ->4
+ * 3 <#> gvsv[*cat] s ->4
+ *
+ * After:
+ * - <@> return K ->-
+ * - <0> pushmark s ->2
+ * - <1> ex-rv2sv sK/1 ->-
+ * 2 <$> gvsv(*cat) s ->3
+ */
+ {
+ OP *next = o->op_next;
+ OP *sibling = o->op_sibling;
+ if ( OP_TYPE_IS(next, OP_PUSHMARK)
+ && OP_TYPE_IS(sibling, OP_RETURN)
+ && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
+ && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ && cUNOPx(sibling)->op_first == next
+ && next->op_sibling && next->op_sibling->op_next
+ && next->op_next
+ ) {
+ /* Look through the PUSHMARK's siblings for one that
+ * points to the RETURN */
+ OP *top = next->op_sibling;
+ while (top && top->op_next) {
+ if (top->op_next == sibling) {
+ top->op_next = sibling->op_next;
+ o->op_next = next->op_next;
+ break;
+ }
+ top = top->op_sibling;
+ }
+ }
+ }
+
+ /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
+ *
+ * This latter form is then suitable for conversion into padrange
+ * later on. Convert:
+ *
+ * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
+ *
+ * into:
+ *
+ * nextstate1 -> listop -> nextstate3
+ * / \
+ * pushmark -> padop1 -> padop2
+ */
+ if (o->op_next && (
+ o->op_next->op_type == OP_PADSV
+ || o->op_next->op_type == OP_PADAV
+ || o->op_next->op_type == OP_PADHV
+ )
+ && !(o->op_next->op_private & ~OPpLVAL_INTRO)
+ && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
+ && o->op_next->op_next->op_next && (
+ o->op_next->op_next->op_next->op_type == OP_PADSV
+ || o->op_next->op_next->op_next->op_type == OP_PADAV
+ || o->op_next->op_next->op_next->op_type == OP_PADHV
+ )
+ && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
+ && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
+ && (!CopLABEL((COP*)o)) /* Don't mess with labels */
+ && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
+ ) {
+ OP *first;
+ OP *last;
+ OP *newop;
+
+ first = o->op_next;
+ last = o->op_next->op_next->op_next;
+
+ newop = newLISTOP(OP_LIST, 0, first, last);
+ newop->op_flags |= OPf_PARENS;
+ newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ /* Kill nextstate2 between padop1/padop2 */
+ op_free(first->op_next);
+
+ first->op_next = last; /* padop2 */
+ first->op_sibling = last; /* ... */
+ o->op_next = cUNOPx(newop)->op_first; /* pushmark */
+ o->op_next->op_next = first; /* padop1 */
+ o->op_next->op_sibling = first; /* ... */
+ newop->op_next = last->op_next; /* nextstate3 */
+ newop->op_sibling = last->op_sibling;
+ last->op_next = newop; /* listop */
+ last->op_sibling = NULL;
+ o->op_sibling = newop; /* ... */
+
+ newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ /* Ensure pushmark has this flag if padops do */
+ if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
+ o->op_next->op_flags |= OPf_MOD;
+ }
+
+ break;
+ }
+
/* Two NEXTSTATEs in a row serve no purpose. Except if they happen
to carry two labels. For now, take the easier option, and skip
this optimisation if the first NEXTSTATE has a label. */
)
break;
- /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ /* let $a[N] potentially be optimised into AELEMFAST_LEX
* instead */
if ( p->op_type == OP_PADAV
&& p->op_next
old_count
= (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
- assert(oldoldop->op_targ + old_count == base);
- if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ /* Do not assume pad offsets for $c and $d are con-
+ tiguous in
+ my ($a,$b,$c);
+ my ($d,$e,$f);
+ */
+ if ( oldoldop->op_targ + old_count == base
+ && old_count < OPpPADRANGE_COUNTMASK - count) {
base = oldoldop->op_targ;
count += old_count;
reuse = 1;
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;
+
+ /* if we're an OR and our next is a AND in void context, we'll
+ follow it's op_other on short circuit, same for reverse.
+ We can't do this with OP_DOR since if it's true, its return
+ value is the underlying value which must be evaluated
+ by the next op */
+ if (o->op_next &&
+ (
+ (IS_AND_OP(o) && IS_OR_OP(o->op_next))
+ || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
+ )
+ && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
+ ) {
+ o->op_next = ((LOGOP*)o->op_next)->op_other;
+ }
DEFER(cLOGOP->op_other);
o->op_opt = 1;
case OP_CUSTOM: {
Perl_cpeep_t cpeep =
- XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+ XopENTRYCUSTOM(o, xop_peep);
if (cpeep)
cpeep(aTHX_ o, oldop);
break;
=head1 Custom Operators
=for apidoc Ao||custom_op_xop
-Return the XOP structure for a given custom op. This function should be
+Return the XOP structure for a given custom op. This macro should be
considered internal to OP_NAME and the other access macros: use them instead.
+This macro does call a function. Prior
+to 5.19.9, this was implemented as a
+function.
=cut
*/
-const XOP *
-Perl_custom_op_xop(pTHX_ const OP *o)
+XOPRETANY
+Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
{
SV *keysv;
HE *he = NULL;
static const XOP xop_null = { 0, 0, 0, 0, 0 };
- PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+ PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
assert(o->op_type == OP_CUSTOM);
/* This is wrong. It assumes a function pointer can be cast to IV,
XopENTRY_set(xop, xop_desc, savepvn(pv, l));
}
Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
- return xop;
}
-
- if (!he) return &xop_null;
-
- xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
- return xop;
+ else {
+ if (!he)
+ xop = (XOP *)&xop_null;
+ else
+ xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+ }
+ {
+ XOPRETANY any;
+ if(field == XOPe_xop_ptr) {
+ any.xop_ptr = xop;
+ } else {
+ const U32 flags = XopFLAGS(xop);
+ if(flags & field) {
+ switch(field) {
+ case XOPe_xop_name:
+ any.xop_name = xop->xop_name;
+ break;
+ case XOPe_xop_desc:
+ any.xop_desc = xop->xop_desc;
+ break;
+ case XOPe_xop_class:
+ any.xop_class = xop->xop_class;
+ break;
+ case XOPe_xop_peep:
+ any.xop_peep = xop->xop_peep;
+ break;
+ default:
+ NOT_REACHED;
+ break;
+ }
+ } else {
+ switch(field) {
+ case XOPe_xop_name:
+ any.xop_name = XOPd_xop_name;
+ break;
+ case XOPe_xop_desc:
+ any.xop_desc = XOPd_xop_desc;
+ break;
+ case XOPe_xop_class:
+ any.xop_class = XOPd_xop_class;
+ break;
+ case XOPe_xop_peep:
+ any.xop_peep = XOPd_xop_peep;
+ break;
+ default:
+ NOT_REACHED;
+ break;
+ }
+ }
+ }
+ return any;
+ }
}
/*
=for apidoc Ao||custom_op_register
-Register a custom op. See L<perlguts/"Custom Operators">.
+Register a custom op.
See L<perlguts/"Custom Operators">.
=cut
*/
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 not be equal to 0 or -KEY_CORE.
+by C<keyword()>. It must not be equal to 0.
=cut
*/
PERL_ARGS_ASSERT_CORE_PROTOTYPE;
- assert (code && code != -KEY_CORE);
+ assert (code);
if (!sv) sv = sv_newmortal();
https://perl5.git.perl.org / perl5.git / blobdiff