/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* either way, as the saying is, if you follow me." --the Gaffer
*/
+/* This file contains the functions that create, manipulate and optimize
+ * the OP structures that hold a compiled perl program.
+ *
+ * A Perl program is compiled into a tree of OPs. Each op contains
+ * structural pointers (eg to its siblings and the next op in the
+ * execution sequence), a pointer to the function that would execute the
+ * op, plus any data specific to that op. For example, an OP_CONST op
+ * points to the pp_const() function and to an SV containing the constant
+ * value. When pp_const() is executed, its job is to push that SV onto the
+ * stack.
+ *
+ * OPs are mainly created by the newFOO() functions, which are mainly
+ * called from the parser (in perly.y) as the code is parsed. For example
+ * the Perl code $a + $b * $c would cause the equivalent of the following
+ * to be called (oversimplifying a bit):
+ *
+ * newBINOP(OP_ADD, flags,
+ * newSVREF($a),
+ * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
+ * )
+ *
+ * Note that during the build of miniperl, a temporary copy of this file
+ * is made, called opmini.c.
+ */
+
+/*
+Perl's compiler is essentially a 3-pass compiler with interleaved phases:
+
+ A bottom-up pass
+ A top-down pass
+ An execution-order pass
+
+The bottom-up pass is represented by all the "newOP" routines and
+the ck_ routines. The bottom-upness is actually driven by yacc.
+So at the point that a ck_ routine fires, we have no idea what the
+context is, either upward in the syntax tree, or either forward or
+backward in the execution order. (The bottom-up parser builds that
+part of the execution order it knows about, but if you follow the "next"
+links around, you'll find it's actually a closed loop through the
+top level node.
+
+Whenever the bottom-up parser gets to a node that supplies context to
+its components, it invokes that portion of the top-down pass that applies
+to that part of the subtree (and marks the top node as processed, so
+if a node further up supplies context, it doesn't have to take the
+plunge again). As a particular subcase of this, as the new node is
+built, it takes all the closed execution loops of its subcomponents
+and links them into a new closed loop for the higher level node. But
+it's still not the real execution order.
+
+The actual execution order is not known till we get a grammar reduction
+to a top-level unit like a subroutine or file that will be called by
+"name" rather than via a "next" pointer. At that point, we can call
+into peep() to do that code's portion of the 3rd pass. It has to be
+recursive, but it's recursive on basic blocks, not on tree nodes.
+*/
#include "EXTERN.h"
#define PERL_IN_OP_C
#define PERL_SLAB_SIZE 2048
#endif
-#define NewOp(m,var,c,type) \
- STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
-
-#define FreeOp(p) Slab_Free(p)
-
-STATIC void *
-S_Slab_Alloc(pTHX_ int m, size_t sz)
+void *
+Perl_Slab_Alloc(pTHX_ int m, size_t sz)
{
/*
* To make incrementing use count easy PL_OpSlab is an I32 *
return (void *)(PL_OpPtr + 1);
}
-STATIC void
-S_Slab_Free(pTHX_ void *op)
+void
+Perl_Slab_Free(pTHX_ void *op)
{
I32 **ptr = (I32 **) op;
I32 *slab = ptr[-1];
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
if (--(*slab) == 0) {
- #ifdef NETWARE
- #define PerlMemShared PerlMem
- #endif
+# ifdef NETWARE
+# define PerlMemShared PerlMem
+# endif
PerlMemShared_free(slab);
if (slab == PL_OpSlab) {
}
}
}
-
-#else
-#define NewOp(m, var, c, type) Newz(m, var, c, type)
-#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
}
STATIC OP *
-S_too_few_arguments(pTHX_ OP *o, char *name)
+S_too_few_arguments(pTHX_ OP *o, const char *name)
{
yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
return o;
}
STATIC OP *
-S_too_many_arguments(pTHX_ OP *o, char *name)
+S_too_many_arguments(pTHX_ OP *o, const char *name)
{
yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
return o;
}
STATIC void
-S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
+S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
{
yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
(int)n, name, t, OP_DESC(kid)));
}
STATIC void
-S_no_bareword_allowed(pTHX_ OP *o)
+S_no_bareword_allowed(pTHX_ const OP *o)
{
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
{
PADOFFSET off;
- /* complain about "my $_" etc etc */
+ /* complain about "my $<special_var>" etc etc */
if (!(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (int)strlen(name) > 2)))
+ (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
/* check for duplicate declaration */
pad_check_dup(name,
- PL_in_my == KEY_our,
+ (bool)(PL_in_my == KEY_our),
(PL_curstash ? PL_curstash : PL_defstash)
);
off = pad_add_name(name,
PL_in_my_stash,
(PL_in_my == KEY_our
- ? (PL_curstash ? PL_curstash : PL_defstash)
+ /* $_ is always in main::, even with our */
+ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: Nullhv
),
0 /* not fake */
void
Perl_op_free(pTHX_ OP *o)
{
- register OP *kid, *nextkid;
OPCODE type;
+ PADOFFSET refcnt;
- if (!o || o->op_seq == (U16)-1)
+ if (!o || o->op_static)
return;
if (o->op_private & OPpREFCOUNTED) {
case OP_SCOPE:
case OP_LEAVEWRITE:
OP_REFCNT_LOCK;
- if (OpREFCNT_dec(o)) {
- OP_REFCNT_UNLOCK;
- return;
- }
+ refcnt = OpREFCNT_dec(o);
OP_REFCNT_UNLOCK;
+ if (refcnt)
+ return;
break;
default:
break;
}
if (o->op_flags & OPf_KIDS) {
+ register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
nextkid = kid->op_sibling; /* Get before next freeing kid */
op_free(kid);
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 */
#ifdef USE_ITHREADS
- if (cPADOPo->op_padix > 0) {
- /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
- * may still exist on the pad */
- pad_swipe(cPADOPo->op_padix, TRUE);
- cPADOPo->op_padix = 0;
- }
+ if (cPADOPo->op_padix > 0) {
+ /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
+ * may still exist on the pad */
+ pad_swipe(cPADOPo->op_padix, TRUE);
+ cPADOPo->op_padix = 0;
+ }
#else
- SvREFCNT_dec(cSVOPo->op_sv);
- cSVOPo->op_sv = Nullsv;
+ SvREFCNT_dec(cSVOPo->op_sv);
+ cSVOPo->op_sv = Nullsv;
#endif
+ }
break;
case OP_METHOD_NAMED:
case OP_CONST:
#ifdef USE_ITHREADS
/** Bug #15654
Even if op_clear does a pad_free for the target of the op,
- pad_free doesn't actually remove the sv that exists in the bad
+ pad_free doesn't actually remove the sv that exists in the pad;
instead it lives on. This results in that it could be reused as
a target later on when the pad was reallocated.
**/
o->op_ppaddr = PL_ppaddr[OP_NULL];
}
+void
+Perl_op_refcnt_lock(pTHX)
+{
+ OP_REFCNT_LOCK;
+}
+
+void
+Perl_op_refcnt_unlock(pTHX)
+{
+ OP_REFCNT_UNLOCK;
+}
+
/* Contextualizers */
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
OP *
Perl_linklist(pTHX_ OP *o)
{
- register OP *kid;
if (o->op_next)
return o->op_next;
/* establish postfix order */
if (cUNOPo->op_first) {
+ register OP *kid;
o->op_next = LINKLIST(cUNOPo->op_first);
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling)
OP *
Perl_scalarkids(pTHX_ OP *o)
{
- OP *kid;
if (o && o->op_flags & OPf_KIDS) {
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalar(kid);
}
{
if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
if (ckWARN(WARN_SYNTAX)) {
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_scalarvoid(pTHX_ OP *o)
{
OP *kid;
- char* useless = 0;
+ const char* useless = 0;
SV* sv;
U8 want;
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) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
+
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = 0;
/* the constants 0 and 1 are permitted as they are
conventionally used as dummies in constructs like
1 while some_condition_with_side_effects; */
- if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
else if (SvPOK(sv)) {
/* perl4's way of mixing documentation and code
OP *
Perl_listkids(pTHX_ OP *o)
{
- OP *kid;
if (o && o->op_flags & OPf_KIDS) {
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
list(kid);
}
OP *
Perl_scalarseq(pTHX_ OP *o)
{
- OP *kid;
-
if (o) {
if (o->op_type == OP_LINESEQ ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVE ||
o->op_type == OP_LEAVETRY)
{
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
STATIC OP *
S_modkids(pTHX_ OP *o, I32 type)
{
- OP *kid;
if (o && o->op_flags & OPf_KIDS) {
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
mod(kid, type);
}
break;
case OP_AELEMFAST:
- localize = 1;
+ localize = -1;
PL_modcount++;
break;
}
STATIC bool
-S_scalar_mod_type(pTHX_ OP *o, I32 type)
+S_scalar_mod_type(pTHX_ const OP *o, I32 type)
{
switch (type) {
case OP_SASSIGN:
}
STATIC bool
-S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
+S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
{
switch (o->op_type) {
case OP_PIPE_OP:
OP *
Perl_refkids(pTHX_ OP *o, I32 type)
{
- OP *kid;
if (o && o->op_flags & OPf_KIDS) {
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
ref(kid, type);
}
meth = newSVpvn("import", 6);
(void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ {
+ U32 hash;
+ PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ SvUV_set(meth, hash);
+ }
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
*/
void
-Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
- char *attrstr, STRLEN len)
+Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
+ const char *attrstr, STRLEN len)
{
OP *attrs = Nullop;
while (len) {
for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
if (len) {
- char *sstr = attrstr;
+ const char *sstr = attrstr;
for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
attrs = append_elem(OP_LIST, attrs,
newSVOP(OP_CONST, 0,
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
- OP *kid;
I32 type;
if (!o || PL_error_count)
type = o->op_type;
if (type == OP_LIST) {
+ OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
my_kid(kid, attrs, imopsp);
} else if (type == OP_UNDEF) {
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
OP *o;
+ bool ismatchop = 0;
if (ckWARN(WARN_MISC) &&
(left->op_type == OP_RV2AV ||
left->op_type == OP_RV2HV ||
left->op_type == OP_PADAV ||
left->op_type == OP_PADHV)) {
- char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
+ const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
right->op_type == OP_TRANS)
? right->op_type : OP_MATCH];
const char *sample = ((left->op_type == OP_RV2AV ||
no_bareword_allowed(right);
}
- if (!(right->op_flags & OPf_STACKED) &&
- (right->op_type == OP_MATCH ||
- right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS)) {
+ ismatchop = right->op_type == OP_MATCH ||
+ right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS;
+ if (ismatchop && right->op_private & OPpTARGET_MY) {
+ right->op_targ = 0;
+ right->op_private &= ~OPpTARGET_MY;
+ }
+ if (!(right->op_flags & OPf_STACKED) && ismatchop) {
right->op_flags |= OPf_STACKED;
if (right->op_type != OP_MATCH &&
! (right->op_type == OP_TRANS &&
}
else
return bind_match(type, left,
- pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
+ pmruntime(newPMOP(OP_MATCH, 0), right, 0));
}
OP *
return o;
}
+/* XXX kept for BINCOMPAT only */
void
Perl_save_hints(pTHX)
{
- SAVEI32(PL_hints);
- SAVESPTR(GvHV(PL_hintgv));
- GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
- SAVEFREESV(GvHV(PL_hintgv));
+ Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
}
int
Perl_block_start(pTHX_ int full)
{
- int retval = PL_savestack_ix;
- /* If there were syntax errors, don't try to start a block */
- if (PL_yynerrs) return retval;
-
+ const int retval = PL_savestack_ix;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
- int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
+ const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
- /* If there were syntax errors, don't try to close a block */
- if (PL_yynerrs) return retval;
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
STATIC OP *
S_newDEFSVOP(pTHX)
{
- return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ const I32 offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ }
+ else {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = offset;
+ return o;
+ }
}
void
CALL_PEEP(PL_eval_start);
}
else {
- if (o->op_type == OP_STUB)
+ if (o->op_type == OP_STUB) {
+ PL_comppad_name = 0;
+ PL_compcv = 0;
+ FreeOp(o);
return;
+ }
PL_main_root = scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
PL_main_start = LINKLIST(PL_main_root);
&& PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
{
char *s = PL_bufptr;
- int sigil = 0;
+ bool sigil = FALSE;
/* some heuristics to detect a potential error */
- while (*s && (strchr(", \t\n", *s)
- || (strchr("@$%*", *s) && ++sigil) ))
+ while (*s && (strchr(", \t\n", *s)))
s++;
- if (sigil) {
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
- || strchr("@$%*, \t\n", *s)))
- s++;
- if (*s == ';' || *s == '=')
- Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
+ while (1) {
+ if (*s && strchr("@$%*", *s) && *++s
+ && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+ s++;
+ sigil = TRUE;
+ while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+ s++;
+ while (*s && (strchr(", \t\n", *s)))
+ s++;
+ }
+ else
+ break;
+ }
+ if (sigil && (*s == ';' || *s == '=')) {
+ Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
lex ? (PL_in_my == KEY_our ? "our" : "my")
: "local");
Perl_gen_constant_list(pTHX_ register OP *o)
{
register OP *curop;
- I32 oldtmps_floor = PL_tmps_floor;
+ const I32 oldtmps_floor = PL_tmps_floor;
list(o);
if (PL_error_count)
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_seq = 0; /* needs to be revisited in peep() */
+ o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
+ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
+ o->op_opt = 0; /* needs to be revisited in peep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
op_free(curop);
o->op_flags |= flags;
o = CHECKOP(type, o);
- if (o->op_type != type)
+ if (o->op_type != (unsigned)type)
return o;
return fold_constants(o);
if (!last)
return first;
- if (first->op_type != type
+ if (first->op_type != (unsigned)type
|| (type == OP_LIST && (first->op_flags & OPf_PARENS)))
{
return newLISTOP(type, 0, first, last);
if (!last)
return (OP*)first;
- if (first->op_type != type)
+ if (first->op_type != (unsigned)type)
return prepend_elem(type, (OP*)first, (OP*)last);
- if (last->op_type != type)
+ if (last->op_type != (unsigned)type)
return append_elem(type, (OP*)first, (OP*)last);
first->op_last->op_sibling = last->op_first;
if (!last)
return first;
- if (last->op_type == type) {
+ if (last->op_type == (unsigned)type) {
if (type == OP_LIST) { /* already a PUSHMARK there */
first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
((LISTOP*)last)->op_first->op_sibling = first;
listop->op_last = pushop;
}
- return (OP*)listop;
+ return CHECKOP(type, listop);
}
OP *
static int
uvcompare(const void *a, const void *b)
{
- if (*((UV *)a) < (*(UV *)b))
+ if (*((const UV *)a) < (*(const UV *)b))
return -1;
- if (*((UV *)a) > (*(UV *)b))
+ if (*((const UV *)a) > (*(const UV *)b))
return 1;
- if (*((UV *)a+1) < (*(UV *)b+1))
+ if (*((const UV *)a+1) < (*(const UV *)b+1))
return -1;
- if (*((UV *)a+1) > (*(UV *)b+1))
+ if (*((const UV *)a+1) > (*(const UV *)b+1))
return 1;
return 0;
}
U8* tend = t + tlen;
U8* rend = r + rlen;
STRLEN ulen;
- U32 tfirst = 1;
- U32 tlast = 0;
- I32 tdiff;
- U32 rfirst = 1;
- U32 rlast = 0;
- I32 rdiff;
- I32 diff;
+ UV tfirst = 1;
+ UV tlast = 0;
+ IV tdiff;
+ UV rfirst = 1;
+ UV rlast = 0;
+ IV rdiff;
+ IV diff;
I32 none = 0;
U32 max = 0;
I32 bits;
*/
if (complement) {
- U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 tmpbuf[UTF8_MAXBYTES+1];
UV *cp;
UV nextmin = 0;
New(1109, cp, 2*tlen, UV);
PmopSTASH_set(pmop,PL_curstash);
}
- return (OP*)pmop;
+ return CHECKOP(type, pmop);
}
+/* Given some sort of match op o, and an expression expr containing a
+ * pattern, either compile expr into a regex and attach it to o (if it's
+ * constant), or convert expr into a runtime regcomp op sequence (if it's
+ * not)
+ *
+ * isreg indicates that the pattern is part of a regex construct, eg
+ * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
+ * split "pattern", which aren't. In the former case, expr will be a list
+ * if the pattern contains more than one term (eg /a$b/) or if it contains
+ * a replacement, ie s/// or tr///.
+ */
+
OP *
-Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
+Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
{
PMOP *pm;
LOGOP *rcop;
I32 repl_has_vars = 0;
+ OP* repl = Nullop;
+ bool reglist;
+
+ if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
+ /* last element in list is the replacement; pop it */
+ OP* kid;
+ repl = cLISTOPx(expr)->op_last;
+ kid = cLISTOPx(expr)->op_first;
+ while (kid->op_sibling != repl)
+ kid = kid->op_sibling;
+ kid->op_sibling = Nullop;
+ cLISTOPx(expr)->op_last = kid;
+ }
+
+ if (isreg && expr->op_type == OP_LIST &&
+ cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
+ {
+ /* convert single element list to element */
+ OP* oe = expr;
+ expr = cLISTOPx(oe)->op_first->op_sibling;
+ cLISTOPx(oe)->op_first->op_sibling = Nullop;
+ cLISTOPx(oe)->op_last = Nullop;
+ op_free(oe);
+ }
- if (o->op_type == OP_TRANS)
+ if (o->op_type == OP_TRANS) {
return pmtrans(o, expr, repl);
+ }
+
+ reglist = isreg && expr->op_type == OP_LIST;
+ if (reglist)
+ op_null(expr);
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
STRLEN plen;
SV *pat = ((SVOP*)expr)->op_sv;
char *p = SvPV(pat, plen);
- if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
+ if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
sv_setpvn(pat, "\\s+", 3);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
rcop->op_type = OP_REGCOMP;
rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_first = scalar(expr);
- rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
- ? (OPf_SPECIAL | OPf_KIDS)
- : OPf_KIDS);
+ rcop->op_flags |= OPf_KIDS
+ | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
+ | (reglist ? OPf_STACKED : 0);
rcop->op_private = 1;
rcop->op_other = o;
+ if (reglist)
+ rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
+
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
PL_cv_has_eval = 1;
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
curop = 0;
- if (CopLINE(PL_curcop) < PL_multi_end)
+ if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
else if (repl->op_type == OP_CONST)
void
Perl_package(pTHX_ OP *o)
{
- char *name;
+ const char *name;
STRLEN len;
save_hptr(&PL_curstash);
meth = newSVpvn("VERSION",7);
sv_upgrade(meth, SVt_PVIV);
(void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ {
+ U32 hash;
+ PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ SvUV_set(meth, hash);
+ }
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(version)),
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
(void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
- PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ {
+ U32 hash;
+ PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
+ SvUV_set(meth, hash);
+ }
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
+ PL_cop_seqmax++; /* Purely for B::*'s benefit */
}
/*
}
}
{
- line_t ocopline = PL_copline;
- COP *ocurcop = PL_curcop;
- int oexpect = PL_expect;
+ const line_t ocopline = PL_copline;
+ COP * const ocurcop = PL_curcop;
+ const int oexpect = PL_expect;
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
}
STATIC I32
-S_list_assignment(pTHX_ register OP *o)
+S_list_assignment(pTHX_ register const OP *o)
{
if (!o)
return TRUE;
o = cUNOPo->op_first;
if (o->op_type == OP_COND_EXPR) {
- I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
- I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
+ const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
+ const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
if (t && f)
return TRUE;
op_free(right);
return Nullop;
}
+ /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
+ if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
+ && right->op_type == OP_STUB
+ && (left->op_private & OPpLVAL_INTRO))
+ {
+ op_free(right);
+ left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
+ return left;
+ }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
GV *gv = cGVOPx_gv(curop);
if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
- SvCUR(gv) = PL_generation;
+ SvCUR_set(gv, PL_generation);
}
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
if (PAD_COMPNAME_GEN(curop->op_targ)
== (STRLEN)PL_generation)
break;
- PAD_COMPNAME_GEN(curop->op_targ)
- = PL_generation;
+ PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
}
else if (curop->op_type == OP_RV2CV)
#endif
if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
- SvCUR(gv) = PL_generation;
+ SvCUR_set(gv, PL_generation);
}
}
else
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
- U32 seq = intro_my();
+ const U32 seq = intro_my();
register COP *cop;
NewOp(1101, cop, 1, COP);
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
- SvIVX(*svp) = PTR2IV(cop);
+ SvIV_set(*svp, PTR2IV(cop));
}
}
}
}
if (first->op_type == OP_CONST) {
- if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
- if (first->op_private & OPpCONST_STRICT)
- no_bareword_allowed(first);
- else
+ if (first->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(first);
+ else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
- }
- if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
+ (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
+ if (other->op_type == OP_CONST)
+ other->op_private |= OPpCONST_SHORTCIRCUIT;
return other;
}
else {
+ /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
+ const OP *o2 = other;
+ if ( ! (o2->op_type == OP_LIST
+ && (( o2 = cUNOPx(o2)->op_first))
+ && o2->op_type == OP_PUSHMARK
+ && (( o2 = o2->op_sibling)) )
+ )
+ o2 = other;
+ if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
+ || o2->op_type == OP_PADHV)
+ && o2->op_private & OPpLVAL_INTRO
+ && ckWARN(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated use of my() in false conditional");
+ }
+
op_free(other);
*otherp = Nullop;
+ if (first->op_type == OP_CONST)
+ first->op_private |= OPpCONST_SHORTCIRCUIT;
return first;
}
}
- else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
- OP *k1 = ((UNOP*)first)->op_first;
- OP *k2 = k1->op_sibling;
+ else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
+ type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
+ {
+ const OP *k1 = ((UNOP*)first)->op_first;
+ const OP *k2 = k1->op_sibling;
OPCODE warnop = 0;
switch (first->op_type)
{
break;
}
if (warnop) {
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
first->op_next = (OP*)logop;
first->op_sibling = other;
+ CHECKOP(type,logop);
+
o = newUNOP(OP_NULL, 0, (OP*)logop);
other->op_next = o;
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
+ CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
+ logop);
/* establish postfix order */
start = LINKLIST(first);
{
OP* listop;
OP* o;
- int once = block && block->op_flags & OPf_SPECIAL &&
+ const bool once = block && block->op_flags & OPf_SPECIAL &&
(block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
+ (void)debuggable;
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr->op_flags & OPf_KIDS) {
- OP *k1 = ((UNOP*)expr)->op_first;
- OP *k2 = (k1) ? k1->op_sibling : NULL;
+ const OP *k1 = ((UNOP*)expr)->op_first;
+ const OP *k2 = (k1) ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
}
}
+ /* if block is null, the next append_elem() would put UNSTACK, a scalar
+ * op, in listop. This is wrong. [perl #27024] */
+ if (!block)
+ block = newOP(OP_NULL, 0);
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
o = new_logop(OP_AND, 0, &expr, &listop);
OP *listop;
OP *o;
U8 loopflags = 0;
+ (void)debuggable;
if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
} else if (expr && (expr->op_flags & OPf_KIDS)) {
- OP *k1 = ((UNOP*)expr)->op_first;
- OP *k2 = (k1) ? k1->op_sibling : NULL;
+ const OP *k1 = ((UNOP*)expr)->op_first;
+ const OP *k2 = (k1) ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
if (k2 && k2->op_type == OP_READLINE
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
}
else {
- sv = newGVOP(OP_GV, 0, PL_defgv);
+ const I32 offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ sv = newGVOP(OP_GV, 0, PL_defgv);
+ }
+ else {
+ padoff = offset;
+ }
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
expr = mod(force_list(expr), OP_GREPSTART);
}
-
loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
- * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
- loop->op_private = iterpflags;
+ * for our $x () sets OPpOUR_INTRO */
+ loop->op_private = (U8)iterpflags;
#ifdef PL_OP_SLAB_ALLOC
{
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
- Copy(loop,tmp,1,LOOP);
+ Copy(loop,tmp,1,LISTOP);
FreeOp(loop);
loop = tmp;
}
op_free(label);
}
else {
- if (label->op_type == OP_ENTERSUB)
+ /* Check whether it's going to be a goto &function */
+ if (label->op_type == OP_ENTERSUB
+ && !(label->op_flags & OPf_STACKED))
label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
o = newUNOP(type, OPf_STACKED, label);
}
}
void
-Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
+Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
{
if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
SV* msg = sv_newmortal();
if (name)
Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
+ else
+ Perl_sv_catpv(aTHX_ msg, ": none");
sv_catpv(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
*/
SV *
-Perl_op_const_sv(pTHX_ OP *o, CV *cv)
+Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
{
SV *sv = Nullsv;
void
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
+ (void)floor;
if (o)
SAVEFREEOP(o);
if (proto)
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
STRLEN n_a;
- char *name;
- char *aname;
+ const char *name;
+ const char *aname;
GV *gv;
- char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
+ char *ps;
register CV *cv=0;
SV *const_sv;
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
+ }
+ else
+ ps = Nullch;
+
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
}
else
aname = Nullch;
- gv = gv_fetchpv(name ? name : (aname ? aname :
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
- GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
- SVt_PVCV);
+ gv = name ? gv_fetchsv(cSVOPo->op_sv,
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV)
+ : gv_fetchpv(aname ? aname
+ : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV);
if (o)
SAVEFREEOP(o);
const_sv = op_const_sv(block, Nullcv);
if (cv) {
- bool exists = CvROOT(cv) || CvXSUB(cv);
+ const bool exists = CvROOT(cv) || CvXSUB(cv);
#ifdef GV_UNIQUE_CHECK
if (exists && GvUNIQUE(gv)) {
|| (CvCONST(cv)
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
{
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
}
}
if (const_sv) {
- SvREFCNT_inc(const_sv);
+ (void)SvREFCNT_inc(const_sv);
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
sv_setpv((SV*)cv, ""); /* prototype is "" */
/* transfer PL_compcv to cv */
cv_undef(cv);
CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ if (!CvWEAKOUTSIDE(cv))
+ SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvOUTSIDE(PL_compcv) = 0;
op_free(block);
block = Nullop;
if (name) {
- char *s = strrchr(name, ':');
+ const char *s = strrchr(name, ':');
s = s ? s+1 : name;
if (strEQ(s, "BEGIN")) {
- char *not_safe =
+ const char not_safe[] =
"BEGIN not safe after errors--compilation aborted";
if (PL_in_eval & EVAL_KEEPERR)
Perl_croak(aTHX_ not_safe);
mod(scalarseq(block), OP_LEAVESUBLV));
}
else {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ op_free(block);
+ block = newSTATEOP(0, Nullch, 0);
+ }
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
CvROOT(cv)->op_private |= OPpREFCOUNTED;
}
if (name || aname) {
- char *s;
- char *tname = (name ? name : aname);
+ const char *s;
+ const char *tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV *sv = NEWSV(0,0);
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
- I32 oldscope = PL_scopestack_ix;
+ const I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
*/
CV *
-Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
{
CV* cv;
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
+ if (stash)
+ CopSTASH_free(PL_curcop);
+
LEAVE;
return cv;
*/
CV *
-Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
{
GV *gv = gv_fetchpv(name ? name :
(PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
/* already defined (or promised) */
if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
}
CvGV(cv) = gv;
(void)gv_fetchfile(filename);
- CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
+ CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
CvXSUB(cv) = subaddr;
if (name) {
- char *s = strrchr(name,':');
+ const char *s = strrchr(name,':');
if (s)
s++;
else
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- char *name;
GV *gv;
- STRLEN n_a;
if (o)
- name = SvPVx(cSVOPo->op_sv, n_a);
+ gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
else
- name = "STDOUT";
- gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+ gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
GvMULTI_on(gv);
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ o ? "Format %"SVf" redefined"
+ : "Format STDOUT redefined" ,cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
{
Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
/* STUB */
- return o;
+ (void)o;
+#ifndef HASATTRIBUTE
+ /* No __attribute__, so the compiler doesn't know that croak never returns
+ */
+ return 0;
+#endif
}
OP *
return newUNOP(OP_RV2SV, 0, scalar(o));
}
-/* Check routines. */
+/* Check routines. See the comments at the top of this file for details
+ * on when these are called */
OP *
Perl_ck_anoncode(pTHX_ OP *o)
(op) == OP_NE || (op) == OP_I_NE || \
(op) == OP_NCMP || (op) == OP_I_NCMP)
o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
- if (o->op_type == OP_BIT_OR
- || o->op_type == OP_BIT_AND
- || o->op_type == OP_BIT_XOR)
+ if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
+ && (o->op_type == OP_BIT_OR
+ || o->op_type == OP_BIT_AND
+ || o->op_type == OP_BIT_XOR))
{
- OP * left = cBINOPo->op_first;
- OP * right = left->op_sibling;
+ const OP * left = cBINOPo->op_first;
+ const OP * right = left->op_sibling;
if ((OP_IS_NUMCOMPARE(left->op_type) &&
(left->op_flags & OPf_PARENS) == 0) ||
(OP_IS_NUMCOMPARE(right->op_type) &&
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- if (cUNOPo->op_first->op_type == OP_CONCAT)
- o->op_flags |= OPf_STACKED;
+ const OP *kid = cUNOPo->op_first;
+ if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
+ !(kUNOP->op_first->op_flags & OPf_MOD))
+ o->op_flags |= OPf_STACKED;
return o;
}
if (o->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
- OPCODE type = o->op_type;
+ const OPCODE type = o->op_type;
o = modkids(ck_fun(o), type);
kid = cUNOPo->op_first;
newop = kUNOP->op_first->op_sibling;
OP *
Perl_ck_eof(pTHX_ OP *o)
{
- I32 type = o->op_type;
+ const I32 type = o->op_type;
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
OP *
Perl_ck_exec(pTHX_ OP *o)
{
- OP *kid;
if (o->op_flags & OPf_STACKED) {
+ OP *kid;
o = ck_fun(o);
kid = cUNOPo->op_first->op_sibling;
if (kid->op_type == OP_RV2GV)
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
- char *name;
int iscv;
GV *gv;
SV *kidsv = kid->op_sv;
- STRLEN n_a;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
SV *rsv = SvRV(kidsv);
int svtype = SvTYPE(rsv);
- char *badtype = Nullch;
+ const char *badtype = Nullch;
switch (o->op_type) {
case OP_RV2SV:
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
- name = SvPV(kidsv, n_a);
if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
- char *badthing = Nullch;
+ const char *badthing = Nullch;
switch (o->op_type) {
case OP_RV2SV:
badthing = "a SCALAR";
}
if (badthing)
Perl_croak(aTHX_
- "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
- name, badthing);
+ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ kidsv, badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
*/
iscv = (o->op_type == OP_RV2CV) * 2;
do {
- gv = gv_fetchpv(name,
+ gv = gv_fetchsv(kidsv,
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
OP *
Perl_ck_ftst(pTHX_ OP *o)
{
- I32 type = o->op_type;
+ const I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
/* nothing */
SVOP *kid = (SVOP*)cUNOPo->op_first;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- STRLEN n_a;
OP *newop = newGVOP(type, OPf_REF,
- gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
+ gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
op_free(o);
o = newop;
+ return o;
}
else {
if ((PL_hints & HINT_FILETEST_ACCESS) &&
OP_IS_FILETEST_ACCESS(o))
o->op_private |= OPpFT_ACCESS;
}
+ if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
+ && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
+ o->op_private |= OPpFT_STACKED;
}
else {
op_free(o);
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- register OP *kid;
- OP **tokid;
- OP *sibl;
- I32 numargs = 0;
- int type = o->op_type;
+ const int type = o->op_type;
register I32 oa = PL_opargs[type] >> OASHIFT;
if (o->op_flags & OPf_STACKED) {
}
if (o->op_flags & OPf_KIDS) {
- STRLEN n_a;
- tokid = &cLISTOPo->op_first;
- kid = cLISTOPo->op_first;
+ OP **tokid = &cLISTOPo->op_first;
+ register OP *kid = cLISTOPo->op_first;
+ OP *sibl;
+ I32 numargs = 0;
+
if (kid->op_type == OP_PUSHMARK ||
(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
{
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchpv(name, TRUE, SVt_PVAV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Array @%s missing the @ in argument %"IVdf" of %s()",
- name, (IV)numargs, PL_op_desc[type]);
+ "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
+ ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchpv(name, TRUE, SVt_PVHV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
- "Hash %%%s missing the %% in argument %"IVdf" of %s()",
- name, (IV)numargs, PL_op_desc[type]);
+ "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
+ ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
(kid->op_private & OPpCONST_BARE))
{
OP *newop = newGVOP(OP_GV, 0,
- gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
- SVt_PVIO) );
+ gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
/* is this op a FH constructor? */
if (is_handle_constructor(o,numargs)) {
- char *name = Nullch;
+ const char *name = Nullch;
STRLEN len = 0;
flags = 0;
name = 0;
if ((op = ((BINOP*)kid)->op_first)) {
SV *tmpstr = Nullsv;
- char *a =
+ const char *a =
kid->op_type == OP_AELEM ?
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
else if (op->op_type == OP_PADAV
|| op->op_type == OP_PADHV) {
/* lexicalvar $a[] or $h{} */
- char *padname =
+ const char *padname =
PAD_COMPNAME_PV(op->op_targ);
if (padname)
tmpstr =
}
if (tmpstr) {
- name = savepv(SvPVX(tmpstr));
- len = strlen(name);
+ name = SvPV(tmpstr, len);
sv_2mortal(tmpstr);
}
}
#if !defined(PERL_EXTERNAL_GLOB)
/* XXX this can be tightened up and made more failsafe. */
- if (!gv) {
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV *glob_gv;
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
- SvREFCNT_inc((SV*)GvCV(gv));
+ (void)SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
LEAVE;
}
o->op_ppaddr = PL_ppaddr[OP_LIST];
cLISTOPo->op_first->op_type = OP_PUSHMARK;
cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
+ cLISTOPo->op_first->op_targ = 0;
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
{
LOGOP *gwop;
OP *kid;
- OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+ const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+ I32 offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
NewOp(1101, gwop, 1, LOGOP);
OP* k;
o = ck_sort(o);
kid = cLISTOPo->op_first->op_sibling;
- for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
+ if (!cUNOPx(kid)->op_next)
+ Perl_croak(aTHX_ "panic: ck_grep");
+ for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
kid = k;
}
kid->op_next = (OP*)gwop;
gwop->op_ppaddr = PL_ppaddr[type];
gwop->op_first = listkids(o);
gwop->op_flags |= OPf_KIDS;
- gwop->op_private = 1;
gwop->op_other = LINKLIST(kid);
- gwop->op_targ = pad_alloc(type, SVs_PADTMP);
kid->op_next = (OP*)gwop;
+ offset = pad_findmy("$_");
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+ o->op_private = gwop->op_private = 0;
+ gwop->op_targ = pad_alloc(type, SVs_PADTMP);
+ }
+ else {
+ o->op_private = gwop->op_private = OPpGREP_LEX;
+ gwop->op_targ = o->op_targ = offset;
+ }
kid = cLISTOPo->op_first->op_sibling;
if (!kid || !kid->op_sibling)
OP *
Perl_ck_lfun(pTHX_ OP *o)
{
- OPCODE type = o->op_type;
+ const OPCODE type = o->op_type;
return modkids(ck_fun(o), type);
}
OP *
Perl_ck_rfun(pTHX_ OP *o)
{
- OPCODE type = o->op_type;
+ const OPCODE type = o->op_type;
return refkids(ck_fun(o), type);
}
return kid;
}
}
+ /* optimise C<my $x = undef> to C<my $x> */
+ if (kid->op_type == OP_UNDEF) {
+ OP *kkid = kid->op_sibling;
+ if (kkid && kkid->op_type == OP_PADSV
+ && (kkid->op_private & OPpLVAL_INTRO))
+ {
+ cLISTOPo->op_first = NULL;
+ kid->op_sibling = NULL;
+ op_free(o);
+ op_free(kid);
+ return kkid;
+ }
+ }
return o;
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- o->op_private |= OPpRUNTIME;
+ if (o->op_type != OP_QR) {
+ const I32 offset = pad_findmy("$_");
+ if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
+ o->op_targ = offset;
+ o->op_private |= OPpTARGET_MY;
+ }
+ }
+ if (o->op_type == OP_MATCH || o->op_type == OP_QR)
+ o->op_private |= OPpRUNTIME;
return o;
}
if (*s == ':' && s[1] == ':') {
*s = '/';
Move(s+2, s+1, strlen(s+2)+1, char);
- --SvCUR(kid->op_sv);
+ SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
}
}
if (SvREADONLY(kid->op_sv)) {
OP *
Perl_ck_return(pTHX_ OP *o)
{
- OP *kid;
if (CvLVALUE(PL_compcv)) {
+ OP *kid;
for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, OP_LEAVESUBLV);
}
OP *
Perl_ck_shift(pTHX_ OP *o)
{
- I32 type = o->op_type;
+ const I32 type = o->op_type;
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
{
register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
OP *k;
- int reversed;
+ int descending;
GV *gv;
+ const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
gv = kGVOP_gv;
if (GvSTASH(gv) != PL_curstash)
return;
- if (strEQ(GvNAME(gv), "a"))
- reversed = 0;
- else if (strEQ(GvNAME(gv), "b"))
- reversed = 1;
+ gvname = GvNAME(gv);
+ if (*gvname == 'a' && gvname[1] == '\0')
+ descending = 0;
+ else if (*gvname == 'b' && gvname[1] == '\0')
+ descending = 1;
else
return;
+
kid = k; /* back to cmp */
if (kBINOP->op_last->op_type != OP_RV2SV)
return;
return;
kid = kUNOP->op_first; /* get past rv2sv */
gv = kGVOP_gv;
- if (GvSTASH(gv) != PL_curstash
- || ( reversed
- ? strNE(GvNAME(gv), "a")
- : strNE(GvNAME(gv), "b")))
+ if (GvSTASH(gv) != PL_curstash)
+ return;
+ gvname = GvNAME(gv);
+ if ( descending
+ ? !(*gvname == 'a' && gvname[1] == '\0')
+ : !(*gvname == 'b' && gvname[1] == '\0'))
return;
o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
- if (reversed)
- o->op_private |= OPpSORT_REVERSE;
+ if (descending)
+ o->op_private |= OPpSORT_DESCEND;
if (k->op_type == OP_NCMP)
o->op_private |= OPpSORT_NUMERIC;
if (k->op_type == OP_I_NCMP)
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP *sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
Perl_ck_join(pTHX_ OP *o)
{
if (ckWARN(WARN_SYNTAX)) {
- OP *kid = cLISTOPo->op_first->op_sibling;
+ const OP *kid = cLISTOPo->op_first->op_sibling;
if (kid && kid->op_type == OP_MATCH) {
- char *pmstr = "STRING";
- if (PM_GETRE(kPMOP))
- pmstr = PM_GETRE(kPMOP)->precomp;
+ const REGEXP *re = PM_GETRE(kPMOP);
+ const char *pmstr = re ? re->precomp : "STRING";
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
I32 contextclass = 0;
char *e = 0;
STRLEN n_a;
- bool delete=0;
+ bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
o->op_private |= OPpENTERSUB_DB;
}
else {
- delete=1;
+ delete_op = 1;
if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
"Impossible to activate assertion call");
OP *sibling = o2->op_sibling;
SV *n = newSVpvn("",0);
op_free(o2);
- gv_fullname3(n, gv, "");
- if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
- sv_chop(n, SvPVX(n)+6);
+ gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
prev->op_sibling = o2;
o2->op_sibling = sibling;
break;
case ']':
if (contextclass) {
- char *p = proto;
- char s = *p;
+ char *p = proto;
+ const char s = *p;
contextclass = 0;
*p = '\0';
while (*--p != '[');
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
- if(delete) {
+ if(delete_op) {
op_free(o);
o=newSVOP(OP_CONST, 0, newSViv(0));
}
}
OP *
+Perl_ck_unpack(pTHX_ OP *o)
+{
+ OP *kid = cLISTOPo->op_first;
+ 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)
{
o = ck_fun(o);
return o;
}
-/* A peephole optimizer. We visit the ops in the order they're to execute. */
+/* 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 */
void
Perl_peep(pTHX_ register OP *o)
{
register OP* oldop = 0;
- if (!o || o->op_seq)
+ if (!o || o->op_opt)
return;
ENTER;
SAVEOP();
SAVEVPTR(PL_curcop);
for (; o; o = o->op_next) {
- if (o->op_seq)
+ if (o->op_opt)
break;
- /* The special value -1 is used by the B::C compiler backend to indicate
- * that an op is statically defined and should not be freed */
- if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
- PL_op_seqmax = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_CONST:
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
- PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
o->op_targ = ix;
}
#endif
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_CONCAT:
op_null(o->op_next);
}
ignore_optimization:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_STUB:
if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break; /* Scalar stub must produce undef. List stub is noop */
}
goto nothin;
to peep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
though (See 20010220.007). AMS 20010719 */
+ /* op_seq functionality is now replaced by op_opt */
if (oldop && o->op_next) {
oldop->op_next = o->op_next;
continue;
oldop->op_next = o->op_next;
continue;
}
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
+ case OP_PADAV:
case OP_GV:
- if (o->op_next->op_type == OP_RV2SV) {
- if (!(o->op_next->op_private & OPpDEREF)) {
- op_null(o->op_next);
- o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
- | OPpOUR_INTRO);
- o->op_next = o->op_next->op_next;
- o->op_type = OP_GVSV;
- o->op_ppaddr = PL_ppaddr[OP_GVSV];
- }
- }
- else if (o->op_next->op_type == OP_RV2AV) {
- OP* pop = o->op_next->op_next;
+ if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
+ OP* pop = (o->op_type == OP_PADAV) ?
+ o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
- (PL_op = pop->op_next) &&
+ ((PL_op = pop->op_next)) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
(OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
i >= 0)
{
GV *gv;
- op_null(o->op_next);
+ if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(pop);
+ if (o->op_type == OP_GV)
+ op_null(o->op_next);
op_null(pop->op_next);
op_null(pop);
o->op_flags |= pop->op_next->op_flags & OPf_MOD;
o->op_next = pop->op_next->op_next;
- o->op_type = OP_AELEMFAST;
o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
o->op_private = (U8)i;
- gv = cGVOPo_gv;
- GvAVn(gv);
+ if (o->op_type == OP_GV) {
+ gv = cGVOPo_gv;
+ GvAVn(gv);
+ }
+ else
+ o->op_flags |= OPf_SPECIAL;
+ o->op_type = OP_AELEMFAST;
+ }
+ o->op_opt = 1;
+ break;
+ }
+
+ if (o->op_next->op_type == OP_RV2SV) {
+ if (!(o->op_next->op_private & OPpDEREF)) {
+ op_null(o->op_next);
+ o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
+ | OPpOUR_INTRO);
+ o->op_next = o->op_next->op_next;
+ o->op_type = OP_GVSV;
+ o->op_ppaddr = PL_ppaddr[OP_GVSV];
}
}
else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
op_null(o->op_next);
}
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
case OP_MAPWHILE:
case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
case OP_ENTERLOOP:
case OP_ENTERITER:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
case OP_QR:
case OP_MATCH:
case OP_SUBST:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
while (cPMOP->op_pmreplstart &&
cPMOP->op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
break;
case OP_EXEC:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
if (ckWARN(WARN_SYNTAX) && o->op_next
&& o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
o->op_next->op_sibling->op_type != OP_EXIT &&
o->op_next->op_sibling->op_type != OP_WARN &&
o->op_next->op_sibling->op_type != OP_DIE) {
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
Perl_warner(aTHX_ packWARN(WARN_EXEC),
break;
case OP_HELEM: {
+ UNOP *rop;
SV *lexname;
+ GV **fields;
SV **svp, *sv;
char *key = NULL;
STRLEN keylen;
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
break;
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 (!(SvFLAGS(lexname) & SVpad_TYPED))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ key = SvPV(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ }
+
break;
}
+ case OP_HSLICE: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp;
+ 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 (!(SvFLAGS(lexname) & SVpad_TYPED))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, 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(*svp, keylen);
+ if (!hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ {
+ Perl_croak(aTHX_ "No such class field \"%s\" "
+ "in variable %s of type %s",
+ key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
+ }
+ }
+ break;
+ }
+
+ case OP_SORT: {
+ /* will point to RV2AV or PADAV op on LHS/RHS of assign */
+ OP *oleft, *oright;
+ OP *o2;
+
+ /* check that RHS of sort is a single plain array */
+ oright = cUNOPo->op_first;
+ if (!oright || oright->op_type != OP_PUSHMARK)
+ break;
+
+ /* reverse sort ... can be optimised. */
+ if (!cUNOPo->op_sibling) {
+ /* Nothing follows us on the list. */
+ OP *reverse = o->op_next;
+
+ if (reverse->op_type == OP_REVERSE &&
+ (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
+ OP *pushmark = cUNOPx(reverse)->op_first;
+ if (pushmark && (pushmark->op_type == OP_PUSHMARK)
+ && (cUNOPx(pushmark)->op_sibling == o)) {
+ /* reverse -> pushmark -> sort */
+ o->op_private |= OPpSORT_REVERSE;
+ op_null(reverse);
+ pushmark->op_next = oright->op_next;
+ op_null(oright);
+ }
+ }
+ }
+
+ /* make @a = sort @a act in-place */
+
+ o->op_opt = 1;
+
+ oright = cUNOPx(oright)->op_sibling;
+ if (!oright)
+ break;
+ if (oright->op_type == OP_NULL) { /* skip sort block/sub */
+ oright = cUNOPx(oright)->op_sibling;
+ }
+
+ if (!oright ||
+ (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+ || oright->op_next != o
+ || (oright->op_private & OPpLVAL_INTRO)
+ )
+ break;
+
+ /* 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)
+ break;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ 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)
+ )
+ break;
+ oleft = o2;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_AASSIGN
+ || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ break;
+
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ break;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ break;
+ if (o2->op_sibling != o)
+ break;
+
+ /* 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
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ break;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ 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;
+ LISTOP *enter, *exlist;
+ o->op_opt = 1;
+
+ enter = (LISTOP *) o->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_NULL) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ /* for $a (...) will have OP_GV then OP_RV2GV here.
+ for (...) just has an OP_GV. */
+ if (enter->op_type == OP_GV) {
+ gvop = (OP *) enter;
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ if (enter->op_type == OP_RV2GV) {
+ enter = (LISTOP *) enter->op_next;
+ if (!enter)
+ break;
+ }
+ }
+
+ if (enter->op_type != OP_ENTERITER)
+ break;
+
+ iter = enter->op_next;
+ if (!iter || iter->op_type != OP_ITER)
+ break;
+
+ expushmark = enter->op_first;
+ if (!expushmark || expushmark->op_type != OP_NULL
+ || expushmark->op_targ != OP_PUSHMARK)
+ break;
+
+ exlist = (LISTOP *) expushmark->op_sibling;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_last != o) {
+ /* Mmm. Was expecting to point back to this op. */
+ break;
+ }
+ theirmark = exlist->op_first;
+ if (!theirmark || theirmark->op_type != OP_PUSHMARK)
+ break;
+
+ if (theirmark->op_sibling != o) {
+ /* There's something between the mark and the reverse, eg
+ for (1, reverse (...))
+ so no go. */
+ break;
+ }
+
+ ourmark = ((LISTOP *)o)->op_first;
+ if (!ourmark || ourmark->op_type != OP_PUSHMARK)
+ break;
+
+ ourlast = ((LISTOP *)o)->op_last;
+ if (!ourlast || ourlast->op_next != o)
+ break;
+
+ rv2av = ourmark->op_sibling;
+ if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
+ && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
+ && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
+ /* We're just reversing a single array. */
+ rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
+ enter->op_flags |= OPf_STACKED;
+ }
+
+ /* We don't have control over who points to theirmark, so sacrifice
+ ours. */
+ theirmark->op_next = ourmark->op_next;
+ theirmark->op_flags = ourmark->op_flags;
+ ourlast->op_next = gvop ? gvop : (OP *) enter;
+ op_null(ourmark);
+ op_null(o);
+ enter->op_private |= OPpITER_REVERSED;
+ iter->op_private |= OPpITER_REVERSED;
+
+ break;
+ }
+
default:
- o->op_seq = PL_op_seqmax++;
+ o->op_opt = 1;
break;
}
oldop = o;
LEAVE;
}
-
-
-char* Perl_custom_op_name(pTHX_ OP* o)
+char*
+Perl_custom_op_name(pTHX_ const OP* o)
{
- IV index = PTR2IV(o->op_ppaddr);
+ const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
return SvPV_nolen(HeVAL(he));
}
-char* Perl_custom_op_desc(pTHX_ OP* o)
+char*
+Perl_custom_op_desc(pTHX_ const OP* o)
{
- IV index = PTR2IV(o->op_ppaddr);
+ const IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
HE* he;
return SvPV_nolen(HeVAL(he));
}
-
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
XSRETURN(1);
}
-PerlIO*
-Perl_my_tmpfp(pTHX)
-{
- PerlIO *f = NULL;
- int fd = -1;
-#ifdef PERL_EXTERNAL_GLOB
- /* File::Temp pulls in Fcntl, which may not be available with
- * e.g. miniperl, use mkstemp() or stdio tmpfile() instead. */
-# if defined(WIN32) || !defined(HAS_MKSTEMP)
- FILE *stdio = PerlSIO_tmpfile();
-
- if (stdio) {
- if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
- &PerlIO_stdio, "w+", Nullsv))) {
- PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
-
- if (s)
- s->stdio = stdio;
- }
- }
-# else /* !WIN32 && HAS_MKSTEMP */
- SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
-
- if (sv) {
- fd = mkstemp(SvPVX(sv));
- if (fd >= 0) {
- f = PerlIO_fdopen(fd, "w+");
- if (f) {
- PerlLIO_unlink(SvPVX(sv));
- SvREFCNT_dec(sv);
- }
- }
- }
-# endif /* WIN32 || !HAS_MKSTEMP */
-#else
- /* We have internal glob, which probably also means that we
- * can also use File::Temp (which uses Fcntl) with impunity. */
- GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
-
- if (!gv) {
- ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv);
- gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV);
- GvIMPORTED_CV_on(gv);
- LEAVE;
- }
- if (gv && GvCV(gv)) {
- dSP;
- ENTER;
- SAVETMPS;
- PUSHMARK(SP);
- PUTBACK;
- if (call_sv((SV*)GvCV(gv), G_SCALAR)) {
- GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--));
-
- if (gv) {
- IO *io = GvIO(gv);
-
- if (io) {
- fd = PerlIO_fileno(IoIFP(io));
- if (fd >= 0)
- f = PerlIO_fdopen(fd, "w+");
- }
- }
- }
- SPAGAIN;
- PUTBACK;
- FREETMPS;
- LEAVE;
- }
-#endif
-
- return f;
-}
-
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/
https://perl5.git.perl.org / perl5.git / blobdiff