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