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