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