This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[perl #109264] ->method(my(...)) forcing lvalue cx
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC		 4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW		 6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW		 10 */
11
12/*
4ac71550
TC		 13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW		 20 */
21
166f8a29
DM		 22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM		 47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM		 62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC		 80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC		 88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC		 97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC		 99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
79072805 106
16c91539 107#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 108#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 109#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 110
238a4c30
NIS		 111#if defined(PL_OP_SLAB_ALLOC)
112
f1fac472
NC		 113#ifdef PERL_DEBUG_READONLY_OPS
114# define PERL_SLAB_SIZE 4096
115# include <sys/mman.h>
116#endif
117
238a4c30
NIS		 118#ifndef PERL_SLAB_SIZE
119#define PERL_SLAB_SIZE 2048
120#endif
121
c7e45529 122void *
e91d68d5 123Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 124{
5186cc12 125 dVAR;
5a8e194f
NIS		 126 /*
127 * To make incrementing use count easy PL_OpSlab is an I32 *
128 * To make inserting the link to slab PL_OpPtr is I32 **
129 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
130 * Add an overhead for pointer to slab and round up as a number of pointers
131 */
132 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 133 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC		 134#ifdef PERL_DEBUG_READONLY_OPS
135 /* We need to allocate chunk by chunk so that we can control the VM
136 mapping */
5186cc12 137 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
f1fac472
NC		 138 MAP_ANON|MAP_PRIVATE, -1, 0);
139
140 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
141 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
142 PL_OpPtr));
143 if(PL_OpPtr == MAP_FAILED) {
144 perror("mmap failed");
145 abort();
146 }
147#else
277e868c
NC		 148
149 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 150#endif
083fcd59 151 if (!PL_OpPtr) {
238a4c30
NIS		 152 return NULL;
153 }
5a8e194f
NIS		 154 /* We reserve the 0'th I32 sized chunk as a use count */
155 PL_OpSlab = (I32 *) PL_OpPtr;
156 /* Reduce size by the use count word, and by the size we need.
157 * Latter is to mimic the '-=' in the if() above
158 */
159 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS		 160 /* Allocation pointer starts at the top.
161 Theory: because we build leaves before trunk allocating at end
162 means that at run time access is cache friendly upward
163 */
5a8e194f 164 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC		 165
166#ifdef PERL_DEBUG_READONLY_OPS
167 /* We remember this slab. */
168 /* This implementation isn't efficient, but it is simple. */
5186cc12 169 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
f1fac472
NC		 170 PL_slabs[PL_slab_count++] = PL_OpSlab;
171 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
172#endif
238a4c30
NIS		 173 }
174 assert( PL_OpSpace >= 0 );
175 /* Move the allocation pointer down */
176 PL_OpPtr -= sz;
5a8e194f 177 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS		 178 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
179 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 180 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS		 181 assert( *PL_OpSlab > 0 );
182 return (void *)(PL_OpPtr + 1);
183}
184
f1fac472
NC		 185#ifdef PERL_DEBUG_READONLY_OPS
186void
187Perl_pending_Slabs_to_ro(pTHX) {
188 /* Turn all the allocated op slabs read only. */
189 U32 count = PL_slab_count;
190 I32 **const slabs = PL_slabs;
191
192 /* Reset the array of pending OP slabs, as we're about to turn this lot
193 read only. Also, do it ahead of the loop in case the warn triggers,
194 and a warn handler has an eval */
195
f1fac472
NC		 196 PL_slabs = NULL;
197 PL_slab_count = 0;
198
199 /* Force a new slab for any further allocation. */
200 PL_OpSpace = 0;
201
202 while (count--) {
5892a4d4 203 void *const start = slabs[count];
f1fac472
NC		 204 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
205 if(mprotect(start, size, PROT_READ)) {
206 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
207 start, (unsigned long) size, errno);
208 }
209 }
5892a4d4
NC		 210
211 free(slabs);
f1fac472
NC		 212}
213
214STATIC void
215S_Slab_to_rw(pTHX_ void *op)
216{
217 I32 * const * const ptr = (I32 **) op;
218 I32 * const slab = ptr[-1];
7918f24d
NC		 219
220 PERL_ARGS_ASSERT_SLAB_TO_RW;
221
f1fac472
NC		 222 assert( ptr-1 > (I32 **) slab );
223 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
224 assert( *slab > 0 );
225 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
226 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
227 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
228 }
229}
fc97af9c
NC		 230
231OP *
232Perl_op_refcnt_inc(pTHX_ OP *o)
233{
234 if(o) {
235 Slab_to_rw(o);
236 ++o->op_targ;
237 }
238 return o;
239
240}
241
242PADOFFSET
243Perl_op_refcnt_dec(pTHX_ OP *o)
244{
7918f24d 245 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
fc97af9c
NC		 246 Slab_to_rw(o);
247 return --o->op_targ;
248}
f1fac472
NC		 249#else
250# define Slab_to_rw(op)
251#endif
252
c7e45529
AE		 253void
254Perl_Slab_Free(pTHX_ void *op)
238a4c30 255{
551405c4 256 I32 * const * const ptr = (I32 **) op;
aec46f14 257 I32 * const slab = ptr[-1];
7918f24d 258 PERL_ARGS_ASSERT_SLAB_FREE;
5a8e194f
NIS		 259 assert( ptr-1 > (I32 **) slab );
260 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 261 assert( *slab > 0 );
f1fac472 262 Slab_to_rw(op);
238a4c30 263 if (--(*slab) == 0) {
7e4e8c89
NC		 264# ifdef NETWARE
265# define PerlMemShared PerlMem
266# endif
083fcd59 267
f1fac472 268#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 269 U32 count = PL_slab_count;
f1fac472 270 /* Need to remove this slab from our list of slabs */
782a40f1 271 if (count) {
f1fac472
NC		 272 while (count--) {
273 if (PL_slabs[count] == slab) {
5186cc12 274 dVAR;
f1fac472
NC		 275 /* Found it. Move the entry at the end to overwrite it. */
276 DEBUG_m(PerlIO_printf(Perl_debug_log,
277 "Deallocate %p by moving %p from %lu to %lu\n",
278 PL_OpSlab,
279 PL_slabs[PL_slab_count - 1],
280 PL_slab_count, count));
281 PL_slabs[count] = PL_slabs[--PL_slab_count];
282 /* Could realloc smaller at this point, but probably not
283 worth it. */
fc97af9c
NC		 284 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
285 perror("munmap failed");
286 abort();
287 }
288 break;
f1fac472 289 }
f1fac472
NC		 290 }
291 }
292#else
083fcd59 293 PerlMemShared_free(slab);
f1fac472 294#endif
238a4c30
NIS		 295 if (slab == PL_OpSlab) {
296 PL_OpSpace = 0;
297 }
298 }
b7dc083c 299}
b7dc083c 300#endif
e50aee73 301/*
ce6f1cbc 302 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 303 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 304 */
11343788 305#define CHECKOP(type,o) \
ce6f1cbc 306 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 307 ? ( op_free((OP*)o), \
cb77fdf0 308 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 309 (OP*)0 ) \
16c91539 310 : PL_check[type](aTHX_ (OP*)o))
e50aee73 311
e6438c1a 312#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 313
cba5a3b0
DG		 314#define CHANGE_TYPE(o,type) \
315 STMT_START { \
316 o->op_type = (OPCODE)type; \
317 o->op_ppaddr = PL_ppaddr[type]; \
318 } STMT_END
319
8b6b16e7 320STATIC const char*
cea2e8a9 321S_gv_ename(pTHX_ GV *gv)
4633a7c4 322{
46c461b5 323 SV* const tmpsv = sv_newmortal();
7918f24d
NC		 324
325 PERL_ARGS_ASSERT_GV_ENAME;
326
bd61b366 327 gv_efullname3(tmpsv, gv, NULL);
8b6b16e7 328 return SvPV_nolen_const(tmpsv);
4633a7c4
LW		 329}
330
76e3520e 331STATIC OP *
cea2e8a9 332S_no_fh_allowed(pTHX_ OP *o)
79072805 333{
7918f24d
NC		 334 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
335
cea2e8a9 336 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 337 OP_DESC(o)));
11343788 338 return o;
79072805
LW		 339}
340
76e3520e 341STATIC OP *
bfed75c6 342S_too_few_arguments(pTHX_ OP *o, const char *name)
79072805 343{
7918f24d
NC		 344 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
345
cea2e8a9 346 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
11343788 347 return o;
79072805
LW		 348}
349
76e3520e 350STATIC OP *
bfed75c6 351S_too_many_arguments(pTHX_ OP *o, const char *name)
79072805 352{
7918f24d
NC		 353 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
354
cea2e8a9 355 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
11343788 356 return o;
79072805
LW		 357}
358
76e3520e 359STATIC void
6867be6d 360S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
8990e307 361{
7918f24d
NC		 362 PERL_ARGS_ASSERT_BAD_TYPE;
363
cea2e8a9 364 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
53e06cf0 365 (int)n, name, t, OP_DESC(kid)));
8990e307
LW		 366}
367
7a52d87a 368STATIC void
eb796c7f 369S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 370{
7918f24d
NC		 371 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
372
eb8433b7
NC		 373 if (PL_madskills)
374 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 375 qerror(Perl_mess(aTHX_
35c1215d 376 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 377 SVfARG(cSVOPo_sv)));
eb796c7f 378 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS		 379}
380
79072805
LW		 381/* "register" allocation */
382
383PADOFFSET
d6447115 384Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 385{
97aff369 386 dVAR;
a0d0e21e 387 PADOFFSET off;
12bd6ede 388 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 389
7918f24d
NC		 390 PERL_ARGS_ASSERT_ALLOCMY;
391
48d0d1be 392 if (flags & ~SVf_UTF8)
d6447115
NC		 393 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
394 (UV)flags);
395
396 /* Until we're using the length for real, cross check that we're being
397 told the truth. */
398 assert(strlen(name) == len);
399
59f00321 400 /* complain about "my $<special_var>" etc etc */
d6447115 401 if (len &&
3edf23ff 402 !(is_our ||
155aba94 403 isALPHA(name[1]) ||
48d0d1be 404 ((flags & SVf_UTF8) && UTF8_IS_START(name[1])) ||
d6447115 405 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 406 {
6b58708b 407 /* name[2] is true if strlen(name) > 2 */
c4d0567e 408 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
d6447115
NC		 409 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
410 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 411 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 412 } else {
d6447115 413 yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
aab6a793 414 PL_parser->in_my == KEY_state ? "state" : "my"));
46fc3d4c 415 }
a0d0e21e 416 }
748a9306 417
dd2155a4 418 /* allocate a spare slot and store the name in that slot */
93a17b20 419
cc76b5cc 420 off = pad_add_name_pvn(name, len,
48d0d1be
BF		 421 (is_our ? padadd_OUR :
422 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
423 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 424 PL_parser->in_my_stash,
3edf23ff 425 (is_our
133706a6
RGS		 426 /* $_ is always in main::, even with our */
427 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 428 : NULL
cca43f78 429 )
dd2155a4 430 );
a74073ad
DM		 431 /* anon sub prototypes contains state vars should always be cloned,
432 * otherwise the state var would be shared between anon subs */
433
434 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
435 CvCLONE_on(PL_compcv);
436
dd2155a4 437 return off;
79072805
LW		 438}
439
d2c837a0
DM		 440/* free the body of an op without examining its contents.
441 * Always use this rather than FreeOp directly */
442
4136a0f7 443static void
d2c837a0
DM		 444S_op_destroy(pTHX_ OP *o)
445{
446 if (o->op_latefree) {
447 o->op_latefreed = 1;
448 return;
449 }
450 FreeOp(o);
451}
452
c4bd3ae5
NC		 453#ifdef USE_ITHREADS
454# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
455#else
456# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
457#endif
d2c837a0 458
79072805
LW		 459/* Destructor */
460
461void
864dbfa3 462Perl_op_free(pTHX_ OP *o)
79072805 463{
27da23d5 464 dVAR;
acb36ea4 465 OPCODE type;
79072805 466
85594c31 467 if (!o)
79072805 468 return;
670f3923
DM		 469 if (o->op_latefreed) {
470 if (o->op_latefree)
471 return;
472 goto do_free;
473 }
79072805 474
67566ccd 475 type = o->op_type;
7934575e 476 if (o->op_private & OPpREFCOUNTED) {
67566ccd 477 switch (type) {
7934575e
GS		 478 case OP_LEAVESUB:
479 case OP_LEAVESUBLV:
480 case OP_LEAVEEVAL:
481 case OP_LEAVE:
482 case OP_SCOPE:
483 case OP_LEAVEWRITE:
67566ccd
AL		 484 {
485 PADOFFSET refcnt;
7934575e 486 OP_REFCNT_LOCK;
4026c95a 487 refcnt = OpREFCNT_dec(o);
7934575e 488 OP_REFCNT_UNLOCK;
bfd0ff22
NC		 489 if (refcnt) {
490 /* Need to find and remove any pattern match ops from the list
491 we maintain for reset(). */
492 find_and_forget_pmops(o);
4026c95a 493 return;
67566ccd 494 }
bfd0ff22 495 }
7934575e
GS		 496 break;
497 default:
498 break;
499 }
500 }
501
f37b8c3f
VP		 502 /* Call the op_free hook if it has been set. Do it now so that it's called
503 * at the right time for refcounted ops, but still before all of the kids
504 * are freed. */
505 CALL_OPFREEHOOK(o);
506
11343788 507 if (o->op_flags & OPf_KIDS) {
6867be6d 508 register OP *kid, *nextkid;
11343788 509 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 510 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 511 op_free(kid);
85e6fe83 512 }
79072805 513 }
acb36ea4 514
fc97af9c
NC		 515#ifdef PERL_DEBUG_READONLY_OPS
516 Slab_to_rw(o);
517#endif
518
acb36ea4
GS		 519 /* COP* is not cleared by op_clear() so that we may track line
520 * numbers etc even after null() */
cc93af5f
RGS		 521 if (type == OP_NEXTSTATE || type == OP_DBSTATE
522 || (type == OP_NULL /* the COP might have been null'ed */
523 && ((OPCODE)o->op_targ == OP_NEXTSTATE
524 || (OPCODE)o->op_targ == OP_DBSTATE))) {
acb36ea4 525 cop_free((COP*)o);
3235b7a3 526 }
acb36ea4 527
c53f1caa
RU		 528 if (type == OP_NULL)
529 type = (OPCODE)o->op_targ;
530
acb36ea4 531 op_clear(o);
670f3923
DM		 532 if (o->op_latefree) {
533 o->op_latefreed = 1;
534 return;
535 }
536 do_free:
238a4c30 537 FreeOp(o);
4d494880
DM		 538#ifdef DEBUG_LEAKING_SCALARS
539 if (PL_op == o)
5f66b61c 540 PL_op = NULL;
4d494880 541#endif
acb36ea4 542}
79072805 543
93c66552
DM		 544void
545Perl_op_clear(pTHX_ OP *o)
acb36ea4 546{
13137afc 547
27da23d5 548 dVAR;
7918f24d
NC		 549
550 PERL_ARGS_ASSERT_OP_CLEAR;
551
eb8433b7 552#ifdef PERL_MAD
df31c78c
NC		 553 mad_free(o->op_madprop);
554 o->op_madprop = 0;
eb8433b7
NC		 555#endif
556
557 retry:
11343788 558 switch (o->op_type) {
acb36ea4 559 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 560 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 561 o->op_type = (Optype)o->op_targ;
eb8433b7
NC		 562 o->op_targ = 0;
563 goto retry;
564 }
4d193d44 565 case OP_ENTERTRY:
acb36ea4 566 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 567 o->op_targ = 0;
a0d0e21e 568 break;
a6006777 569 default:
ac4c12e7 570 if (!(o->op_flags & OPf_REF)
ef69c8fc 571 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 572 break;
573 /* FALL THROUGH */
463ee0b2 574 case OP_GVSV:
79072805 575 case OP_GV:
a6006777 576 case OP_AELEMFAST:
93bad3fd 577 {
f7461760
Z		 578 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
579#ifdef USE_ITHREADS
580 && PL_curpad
581#endif
582 ? cGVOPo_gv : NULL;
b327b36f
NC		 583 /* It's possible during global destruction that the GV is freed
584 before the optree. Whilst the SvREFCNT_inc is happy to bump from
585 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
586 will trigger an assertion failure, because the entry to sv_clear
587 checks that the scalar is not already freed. A check of for
588 !SvIS_FREED(gv) turns out to be invalid, because during global
589 destruction the reference count can be forced down to zero
590 (with SVf_BREAK set). In which case raising to 1 and then
591 dropping to 0 triggers cleanup before it should happen. I
592 *think* that this might actually be a general, systematic,
593 weakness of the whole idea of SVf_BREAK, in that code *is*
594 allowed to raise and lower references during global destruction,
595 so any *valid* code that happens to do this during global
596 destruction might well trigger premature cleanup. */
597 bool still_valid = gv && SvREFCNT(gv);
598
599 if (still_valid)
600 SvREFCNT_inc_simple_void(gv);
350de78d 601#ifdef USE_ITHREADS
6a077020
DM		 602 if (cPADOPo->op_padix > 0) {
603 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
604 * may still exist on the pad */
605 pad_swipe(cPADOPo->op_padix, TRUE);
606 cPADOPo->op_padix = 0;
607 }
350de78d 608#else
6a077020 609 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 610 cSVOPo->op_sv = NULL;
350de78d 611#endif
b327b36f 612 if (still_valid) {
f7461760
Z		 613 int try_downgrade = SvREFCNT(gv) == 2;
614 SvREFCNT_dec(gv);
615 if (try_downgrade)
616 gv_try_downgrade(gv);
617 }
6a077020 618 }
79072805 619 break;
a1ae71d2 620 case OP_METHOD_NAMED:
79072805 621 case OP_CONST:
996c9baa 622 case OP_HINTSEVAL:
11343788 623 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 624 cSVOPo->op_sv = NULL;
3b1c21fa
AB		 625#ifdef USE_ITHREADS
626 /** Bug #15654
627 Even if op_clear does a pad_free for the target of the op,
6a077020 628 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB		 629 instead it lives on. This results in that it could be reused as
630 a target later on when the pad was reallocated.
631 **/
632 if(o->op_targ) {
633 pad_swipe(o->op_targ,1);
634 o->op_targ = 0;
635 }
636#endif
79072805 637 break;
748a9306
LW		 638 case OP_GOTO:
639 case OP_NEXT:
640 case OP_LAST:
641 case OP_REDO:
11343788 642 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW		 643 break;
644 /* FALL THROUGH */
a0d0e21e 645 case OP_TRANS:
bb16bae8 646 case OP_TRANSR:
acb36ea4 647 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM		 648#ifdef USE_ITHREADS
649 if (cPADOPo->op_padix > 0) {
650 pad_swipe(cPADOPo->op_padix, TRUE);
651 cPADOPo->op_padix = 0;
652 }
653#else
a0ed51b3 654 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 655 cSVOPo->op_sv = NULL;
043e41b8 656#endif
acb36ea4
GS		 657 }
658 else {
ea71c68d 659 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 660 cPVOPo->op_pv = NULL;
acb36ea4 661 }
a0d0e21e
LW		 662 break;
663 case OP_SUBST:
20e98b0f 664 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 665 goto clear_pmop;
748a9306 666 case OP_PUSHRE:
971a9dd3 667#ifdef USE_ITHREADS
20e98b0f 668 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM		 669 /* No GvIN_PAD_off here, because other references may still
670 * exist on the pad */
20e98b0f 671 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS		 672 }
673#else
ad64d0ec 674 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS		 675#endif
676 /* FALL THROUGH */
a0d0e21e 677 case OP_MATCH:
8782bef2 678 case OP_QR:
971a9dd3 679clear_pmop:
c2b1997a 680 forget_pmop(cPMOPo, 1);
20e98b0f 681 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC		 682 /* we use the same protection as the "SAFE" version of the PM_ macros
683 * here since sv_clean_all might release some PMOPs
5f8cb046
DM		 684 * after PL_regex_padav has been cleared
685 * and the clearing of PL_regex_padav needs to
686 * happen before sv_clean_all
687 */
13137afc
AB		 688#ifdef USE_ITHREADS
689 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 690 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 691 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC		 692 PL_regex_pad[offset] = &PL_sv_undef;
693 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
694 sizeof(offset));
13137afc 695 }
9cddf794
NC		 696#else
697 ReREFCNT_dec(PM_GETRE(cPMOPo));
698 PM_SETRE(cPMOPo, NULL);
1eb1540c 699#endif
13137afc 700
a0d0e21e 701 break;
79072805
LW		 702 }
703
743e66e6 704 if (o->op_targ > 0) {
11343788 705 pad_free(o->op_targ);
743e66e6
GS		 706 o->op_targ = 0;
707 }
79072805
LW		 708}
709
76e3520e 710STATIC void
3eb57f73
HS		 711S_cop_free(pTHX_ COP* cop)
712{
7918f24d
NC		 713 PERL_ARGS_ASSERT_COP_FREE;
714
05ec9bb3
NIS		 715 CopFILE_free(cop);
716 CopSTASH_free(cop);
0453d815 717 if (! specialWARN(cop->cop_warnings))
72dc9ed5 718 PerlMemShared_free(cop->cop_warnings);
20439bc7 719 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS		 720}
721
c2b1997a 722STATIC void
c4bd3ae5
NC		 723S_forget_pmop(pTHX_ PMOP *const o
724#ifdef USE_ITHREADS
725 , U32 flags
726#endif
727 )
c2b1997a
NC		 728{
729 HV * const pmstash = PmopSTASH(o);
7918f24d
NC		 730
731 PERL_ARGS_ASSERT_FORGET_PMOP;
732
c2b1997a 733 if (pmstash && !SvIS_FREED(pmstash)) {
ad64d0ec 734 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC		 735 if (mg) {
736 PMOP **const array = (PMOP**) mg->mg_ptr;
737 U32 count = mg->mg_len / sizeof(PMOP**);
738 U32 i = count;
739
740 while (i--) {
741 if (array[i] == o) {
742 /* Found it. Move the entry at the end to overwrite it. */
743 array[i] = array[--count];
744 mg->mg_len = count * sizeof(PMOP**);
745 /* Could realloc smaller at this point always, but probably
746 not worth it. Probably worth free()ing if we're the
747 last. */
748 if(!count) {
749 Safefree(mg->mg_ptr);
750 mg->mg_ptr = NULL;
751 }
752 break;
753 }
754 }
755 }
756 }
1cdf7faf
NC		 757 if (PL_curpm == o)
758 PL_curpm = NULL;
c4bd3ae5 759#ifdef USE_ITHREADS
c2b1997a
NC		 760 if (flags)
761 PmopSTASH_free(o);
c4bd3ae5 762#endif
c2b1997a
NC		 763}
764
bfd0ff22
NC		 765STATIC void
766S_find_and_forget_pmops(pTHX_ OP *o)
767{
7918f24d
NC		 768 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
769
bfd0ff22
NC		 770 if (o->op_flags & OPf_KIDS) {
771 OP *kid = cUNOPo->op_first;
772 while (kid) {
773 switch (kid->op_type) {
774 case OP_SUBST:
775 case OP_PUSHRE:
776 case OP_MATCH:
777 case OP_QR:
778 forget_pmop((PMOP*)kid, 0);
779 }
780 find_and_forget_pmops(kid);
781 kid = kid->op_sibling;
782 }
783 }
784}
785
93c66552
DM		 786void
787Perl_op_null(pTHX_ OP *o)
8990e307 788{
27da23d5 789 dVAR;
7918f24d
NC		 790
791 PERL_ARGS_ASSERT_OP_NULL;
792
acb36ea4
GS		 793 if (o->op_type == OP_NULL)
794 return;
eb8433b7
NC		 795 if (!PL_madskills)
796 op_clear(o);
11343788
MB		 797 o->op_targ = o->op_type;
798 o->op_type = OP_NULL;
22c35a8c 799 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW		 800}
801
4026c95a
SH		 802void
803Perl_op_refcnt_lock(pTHX)
804{
27da23d5 805 dVAR;
96a5add6 806 PERL_UNUSED_CONTEXT;
4026c95a
SH		 807 OP_REFCNT_LOCK;
808}
809
810void
811Perl_op_refcnt_unlock(pTHX)
812{
27da23d5 813 dVAR;
96a5add6 814 PERL_UNUSED_CONTEXT;
4026c95a
SH		 815 OP_REFCNT_UNLOCK;
816}
817
79072805
LW		 818/* Contextualizers */
819
d9088386
Z		 820/*
821=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
822
823Applies a syntactic context to an op tree representing an expression.
824I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
825or C<G_VOID> to specify the context to apply. The modified op tree
826is returned.
827
828=cut
829*/
830
831OP *
832Perl_op_contextualize(pTHX_ OP *o, I32 context)
833{
834 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
835 switch (context) {
836 case G_SCALAR: return scalar(o);
837 case G_ARRAY: return list(o);
838 case G_VOID: return scalarvoid(o);
839 default:
5637ef5b
NC		 840 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
841 (long) context);
d9088386
Z		 842 return o;
843 }
844}
845
5983a79d
BM		 846/*
847=head1 Optree Manipulation Functions
79072805 848
5983a79d
BM		 849=for apidoc Am|OP*|op_linklist|OP *o
850This function is the implementation of the L</LINKLIST> macro. It should
851not be called directly.
852
853=cut
854*/
855
856OP *
857Perl_op_linklist(pTHX_ OP *o)
79072805 858{
3edf23ff 859 OP *first;
79072805 860
5983a79d 861 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 862
11343788
MB		 863 if (o->op_next)
864 return o->op_next;
79072805
LW		 865
866 /* establish postfix order */
3edf23ff
AL		 867 first = cUNOPo->op_first;
868 if (first) {
6867be6d 869 register OP *kid;
3edf23ff
AL		 870 o->op_next = LINKLIST(first);
871 kid = first;
872 for (;;) {
873 if (kid->op_sibling) {
79072805 874 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL		 875 kid = kid->op_sibling;
876 } else {
11343788 877 kid->op_next = o;
3edf23ff
AL		 878 break;
879 }
79072805
LW		 880 }
881 }
882 else
11343788 883 o->op_next = o;
79072805 884
11343788 885 return o->op_next;
79072805
LW		 886}
887
1f676739 888static OP *
2dd5337b 889S_scalarkids(pTHX_ OP *o)
79072805 890{
11343788 891 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 892 OP *kid;
11343788 893 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 894 scalar(kid);
895 }
11343788 896 return o;
79072805
LW		 897}
898
76e3520e 899STATIC OP *
cea2e8a9 900S_scalarboolean(pTHX_ OP *o)
8990e307 901{
97aff369 902 dVAR;
7918f24d
NC		 903
904 PERL_ARGS_ASSERT_SCALARBOOLEAN;
905
6b7c6d95
FC		 906 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
907 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 908 if (ckWARN(WARN_SYNTAX)) {
6867be6d 909 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 910
53a7735b
DM		 911 if (PL_parser && PL_parser->copline != NOLINE)
912 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 913 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 914 CopLINE_set(PL_curcop, oldline);
d008e5eb 915 }
a0d0e21e 916 }
11343788 917 return scalar(o);
8990e307
LW		 918}
919
920OP *
864dbfa3 921Perl_scalar(pTHX_ OP *o)
79072805 922{
27da23d5 923 dVAR;
79072805
LW		 924 OP *kid;
925
a0d0e21e 926 /* assumes no premature commitment */
13765c85
DM		 927 if (!o || (PL_parser && PL_parser->error_count)
928 || (o->op_flags & OPf_WANT)
5dc0d613 929 || o->op_type == OP_RETURN)
7e363e51 930 {
11343788 931 return o;
7e363e51 932 }
79072805 933
5dc0d613 934 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 935
11343788 936 switch (o->op_type) {
79072805 937 case OP_REPEAT:
11343788 938 scalar(cBINOPo->op_first);
8990e307 939 break;
79072805
LW		 940 case OP_OR:
941 case OP_AND:
942 case OP_COND_EXPR:
11343788 943 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 944 scalar(kid);
79072805 945 break;
a0d0e21e 946 /* FALL THROUGH */
a6d8037e 947 case OP_SPLIT:
79072805 948 case OP_MATCH:
8782bef2 949 case OP_QR:
79072805
LW		 950 case OP_SUBST:
951 case OP_NULL:
8990e307 952 default:
11343788
MB		 953 if (o->op_flags & OPf_KIDS) {
954 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW		 955 scalar(kid);
956 }
79072805
LW		 957 break;
958 case OP_LEAVE:
959 case OP_LEAVETRY:
5dc0d613 960 kid = cLISTOPo->op_first;
54310121 961 scalar(kid);
25b991bf
VP		 962 kid = kid->op_sibling;
963 do_kids:
964 while (kid) {
965 OP *sib = kid->op_sibling;
c08f093b
VP		 966 if (sib && kid->op_type != OP_LEAVEWHEN)
967 scalarvoid(kid);
968 else
54310121 969 scalar(kid);
25b991bf 970 kid = sib;
54310121 971 }
11206fdd 972 PL_curcop = &PL_compiling;
54310121 973 break;
748a9306 974 case OP_SCOPE:
79072805 975 case OP_LINESEQ:
8990e307 976 case OP_LIST:
25b991bf
VP		 977 kid = cLISTOPo->op_first;
978 goto do_kids;
a801c63c 979 case OP_SORT:
a2a5de95 980 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 981 break;
79072805 982 }
11343788 983 return o;
79072805
LW		 984}
985
986OP *
864dbfa3 987Perl_scalarvoid(pTHX_ OP *o)
79072805 988{
27da23d5 989 dVAR;
79072805 990 OP *kid;
c445ea15 991 const char* useless = NULL;
34ee6772 992 U32 useless_is_utf8 = 0;
8990e307 993 SV* sv;
2ebea0a1
GS		 994 U8 want;
995
7918f24d
NC		 996 PERL_ARGS_ASSERT_SCALARVOID;
997
eb8433b7
NC		 998 /* trailing mad null ops don't count as "there" for void processing */
999 if (PL_madskills &&
1000 o->op_type != OP_NULL &&
1001 o->op_sibling &&
1002 o->op_sibling->op_type == OP_NULL)
1003 {
1004 OP *sib;
1005 for (sib = o->op_sibling;
1006 sib && sib->op_type == OP_NULL;
1007 sib = sib->op_sibling) ;
1008
1009 if (!sib)
1010 return o;
1011 }
1012
acb36ea4 1013 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1014 || o->op_type == OP_DBSTATE
1015 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1016 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1017 PL_curcop = (COP*)o; /* for warning below */
79072805 1018
54310121 1019 /* assumes no premature commitment */
2ebea0a1 1020 want = o->op_flags & OPf_WANT;
13765c85
DM		 1021 if ((want && want != OPf_WANT_SCALAR)
1022 || (PL_parser && PL_parser->error_count)
25b991bf 1023 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1024 {
11343788 1025 return o;
7e363e51 1026 }
79072805 1027
b162f9ea 1028 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1029 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1030 {
b162f9ea 1031 return scalar(o); /* As if inside SASSIGN */
7e363e51 1032 }
1c846c1f 1033
5dc0d613 1034 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1035
11343788 1036 switch (o->op_type) {
79072805 1037 default:
22c35a8c 1038 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1039 break;
36477c24 1040 /* FALL THROUGH */
1041 case OP_REPEAT:
11343788 1042 if (o->op_flags & OPf_STACKED)
8990e307 1043 break;
5d82c453
GA		 1044 goto func_ops;
1045 case OP_SUBSTR:
1046 if (o->op_private == 4)
1047 break;
8990e307
LW		 1048 /* FALL THROUGH */
1049 case OP_GVSV:
1050 case OP_WANTARRAY:
1051 case OP_GV:
74295f0b 1052 case OP_SMARTMATCH:
8990e307
LW		 1053 case OP_PADSV:
1054 case OP_PADAV:
1055 case OP_PADHV:
1056 case OP_PADANY:
1057 case OP_AV2ARYLEN:
8990e307 1058 case OP_REF:
a0d0e21e
LW		 1059 case OP_REFGEN:
1060 case OP_SREFGEN:
8990e307
LW		 1061 case OP_DEFINED:
1062 case OP_HEX:
1063 case OP_OCT:
1064 case OP_LENGTH:
8990e307
LW		 1065 case OP_VEC:
1066 case OP_INDEX:
1067 case OP_RINDEX:
1068 case OP_SPRINTF:
1069 case OP_AELEM:
1070 case OP_AELEMFAST:
93bad3fd 1071 case OP_AELEMFAST_LEX:
8990e307 1072 case OP_ASLICE:
8990e307
LW		 1073 case OP_HELEM:
1074 case OP_HSLICE:
1075 case OP_UNPACK:
1076 case OP_PACK:
8990e307
LW		 1077 case OP_JOIN:
1078 case OP_LSLICE:
1079 case OP_ANONLIST:
1080 case OP_ANONHASH:
1081 case OP_SORT:
1082 case OP_REVERSE:
1083 case OP_RANGE:
1084 case OP_FLIP:
1085 case OP_FLOP:
1086 case OP_CALLER:
1087 case OP_FILENO:
1088 case OP_EOF:
1089 case OP_TELL:
1090 case OP_GETSOCKNAME:
1091 case OP_GETPEERNAME:
1092 case OP_READLINK:
1093 case OP_TELLDIR:
1094 case OP_GETPPID:
1095 case OP_GETPGRP:
1096 case OP_GETPRIORITY:
1097 case OP_TIME:
1098 case OP_TMS:
1099 case OP_LOCALTIME:
1100 case OP_GMTIME:
1101 case OP_GHBYNAME:
1102 case OP_GHBYADDR:
1103 case OP_GHOSTENT:
1104 case OP_GNBYNAME:
1105 case OP_GNBYADDR:
1106 case OP_GNETENT:
1107 case OP_GPBYNAME:
1108 case OP_GPBYNUMBER:
1109 case OP_GPROTOENT:
1110 case OP_GSBYNAME:
1111 case OP_GSBYPORT:
1112 case OP_GSERVENT:
1113 case OP_GPWNAM:
1114 case OP_GPWUID:
1115 case OP_GGRNAM:
1116 case OP_GGRGID:
1117 case OP_GETLOGIN:
78e1b766 1118 case OP_PROTOTYPE:
703227f5 1119 case OP_RUNCV:
5d82c453 1120 func_ops:
64aac5a9 1121 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1122 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1123 useless = OP_DESC(o);
75068674
RGS		 1124 break;
1125
1126 case OP_SPLIT:
1127 kid = cLISTOPo->op_first;
1128 if (kid && kid->op_type == OP_PUSHRE
1129#ifdef USE_ITHREADS
1130 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1131#else
1132 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1133#endif
1134 useless = OP_DESC(o);
8990e307
LW		 1135 break;
1136
9f82cd5f
YST		 1137 case OP_NOT:
1138 kid = cUNOPo->op_first;
1139 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1140 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1141 goto func_ops;
1142 }
1143 useless = "negative pattern binding (!~)";
1144 break;
1145
4f4d7508
DC		 1146 case OP_SUBST:
1147 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1148 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1149 break;
1150
bb16bae8
FC		 1151 case OP_TRANSR:
1152 useless = "non-destructive transliteration (tr///r)";
1153 break;
1154
8990e307
LW		 1155 case OP_RV2GV:
1156 case OP_RV2SV:
1157 case OP_RV2AV:
1158 case OP_RV2HV:
192587c2 1159 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1160 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1161 useless = "a variable";
1162 break;
79072805
LW		 1163
1164 case OP_CONST:
7766f137 1165 sv = cSVOPo_sv;
7a52d87a
GS		 1166 if (cSVOPo->op_private & OPpCONST_STRICT)
1167 no_bareword_allowed(o);
1168 else {
d008e5eb 1169 if (ckWARN(WARN_VOID)) {
e7fec78e 1170 /* don't warn on optimised away booleans, eg
b5a930ec 1171 * use constant Foo, 5; Foo || print; */
e7fec78e 1172 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1173 useless = NULL;
960b4253
MG		 1174 /* the constants 0 and 1 are permitted as they are
1175 conventionally used as dummies in constructs like
1176 1 while some_condition_with_side_effects; */
e7fec78e 1177 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1178 useless = NULL;
d008e5eb 1179 else if (SvPOK(sv)) {
a52fe3ac
A		 1180 /* perl4's way of mixing documentation and code
1181 (before the invention of POD) was based on a
1182 trick to mix nroff and perl code. The trick was
1183 built upon these three nroff macros being used in
1184 void context. The pink camel has the details in
1185 the script wrapman near page 319. */
6136c704
AL		 1186 const char * const maybe_macro = SvPVX_const(sv);
1187 if (strnEQ(maybe_macro, "di", 2) ||
1188 strnEQ(maybe_macro, "ds", 2) ||
1189 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1190 useless = NULL;
919f76a3 1191 else {
d3bcd21f 1192 SV * const dsv = newSVpvs("");
919f76a3
RGS		 1193 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1194 "a constant (%s)",
1195 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1196 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1197 SvREFCNT_dec(dsv);
1198 useless = SvPV_nolen(msv);
1199 useless_is_utf8 = SvUTF8(msv);
1200 }
d008e5eb 1201 }
919f76a3
RGS		 1202 else if (SvOK(sv)) {
1203 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1204 "a constant (%"SVf")", sv));
1205 useless = SvPV_nolen(msv);
1206 }
1207 else
1208 useless = "a constant (undef)";
8990e307
LW		 1209 }
1210 }
93c66552 1211 op_null(o); /* don't execute or even remember it */
79072805
LW		 1212 break;
1213
1214 case OP_POSTINC:
11343788 1215 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1216 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW		 1217 break;
1218
1219 case OP_POSTDEC:
11343788 1220 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1221 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW		 1222 break;
1223
679d6c4e
HS		 1224 case OP_I_POSTINC:
1225 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1226 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1227 break;
1228
1229 case OP_I_POSTDEC:
1230 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1231 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1232 break;
1233
f2f8fd84
GG		 1234 case OP_SASSIGN: {
1235 OP *rv2gv;
1236 UNOP *refgen, *rv2cv;
1237 LISTOP *exlist;
1238
1239 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1240 break;
1241
1242 rv2gv = ((BINOP *)o)->op_last;
1243 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1244 break;
1245
1246 refgen = (UNOP *)((BINOP *)o)->op_first;
1247
1248 if (!refgen || refgen->op_type != OP_REFGEN)
1249 break;
1250
1251 exlist = (LISTOP *)refgen->op_first;
1252 if (!exlist || exlist->op_type != OP_NULL
1253 || exlist->op_targ != OP_LIST)
1254 break;
1255
1256 if (exlist->op_first->op_type != OP_PUSHMARK)
1257 break;
1258
1259 rv2cv = (UNOP*)exlist->op_last;
1260
1261 if (rv2cv->op_type != OP_RV2CV)
1262 break;
1263
1264 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1265 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1266 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1267
1268 o->op_private |= OPpASSIGN_CV_TO_GV;
1269 rv2gv->op_private |= OPpDONT_INIT_GV;
1270 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1271
1272 break;
1273 }
1274
540dd770
GG		 1275 case OP_AASSIGN: {
1276 inplace_aassign(o);
1277 break;
1278 }
1279
79072805
LW		 1280 case OP_OR:
1281 case OP_AND:
edbe35ea
VP		 1282 kid = cLOGOPo->op_first;
1283 if (kid->op_type == OP_NOT
1284 && (kid->op_flags & OPf_KIDS)
1285 && !PL_madskills) {
1286 if (o->op_type == OP_AND) {
1287 o->op_type = OP_OR;
1288 o->op_ppaddr = PL_ppaddr[OP_OR];
1289 } else {
1290 o->op_type = OP_AND;
1291 o->op_ppaddr = PL_ppaddr[OP_AND];
1292 }
1293 op_null(kid);
1294 }
1295
c963b151 1296 case OP_DOR:
79072805 1297 case OP_COND_EXPR:
0d863452
RH		 1298 case OP_ENTERGIVEN:
1299 case OP_ENTERWHEN:
11343788 1300 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1301 scalarvoid(kid);
1302 break;
5aabfad6 1303
a0d0e21e 1304 case OP_NULL:
11343788 1305 if (o->op_flags & OPf_STACKED)
a0d0e21e 1306 break;
5aabfad6 1307 /* FALL THROUGH */
2ebea0a1
GS		 1308 case OP_NEXTSTATE:
1309 case OP_DBSTATE:
79072805
LW		 1310 case OP_ENTERTRY:
1311 case OP_ENTER:
11343788 1312 if (!(o->op_flags & OPf_KIDS))
79072805 1313 break;
54310121 1314 /* FALL THROUGH */
463ee0b2 1315 case OP_SCOPE:
79072805
LW		 1316 case OP_LEAVE:
1317 case OP_LEAVETRY:
a0d0e21e 1318 case OP_LEAVELOOP:
79072805 1319 case OP_LINESEQ:
79072805 1320 case OP_LIST:
0d863452
RH		 1321 case OP_LEAVEGIVEN:
1322 case OP_LEAVEWHEN:
11343788 1323 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1324 scalarvoid(kid);
1325 break;
c90c0ff4 1326 case OP_ENTEREVAL:
5196be3e 1327 scalarkids(o);
c90c0ff4 1328 break;
d6483035 1329 case OP_SCALAR:
5196be3e 1330 return scalar(o);
79072805 1331 }
a2a5de95 1332 if (useless)
34ee6772
BF		 1333 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1334 newSVpvn_flags(useless, strlen(useless),
1335 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
11343788 1336 return o;
79072805
LW		 1337}
1338
1f676739 1339static OP *
412da003 1340S_listkids(pTHX_ OP *o)
79072805 1341{
11343788 1342 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1343 OP *kid;
11343788 1344 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1345 list(kid);
1346 }
11343788 1347 return o;
79072805
LW		 1348}
1349
1350OP *
864dbfa3 1351Perl_list(pTHX_ OP *o)
79072805 1352{
27da23d5 1353 dVAR;
79072805
LW		 1354 OP *kid;
1355
a0d0e21e 1356 /* assumes no premature commitment */
13765c85
DM		 1357 if (!o || (o->op_flags & OPf_WANT)
1358 || (PL_parser && PL_parser->error_count)
5dc0d613 1359 || o->op_type == OP_RETURN)
7e363e51 1360 {
11343788 1361 return o;
7e363e51 1362 }
79072805 1363
b162f9ea 1364 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1365 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1366 {
b162f9ea 1367 return o; /* As if inside SASSIGN */
7e363e51 1368 }
1c846c1f 1369
5dc0d613 1370 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1371
11343788 1372 switch (o->op_type) {
79072805
LW		 1373 case OP_FLOP:
1374 case OP_REPEAT:
11343788 1375 list(cBINOPo->op_first);
79072805
LW		 1376 break;
1377 case OP_OR:
1378 case OP_AND:
1379 case OP_COND_EXPR:
11343788 1380 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1381 list(kid);
1382 break;
1383 default:
1384 case OP_MATCH:
8782bef2 1385 case OP_QR:
79072805
LW		 1386 case OP_SUBST:
1387 case OP_NULL:
11343788 1388 if (!(o->op_flags & OPf_KIDS))
79072805 1389 break;
11343788
MB		 1390 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1391 list(cBINOPo->op_first);
1392 return gen_constant_list(o);
79072805
LW		 1393 }
1394 case OP_LIST:
11343788 1395 listkids(o);
79072805
LW		 1396 break;
1397 case OP_LEAVE:
1398 case OP_LEAVETRY:
5dc0d613 1399 kid = cLISTOPo->op_first;
54310121 1400 list(kid);
25b991bf
VP		 1401 kid = kid->op_sibling;
1402 do_kids:
1403 while (kid) {
1404 OP *sib = kid->op_sibling;
c08f093b
VP		 1405 if (sib && kid->op_type != OP_LEAVEWHEN)
1406 scalarvoid(kid);
1407 else
54310121 1408 list(kid);
25b991bf 1409 kid = sib;
54310121 1410 }
11206fdd 1411 PL_curcop = &PL_compiling;
54310121 1412 break;
748a9306 1413 case OP_SCOPE:
79072805 1414 case OP_LINESEQ:
25b991bf
VP		 1415 kid = cLISTOPo->op_first;
1416 goto do_kids;
79072805 1417 }
11343788 1418 return o;
79072805
LW		 1419}
1420
1f676739 1421static OP *
2dd5337b 1422S_scalarseq(pTHX_ OP *o)
79072805 1423{
97aff369 1424 dVAR;
11343788 1425 if (o) {
1496a290
AL		 1426 const OPCODE type = o->op_type;
1427
1428 if (type == OP_LINESEQ || type == OP_SCOPE ||
1429 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1430 {
6867be6d 1431 OP *kid;
11343788 1432 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1433 if (kid->op_sibling) {
463ee0b2 1434 scalarvoid(kid);
ed6116ce 1435 }
463ee0b2 1436 }
3280af22 1437 PL_curcop = &PL_compiling;
79072805 1438 }
11343788 1439 o->op_flags &= ~OPf_PARENS;
3280af22 1440 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1441 o->op_flags |= OPf_PARENS;
79072805 1442 }
8990e307 1443 else
11343788
MB		 1444 o = newOP(OP_STUB, 0);
1445 return o;
79072805
LW		 1446}
1447
76e3520e 1448STATIC OP *
cea2e8a9 1449S_modkids(pTHX_ OP *o, I32 type)
79072805 1450{
11343788 1451 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1452 OP *kid;
11343788 1453 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1454 op_lvalue(kid, type);
79072805 1455 }
11343788 1456 return o;
79072805
LW		 1457}
1458
3ad73efd 1459/*
d164302a
GG		 1460=for apidoc finalize_optree
1461
1462This function finalizes the optree. Should be called directly after
1463the complete optree is built. It does some additional
1464checking which can't be done in the normal ck_xxx functions and makes
1465the tree thread-safe.
1466
1467=cut
1468*/
1469void
1470Perl_finalize_optree(pTHX_ OP* o)
1471{
1472 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1473
1474 ENTER;
1475 SAVEVPTR(PL_curcop);
1476
1477 finalize_op(o);
1478
1479 LEAVE;
1480}
1481
60dde6b2 1482STATIC void
d164302a
GG		 1483S_finalize_op(pTHX_ OP* o)
1484{
1485 PERL_ARGS_ASSERT_FINALIZE_OP;
1486
1487#if defined(PERL_MAD) && defined(USE_ITHREADS)
1488 {
1489 /* Make sure mad ops are also thread-safe */
1490 MADPROP *mp = o->op_madprop;
1491 while (mp) {
1492 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1493 OP *prop_op = (OP *) mp->mad_val;
1494 /* We only need "Relocate sv to the pad for thread safety.", but this
1495 easiest way to make sure it traverses everything */
4dc304e0
FC		 1496 if (prop_op->op_type == OP_CONST)
1497 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1498 finalize_op(prop_op);
1499 }
1500 mp = mp->mad_next;
1501 }
1502 }
1503#endif
1504
1505 switch (o->op_type) {
1506 case OP_NEXTSTATE:
1507 case OP_DBSTATE:
1508 PL_curcop = ((COP*)o); /* for warnings */
1509 break;
1510 case OP_EXEC:
ea31ed66
GG		 1511 if ( o->op_sibling
1512 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG		 1513 && ckWARN(WARN_SYNTAX))
1514 {
ea31ed66
GG		 1515 if (o->op_sibling->op_sibling) {
1516 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1517 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1518 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1519 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1520 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1521 "Statement unlikely to be reached");
1522 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1523 "\t(Maybe you meant system() when you said exec()?)\n");
1524 CopLINE_set(PL_curcop, oldline);
1525 }
1526 }
1527 }
1528 break;
1529
1530 case OP_GV:
1531 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1532 GV * const gv = cGVOPo_gv;
1533 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1534 /* XXX could check prototype here instead of just carping */
1535 SV * const sv = sv_newmortal();
1536 gv_efullname3(sv, gv, NULL);
1537 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1538 "%"SVf"() called too early to check prototype",
1539 SVfARG(sv));
1540 }
1541 }
1542 break;
1543
1544 case OP_CONST:
eb796c7f
GG		 1545 if (cSVOPo->op_private & OPpCONST_STRICT)
1546 no_bareword_allowed(o);
1547 /* FALLTHROUGH */
d164302a
GG		 1548#ifdef USE_ITHREADS
1549 case OP_HINTSEVAL:
1550 case OP_METHOD_NAMED:
1551 /* Relocate sv to the pad for thread safety.
1552 * Despite being a "constant", the SV is written to,
1553 * for reference counts, sv_upgrade() etc. */
1554 if (cSVOPo->op_sv) {
1555 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1556 if (o->op_type != OP_METHOD_NAMED &&
1557 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1558 {
1559 /* If op_sv is already a PADTMP/MY then it is being used by
1560 * some pad, so make a copy. */
1561 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1562 SvREADONLY_on(PAD_SVl(ix));
1563 SvREFCNT_dec(cSVOPo->op_sv);
1564 }
1565 else if (o->op_type != OP_METHOD_NAMED
1566 && cSVOPo->op_sv == &PL_sv_undef) {
1567 /* PL_sv_undef is hack - it's unsafe to store it in the
1568 AV that is the pad, because av_fetch treats values of
1569 PL_sv_undef as a "free" AV entry and will merrily
1570 replace them with a new SV, causing pad_alloc to think
1571 that this pad slot is free. (When, clearly, it is not)
1572 */
1573 SvOK_off(PAD_SVl(ix));
1574 SvPADTMP_on(PAD_SVl(ix));
1575 SvREADONLY_on(PAD_SVl(ix));
1576 }
1577 else {
1578 SvREFCNT_dec(PAD_SVl(ix));
1579 SvPADTMP_on(cSVOPo->op_sv);
1580 PAD_SETSV(ix, cSVOPo->op_sv);
1581 /* XXX I don't know how this isn't readonly already. */
1582 SvREADONLY_on(PAD_SVl(ix));
1583 }
1584 cSVOPo->op_sv = NULL;
1585 o->op_targ = ix;
1586 }
1587#endif
1588 break;
1589
1590 case OP_HELEM: {
1591 UNOP *rop;
1592 SV *lexname;
1593 GV **fields;
1594 SV **svp, *sv;
1595 const char *key = NULL;
1596 STRLEN keylen;
1597
1598 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1599 break;
1600
1601 /* Make the CONST have a shared SV */
1602 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1603 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1604 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1605 key = SvPV_const(sv, keylen);
1606 lexname = newSVpvn_share(key,
1607 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1608 0);
1609 SvREFCNT_dec(sv);
1610 *svp = lexname;
1611 }
1612
1613 if ((o->op_private & (OPpLVAL_INTRO)))
1614 break;
1615
1616 rop = (UNOP*)((BINOP*)o)->op_first;
1617 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1618 break;
1619 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1620 if (!SvPAD_TYPED(lexname))
1621 break;
1622 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1623 if (!fields || !GvHV(*fields))
1624 break;
1625 key = SvPV_const(*svp, keylen);
1626 if (!hv_fetch(GvHV(*fields), key,
1627 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1628 Perl_croak(aTHX_ "No such class field \"%s\" "
1629 "in variable %s of type %s",
1630 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1631 }
1632 break;
1633 }
1634
1635 case OP_HSLICE: {
1636 UNOP *rop;
1637 SV *lexname;
1638 GV **fields;
1639 SV **svp;
1640 const char *key;
1641 STRLEN keylen;
1642 SVOP *first_key_op, *key_op;
1643
1644 if ((o->op_private & (OPpLVAL_INTRO))
1645 /* I bet there's always a pushmark... */
1646 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1647 /* hmmm, no optimization if list contains only one key. */
1648 break;
1649 rop = (UNOP*)((LISTOP*)o)->op_last;
1650 if (rop->op_type != OP_RV2HV)
1651 break;
1652 if (rop->op_first->op_type == OP_PADSV)
1653 /* @$hash{qw(keys here)} */
1654 rop = (UNOP*)rop->op_first;
1655 else {
1656 /* @{$hash}{qw(keys here)} */
1657 if (rop->op_first->op_type == OP_SCOPE
1658 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1659 {
1660 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1661 }
1662 else
1663 break;
1664 }
1665
1666 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1667 if (!SvPAD_TYPED(lexname))
1668 break;
1669 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1670 if (!fields || !GvHV(*fields))
1671 break;
1672 /* Again guessing that the pushmark can be jumped over.... */
1673 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1674 ->op_first->op_sibling;
1675 for (key_op = first_key_op; key_op;
1676 key_op = (SVOP*)key_op->op_sibling) {
1677 if (key_op->op_type != OP_CONST)
1678 continue;
1679 svp = cSVOPx_svp(key_op);
1680 key = SvPV_const(*svp, keylen);
1681 if (!hv_fetch(GvHV(*fields), key,
1682 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1683 Perl_croak(aTHX_ "No such class field \"%s\" "
1684 "in variable %s of type %s",
1685 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1686 }
1687 }
1688 break;
1689 }
1690 case OP_SUBST: {
1691 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1692 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1693 break;
1694 }
1695 default:
1696 break;
1697 }
1698
1699 if (o->op_flags & OPf_KIDS) {
1700 OP *kid;
1701 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1702 finalize_op(kid);
1703 }
1704}
1705
1706/*
3ad73efd
Z		 1707=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1708
1709Propagate lvalue ("modifiable") context to an op and its children.
1710I<type> represents the context type, roughly based on the type of op that
1711would do the modifying, although C<local()> is represented by OP_NULL,
1712because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 1713the lvalue op).
1714
1715This function detects things that can't be modified, such as C<$x+1>, and
1716generates errors for them. For example, C<$x+1 = 2> would cause it to be
1717called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1718
1719It also flags things that need to behave specially in an lvalue context,
1720such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 1721
1722=cut
1723*/
ddeae0f1 1724
79072805 1725OP *
d3d7d28f 1726Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1727{
27da23d5 1728 dVAR;
79072805 1729 OP *kid;
ddeae0f1
DM		 1730 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1731 int localize = -1;
79072805 1732
13765c85 1733 if (!o || (PL_parser && PL_parser->error_count))
11343788 1734 return o;
79072805 1735
b162f9ea 1736 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1737 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1738 {
b162f9ea 1739 return o;
7e363e51 1740 }
1c846c1f 1741
5c906035
GG		 1742 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1743
69974ce6
FC		 1744 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1745
11343788 1746 switch (o->op_type) {
68dc0745 1747 case OP_UNDEF:
ddeae0f1 1748 localize = 0;
3280af22 1749 PL_modcount++;
5dc0d613 1750 return o;
5f05dabc 1751 case OP_STUB:
58bde88d 1752 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1753 break;
1754 goto nomod;
a0d0e21e 1755 case OP_ENTERSUB:
f79aa60b 1756 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 1757 !(o->op_flags & OPf_STACKED)) {
1758 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 1759 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1760 poses, so we need it clear. */
e26df76a 1761 o->op_private &= ~1;
22c35a8c 1762 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1763 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1764 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1765 break;
1766 }
cd06dffe 1767 else { /* lvalue subroutine call */
777d9014
FC		 1768 o->op_private |= OPpLVAL_INTRO
1769 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1770 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1771 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1772 /* Potential lvalue context: */
cd06dffe
GS		 1773 o->op_private |= OPpENTERSUB_INARGS;
1774 break;
1775 }
1776 else { /* Compile-time error message: */
1777 OP *kid = cUNOPo->op_first;
1778 CV *cv;
1779 OP *okid;
1780
3ea285d1
AL		 1781 if (kid->op_type != OP_PUSHMARK) {
1782 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1783 Perl_croak(aTHX_
1784 "panic: unexpected lvalue entersub "
1785 "args: type/targ %ld:%"UVuf,
1786 (long)kid->op_type, (UV)kid->op_targ);
1787 kid = kLISTOP->op_first;
1788 }
cd06dffe
GS		 1789 while (kid->op_sibling)
1790 kid = kid->op_sibling;
1791 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS		 1792 break; /* Postpone until runtime */
1793 }
b2ffa427
NIS		 1794
1795 okid = kid;
cd06dffe
GS		 1796 kid = kUNOP->op_first;
1797 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1798 kid = kUNOP->op_first;
b2ffa427 1799 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1800 Perl_croak(aTHX_
1801 "Unexpected constant lvalue entersub "
55140b79 1802 "entry via type/targ %ld:%"UVuf,
3d811634 1803 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 1804 if (kid->op_type != OP_GV) {
cd06dffe
GS		 1805 break;
1806 }
b2ffa427 1807
638eceb6 1808 cv = GvCV(kGVOP_gv);
1c846c1f 1809 if (!cv)
da1dff94 1810 break;
cd06dffe
GS		 1811 if (CvLVALUE(cv))
1812 break;
1813 }
1814 }
79072805
LW		 1815 /* FALL THROUGH */
1816 default:
a0d0e21e 1817 nomod:
f5d552b4 1818 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 1819 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 1820 if (type == OP_GREPSTART || type == OP_ENTERSUB
1821 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 1822 break;
cea2e8a9 1823 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1824 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1825 ? "do block"
1826 : (o->op_type == OP_ENTERSUB
1827 ? "non-lvalue subroutine call"
53e06cf0 1828 : OP_DESC(o))),
22c35a8c 1829 type ? PL_op_desc[type] : "local"));
11343788 1830 return o;
79072805 1831
a0d0e21e
LW		 1832 case OP_PREINC:
1833 case OP_PREDEC:
1834 case OP_POW:
1835 case OP_MULTIPLY:
1836 case OP_DIVIDE:
1837 case OP_MODULO:
1838 case OP_REPEAT:
1839 case OP_ADD:
1840 case OP_SUBTRACT:
1841 case OP_CONCAT:
1842 case OP_LEFT_SHIFT:
1843 case OP_RIGHT_SHIFT:
1844 case OP_BIT_AND:
1845 case OP_BIT_XOR:
1846 case OP_BIT_OR:
1847 case OP_I_MULTIPLY:
1848 case OP_I_DIVIDE:
1849 case OP_I_MODULO:
1850 case OP_I_ADD:
1851 case OP_I_SUBTRACT:
11343788 1852 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1853 goto nomod;
3280af22 1854 PL_modcount++;
a0d0e21e 1855 break;
b2ffa427 1856
79072805 1857 case OP_COND_EXPR:
ddeae0f1 1858 localize = 1;
11343788 1859 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 1860 op_lvalue(kid, type);
79072805
LW		 1861 break;
1862
1863 case OP_RV2AV:
1864 case OP_RV2HV:
11343788 1865 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1866 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1867 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1868 }
1869 /* FALL THROUGH */
79072805 1870 case OP_RV2GV:
5dc0d613 1871 if (scalar_mod_type(o, type))
3fe9a6f1 1872 goto nomod;
11343788 1873 ref(cUNOPo->op_first, o->op_type);
79072805 1874 /* FALL THROUGH */
79072805
LW		 1875 case OP_ASLICE:
1876 case OP_HSLICE:
78f9721b
SM		 1877 if (type == OP_LEAVESUBLV)
1878 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1879 localize = 1;
78f9721b
SM		 1880 /* FALL THROUGH */
1881 case OP_AASSIGN:
93a17b20
LW		 1882 case OP_NEXTSTATE:
1883 case OP_DBSTATE:
e6438c1a 1884 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1885 break;
28c5b5bc
RGS		 1886 case OP_AV2ARYLEN:
1887 PL_hints |= HINT_BLOCK_SCOPE;
1888 if (type == OP_LEAVESUBLV)
1889 o->op_private |= OPpMAYBE_LVSUB;
1890 PL_modcount++;
1891 break;
463ee0b2 1892 case OP_RV2SV:
aeea060c 1893 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1894 localize = 1;
463ee0b2 1895 /* FALL THROUGH */
79072805 1896 case OP_GV:
3280af22 1897 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1898 case OP_SASSIGN:
bf4b1e52
GS		 1899 case OP_ANDASSIGN:
1900 case OP_ORASSIGN:
c963b151 1901 case OP_DORASSIGN:
ddeae0f1
DM		 1902 PL_modcount++;
1903 break;
1904
8990e307 1905 case OP_AELEMFAST:
93bad3fd 1906 case OP_AELEMFAST_LEX:
6a077020 1907 localize = -1;
3280af22 1908 PL_modcount++;
8990e307
LW		 1909 break;
1910
748a9306
LW		 1911 case OP_PADAV:
1912 case OP_PADHV:
e6438c1a 1913 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1914 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1915 return o; /* Treat \(@foo) like ordinary list. */
1916 if (scalar_mod_type(o, type))
3fe9a6f1 1917 goto nomod;
78f9721b
SM		 1918 if (type == OP_LEAVESUBLV)
1919 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1920 /* FALL THROUGH */
1921 case OP_PADSV:
3280af22 1922 PL_modcount++;
ddeae0f1 1923 if (!type) /* local() */
5ede95a0
BF		 1924 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1925 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 1926 break;
1927
748a9306 1928 case OP_PUSHMARK:
ddeae0f1 1929 localize = 0;
748a9306 1930 break;
b2ffa427 1931
69969c6f 1932 case OP_KEYS:
d8065907 1933 case OP_RKEYS:
fad4a2e4 1934 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 1935 goto nomod;
5d82c453
GA		 1936 goto lvalue_func;
1937 case OP_SUBSTR:
1938 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1939 goto nomod;
5f05dabc 1940 /* FALL THROUGH */
a0d0e21e 1941 case OP_POS:
463ee0b2 1942 case OP_VEC:
fad4a2e4 1943 lvalue_func:
78f9721b
SM		 1944 if (type == OP_LEAVESUBLV)
1945 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB		 1946 pad_free(o->op_targ);
1947 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1948 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 1949 if (o->op_flags & OPf_KIDS)
3ad73efd 1950 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 1951 break;
a0d0e21e 1952
463ee0b2
LW		 1953 case OP_AELEM:
1954 case OP_HELEM:
11343788 1955 ref(cBINOPo->op_first, o->op_type);
68dc0745 1956 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1957 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1958 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1959 if (type == OP_LEAVESUBLV)
1960 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1961 localize = 1;
3280af22 1962 PL_modcount++;
463ee0b2
LW		 1963 break;
1964
1965 case OP_SCOPE:
1966 case OP_LEAVE:
1967 case OP_ENTER:
78f9721b 1968 case OP_LINESEQ:
ddeae0f1 1969 localize = 0;
11343788 1970 if (o->op_flags & OPf_KIDS)
3ad73efd 1971 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 1972 break;
1973
1974 case OP_NULL:
ddeae0f1 1975 localize = 0;
638bc118
GS		 1976 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1977 goto nomod;
1978 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 1979 break;
11343788 1980 if (o->op_targ != OP_LIST) {
3ad73efd 1981 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 1982 break;
1983 }
1984 /* FALL THROUGH */
463ee0b2 1985 case OP_LIST:
ddeae0f1 1986 localize = 0;
11343788 1987 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 1988 /* elements might be in void context because the list is
1989 in scalar context or because they are attribute sub calls */
1990 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
1991 op_lvalue(kid, type);
463ee0b2 1992 break;
78f9721b
SM		 1993
1994 case OP_RETURN:
1995 if (type != OP_LEAVESUBLV)
1996 goto nomod;
3ad73efd 1997 break; /* op_lvalue()ing was handled by ck_return() */
463ee0b2 1998 }
58d95175 1999
8be1be90
AMS		 2000 /* [20011101.069] File test operators interpret OPf_REF to mean that
2001 their argument is a filehandle; thus \stat(".") should not set
2002 it. AMS 20011102 */
2003 if (type == OP_REFGEN &&
ef69c8fc 2004 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2005 return o;
2006
2007 if (type != OP_LEAVESUBLV)
2008 o->op_flags |= OPf_MOD;
2009
2010 if (type == OP_AASSIGN || type == OP_SASSIGN)
2011 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2012 else if (!type) { /* local() */
2013 switch (localize) {
2014 case 1:
2015 o->op_private |= OPpLVAL_INTRO;
2016 o->op_flags &= ~OPf_SPECIAL;
2017 PL_hints |= HINT_BLOCK_SCOPE;
2018 break;
2019 case 0:
2020 break;
2021 case -1:
a2a5de95
NC		 2022 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2023 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2024 }
463ee0b2 2025 }
8be1be90
AMS		 2026 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2027 && type != OP_LEAVESUBLV)
2028 o->op_flags |= OPf_REF;
11343788 2029 return o;
463ee0b2
LW		 2030}
2031
864dbfa3 2032STATIC bool
5f66b61c 2033S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2034{
1ecbeecf 2035 assert(o || type != OP_SASSIGN);
7918f24d 2036
3fe9a6f1 2037 switch (type) {
2038 case OP_SASSIGN:
5196be3e 2039 if (o->op_type == OP_RV2GV)
3fe9a6f1 2040 return FALSE;
2041 /* FALL THROUGH */
2042 case OP_PREINC:
2043 case OP_PREDEC:
2044 case OP_POSTINC:
2045 case OP_POSTDEC:
2046 case OP_I_PREINC:
2047 case OP_I_PREDEC:
2048 case OP_I_POSTINC:
2049 case OP_I_POSTDEC:
2050 case OP_POW:
2051 case OP_MULTIPLY:
2052 case OP_DIVIDE:
2053 case OP_MODULO:
2054 case OP_REPEAT:
2055 case OP_ADD:
2056 case OP_SUBTRACT:
2057 case OP_I_MULTIPLY:
2058 case OP_I_DIVIDE:
2059 case OP_I_MODULO:
2060 case OP_I_ADD:
2061 case OP_I_SUBTRACT:
2062 case OP_LEFT_SHIFT:
2063 case OP_RIGHT_SHIFT:
2064 case OP_BIT_AND:
2065 case OP_BIT_XOR:
2066 case OP_BIT_OR:
2067 case OP_CONCAT:
2068 case OP_SUBST:
2069 case OP_TRANS:
bb16bae8 2070 case OP_TRANSR:
49e9fbe6
GS		 2071 case OP_READ:
2072 case OP_SYSREAD:
2073 case OP_RECV:
bf4b1e52
GS		 2074 case OP_ANDASSIGN:
2075 case OP_ORASSIGN:
410d09fe 2076 case OP_DORASSIGN:
3fe9a6f1 2077 return TRUE;
2078 default:
2079 return FALSE;
2080 }
2081}
2082
35cd451c 2083STATIC bool
5f66b61c 2084S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2085{
7918f24d
NC		 2086 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2087
35cd451c
GS		 2088 switch (o->op_type) {
2089 case OP_PIPE_OP:
2090 case OP_SOCKPAIR:
504618e9 2091 if (numargs == 2)
35cd451c
GS		 2092 return TRUE;
2093 /* FALL THROUGH */
2094 case OP_SYSOPEN:
2095 case OP_OPEN:
ded8aa31 2096 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2097 case OP_SOCKET:
2098 case OP_OPEN_DIR:
2099 case OP_ACCEPT:
504618e9 2100 if (numargs == 1)
35cd451c 2101 return TRUE;
5f66b61c 2102 /* FALLTHROUGH */
35cd451c
GS		 2103 default:
2104 return FALSE;
2105 }
2106}
2107
0d86688d
NC		 2108static OP *
2109S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2110{
11343788 2111 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2112 OP *kid;
11343788 2113 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2114 ref(kid, type);
2115 }
11343788 2116 return o;
463ee0b2
LW		 2117}
2118
2119OP *
e4c5ccf3 2120Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2121{
27da23d5 2122 dVAR;
463ee0b2 2123 OP *kid;
463ee0b2 2124
7918f24d
NC		 2125 PERL_ARGS_ASSERT_DOREF;
2126
13765c85 2127 if (!o || (PL_parser && PL_parser->error_count))
11343788 2128 return o;
463ee0b2 2129
11343788 2130 switch (o->op_type) {
a0d0e21e 2131 case OP_ENTERSUB:
f4df43b5 2132 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2133 !(o->op_flags & OPf_STACKED)) {
2134 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2135 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2136 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2137 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2138 o->op_flags |= OPf_SPECIAL;
e26df76a 2139 o->op_private &= ~1;
8990e307 2140 }
767eda44 2141 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2142 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2143 : type == OP_RV2HV ? OPpDEREF_HV
2144 : OPpDEREF_SV);
767eda44
FC		 2145 o->op_flags |= OPf_MOD;
2146 }
2147
8990e307 2148 break;
aeea060c 2149
463ee0b2 2150 case OP_COND_EXPR:
11343788 2151 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2152 doref(kid, type, set_op_ref);
463ee0b2 2153 break;
8990e307 2154 case OP_RV2SV:
35cd451c
GS		 2155 if (type == OP_DEFINED)
2156 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2157 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2158 /* FALL THROUGH */
2159 case OP_PADSV:
5f05dabc 2160 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2161 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2162 : type == OP_RV2HV ? OPpDEREF_HV
2163 : OPpDEREF_SV);
11343788 2164 o->op_flags |= OPf_MOD;
a0d0e21e 2165 }
8990e307 2166 break;
1c846c1f 2167
463ee0b2
LW		 2168 case OP_RV2AV:
2169 case OP_RV2HV:
e4c5ccf3
RH		 2170 if (set_op_ref)
2171 o->op_flags |= OPf_REF;
8990e307 2172 /* FALL THROUGH */
463ee0b2 2173 case OP_RV2GV:
35cd451c
GS		 2174 if (type == OP_DEFINED)
2175 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2176 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2177 break;
8990e307 2178
463ee0b2
LW		 2179 case OP_PADAV:
2180 case OP_PADHV:
e4c5ccf3
RH		 2181 if (set_op_ref)
2182 o->op_flags |= OPf_REF;
79072805 2183 break;
aeea060c 2184
8990e307 2185 case OP_SCALAR:
79072805 2186 case OP_NULL:
11343788 2187 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2188 break;
e4c5ccf3 2189 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2190 break;
2191 case OP_AELEM:
2192 case OP_HELEM:
e4c5ccf3 2193 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2194 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2195 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2196 : type == OP_RV2HV ? OPpDEREF_HV
2197 : OPpDEREF_SV);
11343788 2198 o->op_flags |= OPf_MOD;
8990e307 2199 }
79072805
LW		 2200 break;
2201
463ee0b2 2202 case OP_SCOPE:
79072805 2203 case OP_LEAVE:
e4c5ccf3
RH		 2204 set_op_ref = FALSE;
2205 /* FALL THROUGH */
79072805 2206 case OP_ENTER:
8990e307 2207 case OP_LIST:
11343788 2208 if (!(o->op_flags & OPf_KIDS))
79072805 2209 break;
e4c5ccf3 2210 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2211 break;
a0d0e21e
LW		 2212 default:
2213 break;
79072805 2214 }
11343788 2215 return scalar(o);
8990e307 2216
79072805
LW		 2217}
2218
09bef843
SB		 2219STATIC OP *
2220S_dup_attrlist(pTHX_ OP *o)
2221{
97aff369 2222 dVAR;
0bd48802 2223 OP *rop;
09bef843 2224
7918f24d
NC		 2225 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2226
09bef843
SB		 2227 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2228 * where the first kid is OP_PUSHMARK and the remaining ones
2229 * are OP_CONST. We need to push the OP_CONST values.
2230 */
2231 if (o->op_type == OP_CONST)
b37c2d43 2232 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2233#ifdef PERL_MAD
2234 else if (o->op_type == OP_NULL)
1d866c12 2235 rop = NULL;
eb8433b7 2236#endif
09bef843
SB		 2237 else {
2238 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2239 rop = NULL;
09bef843
SB		 2240 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2241 if (o->op_type == OP_CONST)
2fcb4757 2242 rop = op_append_elem(OP_LIST, rop,
09bef843 2243 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2244 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2245 }
2246 }
2247 return rop;
2248}
2249
2250STATIC void
95f0a2f1 2251S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2252{
27da23d5 2253 dVAR;
09bef843
SB		 2254 SV *stashsv;
2255
7918f24d
NC		 2256 PERL_ARGS_ASSERT_APPLY_ATTRS;
2257
09bef843
SB		 2258 /* fake up C<use attributes $pkg,$rv,@attrs> */
2259 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2260 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2261
09bef843 2262#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2263#define ATTRSMODULE_PM "attributes.pm"
2264
2265 if (for_my) {
95f0a2f1 2266 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2267 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2268 if (svp && *svp != &PL_sv_undef)
6f207bd3 2269 NOOP; /* already in %INC */
95f0a2f1
SB		 2270 else
2271 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2272 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 2273 }
2274 else {
2275 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2276 newSVpvs(ATTRSMODULE),
2277 NULL,
2fcb4757 2278 op_prepend_elem(OP_LIST,
95f0a2f1 2279 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2280 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2281 newSVOP(OP_CONST, 0,
2282 newRV(target)),
2283 dup_attrlist(attrs))));
2284 }
09bef843
SB		 2285 LEAVE;
2286}
2287
95f0a2f1
SB		 2288STATIC void
2289S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2290{
97aff369 2291 dVAR;
95f0a2f1
SB		 2292 OP *pack, *imop, *arg;
2293 SV *meth, *stashsv;
2294
7918f24d
NC		 2295 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2296
95f0a2f1
SB		 2297 if (!attrs)
2298 return;
2299
2300 assert(target->op_type == OP_PADSV ||
2301 target->op_type == OP_PADHV ||
2302 target->op_type == OP_PADAV);
2303
2304 /* Ensure that attributes.pm is loaded. */
dd2155a4 2305 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 2306
2307 /* Need package name for method call. */
6136c704 2308 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2309
2310 /* Build up the real arg-list. */
5aaec2b4
NC		 2311 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2312
95f0a2f1
SB		 2313 arg = newOP(OP_PADSV, 0);
2314 arg->op_targ = target->op_targ;
2fcb4757 2315 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2316 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2317 op_prepend_elem(OP_LIST,
95f0a2f1 2318 newUNOP(OP_REFGEN, 0,
3ad73efd 2319 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2320 dup_attrlist(attrs)));
2321
2322 /* Fake up a method call to import */
18916d0d 2323 meth = newSVpvs_share("import");
95f0a2f1 2324 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2325 op_append_elem(OP_LIST,
2326 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2327 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2328
2329 /* Combine the ops. */
2fcb4757 2330 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2331}
2332
2333/*
2334=notfor apidoc apply_attrs_string
2335
2336Attempts to apply a list of attributes specified by the C<attrstr> and
2337C<len> arguments to the subroutine identified by the C<cv> argument which
2338is expected to be associated with the package identified by the C<stashpv>
2339argument (see L<attributes>). It gets this wrong, though, in that it
2340does not correctly identify the boundaries of the individual attribute
2341specifications within C<attrstr>. This is not really intended for the
2342public API, but has to be listed here for systems such as AIX which
2343need an explicit export list for symbols. (It's called from XS code
2344in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2345to respect attribute syntax properly would be welcome.
2346
2347=cut
2348*/
2349
be3174d2 2350void
6867be6d
AL		 2351Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2352 const char *attrstr, STRLEN len)
be3174d2 2353{
5f66b61c 2354 OP *attrs = NULL;
be3174d2 2355
7918f24d
NC		 2356 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2357
be3174d2
GS		 2358 if (!len) {
2359 len = strlen(attrstr);
2360 }
2361
2362 while (len) {
2363 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2364 if (len) {
890ce7af 2365 const char * const sstr = attrstr;
be3174d2 2366 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2367 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2368 newSVOP(OP_CONST, 0,
2369 newSVpvn(sstr, attrstr-sstr)));
2370 }
2371 }
2372
2373 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2374 newSVpvs(ATTRSMODULE),
2fcb4757 2375 NULL, op_prepend_elem(OP_LIST,
be3174d2 2376 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2377 op_prepend_elem(OP_LIST,
be3174d2 2378 newSVOP(OP_CONST, 0,
ad64d0ec 2379 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2380 attrs)));
2381}
2382
09bef843 2383STATIC OP *
95f0a2f1 2384S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2385{
97aff369 2386 dVAR;
93a17b20 2387 I32 type;
a1fba7eb 2388 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2389
7918f24d
NC		 2390 PERL_ARGS_ASSERT_MY_KID;
2391
13765c85 2392 if (!o || (PL_parser && PL_parser->error_count))
11343788 2393 return o;
93a17b20 2394
bc61e325 2395 type = o->op_type;
eb8433b7
NC		 2396 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2397 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2398 return o;
2399 }
2400
93a17b20 2401 if (type == OP_LIST) {
6867be6d 2402 OP *kid;
11343788 2403 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2404 my_kid(kid, attrs, imopsp);
0865059d 2405 return o;
eb8433b7
NC		 2406 } else if (type == OP_UNDEF
2407#ifdef PERL_MAD
2408 || type == OP_STUB
2409#endif
2410 ) {
7766148a 2411 return o;
77ca0c92
LW		 2412 } else if (type == OP_RV2SV || /* "our" declaration */
2413 type == OP_RV2AV ||
2414 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2415 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2416 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2417 OP_DESC(o),
12bd6ede
DM		 2418 PL_parser->in_my == KEY_our
2419 ? "our"
2420 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2421 } else if (attrs) {
551405c4 2422 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2423 PL_parser->in_my = FALSE;
2424 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2425 apply_attrs(GvSTASH(gv),
2426 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2427 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2428 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS		 2429 attrs, FALSE);
2430 }
192587c2 2431 o->op_private |= OPpOUR_INTRO;
77ca0c92 2432 return o;
95f0a2f1
SB		 2433 }
2434 else if (type != OP_PADSV &&
93a17b20
LW		 2435 type != OP_PADAV &&
2436 type != OP_PADHV &&
2437 type != OP_PUSHMARK)
2438 {
eb64745e 2439 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2440 OP_DESC(o),
12bd6ede
DM		 2441 PL_parser->in_my == KEY_our
2442 ? "our"
2443 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2444 return o;
93a17b20 2445 }
09bef843
SB		 2446 else if (attrs && type != OP_PUSHMARK) {
2447 HV *stash;
09bef843 2448
12bd6ede
DM		 2449 PL_parser->in_my = FALSE;
2450 PL_parser->in_my_stash = NULL;
eb64745e 2451
09bef843 2452 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2453 stash = PAD_COMPNAME_TYPE(o->op_targ);
2454 if (!stash)
09bef843 2455 stash = PL_curstash;
95f0a2f1 2456 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2457 }
11343788
MB		 2458 o->op_flags |= OPf_MOD;
2459 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2460 if (stately)
952306ac 2461 o->op_private |= OPpPAD_STATE;
11343788 2462 return o;
93a17b20
LW		 2463}
2464
2465OP *
09bef843
SB		 2466Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2467{
97aff369 2468 dVAR;
0bd48802 2469 OP *rops;
95f0a2f1
SB		 2470 int maybe_scalar = 0;
2471
7918f24d
NC		 2472 PERL_ARGS_ASSERT_MY_ATTRS;
2473
d2be0de5 2474/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2475 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2476#if 0
09bef843
SB		 2477 if (o->op_flags & OPf_PARENS)
2478 list(o);
95f0a2f1
SB		 2479 else
2480 maybe_scalar = 1;
d2be0de5
YST		 2481#else
2482 maybe_scalar = 1;
2483#endif
09bef843
SB		 2484 if (attrs)
2485 SAVEFREEOP(attrs);
5f66b61c 2486 rops = NULL;
95f0a2f1
SB		 2487 o = my_kid(o, attrs, &rops);
2488 if (rops) {
2489 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2490 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2491 o->op_private |= OPpLVAL_INTRO;
2492 }
f5d1ed10
FC		 2493 else {
2494 /* The listop in rops might have a pushmark at the beginning,
2495 which will mess up list assignment. */
2496 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2497 if (rops->op_type == OP_LIST &&
2498 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2499 {
2500 OP * const pushmark = lrops->op_first;
2501 lrops->op_first = pushmark->op_sibling;
2502 op_free(pushmark);
2503 }
2fcb4757 2504 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2505 }
95f0a2f1 2506 }
12bd6ede
DM		 2507 PL_parser->in_my = FALSE;
2508 PL_parser->in_my_stash = NULL;
eb64745e 2509 return o;
09bef843
SB		 2510}
2511
2512OP *
864dbfa3 2513Perl_sawparens(pTHX_ OP *o)
79072805 2514{
96a5add6 2515 PERL_UNUSED_CONTEXT;
79072805
LW		 2516 if (o)
2517 o->op_flags |= OPf_PARENS;
2518 return o;
2519}
2520
2521OP *
864dbfa3 2522Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2523{
11343788 2524 OP *o;
59f00321 2525 bool ismatchop = 0;
1496a290
AL		 2526 const OPCODE ltype = left->op_type;
2527 const OPCODE rtype = right->op_type;
79072805 2528
7918f24d
NC		 2529 PERL_ARGS_ASSERT_BIND_MATCH;
2530
1496a290
AL		 2531 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2532 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2533 {
1496a290 2534 const char * const desc
bb16bae8
FC		 2535 = PL_op_desc[(
2536 rtype == OP_SUBST || rtype == OP_TRANS
2537 || rtype == OP_TRANSR
2538 )
666ea192 2539 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2540 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2541 GV *gv;
2542 SV * const name =
2543 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2544 ? cUNOPx(left)->op_first->op_type == OP_GV
2545 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2546 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2547 : NULL
ba510004
FC		 2548 : varname(
2549 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2550 );
c6771ab6
FC		 2551 if (name)
2552 Perl_warner(aTHX_ packWARN(WARN_MISC),
2553 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2554 desc, name, name);
2555 else {
2556 const char * const sample = (isary
666ea192 2557 ? "@array" : "%hash");
c6771ab6 2558 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2559 "Applying %s to %s will act on scalar(%s)",
599cee73 2560 desc, sample, sample);
c6771ab6 2561 }
2ae324a7 2562 }
2563
1496a290 2564 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2565 cSVOPx(right)->op_private & OPpCONST_BARE &&
2566 cSVOPx(right)->op_private & OPpCONST_STRICT)
2567 {
2568 no_bareword_allowed(right);
2569 }
2570
bb16bae8 2571 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2572 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2573 type == OP_NOT)
2574 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2575 if (rtype == OP_TRANSR && type == OP_NOT)
2576 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2577
2474a784
FC		 2578 ismatchop = (rtype == OP_MATCH ||
2579 rtype == OP_SUBST ||
bb16bae8 2580 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2581 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2582 if (ismatchop && right->op_private & OPpTARGET_MY) {
2583 right->op_targ = 0;
2584 right->op_private &= ~OPpTARGET_MY;
2585 }
2586 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2587 OP *newleft;
2588
79072805 2589 right->op_flags |= OPf_STACKED;
bb16bae8 2590 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2591 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2592 right->op_private & OPpTRANS_IDENTICAL) &&
2593 ! (rtype == OP_SUBST &&
2594 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2595 newleft = op_lvalue(left, rtype);
1496a290
AL		 2596 else
2597 newleft = left;
bb16bae8 2598 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2599 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2600 else
2fcb4757 2601 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2602 if (type == OP_NOT)
11343788
MB		 2603 return newUNOP(OP_NOT, 0, scalar(o));
2604 return o;
79072805
LW		 2605 }
2606 else
2607 return bind_match(type, left,
131b3ad0 2608 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2609}
2610
2611OP *
864dbfa3 2612Perl_invert(pTHX_ OP *o)
79072805 2613{
11343788 2614 if (!o)
1d866c12 2615 return NULL;
11343788 2616 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2617}
2618
3ad73efd
Z		 2619/*
2620=for apidoc Amx|OP *|op_scope|OP *o
2621
2622Wraps up an op tree with some additional ops so that at runtime a dynamic
2623scope will be created. The original ops run in the new dynamic scope,
2624and then, provided that they exit normally, the scope will be unwound.
2625The additional ops used to create and unwind the dynamic scope will
2626normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2627instead if the ops are simple enough to not need the full dynamic scope
2628structure.
2629
2630=cut
2631*/
2632
79072805 2633OP *
3ad73efd 2634Perl_op_scope(pTHX_ OP *o)
79072805 2635{
27da23d5 2636 dVAR;
79072805 2637 if (o) {
3280af22 2638 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2639 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2640 o->op_type = OP_LEAVE;
22c35a8c 2641 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2642 }
fdb22418
HS		 2643 else if (o->op_type == OP_LINESEQ) {
2644 OP *kid;
2645 o->op_type = OP_SCOPE;
2646 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2647 kid = ((LISTOP*)o)->op_first;
59110972 2648 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2649 op_null(kid);
59110972
RH		 2650
2651 /* The following deals with things like 'do {1 for 1}' */
2652 kid = kid->op_sibling;
2653 if (kid &&
2654 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2655 op_null(kid);
2656 }
463ee0b2 2657 }
fdb22418 2658 else
5f66b61c 2659 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2660 }
2661 return o;
2662}
1930840b 2663
a0d0e21e 2664int
864dbfa3 2665Perl_block_start(pTHX_ int full)
79072805 2666{
97aff369 2667 dVAR;
73d840c0 2668 const int retval = PL_savestack_ix;
1930840b 2669
dd2155a4 2670 pad_block_start(full);
b3ac6de7 2671 SAVEHINTS();
3280af22 2672 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2673 SAVECOMPILEWARNINGS();
72dc9ed5 2674 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2675
a88d97bf 2676 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2677
a0d0e21e
LW		 2678 return retval;
2679}
2680
2681OP*
864dbfa3 2682Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2683{
97aff369 2684 dVAR;
6867be6d 2685 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM		 2686 OP* retval = scalarseq(seq);
2687
a88d97bf 2688 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2689
e9818f4e 2690 LEAVE_SCOPE(floor);
623e6609 2691 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2692 if (needblockscope)
3280af22 2693 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2694 pad_leavemy();
1930840b 2695
a88d97bf 2696 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2697
a0d0e21e
LW		 2698 return retval;
2699}
2700
fd85fad2
BM		 2701/*
2702=head1 Compile-time scope hooks
2703
3e4ddde5 2704=for apidoc Aox||blockhook_register
fd85fad2
BM		 2705
2706Register a set of hooks to be called when the Perl lexical scope changes
2707at compile time. See L<perlguts/"Compile-time scope hooks">.
2708
2709=cut
2710*/
2711
bb6c22e7
BM		 2712void
2713Perl_blockhook_register(pTHX_ BHK *hk)
2714{
2715 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2716
2717 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2718}
2719
76e3520e 2720STATIC OP *
cea2e8a9 2721S_newDEFSVOP(pTHX)
54b9620d 2722{
97aff369 2723 dVAR;
cc76b5cc 2724 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2725 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2726 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2727 }
2728 else {
551405c4 2729 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2730 o->op_targ = offset;
2731 return o;
2732 }
54b9620d
MB		 2733}
2734
a0d0e21e 2735void
864dbfa3 2736Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2737{
97aff369 2738 dVAR;
7918f24d
NC		 2739
2740 PERL_ARGS_ASSERT_NEWPROG;
2741
3280af22 2742 if (PL_in_eval) {
86a64801 2743 PERL_CONTEXT *cx;
b295d113
TH		 2744 if (PL_eval_root)
2745 return;
faef0170
HS		 2746 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2747 ((PL_in_eval & EVAL_KEEPERR)
2748 ? OPf_SPECIAL : 0), o);
86a64801
GG		 2749
2750 cx = &cxstack[cxstack_ix];
2751 assert(CxTYPE(cx) == CXt_EVAL);
2752
2753 if ((cx->blk_gimme & G_WANT) == G_VOID)
2754 scalarvoid(PL_eval_root);
2755 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2756 list(PL_eval_root);
2757 else
2758 scalar(PL_eval_root);
2759
5983a79d
BM		 2760 /* don't use LINKLIST, since PL_eval_root might indirect through
2761 * a rather expensive function call and LINKLIST evaluates its
2762 * argument more than once */
2763 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 2764 PL_eval_root->op_private |= OPpREFCOUNTED;
2765 OpREFCNT_set(PL_eval_root, 1);
3280af22 2766 PL_eval_root->op_next = 0;
a2efc822 2767 CALL_PEEP(PL_eval_start);
86a64801
GG		 2768 finalize_optree(PL_eval_root);
2769
a0d0e21e
LW		 2770 }
2771 else {
6be89cf9
AE		 2772 if (o->op_type == OP_STUB) {
2773 PL_comppad_name = 0;
2774 PL_compcv = 0;
d2c837a0 2775 S_op_destroy(aTHX_ o);
a0d0e21e 2776 return;
6be89cf9 2777 }
3ad73efd 2778 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 2779 PL_curcop = &PL_compiling;
2780 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2781 PL_main_root->op_private |= OPpREFCOUNTED;
2782 OpREFCNT_set(PL_main_root, 1);
3280af22 2783 PL_main_root->op_next = 0;
a2efc822 2784 CALL_PEEP(PL_main_start);
d164302a 2785 finalize_optree(PL_main_root);
3280af22 2786 PL_compcv = 0;
3841441e 2787
4fdae800 2788 /* Register with debugger */
84902520 2789 if (PERLDB_INTER) {
b96d8cd9 2790 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 2791 if (cv) {
2792 dSP;
924508f0 2793 PUSHMARK(SP);
ad64d0ec 2794 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2795 PUTBACK;
ad64d0ec 2796 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 2797 }
2798 }
79072805 2799 }
79072805
LW		 2800}
2801
2802OP *
864dbfa3 2803Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2804{
97aff369 2805 dVAR;
7918f24d
NC		 2806
2807 PERL_ARGS_ASSERT_LOCALIZE;
2808
79072805 2809 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2810/* [perl #17376]: this appears to be premature, and results in code such as
2811 C< our(%x); > executing in list mode rather than void mode */
2812#if 0
79072805 2813 list(o);
d2be0de5 2814#else
6f207bd3 2815 NOOP;
d2be0de5 2816#endif
8990e307 2817 else {
f06b5848
DM		 2818 if ( PL_parser->bufptr > PL_parser->oldbufptr
2819 && PL_parser->bufptr[-1] == ','
041457d9 2820 && ckWARN(WARN_PARENTHESIS))
64420d0d 2821 {
f06b5848 2822 char *s = PL_parser->bufptr;
bac662ee 2823 bool sigil = FALSE;
64420d0d 2824
8473848f 2825 /* some heuristics to detect a potential error */
bac662ee 2826 while (*s && (strchr(", \t\n", *s)))
64420d0d 2827 s++;
8473848f 2828
bac662ee
TS		 2829 while (1) {
2830 if (*s && strchr("@$%*", *s) && *++s
2831 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2832 s++;
2833 sigil = TRUE;
2834 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2835 s++;
2836 while (*s && (strchr(", \t\n", *s)))
2837 s++;
2838 }
2839 else
2840 break;
2841 }
2842 if (sigil && (*s == ';' || *s == '=')) {
2843 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2844 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2845 lex
2846 ? (PL_parser->in_my == KEY_our
2847 ? "our"
2848 : PL_parser->in_my == KEY_state
2849 ? "state"
2850 : "my")
2851 : "local");
8473848f 2852 }
8990e307
LW		 2853 }
2854 }
93a17b20 2855 if (lex)
eb64745e 2856 o = my(o);
93a17b20 2857 else
3ad73efd 2858 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2859 PL_parser->in_my = FALSE;
2860 PL_parser->in_my_stash = NULL;
eb64745e 2861 return o;
79072805
LW		 2862}
2863
2864OP *
864dbfa3 2865Perl_jmaybe(pTHX_ OP *o)
79072805 2866{
7918f24d
NC		 2867 PERL_ARGS_ASSERT_JMAYBE;
2868
79072805 2869 if (o->op_type == OP_LIST) {
fafc274c 2870 OP * const o2
d4c19fe8 2871 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 2872 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 2873 }
2874 return o;
2875}
2876
985b9e54
GG		 2877PERL_STATIC_INLINE OP *
2878S_op_std_init(pTHX_ OP *o)
2879{
2880 I32 type = o->op_type;
2881
2882 PERL_ARGS_ASSERT_OP_STD_INIT;
2883
2884 if (PL_opargs[type] & OA_RETSCALAR)
2885 scalar(o);
2886 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2887 o->op_targ = pad_alloc(type, SVs_PADTMP);
2888
2889 return o;
2890}
2891
2892PERL_STATIC_INLINE OP *
2893S_op_integerize(pTHX_ OP *o)
2894{
2895 I32 type = o->op_type;
2896
2897 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2898
2899 /* integerize op, unless it happens to be C<-foo>.
2900 * XXX should pp_i_negate() do magic string negation instead? */
2901 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2902 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2903 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2904 {
f5f19483 2905 dVAR;
985b9e54
GG		 2906 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2907 }
2908
2909 if (type == OP_NEGATE)
2910 /* XXX might want a ck_negate() for this */
2911 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2912
2913 return o;
2914}
2915
1f676739 2916static OP *
b7783a12 2917S_fold_constants(pTHX_ register OP *o)
79072805 2918{
27da23d5 2919 dVAR;
001d637e 2920 register OP * VOL curop;
eb8433b7 2921 OP *newop;
8ea43dc8 2922 VOL I32 type = o->op_type;
e3cbe32f 2923 SV * VOL sv = NULL;
b7f7fd0b
NC		 2924 int ret = 0;
2925 I32 oldscope;
2926 OP *old_next;
5f2d9966
DM		 2927 SV * const oldwarnhook = PL_warnhook;
2928 SV * const olddiehook = PL_diehook;
c427f4d2 2929 COP not_compiling;
b7f7fd0b 2930 dJMPENV;
79072805 2931
7918f24d
NC		 2932 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2933
22c35a8c 2934 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2935 goto nope;
2936
de939608 2937 switch (type) {
de939608
CS		 2938 case OP_UCFIRST:
2939 case OP_LCFIRST:
2940 case OP_UC:
2941 case OP_LC:
69dcf70c
MB		 2942 case OP_SLT:
2943 case OP_SGT:
2944 case OP_SLE:
2945 case OP_SGE:
2946 case OP_SCMP:
b3fd6149 2947 case OP_SPRINTF:
2de3dbcc 2948 /* XXX what about the numeric ops? */
82ad65bb 2949 if (IN_LOCALE_COMPILETIME)
de939608 2950 goto nope;
553e7bb0 2951 break;
de939608
CS		 2952 }
2953
13765c85 2954 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2955 goto nope; /* Don't try to run w/ errors */
2956
79072805 2957 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2958 const OPCODE type = curop->op_type;
2959 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2960 type != OP_LIST &&
2961 type != OP_SCALAR &&
2962 type != OP_NULL &&
2963 type != OP_PUSHMARK)
7a52d87a 2964 {
79072805
LW		 2965 goto nope;
2966 }
2967 }
2968
2969 curop = LINKLIST(o);
b7f7fd0b 2970 old_next = o->op_next;
79072805 2971 o->op_next = 0;
533c011a 2972 PL_op = curop;
b7f7fd0b
NC		 2973
2974 oldscope = PL_scopestack_ix;
edb2152a 2975 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2976
c427f4d2
NC		 2977 /* Verify that we don't need to save it: */
2978 assert(PL_curcop == &PL_compiling);
2979 StructCopy(&PL_compiling, &not_compiling, COP);
2980 PL_curcop = &not_compiling;
2981 /* The above ensures that we run with all the correct hints of the
2982 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2983 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 2984 PL_warnhook = PERL_WARNHOOK_FATAL;
2985 PL_diehook = NULL;
b7f7fd0b
NC		 2986 JMPENV_PUSH(ret);
2987
2988 switch (ret) {
2989 case 0:
2990 CALLRUNOPS(aTHX);
2991 sv = *(PL_stack_sp--);
523a0f0c
NC		 2992 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2993#ifdef PERL_MAD
2994 /* Can't simply swipe the SV from the pad, because that relies on
2995 the op being freed "real soon now". Under MAD, this doesn't
2996 happen (see the #ifdef below). */
2997 sv = newSVsv(sv);
2998#else
b7f7fd0b 2999 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3000#endif
3001 }
b7f7fd0b
NC		 3002 else if (SvTEMP(sv)) { /* grab mortal temp? */
3003 SvREFCNT_inc_simple_void(sv);
3004 SvTEMP_off(sv);
3005 }
3006 break;
3007 case 3:
3008 /* Something tried to die. Abandon constant folding. */
3009 /* Pretend the error never happened. */
ab69dbc2 3010 CLEAR_ERRSV();
b7f7fd0b
NC		 3011 o->op_next = old_next;
3012 break;
3013 default:
3014 JMPENV_POP;
5f2d9966
DM		 3015 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3016 PL_warnhook = oldwarnhook;
3017 PL_diehook = olddiehook;
3018 /* XXX note that this croak may fail as we've already blown away
3019 * the stack - eg any nested evals */
b7f7fd0b
NC		 3020 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3021 }
b7f7fd0b 3022 JMPENV_POP;
5f2d9966
DM		 3023 PL_warnhook = oldwarnhook;
3024 PL_diehook = olddiehook;
c427f4d2 3025 PL_curcop = &PL_compiling;
edb2152a
NC		 3026
3027 if (PL_scopestack_ix > oldscope)
3028 delete_eval_scope();
eb8433b7 3029
b7f7fd0b
NC		 3030 if (ret)
3031 goto nope;
3032
eb8433b7 3033#ifndef PERL_MAD
79072805 3034 op_free(o);
eb8433b7 3035#endif
de5e01c2 3036 assert(sv);
79072805 3037 if (type == OP_RV2GV)
159b6efe 3038 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3039 else
ad64d0ec 3040 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 3041 op_getmad(o,newop,'f');
3042 return newop;
aeea060c 3043
b7f7fd0b 3044 nope:
79072805
LW		 3045 return o;
3046}
3047
1f676739 3048static OP *
b7783a12 3049S_gen_constant_list(pTHX_ register OP *o)
79072805 3050{
27da23d5 3051 dVAR;
79072805 3052 register OP *curop;
6867be6d 3053 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3054
a0d0e21e 3055 list(o);
13765c85 3056 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3057 return o; /* Don't attempt to run with errors */
3058
533c011a 3059 PL_op = curop = LINKLIST(o);
a0d0e21e 3060 o->op_next = 0;
a2efc822 3061 CALL_PEEP(curop);
897d3989 3062 Perl_pp_pushmark(aTHX);
cea2e8a9 3063 CALLRUNOPS(aTHX);
533c011a 3064 PL_op = curop;
78c72037
NC		 3065 assert (!(curop->op_flags & OPf_SPECIAL));
3066 assert(curop->op_type == OP_RANGE);
897d3989 3067 Perl_pp_anonlist(aTHX);
3280af22 3068 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3069
3070 o->op_type = OP_RV2AV;
22c35a8c 3071 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3072 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3073 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3074 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3075 curop = ((UNOP*)o)->op_first;
b37c2d43 3076 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3077#ifdef PERL_MAD
3078 op_getmad(curop,o,'O');
3079#else
79072805 3080 op_free(curop);
eb8433b7 3081#endif
5983a79d 3082 LINKLIST(o);
79072805
LW		 3083 return list(o);
3084}
3085
3086OP *
864dbfa3 3087Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3088{
27da23d5 3089 dVAR;
d67594ff 3090 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3091 if (!o || o->op_type != OP_LIST)
5f66b61c 3092 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3093 else
5dc0d613 3094 o->op_flags &= ~OPf_WANT;
79072805 3095
22c35a8c 3096 if (!(PL_opargs[type] & OA_MARK))
93c66552 3097 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3098 else {
3099 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3100 if (kid2 && kid2->op_type == OP_COREARGS) {
3101 op_null(cLISTOPo->op_first);
3102 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3103 }
3104 }
8990e307 3105
eb160463 3106 o->op_type = (OPCODE)type;
22c35a8c 3107 o->op_ppaddr = PL_ppaddr[type];
11343788 3108 o->op_flags |= flags;
79072805 3109
11343788 3110 o = CHECKOP(type, o);
fe2774ed 3111 if (o->op_type != (unsigned)type)
11343788 3112 return o;
79072805 3113
985b9e54 3114 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3115}
3116
2fcb4757
Z		 3117/*
3118=head1 Optree Manipulation Functions
3119*/
3120
79072805
LW		 3121/* List constructors */
3122
2fcb4757
Z		 3123/*
3124=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3125
3126Append an item to the list of ops contained directly within a list-type
3127op, returning the lengthened list. I<first> is the list-type op,
3128and I<last> is the op to append to the list. I<optype> specifies the
3129intended opcode for the list. If I<first> is not already a list of the
3130right type, it will be upgraded into one. If either I<first> or I<last>
3131is null, the other is returned unchanged.
3132
3133=cut
3134*/
3135
79072805 3136OP *
2fcb4757 3137Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3138{
3139 if (!first)
3140 return last;
8990e307
LW		 3141
3142 if (!last)
79072805 3143 return first;
8990e307 3144
fe2774ed 3145 if (first->op_type != (unsigned)type
155aba94
GS		 3146 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3147 {
3148 return newLISTOP(type, 0, first, last);
3149 }
79072805 3150
a0d0e21e
LW		 3151 if (first->op_flags & OPf_KIDS)
3152 ((LISTOP*)first)->op_last->op_sibling = last;
3153 else {
3154 first->op_flags |= OPf_KIDS;
3155 ((LISTOP*)first)->op_first = last;
3156 }
3157 ((LISTOP*)first)->op_last = last;
a0d0e21e 3158 return first;
79072805
LW		 3159}
3160
2fcb4757
Z		 3161/*
3162=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3163
3164Concatenate the lists of ops contained directly within two list-type ops,
3165returning the combined list. I<first> and I<last> are the list-type ops
3166to concatenate. I<optype> specifies the intended opcode for the list.
3167If either I<first> or I<last> is not already a list of the right type,
3168it will be upgraded into one. If either I<first> or I<last> is null,
3169the other is returned unchanged.
3170
3171=cut
3172*/
3173
79072805 3174OP *
2fcb4757 3175Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3176{
3177 if (!first)
2fcb4757 3178 return last;
8990e307
LW		 3179
3180 if (!last)
2fcb4757 3181 return first;
8990e307 3182
fe2774ed 3183 if (first->op_type != (unsigned)type)
2fcb4757 3184 return op_prepend_elem(type, first, last);
8990e307 3185
fe2774ed 3186 if (last->op_type != (unsigned)type)
2fcb4757 3187 return op_append_elem(type, first, last);
79072805 3188
2fcb4757
Z		 3189 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3190 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3191 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3192
eb8433b7 3193#ifdef PERL_MAD
2fcb4757
Z		 3194 if (((LISTOP*)last)->op_first && first->op_madprop) {
3195 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3196 if (mp) {
3197 while (mp->mad_next)
3198 mp = mp->mad_next;
3199 mp->mad_next = first->op_madprop;
3200 }
3201 else {
2fcb4757 3202 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3203 }
3204 }
3205 first->op_madprop = last->op_madprop;
3206 last->op_madprop = 0;
3207#endif
3208
2fcb4757 3209 S_op_destroy(aTHX_ last);
238a4c30 3210
2fcb4757 3211 return first;
79072805
LW		 3212}
3213
2fcb4757
Z		 3214/*
3215=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3216
3217Prepend an item to the list of ops contained directly within a list-type
3218op, returning the lengthened list. I<first> is the op to prepend to the
3219list, and I<last> is the list-type op. I<optype> specifies the intended
3220opcode for the list. If I<last> is not already a list of the right type,
3221it will be upgraded into one. If either I<first> or I<last> is null,
3222the other is returned unchanged.
3223
3224=cut
3225*/
3226
79072805 3227OP *
2fcb4757 3228Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3229{
3230 if (!first)
3231 return last;
8990e307
LW		 3232
3233 if (!last)
79072805 3234 return first;
8990e307 3235
fe2774ed 3236 if (last->op_type == (unsigned)type) {
8990e307
LW		 3237 if (type == OP_LIST) { /* already a PUSHMARK there */
3238 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3239 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3240 if (!(first->op_flags & OPf_PARENS))
3241 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3242 }
3243 else {
3244 if (!(last->op_flags & OPf_KIDS)) {
3245 ((LISTOP*)last)->op_last = first;
3246 last->op_flags |= OPf_KIDS;
3247 }
3248 first->op_sibling = ((LISTOP*)last)->op_first;
3249 ((LISTOP*)last)->op_first = first;
79072805 3250 }
117dada2 3251 last->op_flags |= OPf_KIDS;
79072805
LW		 3252 return last;
3253 }
3254
3255 return newLISTOP(type, 0, first, last);
3256}
3257
3258/* Constructors */
3259
eb8433b7
NC		 3260#ifdef PERL_MAD
3261
3262TOKEN *
3263Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3264{
3265 TOKEN *tk;
99129197 3266 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3267 tk->tk_type = (OPCODE)optype;
3268 tk->tk_type = 12345;
3269 tk->tk_lval = lval;
3270 tk->tk_mad = madprop;
3271 return tk;
3272}
3273
3274void
3275Perl_token_free(pTHX_ TOKEN* tk)
3276{
7918f24d
NC		 3277 PERL_ARGS_ASSERT_TOKEN_FREE;
3278
eb8433b7
NC		 3279 if (tk->tk_type != 12345)
3280 return;
3281 mad_free(tk->tk_mad);
3282 Safefree(tk);
3283}
3284
3285void
3286Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3287{
3288 MADPROP* mp;
3289 MADPROP* tm;
7918f24d
NC		 3290
3291 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3292
eb8433b7
NC		 3293 if (tk->tk_type != 12345) {
3294 Perl_warner(aTHX_ packWARN(WARN_MISC),
3295 "Invalid TOKEN object ignored");
3296 return;
3297 }
3298 tm = tk->tk_mad;
3299 if (!tm)
3300 return;
3301
3302 /* faked up qw list? */
3303 if (slot == '(' &&
3304 tm->mad_type == MAD_SV &&
d503a9ba 3305 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3306 slot = 'x';
3307
3308 if (o) {
3309 mp = o->op_madprop;
3310 if (mp) {
3311 for (;;) {
3312 /* pretend constant fold didn't happen? */
3313 if (mp->mad_key == 'f' &&
3314 (o->op_type == OP_CONST ||
3315 o->op_type == OP_GV) )
3316 {
3317 token_getmad(tk,(OP*)mp->mad_val,slot);
3318 return;
3319 }
3320 if (!mp->mad_next)
3321 break;
3322 mp = mp->mad_next;
3323 }
3324 mp->mad_next = tm;
3325 mp = mp->mad_next;
3326 }
3327 else {
3328 o->op_madprop = tm;
3329 mp = o->op_madprop;
3330 }
3331 if (mp->mad_key == 'X')
3332 mp->mad_key = slot; /* just change the first one */
3333
3334 tk->tk_mad = 0;
3335 }
3336 else
3337 mad_free(tm);
3338 Safefree(tk);
3339}
3340
3341void
3342Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3343{
3344 MADPROP* mp;
3345 if (!from)
3346 return;
3347 if (o) {
3348 mp = o->op_madprop;
3349 if (mp) {
3350 for (;;) {
3351 /* pretend constant fold didn't happen? */
3352 if (mp->mad_key == 'f' &&
3353 (o->op_type == OP_CONST ||
3354 o->op_type == OP_GV) )
3355 {
3356 op_getmad(from,(OP*)mp->mad_val,slot);
3357 return;
3358 }
3359 if (!mp->mad_next)
3360 break;
3361 mp = mp->mad_next;
3362 }
3363 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3364 }
3365 else {
3366 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3367 }
3368 }
3369}
3370
3371void
3372Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3373{
3374 MADPROP* mp;
3375 if (!from)
3376 return;
3377 if (o) {
3378 mp = o->op_madprop;
3379 if (mp) {
3380 for (;;) {
3381 /* pretend constant fold didn't happen? */
3382 if (mp->mad_key == 'f' &&
3383 (o->op_type == OP_CONST ||
3384 o->op_type == OP_GV) )
3385 {
3386 op_getmad(from,(OP*)mp->mad_val,slot);
3387 return;
3388 }
3389 if (!mp->mad_next)
3390 break;
3391 mp = mp->mad_next;
3392 }
3393 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3394 }
3395 else {
3396 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3397 }
3398 }
3399 else {
99129197
NC		 3400 PerlIO_printf(PerlIO_stderr(),
3401 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3402 op_free(from);
3403 }
3404}
3405
3406void
3407Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3408{
3409 MADPROP* tm;
3410 if (!mp || !o)
3411 return;
3412 if (slot)
3413 mp->mad_key = slot;
3414 tm = o->op_madprop;
3415 o->op_madprop = mp;
3416 for (;;) {
3417 if (!mp->mad_next)
3418 break;
3419 mp = mp->mad_next;
3420 }
3421 mp->mad_next = tm;
3422}
3423
3424void
3425Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3426{
3427 if (!o)
3428 return;
3429 addmad(tm, &(o->op_madprop), slot);
3430}
3431
3432void
3433Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3434{
3435 MADPROP* mp;
3436 if (!tm || !root)
3437 return;
3438 if (slot)
3439 tm->mad_key = slot;
3440 mp = *root;
3441 if (!mp) {
3442 *root = tm;
3443 return;
3444 }
3445 for (;;) {
3446 if (!mp->mad_next)
3447 break;
3448 mp = mp->mad_next;
3449 }
3450 mp->mad_next = tm;
3451}
3452
3453MADPROP *
3454Perl_newMADsv(pTHX_ char key, SV* sv)
3455{
7918f24d
NC		 3456 PERL_ARGS_ASSERT_NEWMADSV;
3457
eb8433b7
NC		 3458 return newMADPROP(key, MAD_SV, sv, 0);
3459}
3460
3461MADPROP *
d503a9ba 3462Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3463{
c111d5f1 3464 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3465 mp->mad_next = 0;
3466 mp->mad_key = key;
3467 mp->mad_vlen = vlen;
3468 mp->mad_type = type;
3469 mp->mad_val = val;
3470/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3471 return mp;
3472}
3473
3474void
3475Perl_mad_free(pTHX_ MADPROP* mp)
3476{
3477/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3478 if (!mp)
3479 return;
3480 if (mp->mad_next)
3481 mad_free(mp->mad_next);
bc177e6b 3482/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3483 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3484 switch (mp->mad_type) {
3485 case MAD_NULL:
3486 break;
3487 case MAD_PV:
3488 Safefree((char*)mp->mad_val);
3489 break;
3490 case MAD_OP:
3491 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3492 op_free((OP*)mp->mad_val);
3493 break;
3494 case MAD_SV:
ad64d0ec 3495 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3496 break;
3497 default:
3498 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3499 break;
3500 }
c111d5f1 3501 PerlMemShared_free(mp);
eb8433b7
NC		 3502}
3503
3504#endif
3505
d67eb5f4
Z		 3506/*
3507=head1 Optree construction
3508
3509=for apidoc Am|OP *|newNULLLIST
3510
3511Constructs, checks, and returns a new C<stub> op, which represents an
3512empty list expression.
3513
3514=cut
3515*/
3516
79072805 3517OP *
864dbfa3 3518Perl_newNULLLIST(pTHX)
79072805 3519{
8990e307
LW		 3520 return newOP(OP_STUB, 0);
3521}
3522
1f676739 3523static OP *
b7783a12 3524S_force_list(pTHX_ OP *o)
8990e307 3525{
11343788 3526 if (!o || o->op_type != OP_LIST)
5f66b61c 3527 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3528 op_null(o);
11343788 3529 return o;
79072805
LW		 3530}
3531
d67eb5f4
Z		 3532/*
3533=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3534
3535Constructs, checks, and returns an op of any list type. I<type> is
3536the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3537C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3538supply up to two ops to be direct children of the list op; they are
3539consumed by this function and become part of the constructed op tree.
3540
3541=cut
3542*/
3543
79072805 3544OP *
864dbfa3 3545Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3546{
27da23d5 3547 dVAR;
79072805
LW		 3548 LISTOP *listop;
3549
e69777c1
GG		 3550 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3551
b7dc083c 3552 NewOp(1101, listop, 1, LISTOP);
79072805 3553
eb160463 3554 listop->op_type = (OPCODE)type;
22c35a8c 3555 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3556 if (first || last)
3557 flags |= OPf_KIDS;
eb160463 3558 listop->op_flags = (U8)flags;
79072805
LW		 3559
3560 if (!last && first)
3561 last = first;
3562 else if (!first && last)
3563 first = last;
8990e307
LW		 3564 else if (first)
3565 first->op_sibling = last;
79072805
LW		 3566 listop->op_first = first;
3567 listop->op_last = last;
8990e307 3568 if (type == OP_LIST) {
551405c4 3569 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3570 pushop->op_sibling = first;
3571 listop->op_first = pushop;
3572 listop->op_flags |= OPf_KIDS;
3573 if (!last)
3574 listop->op_last = pushop;
3575 }
79072805 3576
463d09e6 3577 return CHECKOP(type, listop);
79072805
LW		 3578}
3579
d67eb5f4
Z		 3580/*
3581=for apidoc Am|OP *|newOP|I32 type|I32 flags
3582
3583Constructs, checks, and returns an op of any base type (any type that
3584has no extra fields). I<type> is the opcode. I<flags> gives the
3585eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3586of C<op_private>.
3587
3588=cut
3589*/
3590
79072805 3591OP *
864dbfa3 3592Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3593{
27da23d5 3594 dVAR;
11343788 3595 OP *o;
e69777c1 3596
7d789282
FC		 3597 if (type == -OP_ENTEREVAL) {
3598 type = OP_ENTEREVAL;
3599 flags |= OPpEVAL_BYTES<<8;
3600 }
3601
e69777c1
GG		 3602 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3603 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3604 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3605 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3606
b7dc083c 3607 NewOp(1101, o, 1, OP);
eb160463 3608 o->op_type = (OPCODE)type;
22c35a8c 3609 o->op_ppaddr = PL_ppaddr[type];
eb160463 3610 o->op_flags = (U8)flags;
670f3923
DM		 3611 o->op_latefree = 0;
3612 o->op_latefreed = 0;
7e5d8ed2 3613 o->op_attached = 0;
79072805 3614
11343788 3615 o->op_next = o;
eb160463 3616 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3617 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3618 scalar(o);
22c35a8c 3619 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3620 o->op_targ = pad_alloc(type, SVs_PADTMP);
3621 return CHECKOP(type, o);
79072805
LW		 3622}
3623
d67eb5f4
Z		 3624/*
3625=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3626
3627Constructs, checks, and returns an op of any unary type. I<type> is
3628the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3629C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3630bits, the eight bits of C<op_private>, except that the bit with value 1
3631is automatically set. I<first> supplies an optional op to be the direct
3632child of the unary op; it is consumed by this function and become part
3633of the constructed op tree.
3634
3635=cut
3636*/
3637
79072805 3638OP *
864dbfa3 3639Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3640{
27da23d5 3641 dVAR;
79072805
LW		 3642 UNOP *unop;
3643
7d789282
FC		 3644 if (type == -OP_ENTEREVAL) {
3645 type = OP_ENTEREVAL;
3646 flags |= OPpEVAL_BYTES<<8;
3647 }
3648
e69777c1
GG		 3649 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3650 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3651 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3652 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3653 || type == OP_SASSIGN
32e2a35d 3654 || type == OP_ENTERTRY
e69777c1
GG		 3655 || type == OP_NULL );
3656
93a17b20 3657 if (!first)
aeea060c 3658 first = newOP(OP_STUB, 0);
22c35a8c 3659 if (PL_opargs[type] & OA_MARK)
8990e307 3660 first = force_list(first);
93a17b20 3661
b7dc083c 3662 NewOp(1101, unop, 1, UNOP);
eb160463 3663 unop->op_type = (OPCODE)type;