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