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