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