This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_newASSIGNOP: fix on g++ builds
[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
BF
624
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_
35c1215d 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);
4d494880 856#ifdef DEBUG_LEAKING_SCALARS
0997db6f
TC
857 if (PL_op == o)
858 PL_op = NULL;
4d494880 859#endif
aa9d1253 860 } while ( (o = POP_DEFERRED_OP()) );
0997db6f
TC
861
862 Safefree(defer_stack);
acb36ea4 863}
79072805 864
ab576797
DM
865/* S_op_clear_gv(): free a GV attached to an OP */
866
f9db5646 867STATIC
ab576797
DM
868#ifdef USE_ITHREADS
869void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
870#else
871void S_op_clear_gv(pTHX_ OP *o, SV**svp)
872#endif
873{
874
fedf30e1
DM
875 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
876 || o->op_type == OP_MULTIDEREF)
ab576797
DM
877#ifdef USE_ITHREADS
878 && PL_curpad
879 ? ((GV*)PAD_SVl(*ixp)) : NULL;
880#else
881 ? (GV*)(*svp) : NULL;
882#endif
883 /* It's possible during global destruction that the GV is freed
884 before the optree. Whilst the SvREFCNT_inc is happy to bump from
885 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
886 will trigger an assertion failure, because the entry to sv_clear
887 checks that the scalar is not already freed. A check of for
888 !SvIS_FREED(gv) turns out to be invalid, because during global
889 destruction the reference count can be forced down to zero
890 (with SVf_BREAK set). In which case raising to 1 and then
891 dropping to 0 triggers cleanup before it should happen. I
892 *think* that this might actually be a general, systematic,
893 weakness of the whole idea of SVf_BREAK, in that code *is*
894 allowed to raise and lower references during global destruction,
895 so any *valid* code that happens to do this during global
896 destruction might well trigger premature cleanup. */
897 bool still_valid = gv && SvREFCNT(gv);
898
899 if (still_valid)
900 SvREFCNT_inc_simple_void(gv);
901#ifdef USE_ITHREADS
902 if (*ixp > 0) {
903 pad_swipe(*ixp, TRUE);
904 *ixp = 0;
905 }
906#else
907 SvREFCNT_dec(*svp);
908 *svp = NULL;
909#endif
910 if (still_valid) {
911 int try_downgrade = SvREFCNT(gv) == 2;
912 SvREFCNT_dec_NN(gv);
913 if (try_downgrade)
914 gv_try_downgrade(gv);
915 }
916}
917
918
93c66552
DM
919void
920Perl_op_clear(pTHX_ OP *o)
acb36ea4 921{
13137afc 922
27da23d5 923 dVAR;
7918f24d
NC
924
925 PERL_ARGS_ASSERT_OP_CLEAR;
926
11343788 927 switch (o->op_type) {
acb36ea4 928 case OP_NULL: /* Was holding old type, if any. */
c67159e1 929 /* FALLTHROUGH */
4d193d44 930 case OP_ENTERTRY:
acb36ea4 931 case OP_ENTEREVAL: /* Was holding hints. */
4fa06845 932 case OP_ARGDEFELEM: /* Was holding signature index. */
acb36ea4 933 o->op_targ = 0;
a0d0e21e 934 break;
a6006777 935 default:
ac4c12e7 936 if (!(o->op_flags & OPf_REF)
ef69c8fc 937 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 938 break;
924ba076 939 /* FALLTHROUGH */
463ee0b2 940 case OP_GVSV:
79072805 941 case OP_GV:
a6006777 942 case OP_AELEMFAST:
f7461760 943#ifdef USE_ITHREADS
ab576797 944 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
350de78d 945#else
ab576797 946 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
350de78d 947#endif
79072805 948 break;
810bd8b7 949 case OP_METHOD_REDIR:
950 case OP_METHOD_REDIR_SUPER:
951#ifdef USE_ITHREADS
952 if (cMETHOPx(o)->op_rclass_targ) {
953 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
954 cMETHOPx(o)->op_rclass_targ = 0;
955 }
956#else
957 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
958 cMETHOPx(o)->op_rclass_sv = NULL;
959#endif
a1ae71d2 960 case OP_METHOD_NAMED:
7d6c333c 961 case OP_METHOD_SUPER:
b46e009d 962 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
963 cMETHOPx(o)->op_u.op_meth_sv = NULL;
964#ifdef USE_ITHREADS
965 if (o->op_targ) {
966 pad_swipe(o->op_targ, 1);
967 o->op_targ = 0;
968 }
969#endif
970 break;
79072805 971 case OP_CONST:
996c9baa 972 case OP_HINTSEVAL:
11343788 973 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 974 cSVOPo->op_sv = NULL;
3b1c21fa
AB
975#ifdef USE_ITHREADS
976 /** Bug #15654
977 Even if op_clear does a pad_free for the target of the op,
6a077020 978 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
979 instead it lives on. This results in that it could be reused as
980 a target later on when the pad was reallocated.
981 **/
982 if(o->op_targ) {
983 pad_swipe(o->op_targ,1);
984 o->op_targ = 0;
985 }
986#endif
79072805 987 break;
c9df4fda 988 case OP_DUMP:
748a9306
LW
989 case OP_GOTO:
990 case OP_NEXT:
991 case OP_LAST:
992 case OP_REDO:
11343788 993 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306 994 break;
924ba076 995 /* FALLTHROUGH */
a0d0e21e 996 case OP_TRANS:
bb16bae8 997 case OP_TRANSR:
acb36ea4 998 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 999 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM
1000#ifdef USE_ITHREADS
1001 if (cPADOPo->op_padix > 0) {
1002 pad_swipe(cPADOPo->op_padix, TRUE);
1003 cPADOPo->op_padix = 0;
1004 }
1005#else
a0ed51b3 1006 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 1007 cSVOPo->op_sv = NULL;
043e41b8 1008#endif
acb36ea4
GS
1009 }
1010 else {
ea71c68d 1011 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 1012 cPVOPo->op_pv = NULL;
acb36ea4 1013 }
a0d0e21e
LW
1014 break;
1015 case OP_SUBST:
20e98b0f 1016 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 1017 goto clear_pmop;
5012eebe
DM
1018
1019 case OP_SPLIT:
692044df
DM
1020 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1021 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
5012eebe
DM
1022 {
1023 if (o->op_private & OPpSPLIT_LEX)
1024 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1025 else
971a9dd3 1026#ifdef USE_ITHREADS
5012eebe 1027 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3 1028#else
5012eebe 1029 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3 1030#endif
5012eebe 1031 }
924ba076 1032 /* FALLTHROUGH */
a0d0e21e 1033 case OP_MATCH:
8782bef2 1034 case OP_QR:
7b52d656 1035 clear_pmop:
867940b8
DM
1036 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1037 op_free(cPMOPo->op_code_list);
68e2671b 1038 cPMOPo->op_code_list = NULL;
23083432 1039 forget_pmop(cPMOPo);
20e98b0f 1040 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC
1041 /* we use the same protection as the "SAFE" version of the PM_ macros
1042 * here since sv_clean_all might release some PMOPs
5f8cb046
DM
1043 * after PL_regex_padav has been cleared
1044 * and the clearing of PL_regex_padav needs to
1045 * happen before sv_clean_all
1046 */
13137afc
AB
1047#ifdef USE_ITHREADS
1048 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 1049 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 1050 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC
1051 PL_regex_pad[offset] = &PL_sv_undef;
1052 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1053 sizeof(offset));
13137afc 1054 }
9cddf794
NC
1055#else
1056 ReREFCNT_dec(PM_GETRE(cPMOPo));
1057 PM_SETRE(cPMOPo, NULL);
1eb1540c 1058#endif
13137afc 1059
a0d0e21e 1060 break;
fedf30e1 1061
4fa06845
DM
1062 case OP_ARGCHECK:
1063 PerlMemShared_free(cUNOP_AUXo->op_aux);
1064 break;
1065
fedf30e1
DM
1066 case OP_MULTIDEREF:
1067 {
1068 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1069 UV actions = items->uv;
1070 bool last = 0;
1071 bool is_hash = FALSE;
1072
1073 while (!last) {
1074 switch (actions & MDEREF_ACTION_MASK) {
1075
1076 case MDEREF_reload:
1077 actions = (++items)->uv;
1078 continue;
1079
1080 case MDEREF_HV_padhv_helem:
1081 is_hash = TRUE;
1082 case MDEREF_AV_padav_aelem:
1083 pad_free((++items)->pad_offset);
1084 goto do_elem;
1085
1086 case MDEREF_HV_gvhv_helem:
1087 is_hash = TRUE;
1088 case MDEREF_AV_gvav_aelem:
1089#ifdef USE_ITHREADS
1090 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1091#else
1092 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1093#endif
1094 goto do_elem;
1095
1096 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1097 is_hash = TRUE;
1098 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1099#ifdef USE_ITHREADS
1100 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1101#else
1102 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1103#endif
1104 goto do_vivify_rv2xv_elem;
1105
1106 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1107 is_hash = TRUE;
1108 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1109 pad_free((++items)->pad_offset);
1110 goto do_vivify_rv2xv_elem;
1111
1112 case MDEREF_HV_pop_rv2hv_helem:
1113 case MDEREF_HV_vivify_rv2hv_helem:
1114 is_hash = TRUE;
1115 do_vivify_rv2xv_elem:
1116 case MDEREF_AV_pop_rv2av_aelem:
1117 case MDEREF_AV_vivify_rv2av_aelem:
1118 do_elem:
1119 switch (actions & MDEREF_INDEX_MASK) {
1120 case MDEREF_INDEX_none:
1121 last = 1;
1122 break;
1123 case MDEREF_INDEX_const:
1124 if (is_hash) {
1125#ifdef USE_ITHREADS
1126 /* see RT #15654 */
1127 pad_swipe((++items)->pad_offset, 1);
1128#else
1129 SvREFCNT_dec((++items)->sv);
1130#endif
1131 }
1132 else
1133 items++;
1134 break;
1135 case MDEREF_INDEX_padsv:
1136 pad_free((++items)->pad_offset);
1137 break;
1138 case MDEREF_INDEX_gvsv:
1139#ifdef USE_ITHREADS
1140 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1141#else
1142 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1143#endif
1144 break;
1145 }
1146
1147 if (actions & MDEREF_FLAG_last)
1148 last = 1;
1149 is_hash = FALSE;
1150
1151 break;
1152
1153 default:
1154 assert(0);
1155 last = 1;
1156 break;
1157
1158 } /* switch */
1159
1160 actions >>= MDEREF_SHIFT;
1161 } /* while */
1162
1163 /* start of malloc is at op_aux[-1], where the length is
1164 * stored */
1165 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1166 }
1167 break;
79072805
LW
1168 }
1169
743e66e6 1170 if (o->op_targ > 0) {
11343788 1171 pad_free(o->op_targ);
743e66e6
GS
1172 o->op_targ = 0;
1173 }
79072805
LW
1174}
1175
76e3520e 1176STATIC void
3eb57f73
HS
1177S_cop_free(pTHX_ COP* cop)
1178{
7918f24d
NC
1179 PERL_ARGS_ASSERT_COP_FREE;
1180
05ec9bb3 1181 CopFILE_free(cop);
0453d815 1182 if (! specialWARN(cop->cop_warnings))
72dc9ed5 1183 PerlMemShared_free(cop->cop_warnings);
20439bc7 1184 cophh_free(CopHINTHASH_get(cop));
515abc43
FC
1185 if (PL_curcop == cop)
1186 PL_curcop = NULL;
3eb57f73
HS
1187}
1188
c2b1997a 1189STATIC void
c4bd3ae5 1190S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 1191 )
c2b1997a
NC
1192{
1193 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
1194
1195 PERL_ARGS_ASSERT_FORGET_PMOP;
1196
e39a6381 1197 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 1198 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
1199 if (mg) {
1200 PMOP **const array = (PMOP**) mg->mg_ptr;
1201 U32 count = mg->mg_len / sizeof(PMOP**);
1202 U32 i = count;
1203
1204 while (i--) {
1205 if (array[i] == o) {
1206 /* Found it. Move the entry at the end to overwrite it. */
1207 array[i] = array[--count];
1208 mg->mg_len = count * sizeof(PMOP**);
1209 /* Could realloc smaller at this point always, but probably
1210 not worth it. Probably worth free()ing if we're the
1211 last. */
1212 if(!count) {
1213 Safefree(mg->mg_ptr);
1214 mg->mg_ptr = NULL;
1215 }
1216 break;
1217 }
1218 }
1219 }
1220 }
1cdf7faf
NC
1221 if (PL_curpm == o)
1222 PL_curpm = NULL;
c2b1997a
NC
1223}
1224
bfd0ff22
NC
1225STATIC void
1226S_find_and_forget_pmops(pTHX_ OP *o)
1227{
7918f24d
NC
1228 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1229
bfd0ff22
NC
1230 if (o->op_flags & OPf_KIDS) {
1231 OP *kid = cUNOPo->op_first;
1232 while (kid) {
1233 switch (kid->op_type) {
1234 case OP_SUBST:
5012eebe 1235 case OP_SPLIT:
bfd0ff22
NC
1236 case OP_MATCH:
1237 case OP_QR:
23083432 1238 forget_pmop((PMOP*)kid);
bfd0ff22
NC
1239 }
1240 find_and_forget_pmops(kid);
e6dae479 1241 kid = OpSIBLING(kid);
bfd0ff22
NC
1242 }
1243 }
1244}
1245
6e53b6ca
DD
1246/*
1247=for apidoc Am|void|op_null|OP *o
1248
1249Neutralizes an op when it is no longer needed, but is still linked to from
1250other ops.
1251
1252=cut
1253*/
1254
93c66552
DM
1255void
1256Perl_op_null(pTHX_ OP *o)
8990e307 1257{
27da23d5 1258 dVAR;
7918f24d
NC
1259
1260 PERL_ARGS_ASSERT_OP_NULL;
1261
acb36ea4
GS
1262 if (o->op_type == OP_NULL)
1263 return;
b5bbe64a 1264 op_clear(o);
11343788 1265 o->op_targ = o->op_type;
b9a07097 1266 OpTYPE_set(o, OP_NULL);
8990e307
LW
1267}
1268
4026c95a
SH
1269void
1270Perl_op_refcnt_lock(pTHX)
e1fc825d 1271 PERL_TSA_ACQUIRE(PL_op_mutex)
4026c95a 1272{
20b7effb 1273#ifdef USE_ITHREADS
27da23d5 1274 dVAR;
20b7effb 1275#endif
96a5add6 1276 PERL_UNUSED_CONTEXT;
4026c95a
SH
1277 OP_REFCNT_LOCK;
1278}
1279
1280void
1281Perl_op_refcnt_unlock(pTHX)
e1fc825d 1282 PERL_TSA_RELEASE(PL_op_mutex)
4026c95a 1283{
20b7effb 1284#ifdef USE_ITHREADS
27da23d5 1285 dVAR;
20b7effb 1286#endif
96a5add6 1287 PERL_UNUSED_CONTEXT;
4026c95a
SH
1288 OP_REFCNT_UNLOCK;
1289}
1290
3253bf85
DM
1291
1292/*
1293=for apidoc op_sibling_splice
1294
1295A general function for editing the structure of an existing chain of
796b6530 1296op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
3253bf85
DM
1297you to delete zero or more sequential nodes, replacing them with zero or
1298more different nodes. Performs the necessary op_first/op_last
29e61fd9 1299housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1300children. The last deleted node will be marked as as the last node by
87b5a8b9 1301updating the op_sibling/op_sibparent or op_moresib field as appropriate.
3253bf85
DM
1302
1303Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1304responsibility of the caller. It also won't create a new list op for an
8ae26bff 1305empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85 1306
796b6530 1307C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
3269ea41 1308the splicing doesn't affect the first or last op in the chain.
3253bf85 1309
796b6530 1310C<start> is the node preceding the first node to be spliced. Node(s)
7e234f81 1311following it will be deleted, and ops will be inserted after it. If it is
796b6530 1312C<NULL>, the first node onwards is deleted, and nodes are inserted at the
3253bf85
DM
1313beginning.
1314
796b6530 1315C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1316If -1 or greater than or equal to the number of remaining kids, all
1317remaining kids are deleted.
1318
796b6530
KW
1319C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1320If C<NULL>, no nodes are inserted.
3253bf85 1321
796b6530 1322The head of the chain of deleted ops is returned, or C<NULL> if no ops were
3253bf85
DM
1323deleted.
1324
1325For example:
1326
1327 action before after returns
1328 ------ ----- ----- -------
1329
1330 P P
8ae26bff
DM
1331 splice(P, A, 2, X-Y-Z) | | B-C
1332 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1333
1334 P P
1335 splice(P, NULL, 1, X-Y) | | A
1336 A-B-C-D X-Y-B-C-D
1337
1338 P P
8ae26bff
DM
1339 splice(P, NULL, 3, NULL) | | A-B-C
1340 A-B-C-D D
3253bf85
DM
1341
1342 P P
1343 splice(P, B, 0, X-Y) | | NULL
1344 A-B-C-D A-B-X-Y-C-D
1345
5e24af7d
DM
1346
1347For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
fbe13c60 1348see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
5e24af7d 1349
3253bf85
DM
1350=cut
1351*/
1352
1353OP *
8ae26bff 1354Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1355{
3269ea41 1356 OP *first;
3253bf85
DM
1357 OP *rest;
1358 OP *last_del = NULL;
1359 OP *last_ins = NULL;
1360
3269ea41
DM
1361 if (start)
1362 first = OpSIBLING(start);
1363 else if (!parent)
1364 goto no_parent;
1365 else
1366 first = cLISTOPx(parent)->op_first;
3253bf85
DM
1367
1368 assert(del_count >= -1);
1369
1370 if (del_count && first) {
1371 last_del = first;
e6dae479
FC
1372 while (--del_count && OpHAS_SIBLING(last_del))
1373 last_del = OpSIBLING(last_del);
1374 rest = OpSIBLING(last_del);
5e24af7d 1375 OpLASTSIB_set(last_del, NULL);
3253bf85
DM
1376 }
1377 else
1378 rest = first;
1379
1380 if (insert) {
1381 last_ins = insert;
e6dae479
FC
1382 while (OpHAS_SIBLING(last_ins))
1383 last_ins = OpSIBLING(last_ins);
5e24af7d 1384 OpMAYBESIB_set(last_ins, rest, NULL);
3253bf85
DM
1385 }
1386 else
1387 insert = rest;
1388
29e61fd9 1389 if (start) {
5e24af7d 1390 OpMAYBESIB_set(start, insert, NULL);
29e61fd9 1391 }
b3e29a8d 1392 else {
3269ea41
DM
1393 if (!parent)
1394 goto no_parent;
3253bf85 1395 cLISTOPx(parent)->op_first = insert;
b3e29a8d
DM
1396 if (insert)
1397 parent->op_flags |= OPf_KIDS;
1398 else
1399 parent->op_flags &= ~OPf_KIDS;
1400 }
3253bf85
DM
1401
1402 if (!rest) {
29e61fd9 1403 /* update op_last etc */
3269ea41 1404 U32 type;
29e61fd9 1405 OP *lastop;
3253bf85 1406
3269ea41
DM
1407 if (!parent)
1408 goto no_parent;
1409
05039abd
DM
1410 /* ought to use OP_CLASS(parent) here, but that can't handle
1411 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1412 * either */
3269ea41 1413 type = parent->op_type;
05039abd
DM
1414 if (type == OP_CUSTOM) {
1415 dTHX;
1416 type = XopENTRYCUSTOM(parent, xop_class);
1417 }
1418 else {
1419 if (type == OP_NULL)
1420 type = parent->op_targ;
1421 type = PL_opargs[type] & OA_CLASS_MASK;
1422 }
3253bf85 1423
29e61fd9 1424 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1425 if ( type == OA_BINOP
1426 || type == OA_LISTOP
1427 || type == OA_PMOP
1428 || type == OA_LOOP
1429 )
29e61fd9
DM
1430 cLISTOPx(parent)->op_last = lastop;
1431
5e24af7d
DM
1432 if (lastop)
1433 OpLASTSIB_set(lastop, parent);
3253bf85
DM
1434 }
1435 return last_del ? first : NULL;
3269ea41
DM
1436
1437 no_parent:
1438 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
3253bf85
DM
1439}
1440
3269ea41 1441
1fafe688
DM
1442#ifdef PERL_OP_PARENT
1443
29e61fd9
DM
1444/*
1445=for apidoc op_parent
1446
796b6530 1447Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1fafe688 1448This function is only available on perls built with C<-DPERL_OP_PARENT>.
29e61fd9
DM
1449
1450=cut
1451*/
1452
1453OP *
8ae26bff 1454Perl_op_parent(OP *o)
29e61fd9
DM
1455{
1456 PERL_ARGS_ASSERT_OP_PARENT;
e6dae479
FC
1457 while (OpHAS_SIBLING(o))
1458 o = OpSIBLING(o);
86cd3a13 1459 return o->op_sibparent;
29e61fd9
DM
1460}
1461
1fafe688
DM
1462#endif
1463
3253bf85
DM
1464
1465/* replace the sibling following start with a new UNOP, which becomes
1466 * the parent of the original sibling; e.g.
1467 *
1468 * op_sibling_newUNOP(P, A, unop-args...)
1469 *
1470 * P P
1471 * | becomes |
1472 * A-B-C A-U-C
1473 * |
1474 * B
1475 *
1476 * where U is the new UNOP.
1477 *
1478 * parent and start args are the same as for op_sibling_splice();
1479 * type and flags args are as newUNOP().
1480 *
1481 * Returns the new UNOP.
1482 */
1483
f9db5646 1484STATIC OP *
3253bf85
DM
1485S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1486{
1487 OP *kid, *newop;
1488
1489 kid = op_sibling_splice(parent, start, 1, NULL);
1490 newop = newUNOP(type, flags, kid);
1491 op_sibling_splice(parent, start, 0, newop);
1492 return newop;
1493}
1494
1495
1496/* lowest-level newLOGOP-style function - just allocates and populates
1497 * the struct. Higher-level stuff should be done by S_new_logop() /
1498 * newLOGOP(). This function exists mainly to avoid op_first assignment
1499 * being spread throughout this file.
1500 */
1501
6cb4123e
DM
1502LOGOP *
1503Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
3253bf85 1504{
1e8db68a 1505 dVAR;
3253bf85 1506 LOGOP *logop;
29e61fd9 1507 OP *kid = first;
3253bf85 1508 NewOp(1101, logop, 1, LOGOP);
b9a07097 1509 OpTYPE_set(logop, type);
3253bf85
DM
1510 logop->op_first = first;
1511 logop->op_other = other;
1512 logop->op_flags = OPf_KIDS;
e6dae479
FC
1513 while (kid && OpHAS_SIBLING(kid))
1514 kid = OpSIBLING(kid);
5e24af7d
DM
1515 if (kid)
1516 OpLASTSIB_set(kid, (OP*)logop);
3253bf85
DM
1517 return logop;
1518}
1519
1520
79072805
LW
1521/* Contextualizers */
1522
d9088386
Z
1523/*
1524=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1525
1526Applies a syntactic context to an op tree representing an expression.
2d7f6611 1527C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
d9088386
Z
1528or C<G_VOID> to specify the context to apply. The modified op tree
1529is returned.
1530
1531=cut
1532*/
1533
1534OP *
1535Perl_op_contextualize(pTHX_ OP *o, I32 context)
1536{
1537 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1538 switch (context) {
1539 case G_SCALAR: return scalar(o);
1540 case G_ARRAY: return list(o);
1541 case G_VOID: return scalarvoid(o);
1542 default:
5637ef5b
NC
1543 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1544 (long) context);
d9088386
Z
1545 }
1546}
1547
5983a79d 1548/*
79072805 1549
5983a79d 1550=for apidoc Am|OP*|op_linklist|OP *o
72d33970 1551This function is the implementation of the L</LINKLIST> macro. It should
5983a79d
BM
1552not be called directly.
1553
1554=cut
1555*/
1556
1557OP *
1558Perl_op_linklist(pTHX_ OP *o)
79072805 1559{
3edf23ff 1560 OP *first;
79072805 1561
5983a79d 1562 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1563
11343788
MB
1564 if (o->op_next)
1565 return o->op_next;
79072805
LW
1566
1567 /* establish postfix order */
3edf23ff
AL
1568 first = cUNOPo->op_first;
1569 if (first) {
eb578fdb 1570 OP *kid;
3edf23ff
AL
1571 o->op_next = LINKLIST(first);
1572 kid = first;
1573 for (;;) {
e6dae479 1574 OP *sibl = OpSIBLING(kid);
29e61fd9
DM
1575 if (sibl) {
1576 kid->op_next = LINKLIST(sibl);
1577 kid = sibl;
3edf23ff 1578 } else {
11343788 1579 kid->op_next = o;
3edf23ff
AL
1580 break;
1581 }
79072805
LW
1582 }
1583 }
1584 else
11343788 1585 o->op_next = o;
79072805 1586
11343788 1587 return o->op_next;
79072805
LW
1588}
1589
1f676739 1590static OP *
2dd5337b 1591S_scalarkids(pTHX_ OP *o)
79072805 1592{
11343788 1593 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1594 OP *kid;
e6dae479 1595 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
1596 scalar(kid);
1597 }
11343788 1598 return o;
79072805
LW
1599}
1600
76e3520e 1601STATIC OP *
cea2e8a9 1602S_scalarboolean(pTHX_ OP *o)
8990e307 1603{
7918f24d
NC
1604 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1605
0a44e30b
DC
1606 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1607 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1608 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1609 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1610 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
d008e5eb 1611 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1612 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1613
2b7cddde
NC
1614 if (PL_parser && PL_parser->copline != NOLINE) {
1615 /* This ensures that warnings are reported at the first line
1616 of the conditional, not the last. */
53a7735b 1617 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1618 }
9014280d 1619 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1620 CopLINE_set(PL_curcop, oldline);
d008e5eb 1621 }
a0d0e21e 1622 }
11343788 1623 return scalar(o);
8990e307
LW
1624}
1625
0920b7fa 1626static SV *
637494ac 1627S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
0920b7fa
FC
1628{
1629 assert(o);
1630 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1631 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1632 {
1633 const char funny = o->op_type == OP_PADAV
1634 || o->op_type == OP_RV2AV ? '@' : '%';
1635 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1636 GV *gv;
1637 if (cUNOPo->op_first->op_type != OP_GV
1638 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1639 return NULL;
637494ac 1640 return varname(gv, funny, 0, NULL, 0, subscript_type);
0920b7fa
FC
1641 }
1642 return
637494ac 1643 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
0920b7fa
FC
1644 }
1645}
1646
637494ac
TC
1647static SV *
1648S_op_varname(pTHX_ const OP *o)
1649{
1650 return S_op_varname_subscript(aTHX_ o, 1);
1651}
1652
429a2555 1653static void
2186f873
FC
1654S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1655{ /* or not so pretty :-) */
2186f873
FC
1656 if (o->op_type == OP_CONST) {
1657 *retsv = cSVOPo_sv;
1658 if (SvPOK(*retsv)) {
1659 SV *sv = *retsv;
1660 *retsv = sv_newmortal();
1661 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1662 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1663 }
1664 else if (!SvOK(*retsv))
1665 *retpv = "undef";
1666 }
1667 else *retpv = "...";
1668}
1669
1670static void
429a2555
FC
1671S_scalar_slice_warning(pTHX_ const OP *o)
1672{
1673 OP *kid;
1674 const char lbrack =
2186f873 1675 o->op_type == OP_HSLICE ? '{' : '[';
429a2555 1676 const char rbrack =
2186f873 1677 o->op_type == OP_HSLICE ? '}' : ']';
429a2555 1678 SV *name;
32e9ec8f 1679 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC
1680 const char *key = NULL;
1681
1682 if (!(o->op_private & OPpSLICEWARNING))
1683 return;
1684 if (PL_parser && PL_parser->error_count)
1685 /* This warning can be nonsensical when there is a syntax error. */
1686 return;
1687
1688 kid = cLISTOPo->op_first;
e6dae479 1689 kid = OpSIBLING(kid); /* get past pushmark */
429a2555
FC
1690 /* weed out false positives: any ops that can return lists */
1691 switch (kid->op_type) {
1692 case OP_BACKTICK:
1693 case OP_GLOB:
1694 case OP_READLINE:
1695 case OP_MATCH:
1696 case OP_RV2AV:
1697 case OP_EACH:
1698 case OP_VALUES:
1699 case OP_KEYS:
1700 case OP_SPLIT:
1701 case OP_LIST:
1702 case OP_SORT:
1703 case OP_REVERSE:
1704 case OP_ENTERSUB:
1705 case OP_CALLER:
1706 case OP_LSTAT:
1707 case OP_STAT:
1708 case OP_READDIR:
1709 case OP_SYSTEM:
1710 case OP_TMS:
1711 case OP_LOCALTIME:
1712 case OP_GMTIME:
1713 case OP_ENTEREVAL:
429a2555
FC
1714 return;
1715 }
7d3c8a68
SM
1716
1717 /* Don't warn if we have a nulled list either. */
1718 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1719 return;
1720
e6dae479
FC
1721 assert(OpSIBLING(kid));
1722 name = S_op_varname(aTHX_ OpSIBLING(kid));
429a2555
FC
1723 if (!name) /* XS module fiddling with the op tree */
1724 return;
2186f873 1725 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC
1726 assert(SvPOK(name));
1727 sv_chop(name,SvPVX(name)+1);
1728 if (key)
2186f873 1729 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1730 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1731 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
429a2555 1732 "%c%s%c",
2186f873 1733 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC
1734 lbrack, key, rbrack);
1735 else
2186f873 1736 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1737 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1738 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
429a2555 1739 SVf"%c%"SVf"%c",
c1f6cd39
BF
1740 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1741 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
429a2555
FC
1742}
1743
8990e307 1744OP *
864dbfa3 1745Perl_scalar(pTHX_ OP *o)
79072805
LW
1746{
1747 OP *kid;
1748
a0d0e21e 1749 /* assumes no premature commitment */
13765c85
DM
1750 if (!o || (PL_parser && PL_parser->error_count)
1751 || (o->op_flags & OPf_WANT)
5dc0d613 1752 || o->op_type == OP_RETURN)
7e363e51 1753 {
11343788 1754 return o;
7e363e51 1755 }
79072805 1756
5dc0d613 1757 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1758
11343788 1759 switch (o->op_type) {
79072805 1760 case OP_REPEAT:
11343788 1761 scalar(cBINOPo->op_first);
82e4f303
FC
1762 if (o->op_private & OPpREPEAT_DOLIST) {
1763 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1764 assert(kid->op_type == OP_PUSHMARK);
e6dae479 1765 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
82e4f303
FC
1766 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1767 o->op_private &=~ OPpREPEAT_DOLIST;
1768 }
1769 }
8990e307 1770 break;
79072805
LW
1771 case OP_OR:
1772 case OP_AND:
1773 case OP_COND_EXPR:
e6dae479 1774 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
8990e307 1775 scalar(kid);
79072805 1776 break;
924ba076 1777 /* FALLTHROUGH */
a6d8037e 1778 case OP_SPLIT:
79072805 1779 case OP_MATCH:
8782bef2 1780 case OP_QR:
79072805
LW
1781 case OP_SUBST:
1782 case OP_NULL:
8990e307 1783 default:
11343788 1784 if (o->op_flags & OPf_KIDS) {
e6dae479 1785 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
8990e307
LW
1786 scalar(kid);
1787 }
79072805
LW
1788 break;
1789 case OP_LEAVE:
1790 case OP_LEAVETRY:
5dc0d613 1791 kid = cLISTOPo->op_first;
54310121 1792 scalar(kid);
e6dae479 1793 kid = OpSIBLING(kid);
25b991bf
VP
1794 do_kids:
1795 while (kid) {
e6dae479 1796 OP *sib = OpSIBLING(kid);
34b54951 1797 if (sib && kid->op_type != OP_LEAVEWHEN
e6dae479 1798 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
34b54951
FC
1799 || ( sib->op_targ != OP_NEXTSTATE
1800 && sib->op_targ != OP_DBSTATE )))
c08f093b
VP
1801 scalarvoid(kid);
1802 else
54310121 1803 scalar(kid);
25b991bf 1804 kid = sib;
54310121 1805 }
11206fdd 1806 PL_curcop = &PL_compiling;
54310121 1807 break;
748a9306 1808 case OP_SCOPE:
79072805 1809 case OP_LINESEQ:
8990e307 1810 case OP_LIST:
25b991bf
VP
1811 kid = cLISTOPo->op_first;
1812 goto do_kids;
a801c63c 1813 case OP_SORT:
a2a5de95 1814 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1815 break;
95a31aad
FC
1816 case OP_KVHSLICE:
1817 case OP_KVASLICE:
2186f873
FC
1818 {
1819 /* Warn about scalar context */
1820 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1821 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1822 SV *name;
1823 SV *keysv;
1824 const char *key = NULL;
1825
1826 /* This warning can be nonsensical when there is a syntax error. */
1827 if (PL_parser && PL_parser->error_count)
1828 break;
1829
1830 if (!ckWARN(WARN_SYNTAX)) break;
1831
1832 kid = cLISTOPo->op_first;
e6dae479
FC
1833 kid = OpSIBLING(kid); /* get past pushmark */
1834 assert(OpSIBLING(kid));
1835 name = S_op_varname(aTHX_ OpSIBLING(kid));
2186f873
FC
1836 if (!name) /* XS module fiddling with the op tree */
1837 break;
1838 S_op_pretty(aTHX_ kid, &keysv, &key);
1839 assert(SvPOK(name));
1840 sv_chop(name,SvPVX(name)+1);
1841 if (key)
1842 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1843 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1844 "%%%"SVf"%c%s%c in scalar context better written "
1845 "as $%"SVf"%c%s%c",
1846 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1847 lbrack, key, rbrack);
1848 else
1849 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1850 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1851 "%%%"SVf"%c%"SVf"%c in scalar context better "
1852 "written as $%"SVf"%c%"SVf"%c",
c1f6cd39
BF
1853 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1854 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2186f873 1855 }
79072805 1856 }
11343788 1857 return o;
79072805
LW
1858}
1859
1860OP *
aa9d1253 1861Perl_scalarvoid(pTHX_ OP *arg)
79072805 1862{
27da23d5 1863 dVAR;
79072805 1864 OP *kid;
8990e307 1865 SV* sv;
2ebea0a1 1866 U8 want;
aa9d1253
TC
1867 SSize_t defer_stack_alloc = 0;
1868 SSize_t defer_ix = -1;
1869 OP **defer_stack = NULL;
1870 OP *o = arg;
2ebea0a1 1871
7918f24d
NC
1872 PERL_ARGS_ASSERT_SCALARVOID;
1873
aa9d1253
TC
1874 do {
1875 SV *useless_sv = NULL;
1876 const char* useless = NULL;
1877
26f0e7d5
TC
1878 if (o->op_type == OP_NEXTSTATE
1879 || o->op_type == OP_DBSTATE
1880 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1881 || o->op_targ == OP_DBSTATE)))
1882 PL_curcop = (COP*)o; /* for warning below */
1883
1884 /* assumes no premature commitment */
1885 want = o->op_flags & OPf_WANT;
1886 if ((want && want != OPf_WANT_SCALAR)
1887 || (PL_parser && PL_parser->error_count)
1888 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1889 {
1890 continue;
1891 }
1c846c1f 1892
26f0e7d5
TC
1893 if ((o->op_private & OPpTARGET_MY)
1894 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1895 {
0d18dd72
FC
1896 /* newASSIGNOP has already applied scalar context, which we
1897 leave, as if this op is inside SASSIGN. */
26f0e7d5
TC
1898 continue;
1899 }
79072805 1900
26f0e7d5 1901 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
75068674 1902
26f0e7d5
TC
1903 switch (o->op_type) {
1904 default:
1905 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1906 break;
1907 /* FALLTHROUGH */
1908 case OP_REPEAT:
1909 if (o->op_flags & OPf_STACKED)
1910 break;
1e2dd519
FC
1911 if (o->op_type == OP_REPEAT)
1912 scalar(cBINOPo->op_first);
26f0e7d5
TC
1913 goto func_ops;
1914 case OP_SUBSTR:
1915 if (o->op_private == 4)
1916 break;
1917 /* FALLTHROUGH */
26f0e7d5
TC
1918 case OP_WANTARRAY:
1919 case OP_GV:
1920 case OP_SMARTMATCH:
26f0e7d5
TC
1921 case OP_AV2ARYLEN:
1922 case OP_REF:
1923 case OP_REFGEN:
1924 case OP_SREFGEN:
1925 case OP_DEFINED:
1926 case OP_HEX:
1927 case OP_OCT:
1928 case OP_LENGTH:
1929 case OP_VEC:
1930 case OP_INDEX:
1931 case OP_RINDEX:
1932 case OP_SPRINTF:
26f0e7d5 1933 case OP_KVASLICE:
26f0e7d5
TC
1934 case OP_KVHSLICE:
1935 case OP_UNPACK:
1936 case OP_PACK:
1937 case OP_JOIN:
1938 case OP_LSLICE:
1939 case OP_ANONLIST:
1940 case OP_ANONHASH:
1941 case OP_SORT:
1942 case OP_REVERSE:
1943 case OP_RANGE:
1944 case OP_FLIP:
1945 case OP_FLOP:
1946 case OP_CALLER:
1947 case OP_FILENO:
1948 case OP_EOF:
1949 case OP_TELL:
1950 case OP_GETSOCKNAME:
1951 case OP_GETPEERNAME:
1952 case OP_READLINK:
1953 case OP_TELLDIR:
1954 case OP_GETPPID:
1955 case OP_GETPGRP:
1956 case OP_GETPRIORITY:
1957 case OP_TIME:
1958 case OP_TMS:
1959 case OP_LOCALTIME:
1960 case OP_GMTIME:
1961 case OP_GHBYNAME:
1962 case OP_GHBYADDR:
1963 case OP_GHOSTENT:
1964 case OP_GNBYNAME:
1965 case OP_GNBYADDR:
1966 case OP_GNETENT:
1967 case OP_GPBYNAME:
1968 case OP_GPBYNUMBER:
1969 case OP_GPROTOENT:
1970 case OP_GSBYNAME:
1971 case OP_GSBYPORT:
1972 case OP_GSERVENT:
1973 case OP_GPWNAM:
1974 case OP_GPWUID:
1975 case OP_GGRNAM:
1976 case OP_GGRGID:
1977 case OP_GETLOGIN:
1978 case OP_PROTOTYPE:
1979 case OP_RUNCV:
1980 func_ops:
9e209402
FC
1981 useless = OP_DESC(o);
1982 break;
1983
1984 case OP_GVSV:
1985 case OP_PADSV:
1986 case OP_PADAV:
1987 case OP_PADHV:
1988 case OP_PADANY:
1989 case OP_AELEM:
1990 case OP_AELEMFAST:
1991 case OP_AELEMFAST_LEX:
1992 case OP_ASLICE:
1993 case OP_HELEM:
1994 case OP_HSLICE:
26f0e7d5 1995 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
ea5519d6 1996 /* Otherwise it's "Useless use of grep iterator" */
3c3f8cd6 1997 useless = OP_DESC(o);
ea5519d6 1998 break;
26f0e7d5
TC
1999
2000 case OP_SPLIT:
5012eebe 2001 if (!(o->op_private & OPpSPLIT_ASSIGN))
26f0e7d5
TC
2002 useless = OP_DESC(o);
2003 break;
2004
2005 case OP_NOT:
2006 kid = cUNOPo->op_first;
2007 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2008 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2009 goto func_ops;
2010 }
2011 useless = "negative pattern binding (!~)";
2012 break;
2013
2014 case OP_SUBST:
2015 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2016 useless = "non-destructive substitution (s///r)";
2017 break;
2018
2019 case OP_TRANSR:
2020 useless = "non-destructive transliteration (tr///r)";
2021 break;
2022
2023 case OP_RV2GV:
2024 case OP_RV2SV:
2025 case OP_RV2AV:
2026 case OP_RV2HV:
2027 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
e6dae479 2028 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
26f0e7d5
TC
2029 useless = "a variable";
2030 break;
2031
2032 case OP_CONST:
2033 sv = cSVOPo_sv;
2034 if (cSVOPo->op_private & OPpCONST_STRICT)
2035 no_bareword_allowed(o);
2036 else {
2037 if (ckWARN(WARN_VOID)) {
2038 NV nv;
2039 /* don't warn on optimised away booleans, eg
2040 * use constant Foo, 5; Foo || print; */
2041 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2042 useless = NULL;
2043 /* the constants 0 and 1 are permitted as they are
2044 conventionally used as dummies in constructs like
2045 1 while some_condition_with_side_effects; */
2046 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2047 useless = NULL;
2048 else if (SvPOK(sv)) {
2049 SV * const dsv = newSVpvs("");
2050 useless_sv
2051 = Perl_newSVpvf(aTHX_
2052 "a constant (%s)",
2053 pv_pretty(dsv, SvPVX_const(sv),
2054 SvCUR(sv), 32, NULL, NULL,
2055 PERL_PV_PRETTY_DUMP
2056 | PERL_PV_ESCAPE_NOCLEAR
2057 | PERL_PV_ESCAPE_UNI_DETECT));
2058 SvREFCNT_dec_NN(dsv);
2059 }
2060 else if (SvOK(sv)) {
2061 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2062 }
2063 else
2064 useless = "a constant (undef)";
2065 }
2066 }
2067 op_null(o); /* don't execute or even remember it */
2068 break;
79072805 2069
26f0e7d5 2070 case OP_POSTINC:
b9a07097 2071 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
26f0e7d5 2072 break;
79072805 2073
26f0e7d5 2074 case OP_POSTDEC:
b9a07097 2075 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
26f0e7d5 2076 break;
79072805 2077
26f0e7d5 2078 case OP_I_POSTINC:
b9a07097 2079 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
26f0e7d5 2080 break;
79072805 2081
26f0e7d5 2082 case OP_I_POSTDEC:
b9a07097 2083 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
26f0e7d5 2084 break;
679d6c4e 2085
26f0e7d5
TC
2086 case OP_SASSIGN: {
2087 OP *rv2gv;
2088 UNOP *refgen, *rv2cv;
2089 LISTOP *exlist;
679d6c4e 2090
26f0e7d5
TC
2091 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2092 break;
f2f8fd84 2093
26f0e7d5
TC
2094 rv2gv = ((BINOP *)o)->op_last;
2095 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2096 break;
f2f8fd84 2097
26f0e7d5 2098 refgen = (UNOP *)((BINOP *)o)->op_first;
f2f8fd84 2099
26f0e7d5
TC
2100 if (!refgen || (refgen->op_type != OP_REFGEN
2101 && refgen->op_type != OP_SREFGEN))
2102 break;
f2f8fd84 2103
26f0e7d5
TC
2104 exlist = (LISTOP *)refgen->op_first;
2105 if (!exlist || exlist->op_type != OP_NULL
2106 || exlist->op_targ != OP_LIST)
2107 break;
f2f8fd84 2108
26f0e7d5
TC
2109 if (exlist->op_first->op_type != OP_PUSHMARK
2110 && exlist->op_first != exlist->op_last)
2111 break;
f2f8fd84 2112
26f0e7d5 2113 rv2cv = (UNOP*)exlist->op_last;
f2f8fd84 2114
26f0e7d5
TC
2115 if (rv2cv->op_type != OP_RV2CV)
2116 break;
f2f8fd84 2117
26f0e7d5
TC
2118 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2119 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2120 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
f2f8fd84 2121
26f0e7d5
TC
2122 o->op_private |= OPpASSIGN_CV_TO_GV;
2123 rv2gv->op_private |= OPpDONT_INIT_GV;
2124 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
f2f8fd84 2125
26f0e7d5
TC
2126 break;
2127 }
540dd770 2128
26f0e7d5
TC
2129 case OP_AASSIGN: {
2130 inplace_aassign(o);
2131 break;
2132 }
edbe35ea 2133
26f0e7d5
TC
2134 case OP_OR:
2135 case OP_AND:
2136 kid = cLOGOPo->op_first;
2137 if (kid->op_type == OP_NOT
2138 && (kid->op_flags & OPf_KIDS)) {
2139 if (o->op_type == OP_AND) {
b9a07097 2140 OpTYPE_set(o, OP_OR);
26f0e7d5 2141 } else {
b9a07097 2142 OpTYPE_set(o, OP_AND);
26f0e7d5
TC
2143 }
2144 op_null(kid);
2145 }
2146 /* FALLTHROUGH */
5aabfad6 2147
26f0e7d5
TC
2148 case OP_DOR:
2149 case OP_COND_EXPR:
2150 case OP_ENTERGIVEN:
2151 case OP_ENTERWHEN:
e6dae479 2152 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
26f0e7d5
TC
2153 if (!(kid->op_flags & OPf_KIDS))
2154 scalarvoid(kid);
2155 else
2156 DEFER_OP(kid);
aa9d1253 2157 break;
095b19d1 2158
26f0e7d5
TC
2159 case OP_NULL:
2160 if (o->op_flags & OPf_STACKED)
2161 break;
2162 /* FALLTHROUGH */
2163 case OP_NEXTSTATE:
2164 case OP_DBSTATE:
2165 case OP_ENTERTRY:
2166 case OP_ENTER:
2167 if (!(o->op_flags & OPf_KIDS))
2168 break;
2169 /* FALLTHROUGH */
2170 case OP_SCOPE:
2171 case OP_LEAVE:
2172 case OP_LEAVETRY:
2173 case OP_LEAVELOOP:
2174 case OP_LINESEQ:
2175 case OP_LEAVEGIVEN:
2176 case OP_LEAVEWHEN:
2177 kids:
e6dae479 2178 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
26f0e7d5
TC
2179 if (!(kid->op_flags & OPf_KIDS))
2180 scalarvoid(kid);
2181 else
2182 DEFER_OP(kid);
2183 break;
2184 case OP_LIST:
2185 /* If the first kid after pushmark is something that the padrange
2186 optimisation would reject, then null the list and the pushmark.
2187 */
2188 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
e6dae479 2189 && ( !(kid = OpSIBLING(kid))
26f0e7d5
TC
2190 || ( kid->op_type != OP_PADSV
2191 && kid->op_type != OP_PADAV
2192 && kid->op_type != OP_PADHV)
2193 || kid->op_private & ~OPpLVAL_INTRO
e6dae479 2194 || !(kid = OpSIBLING(kid))
26f0e7d5
TC
2195 || ( kid->op_type != OP_PADSV
2196 && kid->op_type != OP_PADAV
2197 && kid->op_type != OP_PADHV)
2198 || kid->op_private & ~OPpLVAL_INTRO)
2199 ) {
2200 op_null(cUNOPo->op_first); /* NULL the pushmark */
2201 op_null(o); /* NULL the list */
2202 }
2203 goto kids;
2204 case OP_ENTEREVAL:
2205 scalarkids(o);
2206 break;
2207 case OP_SCALAR:
2208 scalar(o);
2209 break;
2210 }
2211
2212 if (useless_sv) {
2213 /* mortalise it, in case warnings are fatal. */
2214 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2215 "Useless use of %"SVf" in void context",
2216 SVfARG(sv_2mortal(useless_sv)));
2217 }
2218 else if (useless) {
3c3f8cd6
AB
2219 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2220 "Useless use of %s in void context",
2221 useless);
26f0e7d5 2222 }
aa9d1253
TC
2223 } while ( (o = POP_DEFERRED_OP()) );
2224
2225 Safefree(defer_stack);
2226
2227 return arg;
79072805
LW
2228}
2229
1f676739 2230static OP *
412da003 2231S_listkids(pTHX_ OP *o)
79072805 2232{
11343788 2233 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2234 OP *kid;
e6dae479 2235 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
79072805
LW
2236 list(kid);
2237 }
11343788 2238 return o;
79072805
LW
2239}
2240
2241OP *
864dbfa3 2242Perl_list(pTHX_ OP *o)
79072805
LW
2243{
2244 OP *kid;
2245
a0d0e21e 2246 /* assumes no premature commitment */
13765c85
DM
2247 if (!o || (o->op_flags & OPf_WANT)
2248 || (PL_parser && PL_parser->error_count)
5dc0d613 2249 || o->op_type == OP_RETURN)
7e363e51 2250 {
11343788 2251 return o;
7e363e51 2252 }
79072805 2253
b162f9ea 2254 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2255 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2256 {
b162f9ea 2257 return o; /* As if inside SASSIGN */
7e363e51 2258 }
1c846c1f 2259
5dc0d613 2260 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 2261
11343788 2262 switch (o->op_type) {
79072805 2263 case OP_FLOP:
11343788 2264 list(cBINOPo->op_first);
79072805 2265 break;
c57eecc5
FC
2266 case OP_REPEAT:
2267 if (o->op_private & OPpREPEAT_DOLIST
2268 && !(o->op_flags & OPf_STACKED))
2269 {
2270 list(cBINOPo->op_first);
2271 kid = cBINOPo->op_last;
2272 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2273 && SvIVX(kSVOP_sv) == 1)
2274 {
2275 op_null(o); /* repeat */
2276 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2277 /* const (rhs): */
2278 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2279 }
2280 }
2281 break;
79072805
LW
2282 case OP_OR:
2283 case OP_AND:
2284 case OP_COND_EXPR:
e6dae479 2285 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
79072805
LW
2286 list(kid);
2287 break;
2288 default:
2289 case OP_MATCH:
8782bef2 2290 case OP_QR:
79072805
LW
2291 case OP_SUBST:
2292 case OP_NULL:
11343788 2293 if (!(o->op_flags & OPf_KIDS))
79072805 2294 break;
11343788
MB
2295 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2296 list(cBINOPo->op_first);
2297 return gen_constant_list(o);
79072805 2298 }
6aa68307
FC
2299 listkids(o);
2300 break;
79072805 2301 case OP_LIST:
11343788 2302 listkids(o);
6aa68307
FC
2303 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2304 op_null(cUNOPo->op_first); /* NULL the pushmark */
2305 op_null(o); /* NULL the list */
2306 }
79072805
LW
2307 break;
2308 case OP_LEAVE:
2309 case OP_LEAVETRY:
5dc0d613 2310 kid = cLISTOPo->op_first;
54310121 2311 list(kid);
e6dae479 2312 kid = OpSIBLING(kid);
25b991bf
VP
2313 do_kids:
2314 while (kid) {
e6dae479 2315 OP *sib = OpSIBLING(kid);
c08f093b
VP
2316 if (sib && kid->op_type != OP_LEAVEWHEN)
2317 scalarvoid(kid);
2318 else
54310121 2319 list(kid);
25b991bf 2320 kid = sib;
54310121 2321 }
11206fdd 2322 PL_curcop = &PL_compiling;
54310121 2323 break;
748a9306 2324 case OP_SCOPE:
79072805 2325 case OP_LINESEQ:
25b991bf
VP
2326 kid = cLISTOPo->op_first;
2327 goto do_kids;
79072805 2328 }
11343788 2329 return o;
79072805
LW
2330}
2331
1f676739 2332static OP *
2dd5337b 2333S_scalarseq(pTHX_ OP *o)
79072805 2334{
11343788 2335 if (o) {
1496a290
AL
2336 const OPCODE type = o->op_type;
2337
2338 if (type == OP_LINESEQ || type == OP_SCOPE ||
2339 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2340 {
b7bea5da
FC
2341 OP *kid, *sib;
2342 for (kid = cLISTOPo->op_first; kid; kid = sib) {
e6dae479
FC
2343 if ((sib = OpSIBLING(kid))
2344 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
b7bea5da
FC
2345 || ( sib->op_targ != OP_NEXTSTATE
2346 && sib->op_targ != OP_DBSTATE )))
2347 {
463ee0b2 2348 scalarvoid(kid);
ed6116ce 2349 }
463ee0b2 2350 }
3280af22 2351 PL_curcop = &PL_compiling;
79072805 2352 }
11343788 2353 o->op_flags &= ~OPf_PARENS;
3280af22 2354 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2355 o->op_flags |= OPf_PARENS;
79072805 2356 }
8990e307 2357 else
11343788
MB
2358 o = newOP(OP_STUB, 0);
2359 return o;
79072805
LW
2360}
2361
76e3520e 2362STATIC OP *
cea2e8a9 2363S_modkids(pTHX_ OP *o, I32 type)
79072805 2364{
11343788 2365 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2366 OP *kid;
e6dae479 2367 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3ad73efd 2368 op_lvalue(kid, type);
79072805 2369 }
11343788 2370 return o;
79072805
LW
2371}
2372
12ee5d32
DM
2373
2374/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2375 * const fields. Also, convert CONST keys to HEK-in-SVs.
2376 * rop is the op that retrieves the hash;
2377 * key_op is the first key
2378 */
2379
f9db5646 2380STATIC void
fedf30e1 2381S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
12ee5d32
DM
2382{
2383 PADNAME *lexname;
2384 GV **fields;
2385 bool check_fields;
2386
2387 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2388 if (rop) {
2389 if (rop->op_first->op_type == OP_PADSV)
2390 /* @$hash{qw(keys here)} */
2391 rop = (UNOP*)rop->op_first;
2392 else {
2393 /* @{$hash}{qw(keys here)} */
2394 if (rop->op_first->op_type == OP_SCOPE
2395 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2396 {
2397 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2398 }
2399 else
2400 rop = NULL;
2401 }
2402 }
2403
2404 lexname = NULL; /* just to silence compiler warnings */
2405 fields = NULL; /* just to silence compiler warnings */
2406
2407 check_fields =
2408 rop
2409 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2410 SvPAD_TYPED(lexname))
2411 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2412 && isGV(*fields) && GvHV(*fields);
2413
e6dae479 2414 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
12ee5d32
DM
2415 SV **svp, *sv;
2416 if (key_op->op_type != OP_CONST)
2417 continue;
2418 svp = cSVOPx_svp(key_op);
2419
e1ccd220
DIM
2420 /* make sure it's not a bareword under strict subs */
2421 if (key_op->op_private & OPpCONST_BARE &&
2422 key_op->op_private & OPpCONST_STRICT)
2423 {
2424 no_bareword_allowed((OP*)key_op);
2425 }
2426
12ee5d32
DM
2427 /* Make the CONST have a shared SV */
2428 if ( !SvIsCOW_shared_hash(sv = *svp)
2429 && SvTYPE(sv) < SVt_PVMG
2430 && SvOK(sv)
2431 && !SvROK(sv))
2432 {
2433 SSize_t keylen;
2434 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2435 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2436 SvREFCNT_dec_NN(sv);
2437 *svp = nsv;
2438 }
2439
2440 if ( check_fields
2441 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2442 {
2443 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2444 "in variable %"PNf" of type %"HEKf,
2445 SVfARG(*svp), PNfARG(lexname),
2446 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2447 }
2448 }
2449}
2450
2451
3ad73efd 2452/*
d164302a
GG
2453=for apidoc finalize_optree
2454
72d33970
FC
2455This function finalizes the optree. Should be called directly after
2456the complete optree is built. It does some additional
796b6530 2457checking which can't be done in the normal C<ck_>xxx functions and makes
d164302a
GG
2458the tree thread-safe.
2459
2460=cut
2461*/
2462void
2463Perl_finalize_optree(pTHX_ OP* o)
2464{
2465 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2466
2467 ENTER;
2468 SAVEVPTR(PL_curcop);
2469
2470 finalize_op(o);
2471
2472 LEAVE;
2473}
2474
b46e009d 2475#ifdef USE_ITHREADS
2476/* Relocate sv to the pad for thread safety.
2477 * Despite being a "constant", the SV is written to,
2478 * for reference counts, sv_upgrade() etc. */
2479PERL_STATIC_INLINE void
2480S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2481{
2482 PADOFFSET ix;
2483 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2484 if (!*svp) return;
2485 ix = pad_alloc(OP_CONST, SVf_READONLY);
2486 SvREFCNT_dec(PAD_SVl(ix));
2487 PAD_SETSV(ix, *svp);
2488 /* XXX I don't know how this isn't readonly already. */
2489 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2490 *svp = NULL;
2491 *targp = ix;
2492}
2493#endif
2494
2495
60dde6b2 2496STATIC void
d164302a
GG
2497S_finalize_op(pTHX_ OP* o)
2498{
2499 PERL_ARGS_ASSERT_FINALIZE_OP;
2500
68d1ee85 2501 assert(o->op_type != OP_FREED);
d164302a
GG
2502
2503 switch (o->op_type) {
2504 case OP_NEXTSTATE:
2505 case OP_DBSTATE:
2506 PL_curcop = ((COP*)o); /* for warnings */
2507 break;
2508 case OP_EXEC:
e6dae479
FC
2509 if (OpHAS_SIBLING(o)) {
2510 OP *sib = OpSIBLING(o);
1ed44841
DM
2511 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2512 && ckWARN(WARN_EXEC)
e6dae479 2513 && OpHAS_SIBLING(sib))
1ed44841 2514 {
e6dae479 2515 const OPCODE type = OpSIBLING(sib)->op_type;
d164302a
GG
2516 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2517 const line_t oldline = CopLINE(PL_curcop);
1ed44841 2518 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
2519 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2520 "Statement unlikely to be reached");
2521 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2522 "\t(Maybe you meant system() when you said exec()?)\n");
2523 CopLINE_set(PL_curcop, oldline);
2524 }
d164302a 2525 }
1ed44841 2526 }
d164302a
GG
2527 break;
2528
2529 case OP_GV:
2530 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2531 GV * const gv = cGVOPo_gv;
2532 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2533 /* XXX could check prototype here instead of just carping */
2534 SV * const sv = sv_newmortal();
2535 gv_efullname3(sv, gv, NULL);
2536 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2537 "%"SVf"() called too early to check prototype",
2538 SVfARG(sv));
2539 }
2540 }
2541 break;
2542
2543 case OP_CONST:
eb796c7f
GG
2544 if (cSVOPo->op_private & OPpCONST_STRICT)
2545 no_bareword_allowed(o);
2546 /* FALLTHROUGH */
d164302a
GG
2547#ifdef USE_ITHREADS
2548 case OP_HINTSEVAL:
b46e009d 2549 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2550#endif
2551 break;
2552
2553#ifdef USE_ITHREADS
2554 /* Relocate all the METHOP's SVs to the pad for thread safety. */
d164302a 2555 case OP_METHOD_NAMED:
7d6c333c 2556 case OP_METHOD_SUPER:
810bd8b7 2557 case OP_METHOD_REDIR:
2558 case OP_METHOD_REDIR_SUPER:
b46e009d 2559 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2560 break;
d164302a 2561#endif
d164302a
GG
2562
2563 case OP_HELEM: {
2564 UNOP *rop;
565e6f7e
FC
2565 SVOP *key_op;
2566 OP *kid;
d164302a 2567
565e6f7e 2568 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
d164302a
GG
2569 break;
2570
2571 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 2572
565e6f7e 2573 goto check_keys;
d164302a 2574
565e6f7e 2575 case OP_HSLICE:
429a2555 2576 S_scalar_slice_warning(aTHX_ o);
c67159e1 2577 /* FALLTHROUGH */
429a2555 2578
c5f75dba 2579 case OP_KVHSLICE:
e6dae479 2580 kid = OpSIBLING(cLISTOPo->op_first);
71323522 2581 if (/* I bet there's always a pushmark... */
7d3c8a68
SM
2582 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2583 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2584 {
d164302a 2585 break;
7d3c8a68 2586 }
565e6f7e
FC
2587
2588 key_op = (SVOP*)(kid->op_type == OP_CONST
2589 ? kid
e6dae479 2590 : OpSIBLING(kLISTOP->op_first));
565e6f7e
FC
2591
2592 rop = (UNOP*)((LISTOP*)o)->op_last;
2593
2594 check_keys:
12ee5d32
DM
2595 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2596 rop = NULL;
fedf30e1 2597 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
d164302a
GG
2598 break;
2599 }
429a2555
FC
2600 case OP_ASLICE:
2601 S_scalar_slice_warning(aTHX_ o);
2602 break;
a7fd8ef6 2603
d164302a
GG
2604 case OP_SUBST: {
2605 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2606 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2607 break;
2608 }
2609 default:
2610 break;
2611 }
2612
2613 if (o->op_flags & OPf_KIDS) {
2614 OP *kid;
c4b20975
DM
2615
2616#ifdef DEBUGGING
20220689 2617 /* check that op_last points to the last sibling, and that
86cd3a13
DM
2618 * the last op_sibling/op_sibparent field points back to the
2619 * parent, and that the only ops with KIDS are those which are
2620 * entitled to them */
c4b20975
DM
2621 U32 type = o->op_type;
2622 U32 family;
20220689 2623 bool has_last;
c4b20975
DM
2624
2625 if (type == OP_NULL) {
2626 type = o->op_targ;
2627 /* ck_glob creates a null UNOP with ex-type GLOB
2628 * (which is a list op. So pretend it wasn't a listop */
2629 if (type == OP_GLOB)
2630 type = OP_NULL;
2631 }
2632 family = PL_opargs[type] & OA_CLASS_MASK;
2633
20220689
DM
2634 has_last = ( family == OA_BINOP
2635 || family == OA_LISTOP
2636 || family == OA_PMOP
2637 || family == OA_LOOP
2638 );
2639 assert( has_last /* has op_first and op_last, or ...
2640 ... has (or may have) op_first: */
2641 || family == OA_UNOP
2f7c6295 2642 || family == OA_UNOP_AUX
20220689
DM
2643 || family == OA_LOGOP
2644 || family == OA_BASEOP_OR_UNOP
2645 || family == OA_FILESTATOP
2646 || family == OA_LOOPEXOP
b46e009d 2647 || family == OA_METHOP
20220689
DM
2648 || type == OP_CUSTOM
2649 || type == OP_NULL /* new_logop does this */
2650 );
20220689 2651
e6dae479 2652 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
29e61fd9 2653# ifdef PERL_OP_PARENT
e6dae479 2654 if (!OpHAS_SIBLING(kid)) {
20220689 2655 if (has_last)
29e61fd9 2656 assert(kid == cLISTOPo->op_last);
86cd3a13 2657 assert(kid->op_sibparent == o);
20220689 2658 }
29e61fd9 2659# else
35a2929b 2660 if (has_last && !OpHAS_SIBLING(kid))
93059c1a 2661 assert(kid == cLISTOPo->op_last);
20220689 2662# endif
c4b20975
DM
2663 }
2664#endif
2665
e6dae479 2666 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
d164302a
GG
2667 finalize_op(kid);
2668 }
2669}
2670
2671/*
3ad73efd
Z
2672=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2673
2674Propagate lvalue ("modifiable") context to an op and its children.
2d7f6611 2675C<type> represents the context type, roughly based on the type of op that
796b6530 2676would do the modifying, although C<local()> is represented by C<OP_NULL>,
3ad73efd 2677because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
2678the lvalue op).
2679
2680This function detects things that can't be modified, such as C<$x+1>, and
72d33970 2681generates errors for them. For example, C<$x+1 = 2> would cause it to be
796b6530 2682called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
001c3c51
FC
2683
2684It also flags things that need to behave specially in an lvalue context,
2685such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
2686
2687=cut
2688*/
ddeae0f1 2689
03414f05
FC
2690static void
2691S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2692{
2693 CV *cv = PL_compcv;
2694 PadnameLVALUE_on(pn);
2695 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2696 cv = CvOUTSIDE(cv);
aea0412a
DM
2697 /* RT #127786: cv can be NULL due to an eval within the DB package
2698 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2699 * unless they contain an eval, but calling eval within DB
2700 * pretends the eval was done in the caller's scope.
2701 */
2702 if (!cv)
2703 break;
03414f05
FC
2704 assert(CvPADLIST(cv));
2705 pn =
2706 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2707 assert(PadnameLEN(pn));
2708 PadnameLVALUE_on(pn);
2709 }
2710}
2711
375879aa
FC
2712static bool
2713S_vivifies(const OPCODE type)
2714{
2715 switch(type) {
2716 case OP_RV2AV: case OP_ASLICE:
2717 case OP_RV2HV: case OP_KVASLICE:
2718 case OP_RV2SV: case OP_HSLICE:
2719 case OP_AELEMFAST: case OP_KVHSLICE:
2720 case OP_HELEM:
2721 case OP_AELEM:
2722 return 1;
2723 }
2724 return 0;
2725}
2726
7664512e 2727static void
63702de8 2728S_lvref(pTHX_ OP *o, I32 type)
7664512e 2729{
727d2dc6 2730 dVAR;
7664512e
FC
2731 OP *kid;
2732 switch (o->op_type) {
2733 case OP_COND_EXPR:
e6dae479
FC
2734 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2735 kid = OpSIBLING(kid))
63702de8 2736 S_lvref(aTHX_ kid, type);
7664512e
FC
2737 /* FALLTHROUGH */
2738 case OP_PUSHMARK:
2739 return;
2740 case OP_RV2AV:
2741 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2742 o->op_flags |= OPf_STACKED;
2743 if (o->op_flags & OPf_PARENS) {
2744 if (o->op_private & OPpLVAL_INTRO) {
7664512e
FC
2745 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2746 "localized parenthesized array in list assignment"));
2747 return;
2748 }
2749 slurpy:
b9a07097 2750 OpTYPE_set(o, OP_LVAVREF);
7664512e
FC
2751 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2752 o->op_flags |= OPf_MOD|OPf_REF;
2753 return;
2754 }
2755 o->op_private |= OPpLVREF_AV;
2756 goto checkgv;
408e9044 2757 case OP_RV2CV:
19abb1ea
FC
2758 kid = cUNOPo->op_first;
2759 if (kid->op_type == OP_NULL)
cb748240 2760 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
408e9044
FC
2761 ->op_first;
2762 o->op_private = OPpLVREF_CV;
2763 if (kid->op_type == OP_GV)
2764 o->op_flags |= OPf_STACKED;
2765 else if (kid->op_type == OP_PADCV) {
2766 o->op_targ = kid->op_targ;
2767 kid->op_targ = 0;
2768 op_free(cUNOPo->op_first);
2769 cUNOPo->op_first = NULL;
2770 o->op_flags &=~ OPf_KIDS;
2771 }
2772 else goto badref;
2773 break;
7664512e
FC
2774 case OP_RV2HV:
2775 if (o->op_flags & OPf_PARENS) {
2776 parenhash:
7664512e
FC
2777 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2778 "parenthesized hash in list assignment"));
2779 return;
2780 }
2781 o->op_private |= OPpLVREF_HV;
2782 /* FALLTHROUGH */
2783 case OP_RV2SV:
2784 checkgv:
2785 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2786 o->op_flags |= OPf_STACKED;
6f5dab3c
FC
2787 break;
2788 case OP_PADHV:
2789 if (o->op_flags & OPf_PARENS) goto parenhash;
2790 o->op_private |= OPpLVREF_HV;
7664512e
FC
2791 /* FALLTHROUGH */
2792 case OP_PADSV:
6f5dab3c 2793 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2794 break;
2795 case OP_PADAV:
6f5dab3c 2796 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2797 if (o->op_flags & OPf_PARENS) goto slurpy;
2798 o->op_private |= OPpLVREF_AV;
2799 break;
7664512e
FC
2800 case OP_AELEM:
2801 case OP_HELEM:
2802 o->op_private |= OPpLVREF_ELEM;
2803 o->op_flags |= OPf_STACKED;
2804 break;
2805 case OP_ASLICE:
2806 case OP_HSLICE:
b9a07097 2807 OpTYPE_set(o, OP_LVREFSLICE);
36efb5a6 2808 o->op_private &= OPpLVAL_INTRO;
7664512e
FC
2809 return;
2810 case OP_NULL:
2811 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2812 goto badref;
2813 else if (!(o->op_flags & OPf_KIDS))
2814 return;
2815 if (o->op_targ != OP_LIST) {
63702de8 2816 S_lvref(aTHX_ cBINOPo->op_first, type);
7664512e
FC
2817 return;
2818 }
2819 /* FALLTHROUGH */
2820 case OP_LIST:
e6dae479 2821 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
7664512e 2822 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
63702de8 2823 S_lvref(aTHX_ kid, type);
7664512e
FC
2824 }
2825 return;
2826 case OP_STUB:
2827 if (o->op_flags & OPf_PARENS)
2828 return;
2829 /* FALLTHROUGH */
2830 default:
2831 badref:
cf6e1fa1 2832 /* diag_listed_as: Can't modify reference to %s in %s assignment */
63702de8 2833 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
7664512e
FC
2834 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2835 ? "do block"
63702de8
FC
2836 : OP_DESC(o),
2837 PL_op_desc[type]));
2b6a5bfb 2838 return;
7664512e 2839 }
b9a07097 2840 OpTYPE_set(o, OP_LVREF);
3ad7d304
FC
2841 o->op_private &=
2842 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
d39c26a6
FC
2843 if (type == OP_ENTERLOOP)
2844 o->op_private |= OPpLVREF_ITER;
7664512e
FC
2845}
2846
1a3e9724
FC
2847PERL_STATIC_INLINE bool
2848S_potential_mod_type(I32 type)
2849{
2850 /* Types that only potentially result in modification. */
2851 return type == OP_GREPSTART || type == OP_ENTERSUB
2852 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2853}
2854
79072805 2855OP *
d3d7d28f 2856Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2857{
27da23d5 2858 dVAR;
79072805 2859 OP *kid;
ddeae0f1
DM
2860 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2861 int localize = -1;
79072805 2862
13765c85 2863 if (!o || (PL_parser && PL_parser->error_count))
11343788 2864 return o;
79072805 2865
b162f9ea 2866 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2867 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2868 {
b162f9ea 2869 return o;
7e363e51 2870 }
1c846c1f 2871
5c906035
GG
2872 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2873
69974ce6
FC
2874 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2875
11343788 2876 switch (o->op_type) {
68dc0745 2877 case OP_UNDEF:
3280af22 2878 PL_modcount++;
5dc0d613 2879 return o;
5f05dabc 2880 case OP_STUB:
b5bbe64a 2881 if ((o->op_flags & OPf_PARENS))
5f05dabc
PP
2882 break;
2883 goto nomod;
a0d0e21e 2884 case OP_ENTERSUB:
f79aa60b 2885 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788 2886 !(o->op_flags & OPf_STACKED)) {
b9a07097 2887 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2888 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2889 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
2890 break;
2891 }
cd06dffe 2892 else { /* lvalue subroutine call */
9411a3c7 2893 o->op_private |= OPpLVAL_INTRO;
e6438c1a 2894 PL_modcount = RETURN_UNLIMITED_NUMBER;
1a3e9724 2895 if (S_potential_mod_type(type)) {
cd06dffe
GS
2896 o->op_private |= OPpENTERSUB_INARGS;
2897 break;
2898 }
2899 else { /* Compile-time error message: */
2900 OP *kid = cUNOPo->op_first;
2901 CV *cv;
2eaf799e 2902 GV *gv;
0f948285 2903 SV *namesv;
cd06dffe 2904
3ea285d1
AL
2905 if (kid->op_type != OP_PUSHMARK) {
2906 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2907 Perl_croak(aTHX_
2908 "panic: unexpected lvalue entersub "
2909 "args: type/targ %ld:%"UVuf,
2910 (long)kid->op_type, (UV)kid->op_targ);
2911 kid = kLISTOP->op_first;
2912 }
e6dae479
FC
2913 while (OpHAS_SIBLING(kid))
2914 kid = OpSIBLING(kid);
cd06dffe 2915 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2916 break; /* Postpone until runtime */
2917 }
b2ffa427 2918
cd06dffe
GS
2919 kid = kUNOP->op_first;
2920 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2921 kid = kUNOP->op_first;
b2ffa427 2922 if (kid->op_type == OP_NULL)
cd06dffe
GS
2923 Perl_croak(aTHX_
2924 "Unexpected constant lvalue entersub "
55140b79 2925 "entry via type/targ %ld:%"UVuf,
3d811634 2926 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2927 if (kid->op_type != OP_GV) {
cd06dffe
GS
2928 break;
2929 }
b2ffa427 2930
2eaf799e
FC
2931 gv = kGVOP_gv;
2932 cv = isGV(gv)
2933 ? GvCV(gv)
2934 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2935 ? MUTABLE_CV(SvRV(gv))
2936 : NULL;
1c846c1f 2937 if (!cv)
da1dff94 2938 break;
cd06dffe
GS
2939 if (CvLVALUE(cv))
2940 break;
0f948285
DIM
2941 if (flags & OP_LVALUE_NO_CROAK)
2942 return NULL;
2943
2944 namesv = cv_name(cv, NULL, 0);
2945 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2946 "subroutine call of &%"SVf" in %s",
2947 SVfARG(namesv), PL_op_desc[type]),
2948 SvUTF8(namesv));
2949 return o;
cd06dffe
GS
2950 }
2951 }
924ba076 2952 /* FALLTHROUGH */
79072805 2953 default:
a0d0e21e 2954 nomod:
f5d552b4 2955 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2956 /* grep, foreach, subcalls, refgen */
1a3e9724 2957 if (S_potential_mod_type(type))
a0d0e21e 2958 break;
cea2e8a9 2959 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2960 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe 2961 ? "do block"
0f948285 2962 : OP_DESC(o)),
22c35a8c 2963 type ? PL_op_desc[type] : "local"));
11343788 2964 return o;
79072805 2965
a0d0e21e
LW
2966 case OP_PREINC:
2967 case OP_PREDEC:
2968 case OP_POW:
2969 case OP_MULTIPLY:
2970 case OP_DIVIDE:
2971 case OP_MODULO:
a0d0e21e
LW
2972 case OP_ADD:
2973 case OP_SUBTRACT:
2974 case OP_CONCAT:
2975 case OP_LEFT_SHIFT:
2976 case OP_RIGHT_SHIFT:
2977 case OP_BIT_AND:
2978 case OP_BIT_XOR:
2979 case OP_BIT_OR:
2980 case OP_I_MULTIPLY:
2981 case OP_I_DIVIDE:
2982 case OP_I_MODULO:
2983 case OP_I_ADD:
2984 case OP_I_SUBTRACT:
11343788 2985 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2986 goto nomod;
3280af22 2987 PL_modcount++;
a0d0e21e 2988 break;
b2ffa427 2989
82209a5d
FC
2990 case OP_REPEAT:
2991 if (o->op_flags & OPf_STACKED) {
2992 PL_modcount++;
2993 break;
2994 }
ff781254 2995 if (!(o->op_private & OPpREPEAT_DOLIST))
82209a5d
FC
2996 goto nomod;
2997 else {
2998 const I32 mods = PL_modcount;
ff781254
FC
2999 modkids(cBINOPo->op_first, type);
3000 if (type != OP_AASSIGN)
3001 goto nomod;
5e462669 3002 kid = cBINOPo->op_last;
82209a5d 3003 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
565e104c 3004 const IV iv = SvIV(kSVOP_sv);
82209a5d
FC
3005 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3006 PL_modcount =
3007 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3008 }
3009 else
3010 PL_modcount = RETURN_UNLIMITED_NUMBER;
3011 }
3012 break;
3013
79072805 3014 case OP_COND_EXPR:
ddeae0f1 3015 localize = 1;
e6dae479 3016 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3ad73efd 3017 op_lvalue(kid, type);
79072805
LW
3018 break;
3019
3020 case OP_RV2AV:
3021 case OP_RV2HV:
11343788 3022 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 3023 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 3024 return o; /* Treat \(@foo) like ordinary list. */
748a9306 3025 }
924ba076 3026 /* FALLTHROUGH */
79072805 3027 case OP_RV2GV:
5dc0d613 3028 if (scalar_mod_type(o, type))
3fe9a6f1 3029 goto nomod;
11343788 3030 ref(cUNOPo->op_first, o->op_type);
924ba076 3031 /* FALLTHROUGH */
79072805
LW
3032 case OP_ASLICE:
3033 case OP_HSLICE:
ddeae0f1 3034 localize = 1;
924ba076 3035 /* FALLTHROUGH */
78f9721b 3036 case OP_AASSIGN:
32cbae3f
FC
3037 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3038 if (type == OP_LEAVESUBLV && (
3039 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3040 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3041 ))
631dbaa2 3042 o->op_private |= OPpMAYBE_LVSUB;
924ba076 3043 /* FALLTHROUGH */
93a17b20
LW
3044 case OP_NEXTSTATE:
3045 case OP_DBSTATE:
e6438c1a 3046 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 3047 break;
5cae3edb 3048 case OP_KVHSLICE:
6dd3e0f2 3049 case OP_KVASLICE:
738155d2 3050 case OP_AKEYS:
5cae3edb
RZ
3051 if (type == OP_LEAVESUBLV)
3052 o->op_private |= OPpMAYBE_LVSUB;
3053 goto nomod;
cd642408
FC
3054 case OP_AVHVSWITCH:
3055 if (type == OP_LEAVESUBLV
3056 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3057 o->op_private |= OPpMAYBE_LVSUB;
3058 goto nomod;
28c5b5bc
RGS
3059 case OP_AV2ARYLEN:
3060 PL_hints |= HINT_BLOCK_SCOPE;
3061 if (type == OP_LEAVESUBLV)
3062 o->op_private |= OPpMAYBE_LVSUB;
3063 PL_modcount++;
3064 break;
463ee0b2 3065 case OP_RV2SV:
aeea060c 3066 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 3067 localize = 1;
924ba076 3068 /* FALLTHROUGH */
79072805 3069 case OP_GV:
3280af22 3070 PL_hints |= HINT_BLOCK_SCOPE;
924ba076 3071 /* FALLTHROUGH */
463ee0b2 3072 case OP_SASSIGN:
bf4b1e52
GS
3073 case OP_ANDASSIGN:
3074 case OP_ORASSIGN:
c963b151 3075 case OP_DORASSIGN:
ddeae0f1
DM
3076 PL_modcount++;
3077 break;
3078
8990e307 3079 case OP_AELEMFAST:
93bad3fd 3080 case OP_AELEMFAST_LEX:
6a077020 3081 localize = -1;
3280af22 3082 PL_modcount++;
8990e307
LW
3083 break;
3084
748a9306
LW
3085 case OP_PADAV:
3086 case OP_PADHV:
e6438c1a 3087 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
3088 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3089 return o; /* Treat \(@foo) like ordinary list. */
3090 if (scalar_mod_type(o, type))
3fe9a6f1 3091 goto nomod;
32cbae3f
FC
3092 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3093 && type == OP_LEAVESUBLV)
78f9721b 3094 o->op_private |= OPpMAYBE_LVSUB;
924ba076 3095 /* FALLTHROUGH */
748a9306 3096 case OP_PADSV:
3280af22 3097 PL_modcount++;
ddeae0f1 3098 if (!type) /* local() */
ea9a9e77
FC
3099 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3100 PNfARG(PAD_COMPNAME(o->op_targ)));
e4211fee
FC
3101 if (!(o->op_private & OPpLVAL_INTRO)
3102 || ( type != OP_SASSIGN && type != OP_AASSIGN
3103 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
03414f05 3104 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
3105 break;
3106
748a9306 3107 case OP_PUSHMARK:
ddeae0f1 3108 localize = 0;
748a9306 3109 break;
b2ffa427 3110
69969c6f 3111 case OP_KEYS:
e4fc7082 3112 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
69969c6f 3113 goto nomod;
5d82c453
GA
3114 goto lvalue_func;
3115 case OP_SUBSTR:
3116 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3117 goto nomod;
924ba076 3118 /* FALLTHROUGH */
a0d0e21e 3119 case OP_POS:
463ee0b2 3120 case OP_VEC:
fad4a2e4 3121 lvalue_func:
78f9721b
SM
3122 if (type == OP_LEAVESUBLV)
3123 o->op_private |= OPpMAYBE_LVSUB;
79409ac8
FC
3124 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3125 /* substr and vec */
3126 /* If this op is in merely potential (non-fatal) modifiable
33a10326
FC
3127 context, then apply OP_ENTERSUB context to
3128 the kid op (to avoid croaking). Other-
79409ac8
FC
3129 wise pass this op’s own type so the correct op is mentioned
3130 in error messages. */
3131 op_lvalue(OpSIBLING(cBINOPo->op_first),
33a10326 3132 S_potential_mod_type(type)
ee4b19b9 3133 ? (I32)OP_ENTERSUB
33a10326 3134 : o->op_type);
79409ac8 3135 }
463ee0b2 3136 break;
a0d0e21e 3137
463ee0b2
LW
3138 case OP_AELEM:
3139 case OP_HELEM:
11343788 3140 ref(cBINOPo->op_first, o->op_type);
68dc0745 3141 if (type == OP_ENTERSUB &&
5dc0d613
MB
3142 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3143 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
3144 if (type == OP_LEAVESUBLV)
3145 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 3146 localize = 1;
3280af22 3147 PL_modcount++;
463ee0b2
LW
3148 break;
3149
463ee0b2 3150 case OP_LEAVE:
a373464f 3151 case OP_LEAVELOOP:
2ec7f6f2 3152 o->op_private |= OPpLVALUE;
924ba076 3153 /* FALLTHROUGH */
2ec7f6f2 3154 case OP_SCOPE:
463ee0b2 3155 case OP_ENTER:
78f9721b 3156 case OP_LINESEQ:
ddeae0f1 3157 localize = 0;
11343788 3158 if (o->op_flags & OPf_KIDS)
3ad73efd 3159 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
3160 break;
3161
3162 case OP_NULL:
ddeae0f1 3163 localize = 0;
638bc118
GS
3164 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3165 goto nomod;
3166 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 3167 break;
11343788 3168 if (o->op_targ != OP_LIST) {
3ad73efd 3169 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
3170 break;
3171 }
924ba076 3172 /* FALLTHROUGH */
463ee0b2 3173 case OP_LIST:
ddeae0f1 3174 localize = 0;
e6dae479 3175 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5c906035
GG
3176 /* elements might be in void context because the list is
3177 in scalar context or because they are attribute sub calls */
3178 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3179 op_lvalue(kid, type);
463ee0b2 3180 break;
78f9721b 3181
1efec5ed
FC
3182 case OP_COREARGS:
3183 return o;
2ec7f6f2
FC
3184
3185 case OP_AND:
3186 case OP_OR:
375879aa
FC
3187 if (type == OP_LEAVESUBLV
3188 || !S_vivifies(cLOGOPo->op_first->op_type))
3189 op_lvalue(cLOGOPo->op_first, type);
3190 if (type == OP_LEAVESUBLV
e6dae479
FC
3191 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3192 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
2ec7f6f2 3193 goto nomod;
26a50d99
FC
3194
3195 case OP_SREFGEN:
e118fea3
FC
3196 if (type == OP_NULL) { /* local */
3197 local_refgen:
37690136
FC
3198 if (!FEATURE_MYREF_IS_ENABLED)
3199 Perl_croak(aTHX_ "The experimental declared_refs "
3200 "feature is not enabled");
3201 Perl_ck_warner_d(aTHX_
3202 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8fde4f03 3203 "Declaring references is experimental");
e118fea3
FC
3204 op_lvalue(cUNOPo->op_first, OP_NULL);
3205 return o;
3206 }
d39c26a6
FC
3207 if (type != OP_AASSIGN && type != OP_SASSIGN
3208 && type != OP_ENTERLOOP)
3209 goto nomod;
7664512e 3210 /* Don’t bother applying lvalue context to the ex-list. */
26a50d99 3211 kid = cUNOPx(cUNOPo->op_first)->op_first;
e6dae479 3212 assert (!OpHAS_SIBLING(kid));
217e3565
FC
3213 goto kid_2lvref;
3214 case OP_REFGEN:
e118fea3
FC
3215 if (type == OP_NULL) /* local */
3216 goto local_refgen;
217e3565 3217 if (type != OP_AASSIGN) goto nomod;
7664512e
FC
3218 kid = cUNOPo->op_first;
3219 kid_2lvref:
3220 {
3221 const U8 ec = PL_parser ? PL_parser->error_count : 0;
63702de8 3222 S_lvref(aTHX_ kid, type);
7664512e 3223 if (!PL_parser || PL_parser->error_count == ec) {
baabe3fb 3224 if (!FEATURE_REFALIASING_IS_ENABLED)
7664512e 3225 Perl_croak(aTHX_
baabe3fb 3226 "Experimental aliasing via reference not enabled");
7664512e 3227 Perl_ck_warner_d(aTHX_
baabe3fb
FC
3228 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3229 "Aliasing via reference is experimental");
7664512e
FC
3230 }
3231 }
217e3565
FC
3232 if (o->op_type == OP_REFGEN)
3233 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3234 op_null(o);
26a50d99 3235 return o;
e4e95921
FC
3236
3237 case OP_SPLIT:
5012eebe 3238 if ((o->op_private & OPpSPLIT_ASSIGN)) {
e4e95921
FC
3239 /* This is actually @array = split. */
3240 PL_modcount = RETURN_UNLIMITED_NUMBER;
3241 break;
3242 }
3243 goto nomod;
569ddb4a
FC
3244
3245 case OP_SCALAR:
3246 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3247 goto nomod;
463ee0b2 3248 }
58d95175 3249
4fe48737 3250 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
8be1be90
AMS
3251 their argument is a filehandle; thus \stat(".") should not set
3252 it. AMS 20011102 */
3253 if (type == OP_REFGEN &&
ef69c8fc 3254 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
3255 return o;
3256
3257 if (type != OP_LEAVESUBLV)
3258 o->op_flags |= OPf_MOD;
3259
3260 if (type == OP_AASSIGN || type == OP_SASSIGN)
f441d7d2
FC
3261 o->op_flags |= OPf_SPECIAL
3262 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
ddeae0f1
DM
3263 else if (!type) { /* local() */
3264 switch (localize) {
3265 case 1:
3266 o->op_private |= OPpLVAL_INTRO;
3267 o->op_flags &= ~OPf_SPECIAL;
3268 PL_hints |= HINT_BLOCK_SCOPE;
3269 break;
3270 case 0:
3271 break;
3272 case -1:
a2a5de95
NC
3273 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3274 "Useless localization of %s", OP_DESC(o));
ddeae0f1 3275 }
463ee0b2 3276 }
8be1be90 3277 else if (type != OP_GREPSTART && type != OP_ENTERSUB
f441d7d2 3278 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
8be1be90 3279 o->op_flags |= OPf_REF;
11343788 3280 return o;
463ee0b2
LW
3281}
3282
864dbfa3 3283STATIC bool
5f66b61c 3284S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
3285{
3286 switch (type) {
32a60974 3287 case OP_POS:
3fe9a6f1 3288 case OP_SASSIGN:
1efec5ed 3289 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 3290 return FALSE;
924ba076 3291 /* FALLTHROUGH */
3fe9a6f1
PP
3292 case OP_PREINC:
3293 case OP_PREDEC:
3294 case OP_POSTINC:
3295 case OP_POSTDEC:
3296 case OP_I_PREINC:
3297 case OP_I_PREDEC:
3298 case OP_I_POSTINC:
3299 case OP_I_POSTDEC:
3300 case OP_POW:
3301 case OP_MULTIPLY:
3302 case OP_DIVIDE:
3303 case OP_MODULO:
3304 case OP_REPEAT:
3305 case OP_ADD:
3306 case OP_SUBTRACT:
3307 case OP_I_MULTIPLY:
3308 case OP_I_DIVIDE:
3309 case OP_I_MODULO:
3310 case OP_I_ADD:
3311 case OP_I_SUBTRACT:
3312 case OP_LEFT_SHIFT:
3313 case OP_RIGHT_SHIFT:
3314 case OP_BIT_AND:
3315 case OP_BIT_XOR:
3316 case OP_BIT_OR:
76734a32
FC
3317 case OP_NBIT_AND:
3318 case OP_NBIT_XOR:
3319 case OP_NBIT_OR:
3320 case OP_SBIT_AND:
3321 case OP_SBIT_XOR:
3322 case OP_SBIT_OR:
3fe9a6f1
PP
3323 case OP_CONCAT:
3324 case OP_SUBST:
3325 case OP_TRANS:
bb16bae8 3326 case OP_TRANSR:
49e9fbe6
GS
3327 case OP_READ:
3328 case OP_SYSREAD:
3329 case OP_RECV:
bf4b1e52
GS
3330 case OP_ANDASSIGN:
3331 case OP_ORASSIGN:
410d09fe 3332 case OP_DORASSIGN:
79409ac8
FC
3333 case OP_VEC:
3334 case OP_SUBSTR:
3fe9a6f1
PP
3335 return TRUE;
3336 default:
3337 return FALSE;
3338 }
3339}
3340
35cd451c 3341STATIC bool
5f66b61c 3342S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 3343{
7918f24d
NC
3344 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3345
35cd451c
GS
3346 switch (o->op_type) {
3347 case OP_PIPE_OP:
3348 case OP_SOCKPAIR:
504618e9 3349 if (numargs == 2)
35cd451c 3350 return TRUE;
924ba076 3351 /* FALLTHROUGH */
35cd451c
GS
3352 case OP_SYSOPEN:
3353 case OP_OPEN:
ded8aa31 3354 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
3355 case OP_SOCKET:
3356 case OP_OPEN_DIR:
3357 case OP_ACCEPT:
504618e9 3358 if (numargs == 1)
35cd451c 3359 return TRUE;
5f66b61c 3360 /* FALLTHROUGH */
35cd451c
GS
3361 default:
3362 return FALSE;
3363 }
3364}
3365
0d86688d
NC
3366static OP *
3367S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 3368{
11343788 3369 if (o && o->op_flags & OPf_KIDS) {
6867be6d 3370 OP *kid;
e6dae479 3371 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
463ee0b2
LW
3372 ref(kid, type);
3373 }
11343788 3374 return o;
463ee0b2
LW
3375}
3376
3377OP *
e4c5ccf3 3378Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 3379{
27da23d5 3380 dVAR;
463ee0b2 3381 OP *kid;
463ee0b2 3382
7918f24d
NC
3383 PERL_ARGS_ASSERT_DOREF;
3384
3dc78631 3385 if (PL_parser && PL_parser->error_count)
11343788 3386 return o;
463ee0b2 3387
11343788 3388 switch (o->op_type) {
a0d0e21e 3389 case OP_ENTERSUB:
f4df43b5 3390 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788 3391 !(o->op_flags & OPf_STACKED)) {
b9a07097 3392 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 3393 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 3394 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 3395 o->op_flags |= OPf_SPECIAL;
8990e307 3396 }
767eda44 3397 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
3398 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3399 : type == OP_RV2HV ? OPpDEREF_HV
3400 : OPpDEREF_SV);
767eda44
FC
3401 o->op_flags |= OPf_MOD;
3402 }
3403
8990e307 3404 break;
aeea060c 3405
463ee0b2 3406 case OP_COND_EXPR:
e6dae479 3407 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
e4c5ccf3 3408 doref(kid, type, set_op_ref);
463ee0b2 3409 break;
8990e307 3410 case OP_RV2SV:
35cd451c
GS
3411 if (type == OP_DEFINED)
3412 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3413 doref(cUNOPo->op_first, o->op_type, set_op_ref);
924ba076 3414 /* FALLTHROUGH */
4633a7c4 3415 case OP_PADSV:
5f05dabc 3416 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3417 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3418 : type == OP_RV2HV ? OPpDEREF_HV
3419 : OPpDEREF_SV);
11343788 3420 o->op_flags |= OPf_MOD;
a0d0e21e 3421 }
8990e307 3422 break;
1c846c1f 3423
463ee0b2
LW
3424 case OP_RV2AV:
3425 case OP_RV2HV:
e4c5ccf3
RH
3426 if (set_op_ref)
3427 o->op_flags |= OPf_REF;
924ba076 3428 /* FALLTHROUGH */
463ee0b2 3429 case OP_RV2GV:
35cd451c
GS
3430 if (type == OP_DEFINED)
3431 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3432 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 3433 break;
8990e307 3434
463ee0b2
LW
3435 case OP_PADAV:
3436 case OP_PADHV:
e4c5ccf3
RH
3437 if (set_op_ref)
3438 o->op_flags |= OPf_REF;
79072805 3439 break;
aeea060c 3440
8990e307 3441 case OP_SCALAR:
79072805 3442 case OP_NULL:
518618af 3443 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 3444 break;
e4c5ccf3 3445 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
3446 break;
3447 case OP_AELEM:
3448 case OP_HELEM:
e4c5ccf3 3449 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 3450 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3451 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3452 : type == OP_RV2HV ? OPpDEREF_HV
3453 : OPpDEREF_SV);
11343788 3454 o->op_flags |= OPf_MOD;
8990e307 3455 }
79072805
LW
3456 break;
3457
463ee0b2 3458 case OP_SCOPE:
79072805 3459 case OP_LEAVE:
e4c5ccf3 3460 set_op_ref = FALSE;
924ba076 3461 /* FALLTHROUGH */
79072805 3462 case OP_ENTER:
8990e307 3463 case OP_LIST:
11343788 3464 if (!(o->op_flags & OPf_KIDS))
79072805 3465 break;
e4c5ccf3 3466 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 3467 break;
a0d0e21e
LW
3468 default:
3469 break;
79072805 3470 }
11343788 3471 return scalar(o);
8990e307 3472
79072805
LW
3473}
3474
09bef843
SB
3475STATIC OP *
3476S_dup_attrlist(pTHX_ OP *o)
3477{
0bd48802 3478 OP *rop;
09bef843 3479
7918f24d
NC
3480 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3481
09bef843
SB
3482 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3483 * where the first kid is OP_PUSHMARK and the remaining ones
3484 * are OP_CONST. We need to push the OP_CONST values.
3485 */
3486 if (o->op_type == OP_CONST)
b37c2d43 3487 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
09bef843
SB
3488 else {
3489 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 3490 rop = NULL;
e6dae479 3491 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
09bef843 3492 if (o->op_type == OP_CONST)
2fcb4757 3493 rop = op_append_elem(OP_LIST, rop,
09bef843 3494 newSVOP(OP_CONST, o->op_flags,
b37c2d43 3495 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
3496 }
3497 }
3498 return rop;
3499}
3500
3501STATIC void
ad0dc73b 3502S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 3503{
7918f24d 3504 PERL_ARGS_ASSERT_APPLY_ATTRS;
976258ec
JH
3505 {
3506 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
7918f24d 3507
976258ec 3508 /* fake up C<use attributes $pkg,$rv,@attrs> */
e4783991 3509
09bef843 3510#define ATTRSMODULE "attributes"
95f0a2f1
SB
3511#define ATTRSMODULE_PM "attributes.pm"
3512
976258ec
JH
3513 Perl_load_module(
3514 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3515 newSVpvs(ATTRSMODULE),
3516 NULL,
3517 op_prepend_elem(OP_LIST,
3518 newSVOP(OP_CONST, 0, stashsv),
3519 op_prepend_elem(OP_LIST,
3520 newSVOP(OP_CONST, 0,
3521 newRV(target)),
3522 dup_attrlist(attrs))));
3523 }
09bef843
SB
3524}
3525
95f0a2f1
SB
3526STATIC void
3527S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3528{
3529 OP *pack, *imop, *arg;
ad0dc73b 3530 SV *meth, *stashsv, **svp;
95f0a2f1 3531
7918f24d
NC
3532 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3533
95f0a2f1
SB
3534 if (!attrs)
3535 return;
3536
3537 assert(target->op_type == OP_PADSV ||
3538 target->op_type == OP_PADHV ||
3539 target->op_type == OP_PADAV);
3540
3541 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
3542 /* Don't force the C<use> if we don't need it. */
3543 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3544 if (svp && *svp != &PL_sv_undef)
3545 NOOP; /* already in %INC */
3546 else
3547 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3548 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
3549
3550 /* Need package name for method call. */
6136c704 3551 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
3552
3553 /* Build up the real arg-list. */
976258ec 3554 stashsv = newSVhek(HvNAME_HEK(stash));
5aaec2b4 3555
95f0a2f1
SB
3556 arg = newOP(OP_PADSV, 0);
3557 arg->op_targ = target->op_targ;
2fcb4757 3558 arg = op_prepend_elem(OP_LIST,
95f0a2f1 3559 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 3560 op_prepend_elem(OP_LIST,
95f0a2f1 3561 newUNOP(OP_REFGEN, 0,
a282984d 3562 arg),
95f0a2f1
SB
3563 dup_attrlist(attrs)));
3564
3565 /* Fake up a method call to import */
18916d0d 3566 meth = newSVpvs_share("import");
03d05f6e 3567 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757 3568 op_append_elem(OP_LIST,
6aa68307 3569 op_prepend_elem(OP_LIST, pack, arg),
b46e009d 3570 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
3571
3572 /* Combine the ops. */
2fcb4757 3573 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
3574}
3575
3576/*
3577=notfor apidoc apply_attrs_string
3578
3579Attempts to apply a list of attributes specified by the C<attrstr> and
3580C<len> arguments to the subroutine identified by the C<cv> argument which
3581is expected to be associated with the package identified by the C<stashpv>
3582argument (see L<attributes>). It gets this wrong, though, in that it
3583does not correctly identify the boundaries of the individual attribute
3584specifications within C<attrstr>. This is not really intended for the
3585public API, but has to be listed here for systems such as AIX which
3586need an explicit export list for symbols. (It's called from XS code
3587in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3588to respect attribute syntax properly would be welcome.
3589
3590=cut
3591*/
3592
be3174d2 3593void
6867be6d
AL
3594Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3595 const char *attrstr, STRLEN len)
be3174d2 3596{
5f66b61c 3597 OP *attrs = NULL;
be3174d2 3598
7918f24d
NC
3599 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3600
be3174d2
GS
3601 if (!len) {
3602 len = strlen(attrstr);
3603 }
3604
3605 while (len) {
3606 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3607 if (len) {
890ce7af 3608 const char * const sstr = attrstr;
be3174d2 3609 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 3610 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
3611 newSVOP(OP_CONST, 0,
3612 newSVpvn(sstr, attrstr-sstr)));
3613 }
3614 }
3615
3616 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 3617 newSVpvs(ATTRSMODULE),
2fcb4757 3618 NULL, op_prepend_elem(OP_LIST,
be3174d2 3619 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 3620 op_prepend_elem(OP_LIST,
be3174d2 3621 newSVOP(OP_CONST, 0,
ad64d0ec 3622 newRV(MUTABLE_SV(cv))),
be3174d2
GS
3623 attrs)));
3624}
3625
eedb00fa
PM
3626STATIC void
3627S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3628{
3629 OP *new_proto = NULL;
3630 STRLEN pvlen;
3631 char *pv;
3632 OP *o;
3633
3634 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3635
3636 if (!*attrs)
3637 return;
3638
3639 o = *attrs;
3640 if (o->op_type == OP_CONST) {
3641 pv = SvPV(cSVOPo_sv, pvlen);
3642 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3643 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3644 SV ** const tmpo = cSVOPx_svp(o);
3645 SvREFCNT_dec(cSVOPo_sv);
3646 *tmpo = tmpsv;
3647 new_proto = o;
3648 *attrs = NULL;
3649 }
3650 } else if (o->op_type == OP_LIST) {
e78bc664 3651 OP * lasto;
eedb00fa 3652 assert(o->op_flags & OPf_KIDS);
e78bc664
PM
3653 lasto = cLISTOPo->op_first;
3654 assert(lasto->op_type == OP_PUSHMARK);
e6dae479 3655 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
eedb00fa
PM
3656 if (o->op_type == OP_CONST) {
3657 pv = SvPV(cSVOPo_sv, pvlen);
3658 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3659 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3660 SV ** const tmpo = cSVOPx_svp(o);
3661 SvREFCNT_dec(cSVOPo_sv);
3662 *tmpo = tmpsv;
3663 if (new_proto && ckWARN(WARN_MISC)) {
3664 STRLEN new_len;
3665 const char * newp = SvPV(cSVOPo_sv, new_len);
3666 Perl_warner(aTHX_ packWARN(WARN_MISC),
3667 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3668 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3669 op_free(new_proto);
3670 }
3671 else if (new_proto)
3672 op_free(new_proto);
3673 new_proto = o;
3253bf85
DM
3674 /* excise new_proto from the list */
3675 op_sibling_splice(*attrs, lasto, 1, NULL);
3676 o = lasto;
eedb00fa
PM
3677 continue;
3678 }
3679 }
3680 lasto = o;
3681 }
3682 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3683 would get pulled in with no real need */
e6dae479 3684 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
eedb00fa
PM
3685 op_free(*attrs);
3686 *attrs = NULL;
3687 }
3688 }
3689
3690 if (new_proto) {
3691 SV *svname;
3692 if (isGV(name)) {
3693 svname = sv_newmortal();
3694 gv_efullname3(svname, name, NULL);
3695 }
3696 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3697 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3698 else
3699 svname = (SV *)name;
3700 if (ckWARN(WARN_ILLEGALPROTO))
3701 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3702 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3703 STRLEN old_len, new_len;
3704 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3705 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
37