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