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
Add OPpCOREARGS_PUSHMARK flag
[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;
8990e307 990 SV* sv;
2ebea0a1
GS		 991 U8 want;
992
7918f24d
NC		 993 PERL_ARGS_ASSERT_SCALARVOID;
994
eb8433b7
NC		 995 /* trailing mad null ops don't count as "there" for void processing */
996 if (PL_madskills &&
997 o->op_type != OP_NULL &&
998 o->op_sibling &&
999 o->op_sibling->op_type == OP_NULL)
1000 {
1001 OP *sib;
1002 for (sib = o->op_sibling;
1003 sib && sib->op_type == OP_NULL;
1004 sib = sib->op_sibling) ;
1005
1006 if (!sib)
1007 return o;
1008 }
1009
acb36ea4 1010 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS		 1011 || o->op_type == OP_DBSTATE
1012 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1013 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1014 PL_curcop = (COP*)o; /* for warning below */
79072805 1015
54310121 1016 /* assumes no premature commitment */
2ebea0a1 1017 want = o->op_flags & OPf_WANT;
13765c85
DM		 1018 if ((want && want != OPf_WANT_SCALAR)
1019 || (PL_parser && PL_parser->error_count)
25b991bf 1020 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1021 {
11343788 1022 return o;
7e363e51 1023 }
79072805 1024
b162f9ea 1025 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1026 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1027 {
b162f9ea 1028 return scalar(o); /* As if inside SASSIGN */
7e363e51 1029 }
1c846c1f 1030
5dc0d613 1031 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1032
11343788 1033 switch (o->op_type) {
79072805 1034 default:
22c35a8c 1035 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1036 break;
36477c24 1037 /* FALL THROUGH */
1038 case OP_REPEAT:
11343788 1039 if (o->op_flags & OPf_STACKED)
8990e307 1040 break;
5d82c453
GA		 1041 goto func_ops;
1042 case OP_SUBSTR:
1043 if (o->op_private == 4)
1044 break;
8990e307
LW		 1045 /* FALL THROUGH */
1046 case OP_GVSV:
1047 case OP_WANTARRAY:
1048 case OP_GV:
74295f0b 1049 case OP_SMARTMATCH:
8990e307
LW		 1050 case OP_PADSV:
1051 case OP_PADAV:
1052 case OP_PADHV:
1053 case OP_PADANY:
1054 case OP_AV2ARYLEN:
8990e307 1055 case OP_REF:
a0d0e21e
LW		 1056 case OP_REFGEN:
1057 case OP_SREFGEN:
8990e307
LW		 1058 case OP_DEFINED:
1059 case OP_HEX:
1060 case OP_OCT:
1061 case OP_LENGTH:
8990e307
LW		 1062 case OP_VEC:
1063 case OP_INDEX:
1064 case OP_RINDEX:
1065 case OP_SPRINTF:
1066 case OP_AELEM:
1067 case OP_AELEMFAST:
93bad3fd 1068 case OP_AELEMFAST_LEX:
8990e307 1069 case OP_ASLICE:
8990e307
LW		 1070 case OP_HELEM:
1071 case OP_HSLICE:
1072 case OP_UNPACK:
1073 case OP_PACK:
8990e307
LW		 1074 case OP_JOIN:
1075 case OP_LSLICE:
1076 case OP_ANONLIST:
1077 case OP_ANONHASH:
1078 case OP_SORT:
1079 case OP_REVERSE:
1080 case OP_RANGE:
1081 case OP_FLIP:
1082 case OP_FLOP:
1083 case OP_CALLER:
1084 case OP_FILENO:
1085 case OP_EOF:
1086 case OP_TELL:
1087 case OP_GETSOCKNAME:
1088 case OP_GETPEERNAME:
1089 case OP_READLINK:
1090 case OP_TELLDIR:
1091 case OP_GETPPID:
1092 case OP_GETPGRP:
1093 case OP_GETPRIORITY:
1094 case OP_TIME:
1095 case OP_TMS:
1096 case OP_LOCALTIME:
1097 case OP_GMTIME:
1098 case OP_GHBYNAME:
1099 case OP_GHBYADDR:
1100 case OP_GHOSTENT:
1101 case OP_GNBYNAME:
1102 case OP_GNBYADDR:
1103 case OP_GNETENT:
1104 case OP_GPBYNAME:
1105 case OP_GPBYNUMBER:
1106 case OP_GPROTOENT:
1107 case OP_GSBYNAME:
1108 case OP_GSBYPORT:
1109 case OP_GSERVENT:
1110 case OP_GPWNAM:
1111 case OP_GPWUID:
1112 case OP_GGRNAM:
1113 case OP_GGRGID:
1114 case OP_GETLOGIN:
78e1b766 1115 case OP_PROTOTYPE:
5d82c453 1116 func_ops:
64aac5a9 1117 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1118 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1119 useless = OP_DESC(o);
75068674
RGS		 1120 break;
1121
1122 case OP_SPLIT:
1123 kid = cLISTOPo->op_first;
1124 if (kid && kid->op_type == OP_PUSHRE
1125#ifdef USE_ITHREADS
1126 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1127#else
1128 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1129#endif
1130 useless = OP_DESC(o);
8990e307
LW		 1131 break;
1132
9f82cd5f
YST		 1133 case OP_NOT:
1134 kid = cUNOPo->op_first;
1135 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1136 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST		 1137 goto func_ops;
1138 }
1139 useless = "negative pattern binding (!~)";
1140 break;
1141
4f4d7508
DC		 1142 case OP_SUBST:
1143 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1144 useless = "non-destructive substitution (s///r)";
4f4d7508
DC		 1145 break;
1146
bb16bae8
FC		 1147 case OP_TRANSR:
1148 useless = "non-destructive transliteration (tr///r)";
1149 break;
1150
8990e307
LW		 1151 case OP_RV2GV:
1152 case OP_RV2SV:
1153 case OP_RV2AV:
1154 case OP_RV2HV:
192587c2 1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW		 1157 useless = "a variable";
1158 break;
79072805
LW		 1159
1160 case OP_CONST:
7766f137 1161 sv = cSVOPo_sv;
7a52d87a
GS		 1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1164 else {
d008e5eb 1165 if (ckWARN(WARN_VOID)) {
fa01e093
RGS		 1166 if (SvOK(sv)) {
1167 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1168 "a constant (%"SVf")", sv));
1169 useless = SvPV_nolen(msv);
1170 }
1171 else
1172 useless = "a constant (undef)";
2e0ae2d3 1173 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 1174 useless = NULL;
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
NC		 1320 if (useless)
1321 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1322 return o;
79072805
LW		 1323}
1324
1f676739 1325static OP *
412da003 1326S_listkids(pTHX_ OP *o)
79072805 1327{
11343788 1328 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1329 OP *kid;
11343788 1330 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW		 1331 list(kid);
1332 }
11343788 1333 return o;
79072805
LW		 1334}
1335
1336OP *
864dbfa3 1337Perl_list(pTHX_ OP *o)
79072805 1338{
27da23d5 1339 dVAR;
79072805
LW		 1340 OP *kid;
1341
a0d0e21e 1342 /* assumes no premature commitment */
13765c85
DM		 1343 if (!o || (o->op_flags & OPf_WANT)
1344 || (PL_parser && PL_parser->error_count)
5dc0d613 1345 || o->op_type == OP_RETURN)
7e363e51 1346 {
11343788 1347 return o;
7e363e51 1348 }
79072805 1349
b162f9ea 1350 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1351 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1352 {
b162f9ea 1353 return o; /* As if inside SASSIGN */
7e363e51 1354 }
1c846c1f 1355
5dc0d613 1356 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1357
11343788 1358 switch (o->op_type) {
79072805
LW		 1359 case OP_FLOP:
1360 case OP_REPEAT:
11343788 1361 list(cBINOPo->op_first);
79072805
LW		 1362 break;
1363 case OP_OR:
1364 case OP_AND:
1365 case OP_COND_EXPR:
11343788 1366 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW		 1367 list(kid);
1368 break;
1369 default:
1370 case OP_MATCH:
8782bef2 1371 case OP_QR:
79072805
LW		 1372 case OP_SUBST:
1373 case OP_NULL:
11343788 1374 if (!(o->op_flags & OPf_KIDS))
79072805 1375 break;
11343788
MB		 1376 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1377 list(cBINOPo->op_first);
1378 return gen_constant_list(o);
79072805
LW		 1379 }
1380 case OP_LIST:
11343788 1381 listkids(o);
79072805
LW		 1382 break;
1383 case OP_LEAVE:
1384 case OP_LEAVETRY:
5dc0d613 1385 kid = cLISTOPo->op_first;
54310121 1386 list(kid);
25b991bf
VP		 1387 kid = kid->op_sibling;
1388 do_kids:
1389 while (kid) {
1390 OP *sib = kid->op_sibling;
c08f093b
VP		 1391 if (sib && kid->op_type != OP_LEAVEWHEN)
1392 scalarvoid(kid);
1393 else
54310121 1394 list(kid);
25b991bf 1395 kid = sib;
54310121 1396 }
11206fdd 1397 PL_curcop = &PL_compiling;
54310121 1398 break;
748a9306 1399 case OP_SCOPE:
79072805 1400 case OP_LINESEQ:
25b991bf
VP		 1401 kid = cLISTOPo->op_first;
1402 goto do_kids;
79072805 1403 }
11343788 1404 return o;
79072805
LW		 1405}
1406
1f676739 1407static OP *
2dd5337b 1408S_scalarseq(pTHX_ OP *o)
79072805 1409{
97aff369 1410 dVAR;
11343788 1411 if (o) {
1496a290
AL		 1412 const OPCODE type = o->op_type;
1413
1414 if (type == OP_LINESEQ || type == OP_SCOPE ||
1415 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1416 {
6867be6d 1417 OP *kid;
11343788 1418 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1419 if (kid->op_sibling) {
463ee0b2 1420 scalarvoid(kid);
ed6116ce 1421 }
463ee0b2 1422 }
3280af22 1423 PL_curcop = &PL_compiling;
79072805 1424 }
11343788 1425 o->op_flags &= ~OPf_PARENS;
3280af22 1426 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1427 o->op_flags |= OPf_PARENS;
79072805 1428 }
8990e307 1429 else
11343788
MB		 1430 o = newOP(OP_STUB, 0);
1431 return o;
79072805
LW		 1432}
1433
76e3520e 1434STATIC OP *
cea2e8a9 1435S_modkids(pTHX_ OP *o, I32 type)
79072805 1436{
11343788 1437 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1438 OP *kid;
11343788 1439 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1440 op_lvalue(kid, type);
79072805 1441 }
11343788 1442 return o;
79072805
LW		 1443}
1444
3ad73efd 1445/*
d164302a
GG		 1446=for apidoc finalize_optree
1447
1448This function finalizes the optree. Should be called directly after
1449the complete optree is built. It does some additional
1450checking which can't be done in the normal ck_xxx functions and makes
1451the tree thread-safe.
1452
1453=cut
1454*/
1455void
1456Perl_finalize_optree(pTHX_ OP* o)
1457{
1458 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1459
1460 ENTER;
1461 SAVEVPTR(PL_curcop);
1462
1463 finalize_op(o);
1464
1465 LEAVE;
1466}
1467
1468void
1469S_finalize_op(pTHX_ OP* o)
1470{
1471 PERL_ARGS_ASSERT_FINALIZE_OP;
1472
1473#if defined(PERL_MAD) && defined(USE_ITHREADS)
1474 {
1475 /* Make sure mad ops are also thread-safe */
1476 MADPROP *mp = o->op_madprop;
1477 while (mp) {
1478 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1479 OP *prop_op = (OP *) mp->mad_val;
1480 /* We only need "Relocate sv to the pad for thread safety.", but this
1481 easiest way to make sure it traverses everything */
4dc304e0
FC		 1482 if (prop_op->op_type == OP_CONST)
1483 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG		 1484 finalize_op(prop_op);
1485 }
1486 mp = mp->mad_next;
1487 }
1488 }
1489#endif
1490
1491 switch (o->op_type) {
1492 case OP_NEXTSTATE:
1493 case OP_DBSTATE:
1494 PL_curcop = ((COP*)o); /* for warnings */
1495 break;
1496 case OP_EXEC:
ea31ed66
GG		 1497 if ( o->op_sibling
1498 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG		 1499 && ckWARN(WARN_SYNTAX))
1500 {
ea31ed66
GG		 1501 if (o->op_sibling->op_sibling) {
1502 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG		 1503 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1504 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1505 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG		 1506 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1507 "Statement unlikely to be reached");
1508 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1509 "\t(Maybe you meant system() when you said exec()?)\n");
1510 CopLINE_set(PL_curcop, oldline);
1511 }
1512 }
1513 }
1514 break;
1515
1516 case OP_GV:
1517 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1518 GV * const gv = cGVOPo_gv;
1519 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1520 /* XXX could check prototype here instead of just carping */
1521 SV * const sv = sv_newmortal();
1522 gv_efullname3(sv, gv, NULL);
1523 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1524 "%"SVf"() called too early to check prototype",
1525 SVfARG(sv));
1526 }
1527 }
1528 break;
1529
1530 case OP_CONST:
eb796c7f
GG		 1531 if (cSVOPo->op_private & OPpCONST_STRICT)
1532 no_bareword_allowed(o);
1533 /* FALLTHROUGH */
d164302a
GG		 1534#ifdef USE_ITHREADS
1535 case OP_HINTSEVAL:
1536 case OP_METHOD_NAMED:
1537 /* Relocate sv to the pad for thread safety.
1538 * Despite being a "constant", the SV is written to,
1539 * for reference counts, sv_upgrade() etc. */
1540 if (cSVOPo->op_sv) {
1541 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1542 if (o->op_type != OP_METHOD_NAMED &&
1543 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1544 {
1545 /* If op_sv is already a PADTMP/MY then it is being used by
1546 * some pad, so make a copy. */
1547 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1548 SvREADONLY_on(PAD_SVl(ix));
1549 SvREFCNT_dec(cSVOPo->op_sv);
1550 }
1551 else if (o->op_type != OP_METHOD_NAMED
1552 && cSVOPo->op_sv == &PL_sv_undef) {
1553 /* PL_sv_undef is hack - it's unsafe to store it in the
1554 AV that is the pad, because av_fetch treats values of
1555 PL_sv_undef as a "free" AV entry and will merrily
1556 replace them with a new SV, causing pad_alloc to think
1557 that this pad slot is free. (When, clearly, it is not)
1558 */
1559 SvOK_off(PAD_SVl(ix));
1560 SvPADTMP_on(PAD_SVl(ix));
1561 SvREADONLY_on(PAD_SVl(ix));
1562 }
1563 else {
1564 SvREFCNT_dec(PAD_SVl(ix));
1565 SvPADTMP_on(cSVOPo->op_sv);
1566 PAD_SETSV(ix, cSVOPo->op_sv);
1567 /* XXX I don't know how this isn't readonly already. */
1568 SvREADONLY_on(PAD_SVl(ix));
1569 }
1570 cSVOPo->op_sv = NULL;
1571 o->op_targ = ix;
1572 }
1573#endif
1574 break;
1575
1576 case OP_HELEM: {
1577 UNOP *rop;
1578 SV *lexname;
1579 GV **fields;
1580 SV **svp, *sv;
1581 const char *key = NULL;
1582 STRLEN keylen;
1583
1584 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1585 break;
1586
1587 /* Make the CONST have a shared SV */
1588 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1589 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1590 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1591 key = SvPV_const(sv, keylen);
1592 lexname = newSVpvn_share(key,
1593 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1594 0);
1595 SvREFCNT_dec(sv);
1596 *svp = lexname;
1597 }
1598
1599 if ((o->op_private & (OPpLVAL_INTRO)))
1600 break;
1601
1602 rop = (UNOP*)((BINOP*)o)->op_first;
1603 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1604 break;
1605 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1606 if (!SvPAD_TYPED(lexname))
1607 break;
1608 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1609 if (!fields || !GvHV(*fields))
1610 break;
1611 key = SvPV_const(*svp, keylen);
1612 if (!hv_fetch(GvHV(*fields), key,
1613 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1614 Perl_croak(aTHX_ "No such class field \"%s\" "
1615 "in variable %s of type %s",
1616 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1617 }
1618 break;
1619 }
1620
1621 case OP_HSLICE: {
1622 UNOP *rop;
1623 SV *lexname;
1624 GV **fields;
1625 SV **svp;
1626 const char *key;
1627 STRLEN keylen;
1628 SVOP *first_key_op, *key_op;
1629
1630 if ((o->op_private & (OPpLVAL_INTRO))
1631 /* I bet there's always a pushmark... */
1632 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1633 /* hmmm, no optimization if list contains only one key. */
1634 break;
1635 rop = (UNOP*)((LISTOP*)o)->op_last;
1636 if (rop->op_type != OP_RV2HV)
1637 break;
1638 if (rop->op_first->op_type == OP_PADSV)
1639 /* @$hash{qw(keys here)} */
1640 rop = (UNOP*)rop->op_first;
1641 else {
1642 /* @{$hash}{qw(keys here)} */
1643 if (rop->op_first->op_type == OP_SCOPE
1644 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1645 {
1646 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1647 }
1648 else
1649 break;
1650 }
1651
1652 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1653 if (!SvPAD_TYPED(lexname))
1654 break;
1655 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1656 if (!fields || !GvHV(*fields))
1657 break;
1658 /* Again guessing that the pushmark can be jumped over.... */
1659 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1660 ->op_first->op_sibling;
1661 for (key_op = first_key_op; key_op;
1662 key_op = (SVOP*)key_op->op_sibling) {
1663 if (key_op->op_type != OP_CONST)
1664 continue;
1665 svp = cSVOPx_svp(key_op);
1666 key = SvPV_const(*svp, keylen);
1667 if (!hv_fetch(GvHV(*fields), key,
1668 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1669 Perl_croak(aTHX_ "No such class field \"%s\" "
1670 "in variable %s of type %s",
1671 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1672 }
1673 }
1674 break;
1675 }
1676 case OP_SUBST: {
1677 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1678 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1679 break;
1680 }
1681 default:
1682 break;
1683 }
1684
1685 if (o->op_flags & OPf_KIDS) {
1686 OP *kid;
1687 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1688 finalize_op(kid);
1689 }
1690}
1691
1692/*
3ad73efd
Z		 1693=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1694
1695Propagate lvalue ("modifiable") context to an op and its children.
1696I<type> represents the context type, roughly based on the type of op that
1697would do the modifying, although C<local()> is represented by OP_NULL,
1698because it has no op type of its own (it is signalled by a flag on
001c3c51
FC		 1699the lvalue op).
1700
1701This function detects things that can't be modified, such as C<$x+1>, and
1702generates errors for them. For example, C<$x+1 = 2> would cause it to be
1703called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1704
1705It also flags things that need to behave specially in an lvalue context,
1706such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z		 1707
1708=cut
1709*/
ddeae0f1 1710
79072805 1711OP *
d3d7d28f 1712Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1713{
27da23d5 1714 dVAR;
79072805 1715 OP *kid;
ddeae0f1
DM		 1716 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1717 int localize = -1;
79072805 1718
13765c85 1719 if (!o || (PL_parser && PL_parser->error_count))
11343788 1720 return o;
79072805 1721
b162f9ea 1722 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS		 1723 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1724 {
b162f9ea 1725 return o;
7e363e51 1726 }
1c846c1f 1727
5c906035
GG		 1728 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1729
11343788 1730 switch (o->op_type) {
68dc0745 1731 case OP_UNDEF:
ddeae0f1 1732 localize = 0;
3280af22 1733 PL_modcount++;
5dc0d613 1734 return o;
a0d0e21e 1735 case OP_CONST:
2e0ae2d3 1736 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1737 goto nomod;
54dc0f91 1738 localize = 0;
3280af22 1739 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC		 1740 CopARYBASE_set(&PL_compiling,
1741 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1742 PL_eval_start = 0;
a0d0e21e
LW		 1743 }
1744 else if (!type) {
fc15ae8f
NC		 1745 SAVECOPARYBASE(&PL_compiling);
1746 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW		 1747 }
1748 else if (type == OP_REFGEN)
1749 goto nomod;
1750 else
cea2e8a9 1751 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1752 break;
5f05dabc 1753 case OP_STUB:
58bde88d 1754 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1755 break;
1756 goto nomod;
a0d0e21e 1757 case OP_ENTERSUB:
f79aa60b 1758 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB		 1759 !(o->op_flags & OPf_STACKED)) {
1760 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC		 1761 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1762 poses, so we need it clear. */
e26df76a 1763 o->op_private &= ~1;
22c35a8c 1764 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1765 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1766 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW		 1767 break;
1768 }
cd06dffe 1769 else { /* lvalue subroutine call */
777d9014
FC		 1770 o->op_private |= OPpLVAL_INTRO
1771 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1772 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1773 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS		 1774 /* Backward compatibility mode: */
1775 o->op_private |= OPpENTERSUB_INARGS;
1776 break;
1777 }
1778 else { /* Compile-time error message: */
1779 OP *kid = cUNOPo->op_first;
1780 CV *cv;
1781 OP *okid;
1782
3ea285d1
AL		 1783 if (kid->op_type != OP_PUSHMARK) {
1784 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1785 Perl_croak(aTHX_
1786 "panic: unexpected lvalue entersub "
1787 "args: type/targ %ld:%"UVuf,
1788 (long)kid->op_type, (UV)kid->op_targ);
1789 kid = kLISTOP->op_first;
1790 }
cd06dffe
GS		 1791 while (kid->op_sibling)
1792 kid = kid->op_sibling;
1793 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1794 /* Indirect call */
1795 if (kid->op_type == OP_METHOD_NAMED
1796 || kid->op_type == OP_METHOD)
1797 {
87d7fd28 1798 UNOP *newop;
b2ffa427 1799
87d7fd28 1800 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS		 1801 newop->op_type = OP_RV2CV;
1802 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1803 newop->op_first = NULL;
87d7fd28
GS		 1804 newop->op_next = (OP*)newop;
1805 kid->op_sibling = (OP*)newop;
349fd7b7 1806 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1807 newop->op_private &= ~1;
cd06dffe
GS		 1808 break;
1809 }
b2ffa427 1810
cd06dffe
GS		 1811 if (kid->op_type != OP_RV2CV)
1812 Perl_croak(aTHX_
1813 "panic: unexpected lvalue entersub "
55140b79 1814 "entry via type/targ %ld:%"UVuf,
3d811634 1815 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1816 kid->op_private |= OPpLVAL_INTRO;
1817 break; /* Postpone until runtime */
1818 }
b2ffa427
NIS		 1819
1820 okid = kid;
cd06dffe
GS		 1821 kid = kUNOP->op_first;
1822 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1823 kid = kUNOP->op_first;
b2ffa427 1824 if (kid->op_type == OP_NULL)
cd06dffe
GS		 1825 Perl_croak(aTHX_
1826 "Unexpected constant lvalue entersub "
55140b79 1827 "entry via type/targ %ld:%"UVuf,
3d811634 1828 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS		 1829 if (kid->op_type != OP_GV) {
1830 /* Restore RV2CV to check lvalueness */
1831 restore_2cv:
1832 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1833 okid->op_next = kid->op_next;
1834 kid->op_next = okid;
1835 }
1836 else
5f66b61c 1837 okid->op_next = NULL;
cd06dffe
GS		 1838 okid->op_type = OP_RV2CV;
1839 okid->op_targ = 0;
1840 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1841 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1842 okid->op_private &= ~1;
cd06dffe
GS		 1843 break;
1844 }
b2ffa427 1845
638eceb6 1846 cv = GvCV(kGVOP_gv);
1c846c1f 1847 if (!cv)
cd06dffe
GS		 1848 goto restore_2cv;
1849 if (CvLVALUE(cv))
1850 break;
1851 }
1852 }
79072805
LW		 1853 /* FALL THROUGH */
1854 default:
a0d0e21e 1855 nomod:
f5d552b4 1856 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 1857 /* grep, foreach, subcalls, refgen */
145b2bbb
FC		 1858 if (type == OP_GREPSTART || type == OP_ENTERSUB
1859 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 1860 break;
cea2e8a9 1861 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1862 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS		 1863 ? "do block"
1864 : (o->op_type == OP_ENTERSUB
1865 ? "non-lvalue subroutine call"
53e06cf0 1866 : OP_DESC(o))),
22c35a8c 1867 type ? PL_op_desc[type] : "local"));
11343788 1868 return o;
79072805 1869
a0d0e21e
LW		 1870 case OP_PREINC:
1871 case OP_PREDEC:
1872 case OP_POW:
1873 case OP_MULTIPLY:
1874 case OP_DIVIDE:
1875 case OP_MODULO:
1876 case OP_REPEAT:
1877 case OP_ADD:
1878 case OP_SUBTRACT:
1879 case OP_CONCAT:
1880 case OP_LEFT_SHIFT:
1881 case OP_RIGHT_SHIFT:
1882 case OP_BIT_AND:
1883 case OP_BIT_XOR:
1884 case OP_BIT_OR:
1885 case OP_I_MULTIPLY:
1886 case OP_I_DIVIDE:
1887 case OP_I_MODULO:
1888 case OP_I_ADD:
1889 case OP_I_SUBTRACT:
11343788 1890 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1891 goto nomod;
3280af22 1892 PL_modcount++;
a0d0e21e 1893 break;
b2ffa427 1894
79072805 1895 case OP_COND_EXPR:
ddeae0f1 1896 localize = 1;
11343788 1897 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 1898 op_lvalue(kid, type);
79072805
LW		 1899 break;
1900
1901 case OP_RV2AV:
1902 case OP_RV2HV:
11343788 1903 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1904 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1905 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW		 1906 }
1907 /* FALL THROUGH */
79072805 1908 case OP_RV2GV:
5dc0d613 1909 if (scalar_mod_type(o, type))
3fe9a6f1 1910 goto nomod;
11343788 1911 ref(cUNOPo->op_first, o->op_type);
79072805 1912 /* FALL THROUGH */
79072805
LW		 1913 case OP_ASLICE:
1914 case OP_HSLICE:
78f9721b
SM		 1915 if (type == OP_LEAVESUBLV)
1916 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1917 localize = 1;
78f9721b
SM		 1918 /* FALL THROUGH */
1919 case OP_AASSIGN:
93a17b20
LW		 1920 case OP_NEXTSTATE:
1921 case OP_DBSTATE:
e6438c1a 1922 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1923 break;
28c5b5bc
RGS		 1924 case OP_AV2ARYLEN:
1925 PL_hints |= HINT_BLOCK_SCOPE;
1926 if (type == OP_LEAVESUBLV)
1927 o->op_private |= OPpMAYBE_LVSUB;
1928 PL_modcount++;
1929 break;
463ee0b2 1930 case OP_RV2SV:
aeea060c 1931 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1932 localize = 1;
463ee0b2 1933 /* FALL THROUGH */
79072805 1934 case OP_GV:
3280af22 1935 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1936 case OP_SASSIGN:
bf4b1e52
GS		 1937 case OP_ANDASSIGN:
1938 case OP_ORASSIGN:
c963b151 1939 case OP_DORASSIGN:
ddeae0f1
DM		 1940 PL_modcount++;
1941 break;
1942
8990e307 1943 case OP_AELEMFAST:
93bad3fd 1944 case OP_AELEMFAST_LEX:
6a077020 1945 localize = -1;
3280af22 1946 PL_modcount++;
8990e307
LW		 1947 break;
1948
748a9306
LW		 1949 case OP_PADAV:
1950 case OP_PADHV:
e6438c1a 1951 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 1952 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1953 return o; /* Treat \(@foo) like ordinary list. */
1954 if (scalar_mod_type(o, type))
3fe9a6f1 1955 goto nomod;
78f9721b
SM		 1956 if (type == OP_LEAVESUBLV)
1957 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 1958 /* FALL THROUGH */
1959 case OP_PADSV:
3280af22 1960 PL_modcount++;
ddeae0f1 1961 if (!type) /* local() */
5ede95a0
BF		 1962 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1963 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 1964 break;
1965
748a9306 1966 case OP_PUSHMARK:
ddeae0f1 1967 localize = 0;
748a9306 1968 break;
b2ffa427 1969
69969c6f 1970 case OP_KEYS:
d8065907 1971 case OP_RKEYS:
fad4a2e4 1972 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 1973 goto nomod;
5d82c453
GA		 1974 goto lvalue_func;
1975 case OP_SUBSTR:
1976 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1977 goto nomod;
5f05dabc 1978 /* FALL THROUGH */
a0d0e21e 1979 case OP_POS:
463ee0b2 1980 case OP_VEC:
fad4a2e4 1981 lvalue_func:
78f9721b
SM		 1982 if (type == OP_LEAVESUBLV)
1983 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB		 1984 pad_free(o->op_targ);
1985 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1986 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 1987 if (o->op_flags & OPf_KIDS)
3ad73efd 1988 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 1989 break;
a0d0e21e 1990
463ee0b2
LW		 1991 case OP_AELEM:
1992 case OP_HELEM:
11343788 1993 ref(cBINOPo->op_first, o->op_type);
68dc0745 1994 if (type == OP_ENTERSUB &&
5dc0d613
MB		 1995 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1996 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 1997 if (type == OP_LEAVESUBLV)
1998 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1999 localize = 1;
3280af22 2000 PL_modcount++;
463ee0b2
LW		 2001 break;
2002
2003 case OP_SCOPE:
2004 case OP_LEAVE:
2005 case OP_ENTER:
78f9721b 2006 case OP_LINESEQ:
ddeae0f1 2007 localize = 0;
11343788 2008 if (o->op_flags & OPf_KIDS)
3ad73efd 2009 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2010 break;
2011
2012 case OP_NULL:
ddeae0f1 2013 localize = 0;
638bc118
GS		 2014 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2015 goto nomod;
2016 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2017 break;
11343788 2018 if (o->op_targ != OP_LIST) {
3ad73efd 2019 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2020 break;
2021 }
2022 /* FALL THROUGH */
463ee0b2 2023 case OP_LIST:
ddeae0f1 2024 localize = 0;
11343788 2025 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2026 /* elements might be in void context because the list is
2027 in scalar context or because they are attribute sub calls */
2028 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2029 op_lvalue(kid, type);
463ee0b2 2030 break;
78f9721b
SM		 2031
2032 case OP_RETURN:
2033 if (type != OP_LEAVESUBLV)
2034 goto nomod;
3ad73efd 2035 break; /* op_lvalue()ing was handled by ck_return() */
463ee0b2 2036 }
58d95175 2037
8be1be90
AMS		 2038 /* [20011101.069] File test operators interpret OPf_REF to mean that
2039 their argument is a filehandle; thus \stat(".") should not set
2040 it. AMS 20011102 */
2041 if (type == OP_REFGEN &&
ef69c8fc 2042 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2043 return o;
2044
2045 if (type != OP_LEAVESUBLV)
2046 o->op_flags |= OPf_MOD;
2047
2048 if (type == OP_AASSIGN || type == OP_SASSIGN)
2049 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2050 else if (!type) { /* local() */
2051 switch (localize) {
2052 case 1:
2053 o->op_private |= OPpLVAL_INTRO;
2054 o->op_flags &= ~OPf_SPECIAL;
2055 PL_hints |= HINT_BLOCK_SCOPE;
2056 break;
2057 case 0:
2058 break;
2059 case -1:
a2a5de95
NC		 2060 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2061 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2062 }
463ee0b2 2063 }
8be1be90
AMS		 2064 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2065 && type != OP_LEAVESUBLV)
2066 o->op_flags |= OPf_REF;
11343788 2067 return o;
463ee0b2
LW		 2068}
2069
864dbfa3 2070STATIC bool
5f66b61c 2071S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2072{
1ecbeecf 2073 assert(o || type != OP_SASSIGN);
7918f24d 2074
3fe9a6f1 2075 switch (type) {
2076 case OP_SASSIGN:
5196be3e 2077 if (o->op_type == OP_RV2GV)
3fe9a6f1 2078 return FALSE;
2079 /* FALL THROUGH */
2080 case OP_PREINC:
2081 case OP_PREDEC:
2082 case OP_POSTINC:
2083 case OP_POSTDEC:
2084 case OP_I_PREINC:
2085 case OP_I_PREDEC:
2086 case OP_I_POSTINC:
2087 case OP_I_POSTDEC:
2088 case OP_POW:
2089 case OP_MULTIPLY:
2090 case OP_DIVIDE:
2091 case OP_MODULO:
2092 case OP_REPEAT:
2093 case OP_ADD:
2094 case OP_SUBTRACT:
2095 case OP_I_MULTIPLY:
2096 case OP_I_DIVIDE:
2097 case OP_I_MODULO:
2098 case OP_I_ADD:
2099 case OP_I_SUBTRACT:
2100 case OP_LEFT_SHIFT:
2101 case OP_RIGHT_SHIFT:
2102 case OP_BIT_AND:
2103 case OP_BIT_XOR:
2104 case OP_BIT_OR:
2105 case OP_CONCAT:
2106 case OP_SUBST:
2107 case OP_TRANS:
bb16bae8 2108 case OP_TRANSR:
49e9fbe6
GS		 2109 case OP_READ:
2110 case OP_SYSREAD:
2111 case OP_RECV:
bf4b1e52
GS		 2112 case OP_ANDASSIGN:
2113 case OP_ORASSIGN:
410d09fe 2114 case OP_DORASSIGN:
3fe9a6f1 2115 return TRUE;
2116 default:
2117 return FALSE;
2118 }
2119}
2120
35cd451c 2121STATIC bool
5f66b61c 2122S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2123{
7918f24d
NC		 2124 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2125
35cd451c
GS		 2126 switch (o->op_type) {
2127 case OP_PIPE_OP:
2128 case OP_SOCKPAIR:
504618e9 2129 if (numargs == 2)
35cd451c
GS		 2130 return TRUE;
2131 /* FALL THROUGH */
2132 case OP_SYSOPEN:
2133 case OP_OPEN:
ded8aa31 2134 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2135 case OP_SOCKET:
2136 case OP_OPEN_DIR:
2137 case OP_ACCEPT:
504618e9 2138 if (numargs == 1)
35cd451c 2139 return TRUE;
5f66b61c 2140 /* FALLTHROUGH */
35cd451c
GS		 2141 default:
2142 return FALSE;
2143 }
2144}
2145
0d86688d
NC		 2146static OP *
2147S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2148{
11343788 2149 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2150 OP *kid;
11343788 2151 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2152 ref(kid, type);
2153 }
11343788 2154 return o;
463ee0b2
LW		 2155}
2156
2157OP *
e4c5ccf3 2158Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2159{
27da23d5 2160 dVAR;
463ee0b2 2161 OP *kid;
463ee0b2 2162
7918f24d
NC		 2163 PERL_ARGS_ASSERT_DOREF;
2164
13765c85 2165 if (!o || (PL_parser && PL_parser->error_count))
11343788 2166 return o;
463ee0b2 2167
11343788 2168 switch (o->op_type) {
a0d0e21e 2169 case OP_ENTERSUB:
f4df43b5 2170 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2171 !(o->op_flags & OPf_STACKED)) {
2172 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2173 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2174 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2175 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2176 o->op_flags |= OPf_SPECIAL;
e26df76a 2177 o->op_private &= ~1;
8990e307 2178 }
767eda44
FC		 2179 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2180 o->op_private |= OPpENTERSUB_DEREF;
2181 o->op_flags |= OPf_MOD;
2182 }
2183
8990e307 2184 break;
aeea060c 2185
463ee0b2 2186 case OP_COND_EXPR:
11343788 2187 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2188 doref(kid, type, set_op_ref);
463ee0b2 2189 break;
8990e307 2190 case OP_RV2SV:
35cd451c
GS		 2191 if (type == OP_DEFINED)
2192 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2193 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2194 /* FALL THROUGH */
2195 case OP_PADSV:
5f05dabc 2196 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2197 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2198 : type == OP_RV2HV ? OPpDEREF_HV
2199 : OPpDEREF_SV);
11343788 2200 o->op_flags |= OPf_MOD;
a0d0e21e 2201 }
8990e307 2202 break;
1c846c1f 2203
463ee0b2
LW		 2204 case OP_RV2AV:
2205 case OP_RV2HV:
e4c5ccf3
RH		 2206 if (set_op_ref)
2207 o->op_flags |= OPf_REF;
8990e307 2208 /* FALL THROUGH */
463ee0b2 2209 case OP_RV2GV:
35cd451c
GS		 2210 if (type == OP_DEFINED)
2211 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2212 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2213 break;
8990e307 2214
463ee0b2
LW		 2215 case OP_PADAV:
2216 case OP_PADHV:
e4c5ccf3
RH		 2217 if (set_op_ref)
2218 o->op_flags |= OPf_REF;
79072805 2219 break;
aeea060c 2220
8990e307 2221 case OP_SCALAR:
79072805 2222 case OP_NULL:
11343788 2223 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2224 break;
e4c5ccf3 2225 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2226 break;
2227 case OP_AELEM:
2228 case OP_HELEM:
e4c5ccf3 2229 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2230 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2231 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2232 : type == OP_RV2HV ? OPpDEREF_HV
2233 : OPpDEREF_SV);
11343788 2234 o->op_flags |= OPf_MOD;
8990e307 2235 }
79072805
LW		 2236 break;
2237
463ee0b2 2238 case OP_SCOPE:
79072805 2239 case OP_LEAVE:
e4c5ccf3
RH		 2240 set_op_ref = FALSE;
2241 /* FALL THROUGH */
79072805 2242 case OP_ENTER:
8990e307 2243 case OP_LIST:
11343788 2244 if (!(o->op_flags & OPf_KIDS))
79072805 2245 break;
e4c5ccf3 2246 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2247 break;
a0d0e21e
LW		 2248 default:
2249 break;
79072805 2250 }
11343788 2251 return scalar(o);
8990e307 2252
79072805
LW		 2253}
2254
09bef843
SB		 2255STATIC OP *
2256S_dup_attrlist(pTHX_ OP *o)
2257{
97aff369 2258 dVAR;
0bd48802 2259 OP *rop;
09bef843 2260
7918f24d
NC		 2261 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2262
09bef843
SB		 2263 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2264 * where the first kid is OP_PUSHMARK and the remaining ones
2265 * are OP_CONST. We need to push the OP_CONST values.
2266 */
2267 if (o->op_type == OP_CONST)
b37c2d43 2268 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2269#ifdef PERL_MAD
2270 else if (o->op_type == OP_NULL)
1d866c12 2271 rop = NULL;
eb8433b7 2272#endif
09bef843
SB		 2273 else {
2274 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2275 rop = NULL;
09bef843
SB		 2276 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2277 if (o->op_type == OP_CONST)
2fcb4757 2278 rop = op_append_elem(OP_LIST, rop,
09bef843 2279 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2280 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2281 }
2282 }
2283 return rop;
2284}
2285
2286STATIC void
95f0a2f1 2287S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2288{
27da23d5 2289 dVAR;
09bef843
SB		 2290 SV *stashsv;
2291
7918f24d
NC		 2292 PERL_ARGS_ASSERT_APPLY_ATTRS;
2293
09bef843
SB		 2294 /* fake up C<use attributes $pkg,$rv,@attrs> */
2295 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2296 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2297
09bef843 2298#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2299#define ATTRSMODULE_PM "attributes.pm"
2300
2301 if (for_my) {
95f0a2f1 2302 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2303 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2304 if (svp && *svp != &PL_sv_undef)
6f207bd3 2305 NOOP; /* already in %INC */
95f0a2f1
SB		 2306 else
2307 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2308 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 2309 }
2310 else {
2311 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2312 newSVpvs(ATTRSMODULE),
2313 NULL,
2fcb4757 2314 op_prepend_elem(OP_LIST,
95f0a2f1 2315 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2316 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2317 newSVOP(OP_CONST, 0,
2318 newRV(target)),
2319 dup_attrlist(attrs))));
2320 }
09bef843
SB		 2321 LEAVE;
2322}
2323
95f0a2f1
SB		 2324STATIC void
2325S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2326{
97aff369 2327 dVAR;
95f0a2f1
SB		 2328 OP *pack, *imop, *arg;
2329 SV *meth, *stashsv;
2330
7918f24d
NC		 2331 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2332
95f0a2f1
SB		 2333 if (!attrs)
2334 return;
2335
2336 assert(target->op_type == OP_PADSV ||
2337 target->op_type == OP_PADHV ||
2338 target->op_type == OP_PADAV);
2339
2340 /* Ensure that attributes.pm is loaded. */
dd2155a4 2341 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 2342
2343 /* Need package name for method call. */
6136c704 2344 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2345
2346 /* Build up the real arg-list. */
5aaec2b4
NC		 2347 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2348
95f0a2f1
SB		 2349 arg = newOP(OP_PADSV, 0);
2350 arg->op_targ = target->op_targ;
2fcb4757 2351 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2352 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2353 op_prepend_elem(OP_LIST,
95f0a2f1 2354 newUNOP(OP_REFGEN, 0,
3ad73efd 2355 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2356 dup_attrlist(attrs)));
2357
2358 /* Fake up a method call to import */
18916d0d 2359 meth = newSVpvs_share("import");
95f0a2f1 2360 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2361 op_append_elem(OP_LIST,
2362 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2363 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2364
2365 /* Combine the ops. */
2fcb4757 2366 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2367}
2368
2369/*
2370=notfor apidoc apply_attrs_string
2371
2372Attempts to apply a list of attributes specified by the C<attrstr> and
2373C<len> arguments to the subroutine identified by the C<cv> argument which
2374is expected to be associated with the package identified by the C<stashpv>
2375argument (see L<attributes>). It gets this wrong, though, in that it
2376does not correctly identify the boundaries of the individual attribute
2377specifications within C<attrstr>. This is not really intended for the
2378public API, but has to be listed here for systems such as AIX which
2379need an explicit export list for symbols. (It's called from XS code
2380in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2381to respect attribute syntax properly would be welcome.
2382
2383=cut
2384*/
2385
be3174d2 2386void
6867be6d
AL		 2387Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2388 const char *attrstr, STRLEN len)
be3174d2 2389{
5f66b61c 2390 OP *attrs = NULL;
be3174d2 2391
7918f24d
NC		 2392 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2393
be3174d2
GS		 2394 if (!len) {
2395 len = strlen(attrstr);
2396 }
2397
2398 while (len) {
2399 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2400 if (len) {
890ce7af 2401 const char * const sstr = attrstr;
be3174d2 2402 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2403 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2404 newSVOP(OP_CONST, 0,
2405 newSVpvn(sstr, attrstr-sstr)));
2406 }
2407 }
2408
2409 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2410 newSVpvs(ATTRSMODULE),
2fcb4757 2411 NULL, op_prepend_elem(OP_LIST,
be3174d2 2412 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2413 op_prepend_elem(OP_LIST,
be3174d2 2414 newSVOP(OP_CONST, 0,
ad64d0ec 2415 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2416 attrs)));
2417}
2418
09bef843 2419STATIC OP *
95f0a2f1 2420S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2421{
97aff369 2422 dVAR;
93a17b20 2423 I32 type;
a1fba7eb 2424 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2425
7918f24d
NC		 2426 PERL_ARGS_ASSERT_MY_KID;
2427
13765c85 2428 if (!o || (PL_parser && PL_parser->error_count))
11343788 2429 return o;
93a17b20 2430
bc61e325 2431 type = o->op_type;
eb8433b7
NC		 2432 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2433 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2434 return o;
2435 }
2436
93a17b20 2437 if (type == OP_LIST) {
6867be6d 2438 OP *kid;
11343788 2439 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2440 my_kid(kid, attrs, imopsp);
eb8433b7
NC		 2441 } else if (type == OP_UNDEF
2442#ifdef PERL_MAD
2443 || type == OP_STUB
2444#endif
2445 ) {
7766148a 2446 return o;
77ca0c92
LW		 2447 } else if (type == OP_RV2SV || /* "our" declaration */
2448 type == OP_RV2AV ||
2449 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2450 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2451 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2452 OP_DESC(o),
12bd6ede
DM		 2453 PL_parser->in_my == KEY_our
2454 ? "our"
2455 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2456 } else if (attrs) {
551405c4 2457 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2458 PL_parser->in_my = FALSE;
2459 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2460 apply_attrs(GvSTASH(gv),
2461 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2462 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2463 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS		 2464 attrs, FALSE);
2465 }
192587c2 2466 o->op_private |= OPpOUR_INTRO;
77ca0c92 2467 return o;
95f0a2f1
SB		 2468 }
2469 else if (type != OP_PADSV &&
93a17b20
LW		 2470 type != OP_PADAV &&
2471 type != OP_PADHV &&
2472 type != OP_PUSHMARK)
2473 {
eb64745e 2474 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2475 OP_DESC(o),
12bd6ede
DM		 2476 PL_parser->in_my == KEY_our
2477 ? "our"
2478 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2479 return o;
93a17b20 2480 }
09bef843
SB		 2481 else if (attrs && type != OP_PUSHMARK) {
2482 HV *stash;
09bef843 2483
12bd6ede
DM		 2484 PL_parser->in_my = FALSE;
2485 PL_parser->in_my_stash = NULL;
eb64745e 2486
09bef843 2487 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2488 stash = PAD_COMPNAME_TYPE(o->op_targ);
2489 if (!stash)
09bef843 2490 stash = PL_curstash;
95f0a2f1 2491 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2492 }
11343788
MB		 2493 o->op_flags |= OPf_MOD;
2494 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2495 if (stately)
952306ac 2496 o->op_private |= OPpPAD_STATE;
11343788 2497 return o;
93a17b20
LW		 2498}
2499
2500OP *
09bef843
SB		 2501Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2502{
97aff369 2503 dVAR;
0bd48802 2504 OP *rops;
95f0a2f1
SB		 2505 int maybe_scalar = 0;
2506
7918f24d
NC		 2507 PERL_ARGS_ASSERT_MY_ATTRS;
2508
d2be0de5 2509/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2510 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2511#if 0
09bef843
SB		 2512 if (o->op_flags & OPf_PARENS)
2513 list(o);
95f0a2f1
SB		 2514 else
2515 maybe_scalar = 1;
d2be0de5
YST		 2516#else
2517 maybe_scalar = 1;
2518#endif
09bef843
SB		 2519 if (attrs)
2520 SAVEFREEOP(attrs);
5f66b61c 2521 rops = NULL;
95f0a2f1
SB		 2522 o = my_kid(o, attrs, &rops);
2523 if (rops) {
2524 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2525 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2526 o->op_private |= OPpLVAL_INTRO;
2527 }
f5d1ed10
FC		 2528 else {
2529 /* The listop in rops might have a pushmark at the beginning,
2530 which will mess up list assignment. */
2531 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2532 if (rops->op_type == OP_LIST &&
2533 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2534 {
2535 OP * const pushmark = lrops->op_first;
2536 lrops->op_first = pushmark->op_sibling;
2537 op_free(pushmark);
2538 }
2fcb4757 2539 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2540 }
95f0a2f1 2541 }
12bd6ede
DM		 2542 PL_parser->in_my = FALSE;
2543 PL_parser->in_my_stash = NULL;
eb64745e 2544 return o;
09bef843
SB		 2545}
2546
2547OP *
864dbfa3 2548Perl_sawparens(pTHX_ OP *o)
79072805 2549{
96a5add6 2550 PERL_UNUSED_CONTEXT;
79072805
LW		 2551 if (o)
2552 o->op_flags |= OPf_PARENS;
2553 return o;
2554}
2555
2556OP *
864dbfa3 2557Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2558{
11343788 2559 OP *o;
59f00321 2560 bool ismatchop = 0;
1496a290
AL		 2561 const OPCODE ltype = left->op_type;
2562 const OPCODE rtype = right->op_type;
79072805 2563
7918f24d
NC		 2564 PERL_ARGS_ASSERT_BIND_MATCH;
2565
1496a290
AL		 2566 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2567 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2568 {
1496a290 2569 const char * const desc
bb16bae8
FC		 2570 = PL_op_desc[(
2571 rtype == OP_SUBST || rtype == OP_TRANS
2572 || rtype == OP_TRANSR
2573 )
666ea192
JH		 2574 ? (int)rtype : OP_MATCH];
2575 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2576 ? "@array" : "%hash");
9014280d 2577 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2578 "Applying %s to %s will act on scalar(%s)",
599cee73 2579 desc, sample, sample);
2ae324a7 2580 }
2581
1496a290 2582 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2583 cSVOPx(right)->op_private & OPpCONST_BARE &&
2584 cSVOPx(right)->op_private & OPpCONST_STRICT)
2585 {
2586 no_bareword_allowed(right);
2587 }
2588
bb16bae8 2589 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2590 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2591 type == OP_NOT)
2592 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2593 if (rtype == OP_TRANSR && type == OP_NOT)
2594 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2595
2474a784
FC		 2596 ismatchop = (rtype == OP_MATCH ||
2597 rtype == OP_SUBST ||
bb16bae8 2598 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2599 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2600 if (ismatchop && right->op_private & OPpTARGET_MY) {
2601 right->op_targ = 0;
2602 right->op_private &= ~OPpTARGET_MY;
2603 }
2604 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2605 OP *newleft;
2606
79072805 2607 right->op_flags |= OPf_STACKED;
bb16bae8 2608 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2609 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2610 right->op_private & OPpTRANS_IDENTICAL) &&
2611 ! (rtype == OP_SUBST &&
2612 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2613 newleft = op_lvalue(left, rtype);
1496a290
AL		 2614 else
2615 newleft = left;
bb16bae8 2616 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2617 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2618 else
2fcb4757 2619 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2620 if (type == OP_NOT)
11343788
MB		 2621 return newUNOP(OP_NOT, 0, scalar(o));
2622 return o;
79072805
LW		 2623 }
2624 else
2625 return bind_match(type, left,
131b3ad0 2626 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2627}
2628
2629OP *
864dbfa3 2630Perl_invert(pTHX_ OP *o)
79072805 2631{
11343788 2632 if (!o)
1d866c12 2633 return NULL;
11343788 2634 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2635}
2636
3ad73efd
Z		 2637/*
2638=for apidoc Amx|OP *|op_scope|OP *o
2639
2640Wraps up an op tree with some additional ops so that at runtime a dynamic
2641scope will be created. The original ops run in the new dynamic scope,
2642and then, provided that they exit normally, the scope will be unwound.
2643The additional ops used to create and unwind the dynamic scope will
2644normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2645instead if the ops are simple enough to not need the full dynamic scope
2646structure.
2647
2648=cut
2649*/
2650
79072805 2651OP *
3ad73efd 2652Perl_op_scope(pTHX_ OP *o)
79072805 2653{
27da23d5 2654 dVAR;
79072805 2655 if (o) {
3280af22 2656 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2657 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2658 o->op_type = OP_LEAVE;
22c35a8c 2659 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2660 }
fdb22418
HS		 2661 else if (o->op_type == OP_LINESEQ) {
2662 OP *kid;
2663 o->op_type = OP_SCOPE;
2664 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2665 kid = ((LISTOP*)o)->op_first;
59110972 2666 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2667 op_null(kid);
59110972
RH		 2668
2669 /* The following deals with things like 'do {1 for 1}' */
2670 kid = kid->op_sibling;
2671 if (kid &&
2672 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2673 op_null(kid);
2674 }
463ee0b2 2675 }
fdb22418 2676 else
5f66b61c 2677 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2678 }
2679 return o;
2680}
1930840b 2681
a0d0e21e 2682int
864dbfa3 2683Perl_block_start(pTHX_ int full)
79072805 2684{
97aff369 2685 dVAR;
73d840c0 2686 const int retval = PL_savestack_ix;
1930840b 2687
dd2155a4 2688 pad_block_start(full);
b3ac6de7 2689 SAVEHINTS();
3280af22 2690 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2691 SAVECOMPILEWARNINGS();
72dc9ed5 2692 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2693
a88d97bf 2694 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2695
a0d0e21e
LW		 2696 return retval;
2697}
2698
2699OP*
864dbfa3 2700Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2701{
97aff369 2702 dVAR;
6867be6d 2703 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM		 2704 OP* retval = scalarseq(seq);
2705
a88d97bf 2706 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2707
e9818f4e 2708 LEAVE_SCOPE(floor);
623e6609 2709 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2710 if (needblockscope)
3280af22 2711 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2712 pad_leavemy();
1930840b 2713
a88d97bf 2714 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2715
a0d0e21e
LW		 2716 return retval;
2717}
2718
fd85fad2
BM		 2719/*
2720=head1 Compile-time scope hooks
2721
3e4ddde5 2722=for apidoc Aox||blockhook_register
fd85fad2
BM		 2723
2724Register a set of hooks to be called when the Perl lexical scope changes
2725at compile time. See L<perlguts/"Compile-time scope hooks">.
2726
2727=cut
2728*/
2729
bb6c22e7
BM		 2730void
2731Perl_blockhook_register(pTHX_ BHK *hk)
2732{
2733 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2734
2735 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2736}
2737
76e3520e 2738STATIC OP *
cea2e8a9 2739S_newDEFSVOP(pTHX)
54b9620d 2740{
97aff369 2741 dVAR;
cc76b5cc 2742 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2743 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2744 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2745 }
2746 else {
551405c4 2747 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2748 o->op_targ = offset;
2749 return o;
2750 }
54b9620d
MB		 2751}
2752
a0d0e21e 2753void
864dbfa3 2754Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2755{
97aff369 2756 dVAR;
7918f24d
NC		 2757
2758 PERL_ARGS_ASSERT_NEWPROG;
2759
3280af22 2760 if (PL_in_eval) {
86a64801 2761 PERL_CONTEXT *cx;
b295d113
TH		 2762 if (PL_eval_root)
2763 return;
faef0170
HS		 2764 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2765 ((PL_in_eval & EVAL_KEEPERR)
2766 ? OPf_SPECIAL : 0), o);
86a64801
GG		 2767
2768 cx = &cxstack[cxstack_ix];
2769 assert(CxTYPE(cx) == CXt_EVAL);
2770
2771 if ((cx->blk_gimme & G_WANT) == G_VOID)
2772 scalarvoid(PL_eval_root);
2773 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2774 list(PL_eval_root);
2775 else
2776 scalar(PL_eval_root);
2777
5983a79d
BM		 2778 /* don't use LINKLIST, since PL_eval_root might indirect through
2779 * a rather expensive function call and LINKLIST evaluates its
2780 * argument more than once */
2781 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 2782 PL_eval_root->op_private |= OPpREFCOUNTED;
2783 OpREFCNT_set(PL_eval_root, 1);
3280af22 2784 PL_eval_root->op_next = 0;
a2efc822 2785 CALL_PEEP(PL_eval_start);
86a64801
GG		 2786 finalize_optree(PL_eval_root);
2787
a0d0e21e
LW		 2788 }
2789 else {
6be89cf9
AE		 2790 if (o->op_type == OP_STUB) {
2791 PL_comppad_name = 0;
2792 PL_compcv = 0;
d2c837a0 2793 S_op_destroy(aTHX_ o);
a0d0e21e 2794 return;
6be89cf9 2795 }
3ad73efd 2796 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 2797 PL_curcop = &PL_compiling;
2798 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2799 PL_main_root->op_private |= OPpREFCOUNTED;
2800 OpREFCNT_set(PL_main_root, 1);
3280af22 2801 PL_main_root->op_next = 0;
a2efc822 2802 CALL_PEEP(PL_main_start);
d164302a 2803 finalize_optree(PL_main_root);
3280af22 2804 PL_compcv = 0;
3841441e 2805
4fdae800 2806 /* Register with debugger */
84902520 2807 if (PERLDB_INTER) {
b96d8cd9 2808 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 2809 if (cv) {
2810 dSP;
924508f0 2811 PUSHMARK(SP);
ad64d0ec 2812 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2813 PUTBACK;
ad64d0ec 2814 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 2815 }
2816 }
79072805 2817 }
79072805
LW		 2818}
2819
2820OP *
864dbfa3 2821Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2822{
97aff369 2823 dVAR;
7918f24d
NC		 2824
2825 PERL_ARGS_ASSERT_LOCALIZE;
2826
79072805 2827 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2828/* [perl #17376]: this appears to be premature, and results in code such as
2829 C< our(%x); > executing in list mode rather than void mode */
2830#if 0
79072805 2831 list(o);
d2be0de5 2832#else
6f207bd3 2833 NOOP;
d2be0de5 2834#endif
8990e307 2835 else {
f06b5848
DM		 2836 if ( PL_parser->bufptr > PL_parser->oldbufptr
2837 && PL_parser->bufptr[-1] == ','
041457d9 2838 && ckWARN(WARN_PARENTHESIS))
64420d0d 2839 {
f06b5848 2840 char *s = PL_parser->bufptr;
bac662ee 2841 bool sigil = FALSE;
64420d0d 2842
8473848f 2843 /* some heuristics to detect a potential error */
bac662ee 2844 while (*s && (strchr(", \t\n", *s)))
64420d0d 2845 s++;
8473848f 2846
bac662ee
TS		 2847 while (1) {
2848 if (*s && strchr("@$%*", *s) && *++s
2849 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2850 s++;
2851 sigil = TRUE;
2852 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2853 s++;
2854 while (*s && (strchr(", \t\n", *s)))
2855 s++;
2856 }
2857 else
2858 break;
2859 }
2860 if (sigil && (*s == ';' || *s == '=')) {
2861 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2862 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2863 lex
2864 ? (PL_parser->in_my == KEY_our
2865 ? "our"
2866 : PL_parser->in_my == KEY_state
2867 ? "state"
2868 : "my")
2869 : "local");
8473848f 2870 }
8990e307
LW		 2871 }
2872 }
93a17b20 2873 if (lex)
eb64745e 2874 o = my(o);
93a17b20 2875 else
3ad73efd 2876 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2877 PL_parser->in_my = FALSE;
2878 PL_parser->in_my_stash = NULL;
eb64745e 2879 return o;
79072805
LW		 2880}
2881
2882OP *
864dbfa3 2883Perl_jmaybe(pTHX_ OP *o)
79072805 2884{
7918f24d
NC		 2885 PERL_ARGS_ASSERT_JMAYBE;
2886
79072805 2887 if (o->op_type == OP_LIST) {
fafc274c 2888 OP * const o2
d4c19fe8 2889 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 2890 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 2891 }
2892 return o;
2893}
2894
1f676739 2895static OP *
b7783a12 2896S_fold_constants(pTHX_ register OP *o)
79072805 2897{
27da23d5 2898 dVAR;
001d637e 2899 register OP * VOL curop;
eb8433b7 2900 OP *newop;
8ea43dc8 2901 VOL I32 type = o->op_type;
e3cbe32f 2902 SV * VOL sv = NULL;
b7f7fd0b
NC		 2903 int ret = 0;
2904 I32 oldscope;
2905 OP *old_next;
5f2d9966
DM		 2906 SV * const oldwarnhook = PL_warnhook;
2907 SV * const olddiehook = PL_diehook;
c427f4d2 2908 COP not_compiling;
b7f7fd0b 2909 dJMPENV;
79072805 2910
7918f24d
NC		 2911 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2912
22c35a8c 2913 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2914 scalar(o);
b162f9ea 2915 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2916 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2917
eac055e9
GS		 2918 /* integerize op, unless it happens to be C<-foo>.
2919 * XXX should pp_i_negate() do magic string negation instead? */
2920 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2921 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2922 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2923 {
22c35a8c 2924 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2925 }
85e6fe83 2926
22c35a8c 2927 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2928 goto nope;
2929
de939608 2930 switch (type) {
7a52d87a
GS		 2931 case OP_NEGATE:
2932 /* XXX might want a ck_negate() for this */
2933 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2934 break;
de939608
CS		 2935 case OP_UCFIRST:
2936 case OP_LCFIRST:
2937 case OP_UC:
2938 case OP_LC:
69dcf70c
MB		 2939 case OP_SLT:
2940 case OP_SGT:
2941 case OP_SLE:
2942 case OP_SGE:
2943 case OP_SCMP:
b3fd6149 2944 case OP_SPRINTF:
2de3dbcc
JH		 2945 /* XXX what about the numeric ops? */
2946 if (PL_hints & HINT_LOCALE)
de939608 2947 goto nope;
553e7bb0 2948 break;
de939608
CS		 2949 }
2950
13765c85 2951 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2952 goto nope; /* Don't try to run w/ errors */
2953
79072805 2954 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2955 const OPCODE type = curop->op_type;
2956 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2957 type != OP_LIST &&
2958 type != OP_SCALAR &&
2959 type != OP_NULL &&
2960 type != OP_PUSHMARK)
7a52d87a 2961 {
79072805
LW		 2962 goto nope;
2963 }
2964 }
2965
2966 curop = LINKLIST(o);
b7f7fd0b 2967 old_next = o->op_next;
79072805 2968 o->op_next = 0;
533c011a 2969 PL_op = curop;
b7f7fd0b
NC		 2970
2971 oldscope = PL_scopestack_ix;
edb2152a 2972 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2973
c427f4d2
NC		 2974 /* Verify that we don't need to save it: */
2975 assert(PL_curcop == &PL_compiling);
2976 StructCopy(&PL_compiling, &not_compiling, COP);
2977 PL_curcop = &not_compiling;
2978 /* The above ensures that we run with all the correct hints of the
2979 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2980 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 2981 PL_warnhook = PERL_WARNHOOK_FATAL;
2982 PL_diehook = NULL;
b7f7fd0b
NC		 2983 JMPENV_PUSH(ret);
2984
2985 switch (ret) {
2986 case 0:
2987 CALLRUNOPS(aTHX);
2988 sv = *(PL_stack_sp--);
523a0f0c
NC		 2989 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2990#ifdef PERL_MAD
2991 /* Can't simply swipe the SV from the pad, because that relies on
2992 the op being freed "real soon now". Under MAD, this doesn't
2993 happen (see the #ifdef below). */
2994 sv = newSVsv(sv);
2995#else
b7f7fd0b 2996 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 2997#endif
2998 }
b7f7fd0b
NC		 2999 else if (SvTEMP(sv)) { /* grab mortal temp? */
3000 SvREFCNT_inc_simple_void(sv);
3001 SvTEMP_off(sv);
3002 }
3003 break;
3004 case 3:
3005 /* Something tried to die. Abandon constant folding. */
3006 /* Pretend the error never happened. */
ab69dbc2 3007 CLEAR_ERRSV();
b7f7fd0b
NC		 3008 o->op_next = old_next;
3009 break;
3010 default:
3011 JMPENV_POP;
5f2d9966
DM		 3012 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3013 PL_warnhook = oldwarnhook;
3014 PL_diehook = olddiehook;
3015 /* XXX note that this croak may fail as we've already blown away
3016 * the stack - eg any nested evals */
b7f7fd0b
NC		 3017 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3018 }
b7f7fd0b 3019 JMPENV_POP;
5f2d9966
DM		 3020 PL_warnhook = oldwarnhook;
3021 PL_diehook = olddiehook;
c427f4d2 3022 PL_curcop = &PL_compiling;
edb2152a
NC		 3023
3024 if (PL_scopestack_ix > oldscope)
3025 delete_eval_scope();
eb8433b7 3026
b7f7fd0b
NC		 3027 if (ret)
3028 goto nope;
3029
eb8433b7 3030#ifndef PERL_MAD
79072805 3031 op_free(o);
eb8433b7 3032#endif
de5e01c2 3033 assert(sv);
79072805 3034 if (type == OP_RV2GV)
159b6efe 3035 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3036 else
ad64d0ec 3037 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 3038 op_getmad(o,newop,'f');
3039 return newop;
aeea060c 3040
b7f7fd0b 3041 nope:
79072805
LW		 3042 return o;
3043}
3044
1f676739 3045static OP *
b7783a12 3046S_gen_constant_list(pTHX_ register OP *o)
79072805 3047{
27da23d5 3048 dVAR;
79072805 3049 register OP *curop;
6867be6d 3050 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3051
a0d0e21e 3052 list(o);
13765c85 3053 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3054 return o; /* Don't attempt to run with errors */
3055
533c011a 3056 PL_op = curop = LINKLIST(o);
a0d0e21e 3057 o->op_next = 0;
a2efc822 3058 CALL_PEEP(curop);
897d3989 3059 Perl_pp_pushmark(aTHX);
cea2e8a9 3060 CALLRUNOPS(aTHX);
533c011a 3061 PL_op = curop;
78c72037
NC		 3062 assert (!(curop->op_flags & OPf_SPECIAL));
3063 assert(curop->op_type == OP_RANGE);
897d3989 3064 Perl_pp_anonlist(aTHX);
3280af22 3065 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3066
3067 o->op_type = OP_RV2AV;
22c35a8c 3068 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3069 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3070 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3071 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3072 curop = ((UNOP*)o)->op_first;
b37c2d43 3073 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3074#ifdef PERL_MAD
3075 op_getmad(curop,o,'O');
3076#else
79072805 3077 op_free(curop);
eb8433b7 3078#endif
5983a79d 3079 LINKLIST(o);
79072805
LW		 3080 return list(o);
3081}
3082
3083OP *
864dbfa3 3084Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3085{
27da23d5 3086 dVAR;
11343788 3087 if (!o || o->op_type != OP_LIST)
5f66b61c 3088 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3089 else
5dc0d613 3090 o->op_flags &= ~OPf_WANT;
79072805 3091
22c35a8c 3092 if (!(PL_opargs[type] & OA_MARK))
93c66552 3093 op_null(cLISTOPo->op_first);
8990e307 3094
eb160463 3095 o->op_type = (OPCODE)type;
22c35a8c 3096 o->op_ppaddr = PL_ppaddr[type];
11343788 3097 o->op_flags |= flags;
79072805 3098
11343788 3099 o = CHECKOP(type, o);
fe2774ed 3100 if (o->op_type != (unsigned)type)
11343788 3101 return o;
79072805 3102
11343788 3103 return fold_constants(o);
79072805
LW		 3104}
3105
2fcb4757
Z		 3106/*
3107=head1 Optree Manipulation Functions
3108*/
3109
79072805
LW		 3110/* List constructors */
3111
2fcb4757
Z		 3112/*
3113=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3114
3115Append an item to the list of ops contained directly within a list-type
3116op, returning the lengthened list. I<first> is the list-type op,
3117and I<last> is the op to append to the list. I<optype> specifies the
3118intended opcode for the list. If I<first> is not already a list of the
3119right type, it will be upgraded into one. If either I<first> or I<last>
3120is null, the other is returned unchanged.
3121
3122=cut
3123*/
3124
79072805 3125OP *
2fcb4757 3126Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3127{
3128 if (!first)
3129 return last;
8990e307
LW		 3130
3131 if (!last)
79072805 3132 return first;
8990e307 3133
fe2774ed 3134 if (first->op_type != (unsigned)type
155aba94
GS		 3135 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3136 {
3137 return newLISTOP(type, 0, first, last);
3138 }
79072805 3139
a0d0e21e
LW		 3140 if (first->op_flags & OPf_KIDS)
3141 ((LISTOP*)first)->op_last->op_sibling = last;
3142 else {
3143 first->op_flags |= OPf_KIDS;
3144 ((LISTOP*)first)->op_first = last;
3145 }
3146 ((LISTOP*)first)->op_last = last;
a0d0e21e 3147 return first;
79072805
LW		 3148}
3149
2fcb4757
Z		 3150/*
3151=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3152
3153Concatenate the lists of ops contained directly within two list-type ops,
3154returning the combined list. I<first> and I<last> are the list-type ops
3155to concatenate. I<optype> specifies the intended opcode for the list.
3156If either I<first> or I<last> is not already a list of the right type,
3157it will be upgraded into one. If either I<first> or I<last> is null,
3158the other is returned unchanged.
3159
3160=cut
3161*/
3162
79072805 3163OP *
2fcb4757 3164Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3165{
3166 if (!first)
2fcb4757 3167 return last;
8990e307
LW		 3168
3169 if (!last)
2fcb4757 3170 return first;
8990e307 3171
fe2774ed 3172 if (first->op_type != (unsigned)type)
2fcb4757 3173 return op_prepend_elem(type, first, last);
8990e307 3174
fe2774ed 3175 if (last->op_type != (unsigned)type)
2fcb4757 3176 return op_append_elem(type, first, last);
79072805 3177
2fcb4757
Z		 3178 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3179 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3180 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3181
eb8433b7 3182#ifdef PERL_MAD
2fcb4757
Z		 3183 if (((LISTOP*)last)->op_first && first->op_madprop) {
3184 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3185 if (mp) {
3186 while (mp->mad_next)
3187 mp = mp->mad_next;
3188 mp->mad_next = first->op_madprop;
3189 }
3190 else {
2fcb4757 3191 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3192 }
3193 }
3194 first->op_madprop = last->op_madprop;
3195 last->op_madprop = 0;
3196#endif
3197
2fcb4757 3198 S_op_destroy(aTHX_ last);
238a4c30 3199
2fcb4757 3200 return first;
79072805
LW		 3201}
3202
2fcb4757
Z		 3203/*
3204=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3205
3206Prepend an item to the list of ops contained directly within a list-type
3207op, returning the lengthened list. I<first> is the op to prepend to the
3208list, and I<last> is the list-type op. I<optype> specifies the intended
3209opcode for the list. If I<last> is not already a list of the right type,
3210it will be upgraded into one. If either I<first> or I<last> is null,
3211the other is returned unchanged.
3212
3213=cut
3214*/
3215
79072805 3216OP *
2fcb4757 3217Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3218{
3219 if (!first)
3220 return last;
8990e307
LW		 3221
3222 if (!last)
79072805 3223 return first;
8990e307 3224
fe2774ed 3225 if (last->op_type == (unsigned)type) {
8990e307
LW		 3226 if (type == OP_LIST) { /* already a PUSHMARK there */
3227 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3228 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3229 if (!(first->op_flags & OPf_PARENS))
3230 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3231 }
3232 else {
3233 if (!(last->op_flags & OPf_KIDS)) {
3234 ((LISTOP*)last)->op_last = first;
3235 last->op_flags |= OPf_KIDS;
3236 }
3237 first->op_sibling = ((LISTOP*)last)->op_first;
3238 ((LISTOP*)last)->op_first = first;
79072805 3239 }
117dada2 3240 last->op_flags |= OPf_KIDS;
79072805
LW		 3241 return last;
3242 }
3243
3244 return newLISTOP(type, 0, first, last);
3245}
3246
3247/* Constructors */
3248
eb8433b7
NC		 3249#ifdef PERL_MAD
3250
3251TOKEN *
3252Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3253{
3254 TOKEN *tk;
99129197 3255 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3256 tk->tk_type = (OPCODE)optype;
3257 tk->tk_type = 12345;
3258 tk->tk_lval = lval;
3259 tk->tk_mad = madprop;
3260 return tk;
3261}
3262
3263void
3264Perl_token_free(pTHX_ TOKEN* tk)
3265{
7918f24d
NC		 3266 PERL_ARGS_ASSERT_TOKEN_FREE;
3267
eb8433b7
NC		 3268 if (tk->tk_type != 12345)
3269 return;
3270 mad_free(tk->tk_mad);
3271 Safefree(tk);
3272}
3273
3274void
3275Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3276{
3277 MADPROP* mp;
3278 MADPROP* tm;
7918f24d
NC		 3279
3280 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3281
eb8433b7
NC		 3282 if (tk->tk_type != 12345) {
3283 Perl_warner(aTHX_ packWARN(WARN_MISC),
3284 "Invalid TOKEN object ignored");
3285 return;
3286 }
3287 tm = tk->tk_mad;
3288 if (!tm)
3289 return;
3290
3291 /* faked up qw list? */
3292 if (slot == '(' &&
3293 tm->mad_type == MAD_SV &&
d503a9ba 3294 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3295 slot = 'x';
3296
3297 if (o) {
3298 mp = o->op_madprop;
3299 if (mp) {
3300 for (;;) {
3301 /* pretend constant fold didn't happen? */
3302 if (mp->mad_key == 'f' &&
3303 (o->op_type == OP_CONST ||
3304 o->op_type == OP_GV) )
3305 {
3306 token_getmad(tk,(OP*)mp->mad_val,slot);
3307 return;
3308 }
3309 if (!mp->mad_next)
3310 break;
3311 mp = mp->mad_next;
3312 }
3313 mp->mad_next = tm;
3314 mp = mp->mad_next;
3315 }
3316 else {
3317 o->op_madprop = tm;
3318 mp = o->op_madprop;
3319 }
3320 if (mp->mad_key == 'X')
3321 mp->mad_key = slot; /* just change the first one */
3322
3323 tk->tk_mad = 0;
3324 }
3325 else
3326 mad_free(tm);
3327 Safefree(tk);
3328}
3329
3330void
3331Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3332{
3333 MADPROP* mp;
3334 if (!from)
3335 return;
3336 if (o) {
3337 mp = o->op_madprop;
3338 if (mp) {
3339 for (;;) {
3340 /* pretend constant fold didn't happen? */
3341 if (mp->mad_key == 'f' &&
3342 (o->op_type == OP_CONST ||
3343 o->op_type == OP_GV) )
3344 {
3345 op_getmad(from,(OP*)mp->mad_val,slot);
3346 return;
3347 }
3348 if (!mp->mad_next)
3349 break;
3350 mp = mp->mad_next;
3351 }
3352 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3353 }
3354 else {
3355 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3356 }
3357 }
3358}
3359
3360void
3361Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3362{
3363 MADPROP* mp;
3364 if (!from)
3365 return;
3366 if (o) {
3367 mp = o->op_madprop;
3368 if (mp) {
3369 for (;;) {
3370 /* pretend constant fold didn't happen? */
3371 if (mp->mad_key == 'f' &&
3372 (o->op_type == OP_CONST ||
3373 o->op_type == OP_GV) )
3374 {
3375 op_getmad(from,(OP*)mp->mad_val,slot);
3376 return;
3377 }
3378 if (!mp->mad_next)
3379 break;
3380 mp = mp->mad_next;
3381 }
3382 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3383 }
3384 else {
3385 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3386 }
3387 }
3388 else {
99129197
NC		 3389 PerlIO_printf(PerlIO_stderr(),
3390 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3391 op_free(from);
3392 }
3393}
3394
3395void
3396Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3397{
3398 MADPROP* tm;
3399 if (!mp || !o)
3400 return;
3401 if (slot)
3402 mp->mad_key = slot;
3403 tm = o->op_madprop;
3404 o->op_madprop = mp;
3405 for (;;) {
3406 if (!mp->mad_next)
3407 break;
3408 mp = mp->mad_next;
3409 }
3410 mp->mad_next = tm;
3411}
3412
3413void
3414Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3415{
3416 if (!o)
3417 return;
3418 addmad(tm, &(o->op_madprop), slot);
3419}
3420
3421void
3422Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3423{
3424 MADPROP* mp;
3425 if (!tm || !root)
3426 return;
3427 if (slot)
3428 tm->mad_key = slot;
3429 mp = *root;
3430 if (!mp) {
3431 *root = tm;
3432 return;
3433 }
3434 for (;;) {
3435 if (!mp->mad_next)
3436 break;
3437 mp = mp->mad_next;
3438 }
3439 mp->mad_next = tm;
3440}
3441
3442MADPROP *
3443Perl_newMADsv(pTHX_ char key, SV* sv)
3444{
7918f24d
NC		 3445 PERL_ARGS_ASSERT_NEWMADSV;
3446
eb8433b7
NC		 3447 return newMADPROP(key, MAD_SV, sv, 0);
3448}
3449
3450MADPROP *
d503a9ba 3451Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3452{
c111d5f1 3453 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3454 mp->mad_next = 0;
3455 mp->mad_key = key;
3456 mp->mad_vlen = vlen;
3457 mp->mad_type = type;
3458 mp->mad_val = val;
3459/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3460 return mp;
3461}
3462
3463void
3464Perl_mad_free(pTHX_ MADPROP* mp)
3465{
3466/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3467 if (!mp)
3468 return;
3469 if (mp->mad_next)
3470 mad_free(mp->mad_next);
bc177e6b 3471/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3472 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3473 switch (mp->mad_type) {
3474 case MAD_NULL:
3475 break;
3476 case MAD_PV:
3477 Safefree((char*)mp->mad_val);
3478 break;
3479 case MAD_OP:
3480 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3481 op_free((OP*)mp->mad_val);
3482 break;
3483 case MAD_SV:
ad64d0ec 3484 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3485 break;
3486 default:
3487 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3488 break;
3489 }
c111d5f1 3490 PerlMemShared_free(mp);
eb8433b7
NC		 3491}
3492
3493#endif
3494
d67eb5f4
Z		 3495/*
3496=head1 Optree construction
3497
3498=for apidoc Am|OP *|newNULLLIST
3499
3500Constructs, checks, and returns a new C<stub> op, which represents an
3501empty list expression.
3502
3503=cut
3504*/
3505
79072805 3506OP *
864dbfa3 3507Perl_newNULLLIST(pTHX)
79072805 3508{
8990e307
LW		 3509 return newOP(OP_STUB, 0);
3510}
3511
1f676739 3512static OP *
b7783a12 3513S_force_list(pTHX_ OP *o)
8990e307 3514{
11343788 3515 if (!o || o->op_type != OP_LIST)
5f66b61c 3516 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3517 op_null(o);
11343788 3518 return o;
79072805
LW		 3519}
3520
d67eb5f4
Z		 3521/*
3522=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3523
3524Constructs, checks, and returns an op of any list type. I<type> is
3525the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3526C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3527supply up to two ops to be direct children of the list op; they are
3528consumed by this function and become part of the constructed op tree.
3529
3530=cut
3531*/
3532
79072805 3533OP *
864dbfa3 3534Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3535{
27da23d5 3536 dVAR;
79072805
LW		 3537 LISTOP *listop;
3538
e69777c1
GG		 3539 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3540
b7dc083c 3541 NewOp(1101, listop, 1, LISTOP);
79072805 3542
eb160463 3543 listop->op_type = (OPCODE)type;
22c35a8c 3544 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3545 if (first || last)
3546 flags |= OPf_KIDS;
eb160463 3547 listop->op_flags = (U8)flags;
79072805
LW		 3548
3549 if (!last && first)
3550 last = first;
3551 else if (!first && last)
3552 first = last;
8990e307
LW		 3553 else if (first)
3554 first->op_sibling = last;
79072805
LW		 3555 listop->op_first = first;
3556 listop->op_last = last;
8990e307 3557 if (type == OP_LIST) {
551405c4 3558 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3559 pushop->op_sibling = first;
3560 listop->op_first = pushop;
3561 listop->op_flags |= OPf_KIDS;
3562 if (!last)
3563 listop->op_last = pushop;
3564 }
79072805 3565
463d09e6 3566 return CHECKOP(type, listop);
79072805
LW		 3567}
3568
d67eb5f4
Z		 3569/*
3570=for apidoc Am|OP *|newOP|I32 type|I32 flags
3571
3572Constructs, checks, and returns an op of any base type (any type that
3573has no extra fields). I<type> is the opcode. I<flags> gives the
3574eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3575of C<op_private>.
3576
3577=cut
3578*/
3579
79072805 3580OP *
864dbfa3 3581Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3582{
27da23d5 3583 dVAR;
11343788 3584 OP *o;
e69777c1
GG		 3585
3586 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3587 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3588 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3589 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3590
b7dc083c 3591 NewOp(1101, o, 1, OP);
eb160463 3592 o->op_type = (OPCODE)type;
22c35a8c 3593 o->op_ppaddr = PL_ppaddr[type];
eb160463 3594 o->op_flags = (U8)flags;
670f3923
DM		 3595 o->op_latefree = 0;
3596 o->op_latefreed = 0;
7e5d8ed2 3597 o->op_attached = 0;
79072805 3598
11343788 3599 o->op_next = o;
eb160463 3600 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3601 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3602 scalar(o);
22c35a8c 3603 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3604 o->op_targ = pad_alloc(type, SVs_PADTMP);
3605 return CHECKOP(type, o);
79072805
LW		 3606}
3607
d67eb5f4
Z		 3608/*
3609=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3610
3611Constructs, checks, and returns an op of any unary type. I<type> is
3612the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3613C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3614bits, the eight bits of C<op_private>, except that the bit with value 1
3615is automatically set. I<first> supplies an optional op to be the direct
3616child of the unary op; it is consumed by this function and become part
3617of the constructed op tree.
3618
3619=cut
3620*/
3621
79072805 3622OP *
864dbfa3 3623Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3624{
27da23d5 3625 dVAR;
79072805
LW		 3626 UNOP *unop;
3627
e69777c1
GG		 3628 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3629 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3630 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3631 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3632 || type == OP_SASSIGN
32e2a35d 3633 || type == OP_ENTERTRY
e69777c1
GG		 3634 || type == OP_NULL );
3635
93a17b20 3636 if (!first)
aeea060c 3637 first = newOP(OP_STUB, 0);
22c35a8c 3638 if (PL_opargs[type] & OA_MARK)
8990e307 3639 first = force_list(first);
93a17b20 3640
b7dc083c 3641 NewOp(1101, unop, 1, UNOP);
eb160463 3642 unop->op_type = (OPCODE)type;
22c35a8c 3643 unop->op_ppaddr = PL_ppaddr[type];
79072805 3644 unop->op_first = first;
585ec06d 3645 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3646 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3647 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW		 3648 if (unop->op_next)
3649 return (OP*)unop;
3650
a0d0e21e