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