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