This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid premature free of referent in list assign
[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 *
9b7bf845
DM
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
27 *
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
166f8a29
DM
38 *
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
43 *
44 * newBINOP(OP_ADD, flags,
45 * newSVREF($a),
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47 * )
48 *
9b7bf845
DM
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
53 * parse tree left.
54 *
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
58 *
59 * [+]
60 * |
61 * [*]------[/]
62 * | |
63 * A---B C---D
64 *
65 * with the intended execution order being:
66 *
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
68 *
69 * At this point all the nodes' op_next pointers will have been set,
70 * except that:
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
83 * initially have had:
84 * [*] => A; A => B; B => [*]
85 * and
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
90 *
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
96 *
97 * In summary: given a subtree, its top-level node's op_next will either
98 * be:
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
166f8a29 102 */
ccfc67b7 103
61b743bb 104/*
9b7bf845
DM
105
106Here's an older description from Larry.
107
61b743bb
DM
108Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110 A bottom-up pass
111 A top-down pass
112 An execution-order pass
113
114The bottom-up pass is represented by all the "newOP" routines and
115the ck_ routines. The bottom-upness is actually driven by yacc.
116So at the point that a ck_ routine fires, we have no idea what the
117context is, either upward in the syntax tree, or either forward or
118backward in the execution order. (The bottom-up parser builds that
119part of the execution order it knows about, but if you follow the "next"
120links around, you'll find it's actually a closed loop through the
ef9da979 121top level node.)
61b743bb
DM
122
123Whenever the bottom-up parser gets to a node that supplies context to
124its components, it invokes that portion of the top-down pass that applies
125to that part of the subtree (and marks the top node as processed, so
126if a node further up supplies context, it doesn't have to take the
127plunge again). As a particular subcase of this, as the new node is
128built, it takes all the closed execution loops of its subcomponents
129and links them into a new closed loop for the higher level node. But
130it's still not the real execution order.
131
132The actual execution order is not known till we get a grammar reduction
133to a top-level unit like a subroutine or file that will be called by
134"name" rather than via a "next" pointer. At that point, we can call
135into peep() to do that code's portion of the 3rd pass. It has to be
136recursive, but it's recursive on basic blocks, not on tree nodes.
137*/
138
06e0342d 139/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
06e0342d 147 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
151
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC
159*/
160
79072805 161#include "EXTERN.h"
864dbfa3 162#define PERL_IN_OP_C
79072805 163#include "perl.h"
77ca0c92 164#include "keywords.h"
2846acbf 165#include "feature.h"
74529a43 166#include "regcomp.h"
79072805 167
16c91539 168#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 169#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 170#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 171
5068f264 172static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
637494ac 173
aa9d1253
TC
174/* Used to avoid recursion through the op tree in scalarvoid() and
175 op_free()
176*/
177
178#define DEFERRED_OP_STEP 100
179#define DEFER_OP(o) \
180 STMT_START { \
181 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
182 defer_stack_alloc += DEFERRED_OP_STEP; \
183 assert(defer_stack_alloc > 0); \
184 Renew(defer_stack, defer_stack_alloc, OP *); \
185 } \
186 defer_stack[++defer_ix] = o; \
187 } STMT_END
188
189#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
190
72621f84
DM
191/* remove any leading "empty" ops from the op_next chain whose first
192 * node's address is stored in op_p. Store the updated address of the
193 * first node in op_p.
194 */
195
196STATIC void
dc3bf405 197S_prune_chain_head(OP** op_p)
72621f84
DM
198{
199 while (*op_p
200 && ( (*op_p)->op_type == OP_NULL
201 || (*op_p)->op_type == OP_SCOPE
202 || (*op_p)->op_type == OP_SCALAR
203 || (*op_p)->op_type == OP_LINESEQ)
204 )
205 *op_p = (*op_p)->op_next;
206}
207
208
8be227ab
FC
209/* See the explanatory comments above struct opslab in op.h. */
210
7aef8e5b 211#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
212# define PERL_SLAB_SIZE 128
213# define PERL_MAX_SLAB_SIZE 4096
214# include <sys/mman.h>
7aef8e5b 215#endif
3107b51f 216
7aef8e5b 217#ifndef PERL_SLAB_SIZE
8be227ab 218# define PERL_SLAB_SIZE 64
7aef8e5b
FC
219#endif
220#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 221# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 222#endif
8be227ab
FC
223
224/* rounds up to nearest pointer */
7aef8e5b
FC
225#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
226#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab
FC
227
228static OPSLAB *
229S_new_slab(pTHX_ size_t sz)
230{
7aef8e5b 231#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
232 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
233 PROT_READ|PROT_WRITE,
234 MAP_ANON|MAP_PRIVATE, -1, 0);
235 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
236 (unsigned long) sz, slab));
237 if (slab == MAP_FAILED) {
238 perror("mmap failed");
239 abort();
240 }
241 slab->opslab_size = (U16)sz;
7aef8e5b 242#else
8be227ab 243 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 244#endif
dc3bf405
BF
245#ifndef WIN32
246 /* The context is unused in non-Windows */
247 PERL_UNUSED_CONTEXT;
248#endif
8be227ab
FC
249 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
250 return slab;
251}
252
e7372881
FC
253/* requires double parens and aTHX_ */
254#define DEBUG_S_warn(args) \
255 DEBUG_S( \
256 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
257 )
258
8be227ab
FC
259void *
260Perl_Slab_Alloc(pTHX_ size_t sz)
261{
8be227ab
FC
262 OPSLAB *slab;
263 OPSLAB *slab2;
264 OPSLOT *slot;
265 OP *o;
5cb52f30 266 size_t opsz, space;
8be227ab 267
2073970f
NC
268 /* We only allocate ops from the slab during subroutine compilation.
269 We find the slab via PL_compcv, hence that must be non-NULL. It could
270 also be pointing to a subroutine which is now fully set up (CvROOT()
271 pointing to the top of the optree for that sub), or a subroutine
272 which isn't using the slab allocator. If our sanity checks aren't met,
273 don't use a slab, but allocate the OP directly from the heap. */
8be227ab
FC
274 if (!PL_compcv || CvROOT(PL_compcv)
275 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
29e61fd9
DM
276 {
277 o = (OP*)PerlMemShared_calloc(1, sz);
278 goto gotit;
279 }
8be227ab 280
2073970f
NC
281 /* While the subroutine is under construction, the slabs are accessed via
282 CvSTART(), to avoid needing to expand PVCV by one pointer for something
283 unneeded at runtime. Once a subroutine is constructed, the slabs are
284 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
285 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
286 details. */
287 if (!CvSTART(PL_compcv)) {
8be227ab
FC
288 CvSTART(PL_compcv) =
289 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
290 CvSLABBED_on(PL_compcv);
291 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
292 }
293 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
294
5cb52f30
FC
295 opsz = SIZE_TO_PSIZE(sz);
296 sz = opsz + OPSLOT_HEADER_P;
8be227ab 297
2073970f
NC
298 /* The slabs maintain a free list of OPs. In particular, constant folding
299 will free up OPs, so it makes sense to re-use them where possible. A
300 freed up slot is used in preference to a new allocation. */
8be227ab
FC
301 if (slab->opslab_freed) {
302 OP **too = &slab->opslab_freed;
303 o = *too;
eb212a1c 304 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
8be227ab 305 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 306 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 307 o = *(too = &o->op_next);
eb212a1c 308 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
8be227ab
FC
309 }
310 if (o) {
311 *too = o->op_next;
5cb52f30 312 Zero(o, opsz, I32 *);
8be227ab 313 o->op_slabbed = 1;
29e61fd9 314 goto gotit;
8be227ab
FC
315 }
316 }
317
7aef8e5b 318#define INIT_OPSLOT \
8be227ab
FC
319 slot->opslot_slab = slab; \
320 slot->opslot_next = slab2->opslab_first; \
321 slab2->opslab_first = slot; \
322 o = &slot->opslot_op; \
323 o->op_slabbed = 1
324
325 /* The partially-filled slab is next in the chain. */
326 slab2 = slab->opslab_next ? slab->opslab_next : slab;
327 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
328 /* Remaining space is too small. */
329
8be227ab
FC
330 /* If we can fit a BASEOP, add it to the free chain, so as not
331 to waste it. */
332 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
333 slot = &slab2->opslab_slots;
334 INIT_OPSLOT;
335 o->op_type = OP_FREED;
336 o->op_next = slab->opslab_freed;
337 slab->opslab_freed = o;
338 }
339
340 /* Create a new slab. Make this one twice as big. */
341 slot = slab2->opslab_first;
342 while (slot->opslot_next) slot = slot->opslot_next;
af7751f6
FC
343 slab2 = S_new_slab(aTHX_
344 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 345 ? PERL_MAX_SLAB_SIZE
af7751f6 346 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC
347 slab2->opslab_next = slab->opslab_next;
348 slab->opslab_next = slab2;
8be227ab
FC
349 }
350 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
351
352 /* Create a new op slot */
353 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
354 assert(slot >= &slab2->opslab_slots);
51c777ca
FC
355 if (DIFF(&slab2->opslab_slots, slot)
356 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
357 slot = &slab2->opslab_slots;
8be227ab 358 INIT_OPSLOT;
eb212a1c 359 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
29e61fd9
DM
360
361 gotit:
93059c1a 362#ifdef PERL_OP_PARENT
87b5a8b9
DM
363 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
364 assert(!o->op_moresib);
86cd3a13 365 assert(!o->op_sibparent);
93059c1a 366#endif
29e61fd9 367
8be227ab
FC
368 return (void *)o;
369}
370
7aef8e5b 371#undef INIT_OPSLOT
8be227ab 372
7aef8e5b 373#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
374void
375Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
376{
377 PERL_ARGS_ASSERT_SLAB_TO_RO;
378
379 if (slab->opslab_readonly) return;
380 slab->opslab_readonly = 1;
381 for (; slab; slab = slab->opslab_next) {
382 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
383 (unsigned long) slab->opslab_size, slab));*/
384 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
385 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
386 (unsigned long)slab->opslab_size, errno);
387 }
388}
389
7bbbc3c0
NC
390void
391Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 392{
3107b51f
FC
393 OPSLAB *slab2;
394
395 PERL_ARGS_ASSERT_SLAB_TO_RW;
396
3107b51f
FC
397 if (!slab->opslab_readonly) return;
398 slab2 = slab;
399 for (; slab2; slab2 = slab2->opslab_next) {
400 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
401 (unsigned long) size, slab2));*/
402 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
403 PROT_READ|PROT_WRITE)) {
404 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
405 (unsigned long)slab2->opslab_size, errno);
406 }
407 }
408 slab->opslab_readonly = 0;
409}
410
411#else
9e4d7a13 412# define Slab_to_rw(op) NOOP
3107b51f
FC
413#endif
414
8be227ab
FC
415/* This cannot possibly be right, but it was copied from the old slab
416 allocator, to which it was originally added, without explanation, in
417 commit 083fcd5. */
7aef8e5b 418#ifdef NETWARE
8be227ab 419# define PerlMemShared PerlMem
7aef8e5b 420#endif
8be227ab
FC
421
422void
423Perl_Slab_Free(pTHX_ void *op)
424{
425 OP * const o = (OP *)op;
426 OPSLAB *slab;
427
428 PERL_ARGS_ASSERT_SLAB_FREE;
429
430 if (!o->op_slabbed) {
90840c5d
RU
431 if (!o->op_static)
432 PerlMemShared_free(op);
8be227ab
FC
433 return;
434 }
435
436 slab = OpSLAB(o);
437 /* If this op is already freed, our refcount will get screwy. */
438 assert(o->op_type != OP_FREED);
439 o->op_type = OP_FREED;
440 o->op_next = slab->opslab_freed;
441 slab->opslab_freed = o;
eb212a1c 442 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
8be227ab
FC
443 OpslabREFCNT_dec_padok(slab);
444}
445
446void
447Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
448{
8be227ab
FC
449 const bool havepad = !!PL_comppad;
450 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
451 if (havepad) {
452 ENTER;
453 PAD_SAVE_SETNULLPAD();
454 }
455 opslab_free(slab);
456 if (havepad) LEAVE;
457}
458
459void
460Perl_opslab_free(pTHX_ OPSLAB *slab)
461{
462 OPSLAB *slab2;
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
81611534 464 PERL_UNUSED_CONTEXT;
eb212a1c 465 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
8be227ab 466 assert(slab->opslab_refcnt == 1);
3dc78631 467 do {
8be227ab 468 slab2 = slab->opslab_next;
7aef8e5b 469#ifdef DEBUGGING
8be227ab 470 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC
471#endif
472#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 473 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
eb212a1c 474 (void*)slab));
3107b51f
FC
475 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
476 perror("munmap failed");
477 abort();
478 }
7aef8e5b 479#else
8be227ab 480 PerlMemShared_free(slab);
7aef8e5b 481#endif
3dc78631
DM
482 slab = slab2;
483 } while (slab);
8be227ab
FC
484}
485
486void
487Perl_opslab_force_free(pTHX_ OPSLAB *slab)
488{
489 OPSLAB *slab2;
490 OPSLOT *slot;
7aef8e5b 491#ifdef DEBUGGING
8be227ab 492 size_t savestack_count = 0;
7aef8e5b 493#endif
8be227ab
FC
494 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
495 slab2 = slab;
496 do {
497 for (slot = slab2->opslab_first;
498 slot->opslot_next;
499 slot = slot->opslot_next) {
500 if (slot->opslot_op.op_type != OP_FREED
501 && !(slot->opslot_op.op_savefree
7aef8e5b 502#ifdef DEBUGGING
8be227ab 503 && ++savestack_count
7aef8e5b 504#endif
8be227ab
FC
505 )
506 ) {
507 assert(slot->opslot_op.op_slabbed);
8be227ab 508 op_free(&slot->opslot_op);
3bf28c7e 509 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC
510 }
511 }
512 } while ((slab2 = slab2->opslab_next));
513 /* > 1 because the CV still holds a reference count. */
514 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
7aef8e5b 515#ifdef DEBUGGING
8be227ab 516 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 517#endif
ee5ee853
FC
518 /* Remove the CV’s reference count. */
519 slab->opslab_refcnt--;
8be227ab
FC
520 return;
521 }
522 free:
523 opslab_free(slab);
524}
525
3107b51f
FC
526#ifdef PERL_DEBUG_READONLY_OPS
527OP *
528Perl_op_refcnt_inc(pTHX_ OP *o)
529{
530 if(o) {
372eab01
NC
531 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532 if (slab && slab->opslab_readonly) {
83519873 533 Slab_to_rw(slab);
372eab01
NC
534 ++o->op_targ;
535 Slab_to_ro(slab);
536 } else {
537 ++o->op_targ;
538 }
3107b51f
FC
539 }
540 return o;
541
542}
543
544PADOFFSET
545Perl_op_refcnt_dec(pTHX_ OP *o)
546{
372eab01
NC
547 PADOFFSET result;
548 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
549
3107b51f 550 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC
551
552 if (slab && slab->opslab_readonly) {
83519873 553 Slab_to_rw(slab);
372eab01
NC
554 result = --o->op_targ;
555 Slab_to_ro(slab);
556 } else {
557 result = --o->op_targ;
558 }
559 return result;
3107b51f
FC
560}
561#endif
e50aee73 562/*
ce6f1cbc 563 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 564 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 565 */
11343788 566#define CHECKOP(type,o) \
ce6f1cbc 567 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 568 ? ( op_free((OP*)o), \
cb77fdf0 569 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 570 (OP*)0 ) \
16c91539 571 : PL_check[type](aTHX_ (OP*)o))
e50aee73 572
e6438c1a 573#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 574
b9a07097 575#define OpTYPE_set(o,type) \
cba5a3b0
DG
576 STMT_START { \
577 o->op_type = (OPCODE)type; \
578 o->op_ppaddr = PL_ppaddr[type]; \
579 } STMT_END
580
76e3520e 581STATIC OP *
cea2e8a9 582S_no_fh_allowed(pTHX_ OP *o)
79072805 583{
7918f24d
NC
584 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
585
cea2e8a9 586 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 587 OP_DESC(o)));
11343788 588 return o;
79072805
LW
589}
590
76e3520e 591STATIC OP *
ce16c625
BF
592S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
593{
594 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
596 return o;
597}
598
599STATIC OP *
600S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
601{
602 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 603
ce16c625 604 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 605 return o;
79072805
LW
606}
607
76e3520e 608STATIC void
ed9feedd 609S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
8990e307 610{
ce16c625
BF
611 PERL_ARGS_ASSERT_BAD_TYPE_PV;
612
613 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
ed9feedd 614 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
ce16c625 615}
7918f24d 616
ed9feedd
DD
617/* remove flags var, its unused in all callers, move to to right end since gv
618 and kid are always the same */
ce16c625 619STATIC void
ed9feedd 620S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
ce16c625 621{
ecf05a58 622 SV * const namesv = cv_name((CV *)gv, NULL, 0);
7b3b0904 623 PERL_ARGS_ASSERT_BAD_TYPE_GV;
ce16c625 624
147e3846 625 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
ed9feedd 626 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
8990e307
LW
627}
628
7a52d87a 629STATIC void
eb796c7f 630S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 631{
7918f24d
NC
632 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
633
5a844595 634 qerror(Perl_mess(aTHX_
147e3846 635 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
be2597df 636 SVfARG(cSVOPo_sv)));
eb796c7f 637 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS
638}
639
79072805
LW
640/* "register" allocation */
641
642PADOFFSET
d6447115 643Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 644{
a0d0e21e 645 PADOFFSET off;
12bd6ede 646 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 647
7918f24d
NC
648 PERL_ARGS_ASSERT_ALLOCMY;
649
48d0d1be 650 if (flags & ~SVf_UTF8)
d6447115
NC
651 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
652 (UV)flags);
653
59f00321 654 /* complain about "my $<special_var>" etc etc */
d6447115 655 if (len &&
3edf23ff 656 !(is_our ||
155aba94 657 isALPHA(name[1]) ||
b14845b4 658 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
7fba2966 659 (name[1] == '_' && len > 2)))
834a4ddd 660 {
b14845b4 661 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
f6a1dc93 662 && isASCII(name[1])
b14845b4 663 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC
664 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
665 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 666 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 667 } else {
ce16c625
BF
668 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
669 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 670 }
a0d0e21e 671 }
748a9306 672
dd2155a4 673 /* allocate a spare slot and store the name in that slot */
93a17b20 674
cc76b5cc 675 off = pad_add_name_pvn(name, len,
48d0d1be 676 (is_our ? padadd_OUR :
2502ffdf 677 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
12bd6ede 678 PL_parser->in_my_stash,
3edf23ff 679 (is_our
133706a6 680 /* $_ is always in main::, even with our */
ef00320b
FC
681 ? (PL_curstash && !memEQs(name,len,"$_")
682 ? PL_curstash
683 : PL_defstash)
5c284bb0 684 : NULL
cca43f78 685 )
dd2155a4 686 );
a74073ad
DM
687 /* anon sub prototypes contains state vars should always be cloned,
688 * otherwise the state var would be shared between anon subs */
689
690 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
691 CvCLONE_on(PL_compcv);
692
dd2155a4 693 return off;
79072805
LW
694}
695
c0b8aebd 696/*
dcccc8ff
KW
697=head1 Optree Manipulation Functions
698
c0b8aebd
FC
699=for apidoc alloccopstash
700
701Available only under threaded builds, this function allocates an entry in
702C<PL_stashpad> for the stash passed to it.
703
704=cut
705*/
706
d4d03940
FC
707#ifdef USE_ITHREADS
708PADOFFSET
1dc74fdb 709Perl_alloccopstash(pTHX_ HV *hv)
d4d03940
FC
710{
711 PADOFFSET off = 0, o = 1;
712 bool found_slot = FALSE;
713
1dc74fdb
FC
714 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
715
716 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
d4d03940 717
1dc74fdb
FC
718 for (; o < PL_stashpadmax; ++o) {
719 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
720 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
d4d03940
FC
721 found_slot = TRUE, off = o;
722 }
723 if (!found_slot) {
1dc74fdb
FC
724 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
725 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
726 off = PL_stashpadmax;
727 PL_stashpadmax += 10;
d4d03940
FC
728 }
729
1dc74fdb 730 PL_stashpad[PL_stashpadix = off] = hv;
d4d03940
FC
731 return off;
732}
733#endif
734
d2c837a0
DM
735/* free the body of an op without examining its contents.
736 * Always use this rather than FreeOp directly */
737
4136a0f7 738static void
d2c837a0
DM
739S_op_destroy(pTHX_ OP *o)
740{
d2c837a0
DM
741 FreeOp(o);
742}
743
79072805
LW
744/* Destructor */
745
6e53b6ca
DD
746/*
747=for apidoc Am|void|op_free|OP *o
748
cc41839b
FC
749Free an op. Only use this when an op is no longer linked to from any
750optree.
6e53b6ca
DD
751
752=cut
753*/
754
79072805 755void
864dbfa3 756Perl_op_free(pTHX_ OP *o)
79072805 757{
27da23d5 758 dVAR;
acb36ea4 759 OPCODE type;
0997db6f
TC
760 SSize_t defer_ix = -1;
761 SSize_t defer_stack_alloc = 0;
762 OP **defer_stack = NULL;
79072805 763
0997db6f 764 do {
79072805 765
0997db6f
TC
766 /* Though ops may be freed twice, freeing the op after its slab is a
767 big no-no. */
768 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
769 /* During the forced freeing of ops after compilation failure, kidops
770 may be freed before their parents. */
771 if (!o || o->op_type == OP_FREED)
772 continue;
d0c8136d 773
0997db6f 774 type = o->op_type;
d0c8136d 775
0997db6f 776 /* an op should only ever acquire op_private flags that we know about.
09681a13
DM
777 * If this fails, you may need to fix something in regen/op_private.
778 * Don't bother testing if:
779 * * the op_ppaddr doesn't match the op; someone may have
780 * overridden the op and be doing strange things with it;
781 * * we've errored, as op flags are often left in an
782 * inconsistent state then. Note that an error when
783 * compiling the main program leaves PL_parser NULL, so
ad53d4d4 784 * we can't spot faults in the main code, only
09681a13
DM
785 * evaled/required code */
786#ifdef DEBUGGING
787 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
788 && PL_parser
789 && !PL_parser->error_count)
790 {
0997db6f
TC
791 assert(!(o->op_private & ~PL_op_private_valid[type]));
792 }
09681a13 793#endif
7934575e 794
0997db6f
TC
795 if (o->op_private & OPpREFCOUNTED) {
796 switch (type) {
797 case OP_LEAVESUB:
798 case OP_LEAVESUBLV:
799 case OP_LEAVEEVAL:
800 case OP_LEAVE:
801 case OP_SCOPE:
802 case OP_LEAVEWRITE:
803 {
804 PADOFFSET refcnt;
805 OP_REFCNT_LOCK;
806 refcnt = OpREFCNT_dec(o);
807 OP_REFCNT_UNLOCK;
808 if (refcnt) {
809 /* Need to find and remove any pattern match ops from the list
810 we maintain for reset(). */
811 find_and_forget_pmops(o);
812 continue;
813 }
814 }
815 break;
816 default:
817 break;
818 }
819 }
f37b8c3f 820
0997db6f
TC
821 /* Call the op_free hook if it has been set. Do it now so that it's called
822 * at the right time for refcounted ops, but still before all of the kids
823 * are freed. */
824 CALL_OPFREEHOOK(o);
825
826 if (o->op_flags & OPf_KIDS) {
827 OP *kid, *nextkid;
828 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
e6dae479 829 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
0997db6f
TC
830 if (!kid || kid->op_type == OP_FREED)
831 /* During the forced freeing of ops after
832 compilation failure, kidops may be freed before
833 their parents. */
834 continue;
835 if (!(kid->op_flags & OPf_KIDS))
836 /* If it has no kids, just free it now */
837 op_free(kid);
838 else
aa9d1253 839 DEFER_OP(kid);
0997db6f
TC
840 }
841 }
842 if (type == OP_NULL)
843 type = (OPCODE)o->op_targ;
acb36ea4 844
0997db6f
TC
845 if (o->op_slabbed)
846 Slab_to_rw(OpSLAB(o));
fc97af9c 847
0997db6f
TC
848 /* COP* is not cleared by op_clear() so that we may track line
849 * numbers etc even after null() */
850 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
851 cop_free((COP*)o);
852 }
acb36ea4 853
0997db6f
TC
854 op_clear(o);
855 FreeOp(o);
0997db6f
TC
856 if (PL_op == o)
857 PL_op = NULL;
aa9d1253 858 } while ( (o = POP_DEFERRED_OP()) );
0997db6f
TC
859
860 Safefree(defer_stack);
acb36ea4 861}
79072805 862
ab576797
DM
863/* S_op_clear_gv(): free a GV attached to an OP */
864
f9db5646 865STATIC
ab576797
DM
866#ifdef USE_ITHREADS
867void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
868#else
869void S_op_clear_gv(pTHX_ OP *o, SV**svp)
870#endif
871{
872
fedf30e1
DM
873 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
874 || o->op_type == OP_MULTIDEREF)
ab576797
DM
875#ifdef USE_ITHREADS
876 && PL_curpad
877 ? ((GV*)PAD_SVl(*ixp)) : NULL;
878#else
879 ? (GV*)(*svp) : NULL;
880#endif
881 /* It's possible during global destruction that the GV is freed
882 before the optree. Whilst the SvREFCNT_inc is happy to bump from
883 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
884 will trigger an assertion failure, because the entry to sv_clear
885 checks that the scalar is not already freed. A check of for
886 !SvIS_FREED(gv) turns out to be invalid, because during global
887 destruction the reference count can be forced down to zero
888 (with SVf_BREAK set). In which case raising to 1 and then
889 dropping to 0 triggers cleanup before it should happen. I
890 *think* that this might actually be a general, systematic,
891 weakness of the whole idea of SVf_BREAK, in that code *is*
892 allowed to raise and lower references during global destruction,
893 so any *valid* code that happens to do this during global
894 destruction might well trigger premature cleanup. */
895 bool still_valid = gv && SvREFCNT(gv);
896
897 if (still_valid)
898 SvREFCNT_inc_simple_void(gv);
899#ifdef USE_ITHREADS
900 if (*ixp > 0) {
901 pad_swipe(*ixp, TRUE);
902 *ixp = 0;
903 }
904#else
905 SvREFCNT_dec(*svp);
906 *svp = NULL;
907#endif
908 if (still_valid) {
909 int try_downgrade = SvREFCNT(gv) == 2;
910 SvREFCNT_dec_NN(gv);
911 if (try_downgrade)
912 gv_try_downgrade(gv);
913 }
914}
915
916
93c66552
DM
917void
918Perl_op_clear(pTHX_ OP *o)
acb36ea4 919{
13137afc 920
27da23d5 921 dVAR;
7918f24d
NC
922
923 PERL_ARGS_ASSERT_OP_CLEAR;
924
11343788 925 switch (o->op_type) {
acb36ea4 926 case OP_NULL: /* Was holding old type, if any. */
c67159e1 927 /* FALLTHROUGH */
4d193d44 928 case OP_ENTERTRY:
acb36ea4 929 case OP_ENTEREVAL: /* Was holding hints. */
4fa06845 930 case OP_ARGDEFELEM: /* Was holding signature index. */
acb36ea4 931 o->op_targ = 0;
a0d0e21e 932 break;
a6006777 933 default:
ac4c12e7 934 if (!(o->op_flags & OPf_REF)
ef69c8fc 935 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 936 break;
924ba076 937 /* FALLTHROUGH */
463ee0b2 938 case OP_GVSV:
79072805 939 case OP_GV:
a6006777 940 case OP_AELEMFAST:
f7461760 941#ifdef USE_ITHREADS
ab576797 942 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
350de78d 943#else
ab576797 944 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
350de78d 945#endif
79072805 946 break;
810bd8b7 947 case OP_METHOD_REDIR:
948 case OP_METHOD_REDIR_SUPER:
949#ifdef USE_ITHREADS
950 if (cMETHOPx(o)->op_rclass_targ) {
951 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
952 cMETHOPx(o)->op_rclass_targ = 0;
953 }
954#else
955 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
956 cMETHOPx(o)->op_rclass_sv = NULL;
957#endif
a1ae71d2 958 case OP_METHOD_NAMED:
7d6c333c 959 case OP_METHOD_SUPER:
b46e009d 960 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
961 cMETHOPx(o)->op_u.op_meth_sv = NULL;
962#ifdef USE_ITHREADS
963 if (o->op_targ) {
964 pad_swipe(o->op_targ, 1);
965 o->op_targ = 0;
966 }
967#endif
968 break;
79072805 969 case OP_CONST:
996c9baa 970 case OP_HINTSEVAL:
11343788 971 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 972 cSVOPo->op_sv = NULL;
3b1c21fa
AB
973#ifdef USE_ITHREADS
974 /** Bug #15654
975 Even if op_clear does a pad_free for the target of the op,
6a077020 976 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
977 instead it lives on. This results in that it could be reused as
978 a target later on when the pad was reallocated.
979 **/
980 if(o->op_targ) {
981 pad_swipe(o->op_targ,1);
982 o->op_targ = 0;
983 }
984#endif
79072805 985 break;
c9df4fda 986 case OP_DUMP:
748a9306
LW
987 case OP_GOTO:
988 case OP_NEXT:
989 case OP_LAST:
990 case OP_REDO:
11343788 991 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306 992 break;
924ba076 993 /* FALLTHROUGH */
a0d0e21e 994 case OP_TRANS:
bb16bae8 995 case OP_TRANSR:
acb36ea4 996 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 997 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM
998#ifdef USE_ITHREADS
999 if (cPADOPo->op_padix > 0) {
1000 pad_swipe(cPADOPo->op_padix, TRUE);
1001 cPADOPo->op_padix = 0;
1002 }
1003#else
a0ed51b3 1004 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 1005 cSVOPo->op_sv = NULL;
043e41b8 1006#endif
acb36ea4
GS
1007 }
1008 else {
ea71c68d 1009 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 1010 cPVOPo->op_pv = NULL;
acb36ea4 1011 }
a0d0e21e
LW
1012 break;
1013 case OP_SUBST:
20e98b0f 1014 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 1015 goto clear_pmop;
5012eebe
DM
1016
1017 case OP_SPLIT:
692044df
DM
1018 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1019 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
5012eebe
DM
1020 {
1021 if (o->op_private & OPpSPLIT_LEX)
1022 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1023 else
971a9dd3 1024#ifdef USE_ITHREADS
5012eebe 1025 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3 1026#else
5012eebe 1027 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3 1028#endif
5012eebe 1029 }
924ba076 1030 /* FALLTHROUGH */
a0d0e21e 1031 case OP_MATCH:
8782bef2 1032 case OP_QR:
7b52d656 1033 clear_pmop:
867940b8
DM
1034 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1035 op_free(cPMOPo->op_code_list);
68e2671b 1036 cPMOPo->op_code_list = NULL;
23083432 1037 forget_pmop(cPMOPo);
20e98b0f 1038 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC
1039 /* we use the same protection as the "SAFE" version of the PM_ macros
1040 * here since sv_clean_all might release some PMOPs
5f8cb046
DM
1041 * after PL_regex_padav has been cleared
1042 * and the clearing of PL_regex_padav needs to
1043 * happen before sv_clean_all
1044 */
13137afc
AB
1045#ifdef USE_ITHREADS
1046 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 1047 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 1048 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC
1049 PL_regex_pad[offset] = &PL_sv_undef;
1050 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1051 sizeof(offset));
13137afc 1052 }
9cddf794
NC
1053#else
1054 ReREFCNT_dec(PM_GETRE(cPMOPo));
1055 PM_SETRE(cPMOPo, NULL);
1eb1540c 1056#endif
13137afc 1057
a0d0e21e 1058 break;
fedf30e1 1059
4fa06845
DM
1060 case OP_ARGCHECK:
1061 PerlMemShared_free(cUNOP_AUXo->op_aux);
1062 break;
1063
fedf30e1
DM
1064 case OP_MULTIDEREF:
1065 {
1066 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1067 UV actions = items->uv;
1068 bool last = 0;
1069 bool is_hash = FALSE;
1070
1071 while (!last) {
1072 switch (actions & MDEREF_ACTION_MASK) {
1073
1074 case MDEREF_reload:
1075 actions = (++items)->uv;
1076 continue;
1077
1078 case MDEREF_HV_padhv_helem:
1079 is_hash = TRUE;
1080 case MDEREF_AV_padav_aelem:
1081 pad_free((++items)->pad_offset);
1082 goto do_elem;
1083
1084 case MDEREF_HV_gvhv_helem:
1085 is_hash = TRUE;
1086 case MDEREF_AV_gvav_aelem:
1087#ifdef USE_ITHREADS
1088 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1089#else
1090 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1091#endif
1092 goto do_elem;
1093
1094 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1095 is_hash = TRUE;
1096 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1097#ifdef USE_ITHREADS
1098 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1099#else
1100 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1101#endif
1102 goto do_vivify_rv2xv_elem;
1103
1104 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1105 is_hash = TRUE;
1106 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1107 pad_free((++items)->pad_offset);
1108 goto do_vivify_rv2xv_elem;
1109
1110 case MDEREF_HV_pop_rv2hv_helem:
1111 case MDEREF_HV_vivify_rv2hv_helem:
1112 is_hash = TRUE;
1113 do_vivify_rv2xv_elem:
1114 case MDEREF_AV_pop_rv2av_aelem:
1115 case MDEREF_AV_vivify_rv2av_aelem:
1116 do_elem:
1117 switch (actions & MDEREF_INDEX_MASK) {
1118 case MDEREF_INDEX_none:
1119 last = 1;
1120 break;
1121 case MDEREF_INDEX_const:
1122 if (is_hash) {
1123#ifdef USE_ITHREADS
1124 /* see RT #15654 */
1125 pad_swipe((++items)->pad_offset, 1);
1126#else
1127 SvREFCNT_dec((++items)->sv);
1128#endif
1129 }
1130 else
1131 items++;
1132 break;
1133 case MDEREF_INDEX_padsv:
1134 pad_free((++items)->pad_offset);
1135 break;
1136 case MDEREF_INDEX_gvsv:
1137#ifdef USE_ITHREADS
1138 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1139#else
1140 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1141#endif
1142 break;
1143 }
1144
1145 if (actions & MDEREF_FLAG_last)
1146 last = 1;
1147 is_hash = FALSE;
1148
1149 break;
1150
1151 default:
1152 assert(0);
1153 last = 1;
1154 break;
1155
1156 } /* switch */
1157
1158 actions >>= MDEREF_SHIFT;
1159 } /* while */
1160
1161 /* start of malloc is at op_aux[-1], where the length is
1162 * stored */
1163 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1164 }
1165 break;
79072805
LW
1166 }
1167
743e66e6 1168 if (o->op_targ > 0) {
11343788 1169 pad_free(o->op_targ);
743e66e6
GS
1170 o->op_targ = 0;
1171 }
79072805
LW
1172}
1173
76e3520e 1174STATIC void
3eb57f73
HS
1175S_cop_free(pTHX_ COP* cop)
1176{
7918f24d
NC
1177 PERL_ARGS_ASSERT_COP_FREE;
1178
05ec9bb3 1179 CopFILE_free(cop);
0453d815 1180 if (! specialWARN(cop->cop_warnings))
72dc9ed5 1181 PerlMemShared_free(cop->cop_warnings);
20439bc7 1182 cophh_free(CopHINTHASH_get(cop));
515abc43
FC
1183 if (PL_curcop == cop)
1184 PL_curcop = NULL;
3eb57f73
HS
1185}
1186
c2b1997a 1187STATIC void
c4bd3ae5 1188S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 1189 )
c2b1997a
NC
1190{
1191 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
1192
1193 PERL_ARGS_ASSERT_FORGET_PMOP;
1194
e39a6381 1195 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 1196 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
1197 if (mg) {
1198 PMOP **const array = (PMOP**) mg->mg_ptr;
1199 U32 count = mg->mg_len / sizeof(PMOP**);
1200 U32 i = count;
1201
1202 while (i--) {
1203 if (array[i] == o) {
1204 /* Found it. Move the entry at the end to overwrite it. */
1205 array[i] = array[--count];
1206 mg->mg_len = count * sizeof(PMOP**);
1207 /* Could realloc smaller at this point always, but probably
1208 not worth it. Probably worth free()ing if we're the
1209 last. */
1210 if(!count) {
1211 Safefree(mg->mg_ptr);
1212 mg->mg_ptr = NULL;
1213 }
1214 break;
1215 }
1216 }
1217 }
1218 }
1cdf7faf
NC
1219 if (PL_curpm == o)
1220 PL_curpm = NULL;
c2b1997a
NC
1221}
1222
bfd0ff22
NC
1223STATIC void
1224S_find_and_forget_pmops(pTHX_ OP *o)
1225{
7918f24d
NC
1226 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1227
bfd0ff22
NC
1228 if (o->op_flags & OPf_KIDS) {
1229 OP *kid = cUNOPo->op_first;
1230 while (kid) {
1231 switch (kid->op_type) {
1232 case OP_SUBST:
5012eebe 1233 case OP_SPLIT:
bfd0ff22
NC
1234 case OP_MATCH:
1235 case OP_QR:
23083432 1236 forget_pmop((PMOP*)kid);
bfd0ff22
NC
1237 }
1238 find_and_forget_pmops(kid);
e6dae479 1239 kid = OpSIBLING(kid);
bfd0ff22
NC
1240 }
1241 }
1242}
1243
6e53b6ca
DD
1244/*
1245=for apidoc Am|void|op_null|OP *o
1246
1247Neutralizes an op when it is no longer needed, but is still linked to from
1248other ops.
1249
1250=cut
1251*/
1252
93c66552
DM
1253void
1254Perl_op_null(pTHX_ OP *o)
8990e307 1255{
27da23d5 1256 dVAR;
7918f24d
NC
1257
1258 PERL_ARGS_ASSERT_OP_NULL;
1259
acb36ea4
GS
1260 if (o->op_type == OP_NULL)
1261 return;
b5bbe64a 1262 op_clear(o);
11343788 1263 o->op_targ = o->op_type;
b9a07097 1264 OpTYPE_set(o, OP_NULL);
8990e307
LW
1265}
1266
4026c95a
SH
1267void
1268Perl_op_refcnt_lock(pTHX)
e1fc825d 1269 PERL_TSA_ACQUIRE(PL_op_mutex)
4026c95a 1270{
20b7effb 1271#ifdef USE_ITHREADS
27da23d5 1272 dVAR;
20b7effb 1273#endif
96a5add6 1274 PERL_UNUSED_CONTEXT;
4026c95a
SH
1275 OP_REFCNT_LOCK;
1276}
1277
1278void
1279Perl_op_refcnt_unlock(pTHX)
e1fc825d 1280 PERL_TSA_RELEASE(PL_op_mutex)
4026c95a 1281{
20b7effb 1282#ifdef USE_ITHREADS
27da23d5 1283 dVAR;
20b7effb 1284#endif
96a5add6 1285 PERL_UNUSED_CONTEXT;
4026c95a
SH
1286 OP_REFCNT_UNLOCK;
1287}
1288
3253bf85
DM
1289
1290/*
1291=for apidoc op_sibling_splice
1292
1293A general function for editing the structure of an existing chain of
796b6530 1294op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
3253bf85
DM
1295you to delete zero or more sequential nodes, replacing them with zero or
1296more different nodes. Performs the necessary op_first/op_last
29e61fd9 1297housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1298children. The last deleted node will be marked as as the last node by
87b5a8b9 1299updating the op_sibling/op_sibparent or op_moresib field as appropriate.
3253bf85
DM
1300
1301Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1302responsibility of the caller. It also won't create a new list op for an
8ae26bff 1303empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85 1304
796b6530 1305C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
3269ea41 1306the splicing doesn't affect the first or last op in the chain.
3253bf85 1307
796b6530 1308C<start> is the node preceding the first node to be spliced. Node(s)
7e234f81 1309following it will be deleted, and ops will be inserted after it. If it is
796b6530 1310C<NULL>, the first node onwards is deleted, and nodes are inserted at the
3253bf85
DM
1311beginning.
1312
796b6530 1313C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1314If -1 or greater than or equal to the number of remaining kids, all
1315remaining kids are deleted.
1316
796b6530
KW
1317C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1318If C<NULL>, no nodes are inserted.
3253bf85 1319
796b6530 1320The head of the chain of deleted ops is returned, or C<NULL> if no ops were
3253bf85
DM
1321deleted.
1322
1323For example:
1324
1325 action before after returns
1326 ------ ----- ----- -------
1327
1328 P P
8ae26bff
DM
1329 splice(P, A, 2, X-Y-Z) | | B-C
1330 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1331
1332 P P
1333 splice(P, NULL, 1, X-Y) | | A
1334 A-B-C-D X-Y-B-C-D
1335
1336 P P
8ae26bff
DM
1337 splice(P, NULL, 3, NULL) | | A-B-C
1338 A-B-C-D D
3253bf85
DM
1339
1340 P P
1341 splice(P, B, 0, X-Y) | | NULL
1342 A-B-C-D A-B-X-Y-C-D
1343
5e24af7d
DM
1344
1345For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
fbe13c60 1346see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
5e24af7d 1347
3253bf85
DM
1348=cut
1349*/
1350
1351OP *
8ae26bff 1352Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1353{
3269ea41 1354 OP *first;
3253bf85
DM
1355 OP *rest;
1356 OP *last_del = NULL;
1357 OP *last_ins = NULL;
1358
3269ea41
DM
1359 if (start)
1360 first = OpSIBLING(start);
1361 else if (!parent)
1362 goto no_parent;
1363 else
1364 first = cLISTOPx(parent)->op_first;
3253bf85
DM
1365
1366 assert(del_count >= -1);
1367
1368 if (del_count && first) {
1369 last_del = first;
e6dae479
FC
1370 while (--del_count && OpHAS_SIBLING(last_del))
1371 last_del = OpSIBLING(last_del);
1372 rest = OpSIBLING(last_del);
5e24af7d 1373 OpLASTSIB_set(last_del, NULL);
3253bf85
DM
1374 }
1375 else
1376 rest = first;
1377
1378 if (insert) {
1379 last_ins = insert;
e6dae479
FC
1380 while (OpHAS_SIBLING(last_ins))
1381 last_ins = OpSIBLING(last_ins);
5e24af7d 1382 OpMAYBESIB_set(last_ins, rest, NULL);
3253bf85
DM
1383 }
1384 else
1385 insert = rest;
1386
29e61fd9 1387 if (start) {
5e24af7d 1388 OpMAYBESIB_set(start, insert, NULL);
29e61fd9 1389 }
b3e29a8d 1390 else {
3269ea41
DM
1391 if (!parent)
1392 goto no_parent;
3253bf85 1393 cLISTOPx(parent)->op_first = insert;
b3e29a8d
DM
1394 if (insert)
1395 parent->op_flags |= OPf_KIDS;
1396 else
1397 parent->op_flags &= ~OPf_KIDS;
1398 }
3253bf85
DM
1399
1400 if (!rest) {
29e61fd9 1401 /* update op_last etc */
3269ea41 1402 U32 type;
29e61fd9 1403 OP *lastop;
3253bf85 1404
3269ea41
DM
1405 if (!parent)
1406 goto no_parent;
1407
05039abd
DM
1408 /* ought to use OP_CLASS(parent) here, but that can't handle
1409 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1410 * either */
3269ea41 1411 type = parent->op_type;
05039abd
DM
1412 if (type == OP_CUSTOM) {
1413 dTHX;
1414 type = XopENTRYCUSTOM(parent, xop_class);
1415 }
1416 else {
1417 if (type == OP_NULL)
1418 type = parent->op_targ;
1419 type = PL_opargs[type] & OA_CLASS_MASK;
1420 }
3253bf85 1421
29e61fd9 1422 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1423 if ( type == OA_BINOP
1424 || type == OA_LISTOP
1425 || type == OA_PMOP
1426 || type == OA_LOOP
1427 )
29e61fd9
DM
1428 cLISTOPx(parent)->op_last = lastop;
1429
5e24af7d
DM
1430 if (lastop)
1431 OpLASTSIB_set(lastop, parent);
3253bf85
DM
1432 }
1433 return last_del ? first : NULL;
3269ea41
DM
1434
1435 no_parent:
1436 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
3253bf85
DM
1437}
1438
3269ea41 1439
1fafe688
DM
1440#ifdef PERL_OP_PARENT
1441
29e61fd9
DM
1442/*
1443=for apidoc op_parent
1444
796b6530 1445Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1fafe688 1446This function is only available on perls built with C<-DPERL_OP_PARENT>.
29e61fd9
DM
1447
1448=cut
1449*/
1450
1451OP *
8ae26bff 1452Perl_op_parent(OP *o)
29e61fd9
DM
1453{
1454 PERL_ARGS_ASSERT_OP_PARENT;
e6dae479
FC
1455 while (OpHAS_SIBLING(o))
1456 o = OpSIBLING(o);
86cd3a13 1457 return o->op_sibparent;
29e61fd9
DM
1458}
1459
1fafe688
DM
1460#endif
1461
3253bf85
DM
1462
1463/* replace the sibling following start with a new UNOP, which becomes
1464 * the parent of the original sibling; e.g.
1465 *
1466 * op_sibling_newUNOP(P, A, unop-args...)
1467 *
1468 * P P
1469 * | becomes |
1470 * A-B-C A-U-C
1471 * |
1472 * B
1473 *
1474 * where U is the new UNOP.
1475 *
1476 * parent and start args are the same as for op_sibling_splice();
1477 * type and flags args are as newUNOP().
1478 *
1479 * Returns the new UNOP.
1480 */
1481
f9db5646 1482STATIC OP *
3253bf85
DM
1483S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1484{
1485 OP *kid, *newop;
1486
1487 kid = op_sibling_splice(parent, start, 1, NULL);
1488 newop = newUNOP(type, flags, kid);
1489 op_sibling_splice(parent, start, 0, newop);
1490 return newop;
1491}
1492
1493
1494/* lowest-level newLOGOP-style function - just allocates and populates
1495 * the struct. Higher-level stuff should be done by S_new_logop() /
1496 * newLOGOP(). This function exists mainly to avoid op_first assignment
1497 * being spread throughout this file.
1498 */
1499
6cb4123e
DM
1500LOGOP *
1501Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
3253bf85 1502{
1e8db68a 1503 dVAR;
3253bf85 1504 LOGOP *logop;
29e61fd9 1505 OP *kid = first;
3253bf85 1506 NewOp(1101, logop, 1, LOGOP);
b9a07097 1507 OpTYPE_set(logop, type);
3253bf85
DM
1508 logop->op_first = first;
1509 logop->op_other = other;
1510 logop->op_flags = OPf_KIDS;
e6dae479
FC
1511 while (kid && OpHAS_SIBLING(kid))
1512 kid = OpSIBLING(kid);
5e24af7d
DM
1513 if (kid)
1514 OpLASTSIB_set(kid, (OP*)logop);
3253bf85
DM
1515 return logop;
1516}
1517
1518
79072805
LW
1519/* Contextualizers */
1520
d9088386
Z
1521/*
1522=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1523
1524Applies a syntactic context to an op tree representing an expression.
2d7f6611 1525C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
d9088386
Z
1526or C<G_VOID> to specify the context to apply. The modified op tree
1527is returned.
1528
1529=cut
1530*/
1531
1532OP *
1533Perl_op_contextualize(pTHX_ OP *o, I32 context)
1534{
1535 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1536 switch (context) {
1537 case G_SCALAR: return scalar(o);
1538 case G_ARRAY: return list(o);
1539 case G_VOID: return scalarvoid(o);
1540 default:
5637ef5b
NC
1541 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1542 (long) context);
d9088386
Z
1543 }
1544}
1545
5983a79d 1546/*
79072805 1547
5983a79d 1548=for apidoc Am|OP*|op_linklist|OP *o
72d33970 1549This function is the implementation of the L</LINKLIST> macro. It should
5983a79d
BM
1550not be called directly.
1551
1552=cut
1553*/
1554
1555OP *
1556Perl_op_linklist(pTHX_ OP *o)
79072805 1557{
3edf23ff 1558 OP *first;
79072805 1559
5983a79d 1560 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1561
11343788
MB
1562 if (o->op_next)
1563 return o->op_next;
79072805
LW
1564
1565 /* establish postfix order */
3edf23ff
AL
1566 first = cUNOPo->op_first;
1567 if (first) {
eb578fdb 1568 OP *kid;
3edf23ff
AL
1569 o->op_next = LINKLIST(first);
1570 kid = first;
1571 for (;;) {
e6dae479 1572 OP *sibl = OpSIBLING(kid);
29e61fd9
DM
1573 if (sibl) {
1574 kid->op_next = LINKLIST(sibl);
1575 kid = sibl;
3edf23ff 1576 } else {
11343788 1577 kid->op_next = o;
3edf23ff
AL
1578 break;
1579 }
79072805
LW
1580 }
1581 }
1582 else
11343788 1583 o->op_next = o;
79072805 1584
11343788 1585 return o->op_next;
79072805
LW
1586}
1587
1f676739 1588static OP *
2dd5337b 1589S_scalarkids(pTHX_ OP *o)
79072805 1590{
11343788 1591 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1592 OP *kid;
e6dae479 1593 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
1594 scalar(kid);
1595 }
11343788 1596 return o;
79072805
LW
1597}
1598
76e3520e 1599STATIC OP *
cea2e8a9 1600S_scalarboolean(pTHX_ OP *o)
8990e307 1601{
7918f24d
NC
1602 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1603
0a44e30b
DC
1604 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1605 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1606 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1607 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1608 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
d008e5eb 1609 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1610 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1611
2b7cddde
NC
1612 if (PL_parser && PL_parser->copline != NOLINE) {
1613 /* This ensures that warnings are reported at the first line
1614 of the conditional, not the last. */
53a7735b 1615 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1616 }
9014280d 1617 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1618 CopLINE_set(PL_curcop, oldline);
d008e5eb 1619 }
a0d0e21e 1620 }
11343788 1621 return scalar(o);
8990e307
LW
1622}
1623
0920b7fa 1624static SV *
637494ac 1625S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
0920b7fa
FC
1626{
1627 assert(o);
1628 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1629 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1630 {
1631 const char funny = o->op_type == OP_PADAV
1632 || o->op_type == OP_RV2AV ? '@' : '%';
1633 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1634 GV *gv;
1635 if (cUNOPo->op_first->op_type != OP_GV
1636 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1637 return NULL;
637494ac 1638 return varname(gv, funny, 0, NULL, 0, subscript_type);
0920b7fa
FC
1639 }
1640 return
637494ac 1641 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
0920b7fa
FC
1642 }
1643}
1644
637494ac
TC
1645static SV *
1646S_op_varname(pTHX_ const OP *o)
1647{
1648 return S_op_varname_subscript(aTHX_ o, 1);
1649}
1650
429a2555 1651static void
2186f873
FC
1652S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1653{ /* or not so pretty :-) */
2186f873
FC
1654 if (o->op_type == OP_CONST) {
1655 *retsv = cSVOPo_sv;
1656 if (SvPOK(*retsv)) {
1657 SV *sv = *retsv;
1658 *retsv = sv_newmortal();
1659 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1660 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1661 }
1662 else if (!SvOK(*retsv))
1663 *retpv = "undef";
1664 }
1665 else *retpv = "...";
1666}
1667
1668static void
429a2555
FC
1669S_scalar_slice_warning(pTHX_ const OP *o)
1670{
1671 OP *kid;
1672 const char lbrack =
2186f873 1673 o->op_type == OP_HSLICE ? '{' : '[';
429a2555 1674 const char rbrack =
2186f873 1675 o->op_type == OP_HSLICE ? '}' : ']';
429a2555 1676 SV *name;
32e9ec8f 1677 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC
1678 const char *key = NULL;
1679
1680 if (!(o->op_private & OPpSLICEWARNING))
1681 return;
1682 if (PL_parser && PL_parser->error_count)
1683 /* This warning can be nonsensical when there is a syntax error. */
1684 return;
1685
1686 kid = cLISTOPo->op_first;
e6dae479 1687 kid = OpSIBLING(kid); /* get past pushmark */
429a2555
FC
1688 /* weed out false positives: any ops that can return lists */
1689 switch (kid->op_type) {
1690 case OP_BACKTICK:
1691 case OP_GLOB:
1692 case OP_READLINE:
1693 case OP_MATCH:
1694 case OP_RV2AV:
1695 case OP_EACH:
1696 case OP_VALUES:
1697 case OP_KEYS:
1698 case OP_SPLIT:
1699 case OP_LIST:
1700 case OP_SORT:
1701 case OP_REVERSE:
1702 case OP_ENTERSUB:
1703 case OP_CALLER:
1704 case OP_LSTAT:
1705 case OP_STAT:
1706 case OP_READDIR:
1707 case OP_SYSTEM:
1708 case OP_TMS:
1709 case OP_LOCALTIME:
1710 case OP_GMTIME:
1711 case OP_ENTEREVAL:
429a2555
FC
1712 return;
1713 }
7d3c8a68
SM
1714
1715 /* Don't warn if we have a nulled list either. */
1716 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1717 return;
1718
e6dae479
FC
1719 assert(OpSIBLING(kid));
1720 name = S_op_varname(aTHX_ OpSIBLING(kid));
429a2555
FC
1721 if (!name) /* XS module fiddling with the op tree */
1722 return;
2186f873 1723 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC
1724 assert(SvPOK(name));
1725 sv_chop(name,SvPVX(name)+1);
1726 if (key)
2186f873 1727 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1728 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846 1729 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
429a2555 1730 "%c%s%c",
2186f873 1731 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC
1732 lbrack, key, rbrack);
1733 else
2186f873 1734 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1735 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846
KW
1736 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1737 SVf "%c%" SVf "%c",
c1f6cd39
BF
1738 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1739 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
429a2555
FC
1740}
1741
8990e307 1742OP *
864dbfa3 1743Perl_scalar(pTHX_ OP *o)
79072805
LW
1744{
1745 OP *kid;
1746
a0d0e21e 1747 /* assumes no premature commitment */
13765c85
DM
1748 if (!o || (PL_parser && PL_parser->error_count)
1749 || (o->op_flags & OPf_WANT)
5dc0d613 1750 || o->op_type == OP_RETURN)
7e363e51 1751 {
11343788 1752 return o;
7e363e51 1753 }
79072805 1754
5dc0d613 1755 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1756
11343788 1757 switch (o->op_type) {
79072805 1758 case OP_REPEAT:
11343788 1759 scalar(cBINOPo->op_first);
82e4f303
FC
1760 if (o->op_private & OPpREPEAT_DOLIST) {
1761 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1762 assert(kid->op_type == OP_PUSHMARK);
e6dae479 1763 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
82e4f303
FC
1764 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1765 o->op_private &=~ OPpREPEAT_DOLIST;
1766 }
1767 }
8990e307 1768 break;
79072805
LW
1769 case OP_OR:
1770 case OP_AND:
1771 case OP_COND_EXPR:
e6dae479 1772 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
8990e307 1773 scalar(kid);
79072805 1774 break;
924ba076 1775 /* FALLTHROUGH */
a6d8037e 1776 case OP_SPLIT:
79072805 1777 case OP_MATCH:
8782bef2 1778 case OP_QR:
79072805
LW
1779 case OP_SUBST:
1780 case OP_NULL:
8990e307 1781 default:
11343788 1782 if (o->op_flags & OPf_KIDS) {
e6dae479 1783 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
8990e307
LW
1784 scalar(kid);
1785 }
79072805
LW
1786 break;
1787 case OP_LEAVE:
1788 case OP_LEAVETRY:
5dc0d613 1789 kid = cLISTOPo->op_first;
54310121 1790 scalar(kid);
e6dae479 1791 kid = OpSIBLING(kid);
25b991bf
VP
1792 do_kids:
1793 while (kid) {
e6dae479 1794 OP *sib = OpSIBLING(kid);
34b54951 1795 if (sib && kid->op_type != OP_LEAVEWHEN
e6dae479 1796 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
34b54951
FC
1797 || ( sib->op_targ != OP_NEXTSTATE
1798 && sib->op_targ != OP_DBSTATE )))
c08f093b
VP
1799 scalarvoid(kid);
1800 else
54310121 1801 scalar(kid);
25b991bf 1802 kid = sib;
54310121 1803 }
11206fdd 1804 PL_curcop = &PL_compiling;
54310121 1805 break;
748a9306 1806 case OP_SCOPE:
79072805 1807 case OP_LINESEQ:
8990e307 1808 case OP_LIST:
25b991bf
VP
1809 kid = cLISTOPo->op_first;
1810 goto do_kids;
a801c63c 1811 case OP_SORT:
a2a5de95 1812 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1813 break;
95a31aad
FC
1814 case OP_KVHSLICE:
1815 case OP_KVASLICE:
2186f873
FC
1816 {
1817 /* Warn about scalar context */
1818 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1819 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1820 SV *name;
1821 SV *keysv;
1822 const char *key = NULL;
1823
1824 /* This warning can be nonsensical when there is a syntax error. */
1825 if (PL_parser && PL_parser->error_count)
1826 break;
1827
1828 if (!ckWARN(WARN_SYNTAX)) break;
1829
1830 kid = cLISTOPo->op_first;
e6dae479
FC
1831 kid = OpSIBLING(kid); /* get past pushmark */
1832 assert(OpSIBLING(kid));
1833 name = S_op_varname(aTHX_ OpSIBLING(kid));
2186f873
FC
1834 if (!name) /* XS module fiddling with the op tree */
1835 break;
1836 S_op_pretty(aTHX_ kid, &keysv, &key);
1837 assert(SvPOK(name));
1838 sv_chop(name,SvPVX(name)+1);
1839 if (key)
1840 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846
KW
1842 "%%%" SVf "%c%s%c in scalar context better written "
1843 "as $%" SVf "%c%s%c",
2186f873
FC
1844 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1845 lbrack, key, rbrack);
1846 else
1847 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1848 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
147e3846
KW
1849 "%%%" SVf "%c%" SVf "%c in scalar context better "
1850 "written as $%" SVf "%c%" SVf "%c",
c1f6cd39
BF
1851 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1852 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2186f873 1853 }
79072805 1854 }
11343788 1855 return o;
79072805
LW
1856}
1857
1858OP *
aa9d1253 1859Perl_scalarvoid(pTHX_ OP *arg)
79072805 1860{
27da23d5 1861 dVAR;
79072805 1862 OP *kid;
8990e307 1863 SV* sv;
2ebea0a1 1864 U8 want;
aa9d1253
TC
1865 SSize_t defer_stack_alloc = 0;
1866 SSize_t defer_ix = -1;
1867 OP **defer_stack = NULL;
1868 OP *o = arg;
2ebea0a1 1869
7918f24d
NC
1870 PERL_ARGS_ASSERT_SCALARVOID;
1871
aa9d1253
TC
1872 do {
1873 SV *useless_sv = NULL;
1874 const char* useless = NULL;
1875
26f0e7d5
TC
1876 if (o->op_type == OP_NEXTSTATE
1877 || o->op_type == OP_DBSTATE
1878 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1879 || o->op_targ == OP_DBSTATE)))
1880 PL_curcop = (COP*)o; /* for warning below */
1881
1882 /* assumes no premature commitment */
1883 want = o->op_flags & OPf_WANT;
1884 if ((want && want != OPf_WANT_SCALAR)
1885 || (PL_parser && PL_parser->error_count)
1886 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1887 {
1888 continue;
1889 }
1c846c1f 1890
26f0e7d5
TC
1891 if ((o->op_private & OPpTARGET_MY)
1892 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1893 {
0d18dd72
FC
1894 /* newASSIGNOP has already applied scalar context, which we
1895 leave, as if this op is inside SASSIGN. */
26f0e7d5
TC
1896 continue;
1897 }
79072805 1898
26f0e7d5 1899 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
75068674 1900
26f0e7d5
TC
1901 switch (o->op_type) {
1902 default:
1903 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1904 break;
1905 /* FALLTHROUGH */
1906 case OP_REPEAT:
1907 if (o->op_flags & OPf_STACKED)
1908 break;
1e2dd519
FC
1909 if (o->op_type == OP_REPEAT)
1910 scalar(cBINOPo->op_first);
26f0e7d5
TC
1911 goto func_ops;
1912 case OP_SUBSTR:
1913 if (o->op_private == 4)
1914 break;
1915 /* FALLTHROUGH */
26f0e7d5
TC
1916 case OP_WANTARRAY:
1917 case OP_GV:
1918 case OP_SMARTMATCH:
26f0e7d5
TC
1919 case OP_AV2ARYLEN:
1920 case OP_REF:
1921 case OP_REFGEN:
1922 case OP_SREFGEN:
1923 case OP_DEFINED:
1924 case OP_HEX:
1925 case OP_OCT:
1926 case OP_LENGTH:
1927 case OP_VEC:
1928 case OP_INDEX:
1929 case OP_RINDEX:
1930 case OP_SPRINTF:
26f0e7d5 1931 case OP_KVASLICE:
26f0e7d5
TC
1932 case OP_KVHSLICE:
1933 case OP_UNPACK:
1934 case OP_PACK:
1935 case OP_JOIN:
1936 case OP_LSLICE:
1937 case OP_ANONLIST:
1938 case OP_ANONHASH:
1939 case OP_SORT:
1940 case OP_REVERSE:
1941 case OP_RANGE:
1942 case OP_FLIP:
1943 case OP_FLOP:
1944 case OP_CALLER:
1945 case OP_FILENO:
1946 case OP_EOF:
1947 case OP_TELL:
1948 case OP_GETSOCKNAME:
1949 case OP_GETPEERNAME:
1950 case OP_READLINK:
1951 case OP_TELLDIR:
1952 case OP_GETPPID:
1953 case OP_GETPGRP:
1954 case OP_GETPRIORITY:
1955 case OP_TIME:
1956 case OP_TMS:
1957 case OP_LOCALTIME:
1958 case OP_GMTIME:
1959 case OP_GHBYNAME:
1960 case OP_GHBYADDR:
1961 case OP_GHOSTENT:
1962 case OP_GNBYNAME:
1963 case OP_GNBYADDR:
1964 case OP_GNETENT:
1965 case OP_GPBYNAME:
1966 case OP_GPBYNUMBER:
1967 case OP_GPROTOENT:
1968 case OP_GSBYNAME:
1969 case OP_GSBYPORT:
1970 case OP_GSERVENT:
1971 case OP_GPWNAM:
1972 case OP_GPWUID:
1973 case OP_GGRNAM:
1974 case OP_GGRGID:
1975 case OP_GETLOGIN:
1976 case OP_PROTOTYPE:
1977 case OP_RUNCV:
1978 func_ops:
9e209402
FC
1979 useless = OP_DESC(o);
1980 break;
1981
1982 case OP_GVSV:
1983 case OP_PADSV:
1984 case OP_PADAV:
1985 case OP_PADHV:
1986 case OP_PADANY:
1987 case OP_AELEM:
1988 case OP_AELEMFAST:
1989 case OP_AELEMFAST_LEX:
1990 case OP_ASLICE:
1991 case OP_HELEM:
1992 case OP_HSLICE:
26f0e7d5 1993 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
ea5519d6 1994 /* Otherwise it's "Useless use of grep iterator" */
3c3f8cd6 1995 useless = OP_DESC(o);
ea5519d6 1996 break;
26f0e7d5
TC
1997
1998 case OP_SPLIT:
5012eebe 1999 if (!(o->op_private & OPpSPLIT_ASSIGN))
26f0e7d5
TC
2000 useless = OP_DESC(o);
2001 break;
2002
2003 case OP_NOT:
2004 kid = cUNOPo->op_first;
2005 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2006 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2007 goto func_ops;
2008 }
2009 useless = "negative pattern binding (!~)";
2010 break;
2011
2012 case OP_SUBST:
2013 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2014 useless = "non-destructive substitution (s///r)";
2015 break;
2016
2017 case OP_TRANSR:
2018 useless = "non-destructive transliteration (tr///r)";
2019 break;
2020
2021 case OP_RV2GV:
2022 case OP_RV2SV:
2023 case OP_RV2AV:
2024 case OP_RV2HV:
2025 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
e6dae479 2026 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
26f0e7d5
TC
2027 useless = "a variable";
2028 break;
2029
2030 case OP_CONST:
2031 sv = cSVOPo_sv;
2032 if (cSVOPo->op_private & OPpCONST_STRICT)
2033 no_bareword_allowed(o);
2034 else {
2035 if (ckWARN(WARN_VOID)) {
2036 NV nv;
2037 /* don't warn on optimised away booleans, eg
2038 * use constant Foo, 5; Foo || print; */
2039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2040 useless = NULL;
2041 /* the constants 0 and 1 are permitted as they are
2042 conventionally used as dummies in constructs like
2043 1 while some_condition_with_side_effects; */
2044 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2045 useless = NULL;
2046 else if (SvPOK(sv)) {
2047 SV * const dsv = newSVpvs("");
2048 useless_sv
2049 = Perl_newSVpvf(aTHX_
2050 "a constant (%s)",
2051 pv_pretty(dsv, SvPVX_const(sv),
2052 SvCUR(sv), 32, NULL, NULL,
2053 PERL_PV_PRETTY_DUMP
2054 | PERL_PV_ESCAPE_NOCLEAR
2055 | PERL_PV_ESCAPE_UNI_DETECT));
2056 SvREFCNT_dec_NN(dsv);
2057 }
2058 else if (SvOK(sv)) {
147e3846 2059 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
26f0e7d5
TC
2060 }
2061 else
2062 useless = "a constant (undef)";
2063 }
2064 }
2065 op_null(o); /* don't execute or even remember it */
2066 break;
79072805 2067
26f0e7d5 2068 case OP_POSTINC:
b9a07097 2069 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
26f0e7d5 2070 break;
79072805 2071
26f0e7d5 2072 case OP_POSTDEC:
b9a07097 2073 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
26f0e7d5 2074 break;
79072805 2075
26f0e7d5 2076 case OP_I_POSTINC:
b9a07097 2077 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
26f0e7d5 2078 break;
79072805 2079
26f0e7d5 2080 case OP_I_POSTDEC:
b9a07097 2081 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
26f0e7d5 2082 break;
679d6c4e 2083
26f0e7d5
TC
2084 case OP_SASSIGN: {
2085 OP *rv2gv;
2086 UNOP *refgen, *rv2cv;
2087 LISTOP *exlist;
679d6c4e 2088
26f0e7d5
TC
2089 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2090 break;
f2f8fd84 2091
26f0e7d5
TC
2092 rv2gv = ((BINOP *)o)->op_last;
2093 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2094 break;
f2f8fd84 2095
26f0e7d5 2096 refgen = (UNOP *)((BINOP *)o)->op_first;
f2f8fd84 2097
26f0e7d5
TC
2098 if (!refgen || (refgen->op_type != OP_REFGEN
2099 && refgen->op_type != OP_SREFGEN))
2100 break;
f2f8fd84 2101
26f0e7d5
TC
2102 exlist = (LISTOP *)refgen->op_first;
2103 if (!exlist || exlist->op_type != OP_NULL
2104 || exlist->op_targ != OP_LIST)
2105 break;
f2f8fd84 2106
26f0e7d5
TC
2107 if (exlist->op_first->op_type != OP_PUSHMARK
2108 && exlist->op_first != exlist->op_last)
2109 break;
f2f8fd84 2110
26f0e7d5 2111 rv2cv = (UNOP*)exlist->op_last;
f2f8fd84 2112
26f0e7d5
TC
2113 if (rv2cv->op_type != OP_RV2CV)
2114 break;
f2f8fd84 2115
26f0e7d5
TC
2116 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2117 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2118 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
f2f8fd84 2119
26f0e7d5
TC
2120 o->op_private |= OPpASSIGN_CV_TO_GV;
2121 rv2gv->op_private |= OPpDONT_INIT_GV;
2122 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
f2f8fd84 2123
26f0e7d5
TC
2124 break;
2125 }
540dd770 2126
26f0e7d5
TC
2127 case OP_AASSIGN: {
2128 inplace_aassign(o);
2129 break;
2130 }
edbe35ea 2131
26f0e7d5
TC
2132 case OP_OR:
2133 case OP_AND:
2134 kid = cLOGOPo->op_first;
2135 if (kid->op_type == OP_NOT
2136 && (kid->op_flags & OPf_KIDS)) {
2137 if (o->op_type == OP_AND) {
b9a07097 2138 OpTYPE_set(o, OP_OR);
26f0e7d5 2139 } else {
b9a07097 2140 OpTYPE_set(o, OP_AND);
26f0e7d5
TC
2141 }
2142 op_null(kid);
2143 }
2144 /* FALLTHROUGH */
5aabfad6 2145
26f0e7d5
TC
2146 case OP_DOR:
2147 case OP_COND_EXPR:
2148 case OP_ENTERGIVEN:
2149 case OP_ENTERWHEN:
e6dae479 2150 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
26f0e7d5
TC
2151 if (!(kid->op_flags & OPf_KIDS))
2152 scalarvoid(kid);
2153 else
2154 DEFER_OP(kid);
aa9d1253 2155 break;
095b19d1 2156
26f0e7d5
TC
2157 case OP_NULL:
2158 if (o->op_flags & OPf_STACKED)
2159 break;
2160 /* FALLTHROUGH */
2161 case OP_NEXTSTATE:
2162 case OP_DBSTATE:
2163 case OP_ENTERTRY:
2164 case OP_ENTER:
2165 if (!(o->op_flags & OPf_KIDS))
2166 break;
2167 /* FALLTHROUGH */
2168 case OP_SCOPE:
2169 case OP_LEAVE:
2170 case OP_LEAVETRY:
2171 case OP_LEAVELOOP:
2172 case OP_LINESEQ:
2173 case OP_LEAVEGIVEN:
2174 case OP_LEAVEWHEN:
2175 kids:
e6dae479 2176 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
26f0e7d5
TC
2177 if (!(kid->op_flags & OPf_KIDS))
2178 scalarvoid(kid);
2179 else
2180 DEFER_OP(kid);
2181 break;
2182 case OP_LIST:
2183 /* If the first kid after pushmark is something that the padrange
2184 optimisation would reject, then null the list and the pushmark.
2185 */
2186 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
e6dae479 2187 && ( !(kid = OpSIBLING(kid))
26f0e7d5
TC
2188 || ( kid->op_type != OP_PADSV
2189 && kid->op_type != OP_PADAV
2190 && kid->op_type != OP_PADHV)
2191 || kid->op_private & ~OPpLVAL_INTRO
e6dae479 2192 || !(kid = OpSIBLING(kid))
26f0e7d5
TC
2193 || ( kid->op_type != OP_PADSV
2194 && kid->op_type != OP_PADAV
2195 && kid->op_type != OP_PADHV)
2196 || kid->op_private & ~OPpLVAL_INTRO)
2197 ) {
2198 op_null(cUNOPo->op_first); /* NULL the pushmark */
2199 op_null(o); /* NULL the list */
2200 }
2201 goto kids;
2202 case OP_ENTEREVAL:
2203 scalarkids(o);
2204 break;
2205 case OP_SCALAR:
2206 scalar(o);
2207 break;
2208 }
2209
2210 if (useless_sv) {
2211 /* mortalise it, in case warnings are fatal. */
2212 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
147e3846 2213 "Useless use of %" SVf " in void context",
26f0e7d5
TC
2214 SVfARG(sv_2mortal(useless_sv)));
2215 }
2216 else if (useless) {
3c3f8cd6
AB
2217 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218 "Useless use of %s in void context",
2219 useless);
26f0e7d5 2220 }
aa9d1253
TC
2221 } while ( (o = POP_DEFERRED_OP()) );
2222
2223 Safefree(defer_stack);
2224
2225 return arg;
79072805
LW
2226}
2227
1f676739 2228static OP *
412da003 2229S_listkids(pTHX_ OP *o)
79072805 2230{
11343788 2231 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2232 OP *kid;
e6dae479 2233 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
2234 list(kid);
2235 }
11343788 2236 return o;
79072805
LW
2237}
2238
2239OP *
864dbfa3 2240Perl_list(pTHX_ OP *o)
79072805
LW
2241{
2242 OP *kid;
2243
a0d0e21e 2244 /* assumes no premature commitment */
13765c85
DM
2245 if (!o || (o->op_flags & OPf_WANT)
2246 || (PL_parser && PL_parser->error_count)
5dc0d613 2247 || o->op_type == OP_RETURN)
7e363e51 2248 {
11343788 2249 return o;
7e363e51 2250 }
79072805 2251
b162f9ea 2252 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2254 {
b162f9ea 2255 return o; /* As if inside SASSIGN */
7e363e51 2256 }
1c846c1f 2257
5dc0d613 2258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 2259
11343788 2260 switch (o->op_type) {
79072805 2261 case OP_FLOP:
11343788 2262 list(cBINOPo->op_first);
79072805 2263 break;
c57eecc5
FC
2264 case OP_REPEAT:
2265 if (o->op_private & OPpREPEAT_DOLIST
2266 && !(o->op_flags & OPf_STACKED))
2267 {
2268 list(cBINOPo->op_first);
2269 kid = cBINOPo->op_last;
2270 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2271 && SvIVX(kSVOP_sv) == 1)
2272 {
2273 op_null(o); /* repeat */
2274 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2275 /* const (rhs): */
2276 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2277 }
2278 }
2279 break;
79072805
LW
2280 case OP_OR:
2281 case OP_AND:
2282 case OP_COND_EXPR:
e6dae479 2283 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
79072805
LW
2284 list(kid);
2285 break;
2286 default:
2287 case OP_MATCH:
8782bef2 2288 case OP_QR:
79072805
LW
2289 case OP_SUBST:
2290 case OP_NULL:
11343788 2291 if (!(o->op_flags & OPf_KIDS))
79072805 2292 break;
11343788
MB
2293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2294 list(cBINOPo->op_first);
2295 return gen_constant_list(o);
79072805 2296 }
6aa68307
FC
2297 listkids(o);
2298 break;
79072805 2299 case OP_LIST:
11343788 2300 listkids(o);
6aa68307
FC
2301 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2302 op_null(cUNOPo->op_first); /* NULL the pushmark */
2303 op_null(o); /* NULL the list */
2304 }
79072805
LW
2305 break;
2306 case OP_LEAVE:
2307 case OP_LEAVETRY:
5dc0d613 2308 kid = cLISTOPo->op_first;
54310121 2309 list(kid);
e6dae479 2310 kid = OpSIBLING(kid);
25b991bf
VP
2311 do_kids:
2312 while (kid) {
e6dae479 2313 OP *sib = OpSIBLING(kid);
c08f093b
VP
2314 if (sib && kid->op_type != OP_LEAVEWHEN)
2315 scalarvoid(kid);
2316 else
54310121 2317 list(kid);
25b991bf 2318 kid = sib;
54310121 2319 }
11206fdd 2320 PL_curcop = &PL_compiling;
54310121 2321 break;
748a9306 2322 case OP_SCOPE:
79072805 2323 case OP_LINESEQ:
25b991bf
VP
2324 kid = cLISTOPo->op_first;
2325 goto do_kids;
79072805 2326 }
11343788 2327 return o;
79072805
LW
2328}
2329
1f676739 2330static OP *
2dd5337b 2331S_scalarseq(pTHX_ OP *o)
79072805 2332{
11343788 2333 if (o) {
1496a290
AL
2334 const OPCODE type = o->op_type;
2335
2336 if (type == OP_LINESEQ || type == OP_SCOPE ||
2337 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2338 {
b7bea5da
FC
2339 OP *kid, *sib;
2340 for (kid = cLISTOPo->op_first; kid; kid = sib) {
e6dae479
FC
2341 if ((sib = OpSIBLING(kid))
2342 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
b7bea5da
FC
2343 || ( sib->op_targ != OP_NEXTSTATE
2344 && sib->op_targ != OP_DBSTATE )))
2345 {
463ee0b2 2346 scalarvoid(kid);
ed6116ce 2347 }
463ee0b2 2348 }
3280af22 2349 PL_curcop = &PL_compiling;
79072805 2350 }
11343788 2351 o->op_flags &= ~OPf_PARENS;
3280af22 2352 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2353 o->op_flags |= OPf_PARENS;
79072805 2354 }
8990e307 2355 else
11343788
MB
2356 o = newOP(OP_STUB, 0);
2357 return o;
79072805
LW
2358}
2359
76e3520e 2360STATIC OP *
cea2e8a9 2361S_modkids(pTHX_ OP *o, I32 type)
79072805 2362{
11343788 2363 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2364 OP *kid;
e6dae479 2365 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3ad73efd 2366 op_lvalue(kid, type);
79072805 2367 }
11343788 2368 return o;
79072805
LW
2369}
2370
12ee5d32
DM
2371
2372/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2373 * const fields. Also, convert CONST keys to HEK-in-SVs.
2374 * rop is the op that retrieves the hash;
2375 * key_op is the first key
2376 */
2377
f9db5646 2378STATIC void
fedf30e1 2379S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
12ee5d32
DM
2380{
2381 PADNAME *lexname;
2382 GV **fields;
2383 bool check_fields;
2384
2385 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2386 if (rop) {
2387 if (rop->op_first->op_type == OP_PADSV)
2388 /* @$hash{qw(keys here)} */
2389 rop = (UNOP*)rop->op_first;
2390 else {
2391 /* @{$hash}{qw(keys here)} */
2392 if (rop->op_first->op_type == OP_SCOPE
2393 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2394 {
2395 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2396 }
2397 else
2398 rop = NULL;
2399 }
2400 }
2401
2402 lexname = NULL; /* just to silence compiler warnings */
2403 fields = NULL; /* just to silence compiler warnings */
2404
2405 check_fields =
2406 rop
2407 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2408 SvPAD_TYPED(lexname))
2409 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2410 && isGV(*fields) && GvHV(*fields);
2411
e6dae479 2412 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
12ee5d32
DM
2413 SV **svp, *sv;
2414 if (key_op->op_type != OP_CONST)
2415 continue;
2416 svp = cSVOPx_svp(key_op);
2417
e1ccd220
DIM
2418 /* make sure it's not a bareword under strict subs */
2419 if (key_op->op_private & OPpCONST_BARE &&
2420 key_op->op_private & OPpCONST_STRICT)
2421 {
2422 no_bareword_allowed((OP*)key_op);
2423 }
2424
12ee5d32
DM
2425 /* Make the CONST have a shared SV */
2426 if ( !SvIsCOW_shared_hash(sv = *svp)
2427 && SvTYPE(sv) < SVt_PVMG
2428 && SvOK(sv)
2429 && !SvROK(sv))
2430 {
2431 SSize_t keylen;
2432 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2433 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2434 SvREFCNT_dec_NN(sv);
2435 *svp = nsv;
2436 }
2437
2438 if ( check_fields
2439 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2440 {
147e3846
KW
2441 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2442 "in variable %" PNf " of type %" HEKf,
12ee5d32
DM
2443 SVfARG(*svp), PNfARG(lexname),
2444 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2445 }
2446 }
2447}
2448
2449
3ad73efd 2450/*
d164302a
GG
2451=for apidoc finalize_optree
2452
72d33970
FC
2453This function finalizes the optree. Should be called directly after
2454the complete optree is built. It does some additional
796b6530 2455checking which can't be done in the normal C<ck_>xxx functions and makes
d164302a
GG
2456the tree thread-safe.
2457
2458=cut
2459*/
2460void
2461Perl_finalize_optree(pTHX_ OP* o)
2462{
2463 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2464
2465 ENTER;
2466 SAVEVPTR(PL_curcop);
2467
2468 finalize_op(o);
2469
2470 LEAVE;
2471}
2472
b46e009d 2473#ifdef USE_ITHREADS
2474/* Relocate sv to the pad for thread safety.
2475 * Despite being a "constant", the SV is written to,
2476 * for reference counts, sv_upgrade() etc. */
2477PERL_STATIC_INLINE void
2478S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2479{
2480 PADOFFSET ix;
2481 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2482 if (!*svp) return;
2483 ix = pad_alloc(OP_CONST, SVf_READONLY);
2484 SvREFCNT_dec(PAD_SVl(ix));
2485 PAD_SETSV(ix, *svp);
2486 /* XXX I don't know how this isn't readonly already. */
2487 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2488 *svp = NULL;
2489 *targp = ix;
2490}
2491#endif
2492
2493
60dde6b2 2494STATIC void
d164302a
GG
2495S_finalize_op(pTHX_ OP* o)
2496{
2497 PERL_ARGS_ASSERT_FINALIZE_OP;
2498
68d1ee85 2499 assert(o->op_type != OP_FREED);
d164302a
GG
2500
2501 switch (o->op_type) {
2502 case OP_NEXTSTATE:
2503 case OP_DBSTATE:
2504 PL_curcop = ((COP*)o); /* for warnings */
2505 break;
2506 case OP_EXEC:
e6dae479
FC
2507 if (OpHAS_SIBLING(o)) {
2508 OP *sib = OpSIBLING(o);
1ed44841
DM
2509 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2510 && ckWARN(WARN_EXEC)
e6dae479 2511 && OpHAS_SIBLING(sib))
1ed44841 2512 {
e6dae479 2513 const OPCODE type = OpSIBLING(sib)->op_type;
d164302a
GG
2514 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2515 const line_t oldline = CopLINE(PL_curcop);
1ed44841 2516 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
2517 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2518 "Statement unlikely to be reached");
2519 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2520 "\t(Maybe you meant system() when you said exec()?)\n");
2521 CopLINE_set(PL_curcop, oldline);
2522 }
d164302a 2523 }
1ed44841 2524 }
d164302a
GG
2525 break;
2526
2527 case OP_GV:
2528 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2529 GV * const gv = cGVOPo_gv;
2530 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2531 /* XXX could check prototype here instead of just carping */
2532 SV * const sv = sv_newmortal();
2533 gv_efullname3(sv, gv, NULL);
2534 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
147e3846 2535 "%" SVf "() called too early to check prototype",
d164302a
GG
2536 SVfARG(sv));
2537 }
2538 }
2539 break;
2540
2541 case OP_CONST:
eb796c7f
GG
2542 if (cSVOPo->op_private & OPpCONST_STRICT)
2543 no_bareword_allowed(o);
2544 /* FALLTHROUGH */
d164302a
GG
2545#ifdef USE_ITHREADS
2546 case OP_HINTSEVAL:
b46e009d 2547 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2548#endif
2549 break;
2550
2551#ifdef USE_ITHREADS
2552 /* Relocate all the METHOP's SVs to the pad for thread safety. */
d164302a 2553 case OP_METHOD_NAMED:
7d6c333c 2554 case OP_METHOD_SUPER:
810bd8b7 2555 case OP_METHOD_REDIR:
2556 case OP_METHOD_REDIR_SUPER:
b46e009d 2557 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2558 break;
d164302a 2559#endif
d164302a
GG
2560
2561 case OP_HELEM: {
2562 UNOP *rop;
565e6f7e
FC
2563 SVOP *key_op;
2564 OP *kid;
d164302a 2565
565e6f7e 2566 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
d164302a
GG
2567 break;
2568
2569 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 2570
565e6f7e 2571 goto check_keys;
d164302a 2572
565e6f7e 2573 case OP_HSLICE:
429a2555 2574 S_scalar_slice_warning(aTHX_ o);
c67159e1 2575 /* FALLTHROUGH */
429a2555 2576
c5f75dba 2577 case OP_KVHSLICE:
e6dae479 2578 kid = OpSIBLING(cLISTOPo->op_first);
71323522 2579 if (/* I bet there's always a pushmark... */
7d3c8a68
SM
2580 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2581 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2582 {
d164302a 2583 break;
7d3c8a68 2584 }
565e6f7e
FC
2585
2586 key_op = (SVOP*)(kid->op_type == OP_CONST
2587 ? kid
e6dae479 2588 : OpSIBLING(kLISTOP->op_first));
565e6f7e
FC
2589
2590 rop = (UNOP*)((LISTOP*)o)->op_last;
2591
2592 check_keys:
12ee5d32
DM
2593 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2594 rop = NULL;
fedf30e1 2595 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
d164302a
GG
2596 break;
2597 }
429a2555
FC
2598 case OP_ASLICE:
2599 S_scalar_slice_warning(aTHX_ o);
2600 break;
a7fd8ef6 2601
d164302a
GG
2602 case OP_SUBST: {
2603 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2604 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2605 break;
2606 }
2607 default:
2608 break;
2609 }
2610
2611 if (o->op_flags & OPf_KIDS) {
2612 OP *kid;
c4b20975
DM
2613
2614#ifdef DEBUGGING
20220689 2615 /* check that op_last points to the last sibling, and that
86cd3a13
DM
2616 * the last op_sibling/op_sibparent field points back to the
2617 * parent, and that the only ops with KIDS are those which are
2618 * entitled to them */
c4b20975
DM
2619 U32 type = o->op_type;
2620 U32 family;
20220689 2621 bool has_last;
c4b20975
DM
2622
2623 if (type == OP_NULL) {
2624 type = o->op_targ;
2625 /* ck_glob creates a null UNOP with ex-type GLOB
2626 * (which is a list op. So pretend it wasn't a listop */
2627 if (type == OP_GLOB)
2628 type = OP_NULL;
2629 }
2630 family = PL_opargs[type] & OA_CLASS_MASK;
2631
20220689
DM
2632 has_last = ( family == OA_BINOP
2633 || family == OA_LISTOP
2634 || family == OA_PMOP
2635 || family == OA_LOOP
2636 );
2637 assert( has_last /* has op_first and op_last, or ...
2638 ... has (or may have) op_first: */
2639 || family == OA_UNOP
2f7c6295 2640 || family == OA_UNOP_AUX
20220689
DM
2641 || family == OA_LOGOP
2642 || family == OA_BASEOP_OR_UNOP
2643 || family == OA_FILESTATOP
2644 || family == OA_LOOPEXOP
b46e009d 2645 || family == OA_METHOP
20220689
DM
2646 || type == OP_CUSTOM
2647 || type == OP_NULL /* new_logop does this */
2648 );
20220689 2649
e6dae479 2650 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
29e61fd9 2651# ifdef PERL_OP_PARENT
e6dae479 2652 if (!OpHAS_SIBLING(kid)) {
20220689 2653 if (has_last)
29e61fd9 2654 assert(kid == cLISTOPo->op_last);
86cd3a13 2655 assert(kid->op_sibparent == o);
20220689 2656 }
29e61fd9 2657# else
35a2929b 2658 if (has_last && !OpHAS_SIBLING(kid))
93059c1a 2659 assert(kid == cLISTOPo->op_last);
20220689 2660# endif
c4b20975
DM
2661 }
2662#endif
2663
e6dae479 2664 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
d164302a
GG
2665 finalize_op(kid);
2666 }
2667}
2668
2669/*
3ad73efd
Z
2670=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2671
2672Propagate lvalue ("modifiable") context to an op and its children.
2d7f6611 2673C<type> represents the context type, roughly based on the type of op that
796b6530 2674would do the modifying, although C<local()> is represented by C<OP_NULL>,
3ad73efd 2675because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
2676the lvalue op).
2677
2678This function detects things that can't be modified, such as C<$x+1>, and
72d33970 2679generates errors for them. For example, C<$x+1 = 2> would cause it to be
796b6530 2680called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
001c3c51
FC
2681
2682It also flags things that need to behave specially in an lvalue context,
2683such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
2684
2685=cut
2686*/
ddeae0f1 2687
03414f05
FC
2688static void
2689S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2690{
2691 CV *cv = PL_compcv;
2692 PadnameLVALUE_on(pn);
2693 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2694 cv = CvOUTSIDE(cv);
aea0412a
DM
2695 /* RT #127786: cv can be NULL due to an eval within the DB package
2696 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2697 * unless they contain an eval, but calling eval within DB
2698 * pretends the eval was done in the caller's scope.
2699 */
2700 if (!cv)
2701 break;
03414f05
FC
2702 assert(CvPADLIST(cv));
2703 pn =
2704 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2705 assert(PadnameLEN(pn));
2706 PadnameLVALUE_on(pn);
2707 }
2708}
2709
375879aa
FC
2710static bool
2711S_vivifies(const OPCODE type)
2712{
2713 switch(type) {
2714 case OP_RV2AV: case OP_ASLICE:
2715 case OP_RV2HV: case OP_KVASLICE:
2716 case OP_RV2SV: case OP_HSLICE:
2717 case OP_AELEMFAST: case OP_KVHSLICE:
2718 case OP_HELEM:
2719 case OP_AELEM:
2720 return 1;
2721 }
2722 return 0;
2723}
2724
7664512e 2725static void
63702de8 2726S_lvref(pTHX_ OP *o, I32 type)
7664512e 2727{
727d2dc6 2728 dVAR;
7664512e
FC
2729 OP *kid;
2730 switch (o->op_type) {
2731 case OP_COND_EXPR:
e6dae479
FC
2732 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2733 kid = OpSIBLING(kid))
63702de8 2734 S_lvref(aTHX_ kid, type);
7664512e
FC
2735 /* FALLTHROUGH */
2736 case OP_PUSHMARK:
2737 return;
2738 case OP_RV2AV:
2739 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2740 o->op_flags |= OPf_STACKED;
2741 if (o->op_flags & OPf_PARENS) {
2742 if (o->op_private & OPpLVAL_INTRO) {
7664512e
FC
2743 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2744 "localized parenthesized array in list assignment"));
2745 return;
2746 }
2747 slurpy:
b9a07097 2748 OpTYPE_set(o, OP_LVAVREF);
7664512e
FC
2749 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2750 o->op_flags |= OPf_MOD|OPf_REF;
2751 return;
2752 }
2753 o->op_private |= OPpLVREF_AV;
2754 goto checkgv;
408e9044 2755 case OP_RV2CV:
19abb1ea
FC
2756 kid = cUNOPo->op_first;
2757 if (kid->op_type == OP_NULL)
cb748240 2758 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
408e9044
FC
2759 ->op_first;
2760 o->op_private = OPpLVREF_CV;
2761 if (kid->op_type == OP_GV)
2762 o->op_flags |= OPf_STACKED;
2763 else if (kid->op_type == OP_PADCV) {
2764 o->op_targ = kid->op_targ;
2765 kid->op_targ = 0;
2766 op_free(cUNOPo->op_first);
2767 cUNOPo->op_first = NULL;
2768 o->op_flags &=~ OPf_KIDS;
2769 }
2770 else goto badref;
2771 break;
7664512e
FC
2772 case OP_RV2HV:
2773 if (o->op_flags & OPf_PARENS) {
2774 parenhash:
7664512e
FC
2775 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2776 "parenthesized hash in list assignment"));
2777 return;
2778 }
2779 o->op_private |= OPpLVREF_HV;
2780 /* FALLTHROUGH */
2781 case OP_RV2SV:
2782 checkgv:
2783 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2784 o->op_flags |= OPf_STACKED;
6f5dab3c
FC
2785 break;
2786 case OP_PADHV:
2787 if (o->op_flags & OPf_PARENS) goto parenhash;
2788 o->op_private |= OPpLVREF_HV;
7664512e
FC
2789 /* FALLTHROUGH */
2790 case OP_PADSV:
6f5dab3c 2791 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2792 break;
2793 case OP_PADAV:
6f5dab3c 2794 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2795 if (o->op_flags & OPf_PARENS) goto slurpy;
2796 o->op_private |= OPpLVREF_AV;
2797 break;
7664512e
FC
2798 case OP_AELEM:
2799 case OP_HELEM:
2800 o->op_private |= OPpLVREF_ELEM;
2801 o->op_flags |= OPf_STACKED;
2802 break;
2803 case OP_ASLICE:
2804 case OP_HSLICE:
b9a07097 2805 OpTYPE_set(o, OP_LVREFSLICE);
36efb5a6 2806 o->op_private &= OPpLVAL_INTRO;
7664512e
FC
2807 return;
2808 case OP_NULL:
2809 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2810 goto badref;
2811 else if (!(o->op_flags & OPf_KIDS))
2812 return;
2813 if (o->op_targ != OP_LIST) {
63702de8 2814 S_lvref(aTHX_ cBINOPo->op_first, type);
7664512e
FC
2815 return;
2816 }
2817 /* FALLTHROUGH */
2818 case OP_LIST:
e6dae479 2819 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
7664512e 2820 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
63702de8 2821 S_lvref(aTHX_ kid, type);
7664512e
FC
2822 }
2823 return;
2824 case OP_STUB:
2825 if (o->op_flags & OPf_PARENS)
2826 return;
2827 /* FALLTHROUGH */
2828 default:
2829 badref:
cf6e1fa1 2830 /* diag_listed_as: Can't modify reference to %s in %s assignment */
63702de8 2831 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
7664512e
FC
2832 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2833 ? "do block"
63702de8
FC
2834 : OP_DESC(o),
2835 PL_op_desc[type]));
2b6a5bfb 2836 return;
7664512e 2837 }
b9a07097 2838 OpTYPE_set(o, OP_LVREF);
3ad7d304
FC
2839 o->op_private &=
2840 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
d39c26a6
FC
2841 if (type == OP_ENTERLOOP)
2842 o->op_private |= OPpLVREF_ITER;
7664512e
FC
2843}
2844
1a3e9724
FC
2845PERL_STATIC_INLINE bool
2846S_potential_mod_type(I32 type)
2847{
2848 /* Types that only potentially result in modification. */
2849 return type == OP_GREPSTART || type == OP_ENTERSUB
2850 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2851}
2852
79072805 2853OP *
d3d7d28f 2854Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2855{
27da23d5 2856 dVAR;
79072805 2857 OP *kid;
ddeae0f1
DM
2858 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2859 int localize = -1;
79072805 2860
13765c85 2861 if (!o || (PL_parser && PL_parser->error_count))
11343788 2862 return o;
79072805 2863
b162f9ea 2864 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2865 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2866 {
b162f9ea 2867 return o;
7e363e51 2868 }
1c846c1f 2869
5c906035
GG
2870 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2871
69974ce6
FC
2872 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2873
11343788 2874 switch (o->op_type) {
68dc0745 2875 case OP_UNDEF:
3280af22 2876 PL_modcount++;
5dc0d613 2877 return o;
5f05dabc 2878 case OP_STUB:
b5bbe64a 2879 if ((o->op_flags & OPf_PARENS))
5f05dabc
PP
2880 break;
2881 goto nomod;
a0d0e21e 2882 case OP_ENTERSUB:
f79aa60b 2883 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788 2884 !(o->op_flags & OPf_STACKED)) {
b9a07097 2885 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2886 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2887 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
2888 break;
2889 }
cd06dffe 2890 else { /* lvalue subroutine call */
9411a3c7 2891 o->op_private |= OPpLVAL_INTRO;
e6438c1a 2892 PL_modcount = RETURN_UNLIMITED_NUMBER;
1a3e9724 2893 if (S_potential_mod_type(type)) {
cd06dffe
GS
2894 o->op_private |= OPpENTERSUB_INARGS;
2895 break;
2896 }
2897 else { /* Compile-time error message: */
2898 OP *kid = cUNOPo->op_first;
2899 CV *cv;
2eaf799e 2900 GV *gv;
0f948285 2901 SV *namesv;
cd06dffe 2902
3ea285d1
AL
2903 if (kid->op_type != OP_PUSHMARK) {
2904 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2905 Perl_croak(aTHX_
2906 "panic: unexpected lvalue entersub "
147e3846 2907 "args: type/targ %ld:%" UVuf,
3ea285d1
AL
2908 (long)kid->op_type, (UV)kid->op_targ);
2909 kid = kLISTOP->op_first;
2910 }
e6dae479
FC
2911 while (OpHAS_SIBLING(kid))
2912 kid = OpSIBLING(kid);
cd06dffe 2913 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2914 break; /* Postpone until runtime */
2915 }
b2ffa427 2916
cd06dffe
GS
2917 kid = kUNOP->op_first;
2918 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2919 kid = kUNOP->op_first;
b2ffa427 2920 if (kid->op_type == OP_NULL)
cd06dffe
GS
2921 Perl_croak(aTHX_
2922 "Unexpected constant lvalue entersub "
147e3846 2923 "entry via type/targ %ld:%" UVuf,
3d811634 2924 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2925 if (kid->op_type != OP_GV) {
cd06dffe
GS
2926 break;
2927 }
b2ffa427 2928
2eaf799e
FC
2929 gv = kGVOP_gv;
2930 cv = isGV(gv)
2931 ? GvCV(gv)
2932 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2933 ? MUTABLE_CV(SvRV(gv))
2934 : NULL;
1c846c1f 2935 if (!cv)
da1dff94 2936 break;
cd06dffe
GS
2937 if (CvLVALUE(cv))
2938 break;
0f948285
DIM
2939 if (flags & OP_LVALUE_NO_CROAK)
2940 return NULL;
2941
2942 namesv = cv_name(cv, NULL, 0);
2943 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
147e3846 2944 "subroutine call of &%" SVf " in %s",
0f948285
DIM
2945 SVfARG(namesv), PL_op_desc[type]),
2946 SvUTF8(namesv));
2947 return o;
cd06dffe
GS
2948 }
2949 }
924ba076 2950 /* FALLTHROUGH */
79072805 2951 default:
a0d0e21e 2952 nomod:
f5d552b4 2953 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2954 /* grep, foreach, subcalls, refgen */
1a3e9724 2955 if (S_potential_mod_type(type))
a0d0e21e 2956 break;
cea2e8a9 2957 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2958 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe 2959 ? "do block"
0f948285 2960 : OP_DESC(o)),
22c35a8c 2961 type ? PL_op_desc[type] : "local"));
11343788 2962 return o;
79072805 2963
a0d0e21e
LW
2964 case OP_PREINC:
2965 case OP_PREDEC:
2966 case OP_POW:
2967 case OP_MULTIPLY:
2968 case OP_DIVIDE:
2969 case OP_MODULO:
a0d0e21e
LW
2970 case OP_ADD:
2971 case OP_SUBTRACT:
2972 case OP_CONCAT:
2973 case OP_LEFT_SHIFT:
2974 case OP_RIGHT_SHIFT:
2975 case OP_BIT_AND:
2976 case OP_BIT_XOR:
2977 case OP_BIT_OR:
2978 case OP_I_MULTIPLY:
2979 case OP_I_DIVIDE:
2980 case OP_I_MODULO:
2981 case OP_I_ADD:
2982 case OP_I_SUBTRACT:
11343788 2983 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2984 goto nomod;
3280af22 2985 PL_modcount++;
a0d0e21e 2986 break;
b2ffa427 2987
82209a5d
FC
2988 case OP_REPEAT:
2989 if (o->op_flags & OPf_STACKED) {
2990 PL_modcount++;
2991 break;
2992 }
ff781254 2993 if (!(o->op_private & OPpREPEAT_DOLIST))
82209a5d
FC
2994 goto nomod;
2995 else {
2996 const I32 mods = PL_modcount;
ff781254
FC
2997 modkids(cBINOPo->op_first, type);
2998 if (type != OP_AASSIGN)
2999 goto nomod;
5e462669 3000 kid = cBINOPo->op_last;
82209a5d 3001 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
565e104c 3002 const IV iv = SvIV(kSVOP_sv);
82209a5d
FC
3003 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3004 PL_modcount =
3005 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3006 }
3007 else
3008 PL_modcount = RETURN_UNLIMITED_NUMBER;
3009 }
3010 break;
3011
79072805 3012 case OP_COND_EXPR:
ddeae0f1 3013 localize = 1;
e6dae479 3014 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3ad73efd 3015 op_lvalue(kid, type);
79072805
LW
3016 break;
3017
3018 case OP_RV2AV:
3019 case OP_RV2HV:
11343788 3020 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 3021 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 3022 return o; /* Treat \(@foo) like ordinary list. */
748a9306 3023 }
924ba076 3024 /* FALLTHROUGH */
79072805 3025 case OP_RV2GV:
5dc0d613 3026 if (scalar_mod_type(o, type))
3fe9a6f1 3027 goto nomod;
11343788 3028 ref(cUNOPo->op_first, o->op_type);
924ba076 3029 /* FALLTHROUGH */
79072805
LW
3030 case OP_ASLICE:
3031 case OP_HSLICE:
ddeae0f1 3032 localize = 1;
924ba076 3033 /* FALLTHROUGH */
78f9721b 3034 case OP_AASSIGN:
32cbae3f
FC
3035 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3036 if (type == OP_LEAVESUBLV && (
3037 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3038 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3039 ))
631dbaa2 3040 o->op_private |= OPpMAYBE_LVSUB;
924ba076 3041 /* FALLTHROUGH */
93a17b20
LW
3042 case OP_NEXTSTATE:
3043 case OP_DBSTATE:
e6438c1a 3044 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 3045 break;
5cae3edb 3046 case OP_KVHSLICE:
6dd3e0f2 3047 case OP_KVASLICE:
738155d2 3048 case OP_AKEYS:
5cae3edb
RZ
3049 if (type == OP_LEAVESUBLV)
3050 o->op_private |= OPpMAYBE_LVSUB;
3051 goto nomod;
cd642408
FC
3052 case OP_AVHVSWITCH:
3053 if (type == OP_LEAVESUBLV
3054 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3055 o->op_private |= OPpMAYBE_LVSUB;
3056 goto nomod;
28c5b5bc
RGS
3057 case OP_AV2ARYLEN:
3058 PL_hints |= HINT_BLOCK_SCOPE;
3059 if (type == OP_LEAVESUBLV)
3060 o->op_private |= OPpMAYBE_LVSUB;
3061 PL_modcount++;
3062 break;
463ee0b2 3063 case OP_RV2SV:
aeea060c 3064 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 3065 localize = 1;
924ba076 3066 /* FALLTHROUGH */
79072805 3067 case OP_GV:
3280af22 3068 PL_hints |= HINT_BLOCK_SCOPE;
924ba076 3069 /* FALLTHROUGH */
463ee0b2 3070 case OP_SASSIGN:
bf4b1e52
GS
3071 case OP_ANDASSIGN:
3072 case OP_ORASSIGN:
c963b151 3073 case OP_DORASSIGN:
ddeae0f1
DM
3074 PL_modcount++;
3075 break;
3076
8990e307 3077 case OP_AELEMFAST:
93bad3fd 3078 case OP_AELEMFAST_LEX:
6a077020 3079 localize = -1;
3280af22 3080 PL_modcount++;
8990e307
LW
3081 break;
3082
748a9306
LW
3083 case OP_PADAV:
3084 case OP_PADHV:
e6438c1a 3085 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
3086 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3087 return o; /* Treat \(@foo) like ordinary list. */
3088 if (scalar_mod_type(o, type))
3fe9a6f1 3089 goto nomod;
32cbae3f
FC
3090 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3091 && type == OP_LEAVESUBLV)
78f9721b 3092 o->op_private |= OPpMAYBE_LVSUB;
924ba076 3093 /* FALLTHROUGH */
748a9306 3094 case OP_PADSV:
3280af22 3095 PL_modcount++;
ddeae0f1 3096 if (!type) /* local() */
147e3846 3097 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
ea9a9e77 3098 PNfARG(PAD_COMPNAME(o->op_targ)));
e4211fee
FC
3099 if (!(o->op_private & OPpLVAL_INTRO)
3100 || ( type != OP_SASSIGN && type != OP_AASSIGN
3101 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
03414f05 3102 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
3103 break;
3104
748a9306 3105 case OP_PUSHMARK:
ddeae0f1 3106 localize = 0;
748a9306 3107 break;
b2ffa427 3108
69969c6f 3109 case OP_KEYS:
e4fc7082 3110 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
69969c6f 3111 goto nomod;
5d82c453
GA
3112 goto lvalue_func;
3113 case OP_SUBSTR:
3114 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3115 goto nomod;
924ba076 3116 /* FALLTHROUGH */
a0d0e21e 3117 case OP_POS:
463ee0b2 3118 case OP_VEC:
fad4a2e4 3119 lvalue_func:
78f9721b
SM
3120 if (type == OP_LEAVESUBLV)
3121 o->op_private |= OPpMAYBE_LVSUB;
79409ac8
FC
3122 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3123 /* substr and vec */
3124 /* If this op is in merely potential (non-fatal) modifiable
33a10326
FC
3125 context, then apply OP_ENTERSUB context to
3126 the kid op (to avoid croaking). Other-
79409ac8
FC
3127 wise pass this op’s own type so the correct op is mentioned
3128 in error messages. */
3129 op_lvalue(OpSIBLING(cBINOPo->op_first),
33a10326 3130 S_potential_mod_type(type)
ee4b19b9 3131 ? (I32)OP_ENTERSUB
33a10326 3132 : o->op_type);
79409ac8 3133 }
463ee0b2 3134 break;
a0d0e21e 3135
463ee0b2
LW
3136 case OP_AELEM:
3137 case OP_HELEM:
11343788 3138 ref(cBINOPo->op_first, o->op_type);
68dc0745 3139 if (type == OP_ENTERSUB &&
5dc0d613
MB
3140 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3141 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
3142 if (type == OP_LEAVESUBLV)
3143 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 3144 localize = 1;
3280af22 3145 PL_modcount++;
463ee0b2
LW
3146 break;
3147
463ee0b2 3148 case OP_LEAVE:
a373464f 3149 case OP_LEAVELOOP:
2ec7f6f2 3150 o->op_private |= OPpLVALUE;
924ba076 3151 /* FALLTHROUGH */
2ec7f6f2 3152 case OP_SCOPE:
463ee0b2 3153 case OP_ENTER:
78f9721b 3154 case OP_LINESEQ:
ddeae0f1 3155 localize = 0;
11343788 3156 if (o->op_flags & OPf_KIDS)
3ad73efd 3157 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
3158 break;
3159
3160 case OP_NULL:
ddeae0f1 3161 localize = 0;
638bc118
GS
3162 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3163 goto nomod;
3164 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 3165 break;
11343788 3166 if (o->op_targ != OP_LIST) {
3ad73efd 3167 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
3168 break;
3169 }
924ba076 3170 /* FALLTHROUGH */
463ee0b2 3171 case OP_LIST:
ddeae0f1 3172 localize = 0;
e6dae479 3173 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5c906035
GG
3174 /* elements might be in void context because the list is
3175 in scalar context or because they are attribute sub calls */
3176 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3177 op_lvalue(kid, type);
463ee0b2 3178 break;
78f9721b 3179
1efec5ed
FC
3180 case OP_COREARGS:
3181 return o;
2ec7f6f2
FC
3182
3183 case OP_AND:
3184 case OP_OR:
375879aa
FC
3185 if (type == OP_LEAVESUBLV
3186 || !S_vivifies(cLOGOPo->op_first->op_type))
3187 op_lvalue(cLOGOPo->op_first, type);
3188 if (type == OP_LEAVESUBLV
e6dae479
FC
3189 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3190 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
2ec7f6f2 3191 goto nomod;
26a50d99
FC
3192
3193 case OP_SREFGEN:
e118fea3
FC
3194 if (type == OP_NULL) { /* local */
3195 local_refgen:
37690136
FC
3196 if (!FEATURE_MYREF_IS_ENABLED)
3197 Perl_croak(aTHX_ "The experimental declared_refs "
3198 "feature is not enabled");
3199 Perl_ck_warner_d(aTHX_
3200 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8fde4f03 3201 "Declaring references is experimental");
e118fea3
FC
3202 op_lvalue(cUNOPo->op_first, OP_NULL);
3203 return o;
3204 }
d39c26a6
FC
3205 if (type != OP_AASSIGN && type != OP_SASSIGN
3206 && type != OP_ENTERLOOP)
3207 goto nomod;
7664512e 3208 /* Don’t bother applying lvalue context to the ex-list. */
26a50d99 3209 kid = cUNOPx(cUNOPo->op_first)->op_first;
e6dae479 3210 assert (!OpHAS_SIBLING(kid));
217e3565
FC
3211 goto kid_2lvref;
3212 case OP_REFGEN:
e118fea3
FC
3213 if (type == OP_NULL) /* local */
3214 goto local_refgen;
217e3565 3215 if (type != OP_AASSIGN) goto nomod;
7664512e
FC
3216 kid = cUNOPo->op_first;
3217 kid_2lvref:
3218 {
3219 const U8 ec = PL_parser ? PL_parser->error_count : 0;
63702de8 3220 S_lvref(aTHX_ kid, type);
7664512e 3221 if (!PL_parser || PL_parser->error_count == ec) {
baabe3fb 3222 if (!FEATURE_REFALIASING_IS_ENABLED)
7664512e 3223 Perl_croak(aTHX_
baabe3fb 3224 "Experimental aliasing via reference not enabled");
7664512e 3225 Perl_ck_warner_d(aTHX_
baabe3fb
FC
3226 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3227 "Aliasing via reference is experimental");
7664512e
FC
3228 }
3229 }
217e3565
FC
3230 if (o->op_type == OP_REFGEN)
3231 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3232 op_null(o);
26a50d99 3233 return o;
e4e95921
FC
3234
3235 case OP_SPLIT:
5012eebe 3236 if ((o->op_private & OPpSPLIT_ASSIGN)) {
e4e95921
FC
3237 /* This is actually @array = split. */
3238 PL_modcount = RETURN_UNLIMITED_NUMBER;
3239 break;
3240 }
3241 goto nomod;
569ddb4a
FC
3242
3243 case OP_SCALAR:
3244 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3245 goto nomod;
463ee0b2 3246 }
58d95175 3247
4fe48737 3248 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
8be1be90
AMS
3249 their argument is a filehandle; thus \stat(".") should not set
3250 it. AMS 20011102 */
3251 if (type == OP_REFGEN &&
ef69c8fc 3252 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
3253 return o;
3254
3255 if (type != OP_LEAVESUBLV)
3256 o->op_flags |= OPf_MOD;
3257
3258 if (type == OP_AASSIGN || type == OP_SASSIGN)
f441d7d2
FC
3259 o->op_flags |= OPf_SPECIAL
3260 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
ddeae0f1
DM
3261 else if (!type) { /* local() */
3262 switch (localize) {
3263 case 1:
3264 o->op_private |= OPpLVAL_INTRO;
3265 o->op_flags &= ~OPf_SPECIAL;
3266 PL_hints |= HINT_BLOCK_SCOPE;
3267 break;
3268 case 0:
3269 break;
3270 case -1:
a2a5de95
NC
3271 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3272 "Useless localization of %s", OP_DESC(o));
ddeae0f1 3273 }
463ee0b2 3274 }
8be1be90 3275 else if (type != OP_GREPSTART && type != OP_ENTERSUB
f441d7d2 3276 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
8be1be90 3277 o->op_flags |= OPf_REF;
11343788 3278 return o;
463ee0b2
LW
3279}
3280
864dbfa3 3281STATIC bool
5f66b61c 3282S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
3283{
3284 switch (type) {
32a60974 3285 case OP_POS:
3fe9a6f1 3286 case OP_SASSIGN:
1efec5ed 3287 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 3288 return FALSE;
924ba076 3289 /* FALLTHROUGH */
3fe9a6f1
PP
3290 case OP_PREINC:
3291 case OP_PREDEC:
3292 case OP_POSTINC:
3293 case OP_POSTDEC:
3294 case OP_I_PREINC:
3295 case OP_I_PREDEC:
3296 case OP_I_POSTINC:
3297 case OP_I_POSTDEC:
3298 case OP_POW:
3299 case OP_MULTIPLY:
3300 case OP_DIVIDE:
3301 case OP_MODULO:
3302 case OP_REPEAT:
3303 case OP_ADD:
3304 case OP_SUBTRACT:
3305 case OP_I_MULTIPLY:
3306 case OP_I_DIVIDE:
3307 case OP_I_MODULO:
3308 case OP_I_ADD:
3309 case OP_I_SUBTRACT:
3310 case OP_LEFT_SHIFT:
3311 case OP_RIGHT_SHIFT:
3312 case OP_BIT_AND:
3313 case OP_BIT_XOR:
3314 case OP_BIT_OR:
76734a32
FC
3315 case OP_NBIT_AND:
3316 case OP_NBIT_XOR:
3317 case OP_NBIT_OR:
3318 case OP_SBIT_AND:
3319 case OP_SBIT_XOR:
3320 case OP_SBIT_OR:
3fe9a6f1
PP
3321 case OP_CONCAT:
3322 case OP_SUBST:
3323 case OP_TRANS:
bb16bae8 3324 case OP_TRANSR:
49e9fbe6
GS
3325 case OP_READ:
3326 case OP_SYSREAD:
3327 case OP_RECV:
bf4b1e52
GS
3328 case OP_ANDASSIGN:
3329 case OP_ORASSIGN:
410d09fe 3330 case OP_DORASSIGN:
79409ac8
FC
3331 case OP_VEC:
3332 case OP_SUBSTR:
3fe9a6f1
PP
3333 return TRUE;
3334 default:
3335 return FALSE;
3336 }
3337}
3338
35cd451c 3339STATIC bool
5f66b61c 3340S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 3341{
7918f24d
NC
3342 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3343
35cd451c
GS
3344 switch (o->op_type) {
3345 case OP_PIPE_OP:
3346 case OP_SOCKPAIR:
504618e9 3347 if (numargs == 2)
35cd451c 3348 return TRUE;
924ba076 3349 /* FALLTHROUGH */
35cd451c
GS
3350 case OP_SYSOPEN:
3351 case OP_OPEN:
ded8aa31 3352 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
3353 case OP_SOCKET:
3354 case OP_OPEN_DIR:
3355 case OP_ACCEPT:
504618e9 3356 if (numargs == 1)
35cd451c 3357 return TRUE;
5f66b61c 3358 /* FALLTHROUGH */
35cd451c
GS
3359 default:
3360 return FALSE;
3361 }
3362}
3363
0d86688d
NC
3364static OP *
3365S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 3366{
11343788 3367 if (o && o->op_flags & OPf_KIDS) {
6867be6d 3368 OP *kid;
e6dae479 3369 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
463ee0b2
LW
3370 ref(kid, type);
3371 }
11343788 3372 return o;
463ee0b2
LW
3373}
3374
3375OP *
e4c5ccf3 3376Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 3377{
27da23d5 3378 dVAR;
463ee0b2 3379 OP *kid;
463ee0b2 3380
7918f24d
NC
3381 PERL_ARGS_ASSERT_DOREF;
3382
3dc78631 3383 if (PL_parser && PL_parser->error_count)
11343788 3384 return o;
463ee0b2 3385
11343788 3386 switch (o->op_type) {
a0d0e21e 3387 case OP_ENTERSUB:
f4df43b5 3388 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788 3389 !(o->op_flags & OPf_STACKED)) {
b9a07097 3390 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 3391 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 3392 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 3393 o->op_flags |= OPf_SPECIAL;
8990e307 3394 }
767eda44 3395 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
3396 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3397 : type == OP_RV2HV ? OPpDEREF_HV
3398 : OPpDEREF_SV);
767eda44
FC
3399 o->op_flags |= OPf_MOD;
3400 }
3401
8990e307 3402 break;
aeea060c 3403
463ee0b2 3404 case OP_COND_EXPR:
e6dae479 3405 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
e4c5ccf3 3406 doref(kid, type, set_op_ref);
463ee0b2 3407 break;
8990e307 3408 case OP_RV2SV:
35cd451c
GS
3409 if (type == OP_DEFINED)
3410 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3411 doref(cUNOPo->op_first, o->op_type, set_op_ref);
924ba076 3412 /* FALLTHROUGH */
4633a7c4 3413 case OP_PADSV:
5f05dabc 3414 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3415 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3416 : type == OP_RV2HV ? OPpDEREF_HV
3417 : OPpDEREF_SV);
11343788 3418 o->op_flags |= OPf_MOD;
a0d0e21e 3419 }
8990e307 3420 break;
1c846c1f 3421
463ee0b2
LW
3422 case OP_RV2AV:
3423 case OP_RV2HV:
e4c5ccf3
RH
3424 if (set_op_ref)
3425 o->op_flags |= OPf_REF;
924ba076 3426 /* FALLTHROUGH */
463ee0b2 3427 case OP_RV2GV:
35cd451c
GS
3428 if (type == OP_DEFINED)
3429 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3430 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 3431 break;
8990e307 3432
463ee0b2
LW
3433 case OP_PADAV:
3434 case OP_PADHV:
e4c5ccf3
RH
3435 if (set_op_ref)
3436 o->op_flags |= OPf_REF;
79072805 3437 break;
aeea060c 3438
8990e307 3439 case OP_SCALAR:
79072805 3440 case OP_NULL:
518618af 3441 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 3442 break;
e4c5ccf3 3443 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
3444 break;
3445 case OP_AELEM:
3446 case OP_HELEM:
e4c5ccf3 3447 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 3448 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3449 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3450 : type == OP_RV2HV ? OPpDEREF_HV
3451 : OPpDEREF_SV);
11343788 3452 o->op_flags |= OPf_MOD;
8990e307 3453 }
79072805
LW
3454 break;
3455
463ee0b2 3456 case OP_SCOPE:
79072805 3457 case OP_LEAVE:
e4c5ccf3 3458 set_op_ref = FALSE;
924ba076 3459 /* FALLTHROUGH */
79072805 3460 case OP_ENTER:
8990e307 3461 case OP_LIST:
11343788 3462 if (!(o->op_flags & OPf_KIDS))
79072805 3463 break;
e4c5ccf3 3464 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 3465 break;
a0d0e21e
LW
3466 default:
3467 break;
79072805 3468 }
11343788 3469 return scalar(o);
8990e307 3470
79072805
LW
3471}
3472
09bef843
SB
3473STATIC OP *
3474S_dup_attrlist(pTHX_ OP *o)
3475{
0bd48802 3476 OP *rop;
09bef843 3477
7918f24d
NC
3478 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3479
09bef843
SB
3480 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3481 * where the first kid is OP_PUSHMARK and the remaining ones
3482 * are OP_CONST. We need to push the OP_CONST values.
3483 */
3484 if (o->op_type == OP_CONST)
b37c2d43 3485 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
09bef843
SB
3486 else {
3487 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 3488 rop = NULL;
e6dae479 3489 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
09bef843 3490 if (o->op_type == OP_CONST)
2fcb4757 3491 rop = op_append_elem(OP_LIST, rop,
09bef843 3492 newSVOP(OP_CONST, o->op_flags,
b37c2d43 3493 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
3494 }
3495 }
3496 return rop;
3497}
3498
3499STATIC void
ad0dc73b 3500S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 3501{
7918f24d 3502 PERL_ARGS_ASSERT_APPLY_ATTRS;
976258ec
JH
3503 {
3504 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
7918f24d 3505
976258ec 3506 /* fake up C<use attributes $pkg,$rv,@attrs> */
e4783991 3507
09bef843 3508#define ATTRSMODULE "attributes"
95f0a2f1
SB
3509#define ATTRSMODULE_PM "attributes.pm"
3510
976258ec
JH
3511 Perl_load_module(
3512 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3513 newSVpvs(ATTRSMODULE),
3514 NULL,
3515 op_prepend_elem(OP_LIST,
3516 newSVOP(OP_CONST, 0, stashsv),
3517 op_prepend_elem(OP_LIST,
3518 newSVOP(OP_CONST, 0,
3519 newRV(target)),
3520 dup_attrlist(attrs))));
3521 }
09bef843
SB
3522}
3523
95f0a2f1
SB
3524STATIC void
3525S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3526{
3527 OP *pack, *imop, *arg;
ad0dc73b 3528 SV *meth, *stashsv, **svp;
95f0a2f1 3529
7918f24d
NC
3530 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3531
95f0a2f1
SB
3532 if (!attrs)
3533 return;
3534
3535 assert(target->op_type == OP_PADSV ||
3536 target->op_type == OP_PADHV ||
3537 target->op_type == OP_PADAV);
3538
3539 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
3540 /* Don't force the C<use> if we don't need it. */
3541 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3542 if (svp && *svp != &PL_sv_undef)
3543 NOOP; /* already in %INC */
3544 else
3545 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3546 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
3547
3548 /* Need package name for method call. */
6136c704 3549 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
3550
3551 /* Build up the real arg-list. */
976258ec 3552 stashsv = newSVhek(HvNAME_HEK(stash));
5aaec2b4 3553
95f0a2f1
SB
3554 arg = newOP(OP_PADSV, 0);
3555 arg->op_targ = target->op_targ;
2fcb4757 3556 arg = op_prepend_elem(OP_LIST,
95f0a2f1 3557 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 3558 op_prepend_elem(OP_LIST,
95f0a2f1 3559 newUNOP(OP_REFGEN, 0,
a282984d 3560 arg),
95f0a2f1
SB
3561 dup_attrlist(attrs)));
3562
3563 /* Fake up a method call to import */
18916d0d 3564 meth = newSVpvs_share("import");
03d05f6e 3565 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757 3566 op_append_elem(OP_LIST,
6aa68307 3567 op_prepend_elem(OP_LIST, pack, arg),
b46e009d 3568 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
3569
3570 /* Combine the ops. */
2fcb4757 3571 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
3572}
3573
3574/*
3575=notfor apidoc apply_attrs_string
3576
3577Attempts to apply a list of attributes specified by the C<attrstr> and
3578C<len> arguments to the subroutine identified by the C<cv> argument which
3579is expected to be associated with the package identified by the C<stashpv>
3580argument (see L<attributes>). It gets this wrong, though, in that it
3581does not correctly identify the boundaries of the individual attribute
3582specifications within C<attrstr>. This is not really intended for the
3583public API, but has to be listed here for systems such as AIX which
3584need an explicit export list for symbols. (It's called from XS code
3585in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3586to respect attribute syntax properly would be welcome.
3587
3588=cut
3589*/
3590
be3174d2 3591void
6867be6d
AL
3592Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3593 const char *attrstr, STRLEN len)
be3174d2 3594{
5f66b61c 3595 OP *attrs = NULL;
be3174d2 3596
7918f24d
NC
3597 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3598
be3174d2
GS
3599 if (!len) {
3600 len = strlen(attrstr);
3601 }
3602
3603 while (len) {
3604 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3605 if (len) {
890ce7af 3606 const char * const sstr = attrstr;
be3174d2 3607 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 3608 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
3609 newSVOP(OP_CONST, 0,
3610 newSVpvn(sstr, attrstr-sstr)));
3611 }
3612 }
3613
3614 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 3615 newSVpvs(ATTRSMODULE),
2fcb4757 3616 NULL, op_prepend_elem(OP_LIST,
be3174d2 3617 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 3618 op_prepend_elem(OP_LIST,
be3174d2 3619 newSVOP(OP_CONST, 0,
ad64d0ec 3620 newRV(MUTABLE_SV(cv))),
be3174d2
GS
3621 attrs)));
3622}
3623
eedb00fa
PM
3624STATIC void
3625S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3626{
3627 OP *new_proto = NULL;
3628 STRLEN pvlen;
3629 char *pv;
3630 OP *o;
3631
3632 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3633
3634 if (!*attrs)
3635 return;
3636
3637 o = *attrs;
3638 if (o->op_type == OP_CONST) {
3639 pv = SvPV(cSVOPo_sv, pvlen);
3640 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3641 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3642 SV ** const tmpo = cSVOPx_svp(o);
3643 SvREFCNT_dec(cSVOPo_sv);
3644 *tmpo = tmpsv;
3645 new_proto = o;
3646 *attrs = NULL;
3647 }
3648 } else if (o->op_type == OP_LIST) {
e78bc664 3649 OP * lasto;
eedb00fa 3650 assert(o->op_flags & OPf_KIDS);
e78bc664
PM
3651 lasto = cLISTOPo->op_first;
3652 assert(lasto->op_type == OP_PUSHMARK);
e6dae479 3653 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
eedb00fa
PM
3654 if (o->op_type == OP_CONST) {
3655 pv = SvPV(cSVOPo_sv, pvlen);
3656 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3657 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3658 SV ** const tmpo = cSVOPx_svp(o);
3659 SvREFCNT_dec(cSVOPo_sv);
3660 *tmpo = tmpsv;
3661 if (new_proto && ckWARN(WARN_MISC)) {
3662 STRLEN new_len;
3663 const char * newp = SvPV(cSVOPo_sv, new_len);
3664 Perl_warner(aTHX_ packWARN(WARN_MISC),
147e3846 3665 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
eedb00fa
PM
3666 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3667 op_free(new_proto);
3668 }
3669 else if (new_proto)
3670 op_free(new_proto);
3671 new_proto = o;
3253bf85
DM
3672 /* excise new_proto from the list */
3673 op_sibling_splice(*attrs, lasto, 1, NULL);
3674 o = lasto;
eedb00fa
PM
3675 continue;
3676 }
3677 }
3678 lasto = o;
3679 }
3680 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3681 would get pulled in with no real need */
e6dae479 3682 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
eedb00fa
PM
3683 op_free(*attrs);
3684 *attrs = NULL;
3685 }
3686 }
3687
3688 if (new_proto) {
3689 SV *svname;
3690 if (isGV(name)) {
3691 svname = sv_newmortal();
3692 gv_efullname3(svname, name, NULL);
3693 }
3694 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')