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