This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #128260] Fix \substr %h
[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
1a3e9724
FC
2785PERL_STATIC_INLINE bool
2786S_potential_mod_type(I32 type)
2787{
2788 /* Types that only potentially result in modification. */
2789 return type == OP_GREPSTART || type == OP_ENTERSUB
2790 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2791}
2792
79072805 2793OP *
d3d7d28f 2794Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2795{
27da23d5 2796 dVAR;
79072805 2797 OP *kid;
ddeae0f1
DM
2798 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2799 int localize = -1;
79072805 2800
13765c85 2801 if (!o || (PL_parser && PL_parser->error_count))
11343788 2802 return o;
79072805 2803
b162f9ea 2804 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2805 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2806 {
b162f9ea 2807 return o;
7e363e51 2808 }
1c846c1f 2809
5c906035
GG
2810 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2811
69974ce6
FC
2812 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2813
11343788 2814 switch (o->op_type) {
68dc0745 2815 case OP_UNDEF:
3280af22 2816 PL_modcount++;
5dc0d613 2817 return o;
5f05dabc 2818 case OP_STUB:
b5bbe64a 2819 if ((o->op_flags & OPf_PARENS))
5f05dabc
PP
2820 break;
2821 goto nomod;
a0d0e21e 2822 case OP_ENTERSUB:
f79aa60b 2823 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788 2824 !(o->op_flags & OPf_STACKED)) {
b9a07097 2825 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2826 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2827 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
2828 break;
2829 }
cd06dffe 2830 else { /* lvalue subroutine call */
9411a3c7 2831 o->op_private |= OPpLVAL_INTRO;
e6438c1a 2832 PL_modcount = RETURN_UNLIMITED_NUMBER;
1a3e9724 2833 if (S_potential_mod_type(type)) {
cd06dffe
GS
2834 o->op_private |= OPpENTERSUB_INARGS;
2835 break;
2836 }
2837 else { /* Compile-time error message: */
2838 OP *kid = cUNOPo->op_first;
2839 CV *cv;
2eaf799e 2840 GV *gv;
0f948285 2841 SV *namesv;
cd06dffe 2842
3ea285d1
AL
2843 if (kid->op_type != OP_PUSHMARK) {
2844 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2845 Perl_croak(aTHX_
2846 "panic: unexpected lvalue entersub "
2847 "args: type/targ %ld:%"UVuf,
2848 (long)kid->op_type, (UV)kid->op_targ);
2849 kid = kLISTOP->op_first;
2850 }
e6dae479
FC
2851 while (OpHAS_SIBLING(kid))
2852 kid = OpSIBLING(kid);
cd06dffe 2853 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2854 break; /* Postpone until runtime */
2855 }
b2ffa427 2856
cd06dffe
GS
2857 kid = kUNOP->op_first;
2858 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2859 kid = kUNOP->op_first;
b2ffa427 2860 if (kid->op_type == OP_NULL)
cd06dffe
GS
2861 Perl_croak(aTHX_
2862 "Unexpected constant lvalue entersub "
55140b79 2863 "entry via type/targ %ld:%"UVuf,
3d811634 2864 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2865 if (kid->op_type != OP_GV) {
cd06dffe
GS
2866 break;
2867 }
b2ffa427 2868
2eaf799e
FC
2869 gv = kGVOP_gv;
2870 cv = isGV(gv)
2871 ? GvCV(gv)
2872 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2873 ? MUTABLE_CV(SvRV(gv))
2874 : NULL;
1c846c1f 2875 if (!cv)
da1dff94 2876 break;
cd06dffe
GS
2877 if (CvLVALUE(cv))
2878 break;
0f948285
DIM
2879 if (flags & OP_LVALUE_NO_CROAK)
2880 return NULL;
2881
2882 namesv = cv_name(cv, NULL, 0);
2883 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2884 "subroutine call of &%"SVf" in %s",
2885 SVfARG(namesv), PL_op_desc[type]),
2886 SvUTF8(namesv));
2887 return o;
cd06dffe
GS
2888 }
2889 }
924ba076 2890 /* FALLTHROUGH */
79072805 2891 default:
a0d0e21e 2892 nomod:
f5d552b4 2893 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2894 /* grep, foreach, subcalls, refgen */
1a3e9724 2895 if (S_potential_mod_type(type))
a0d0e21e 2896 break;
cea2e8a9 2897 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2898 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe 2899 ? "do block"
0f948285 2900 : OP_DESC(o)),
22c35a8c 2901 type ? PL_op_desc[type] : "local"));
11343788 2902 return o;
79072805 2903
a0d0e21e
LW
2904 case OP_PREINC:
2905 case OP_PREDEC:
2906 case OP_POW:
2907 case OP_MULTIPLY:
2908 case OP_DIVIDE:
2909 case OP_MODULO:
a0d0e21e
LW
2910 case OP_ADD:
2911 case OP_SUBTRACT:
2912 case OP_CONCAT:
2913 case OP_LEFT_SHIFT:
2914 case OP_RIGHT_SHIFT:
2915 case OP_BIT_AND:
2916 case OP_BIT_XOR:
2917 case OP_BIT_OR:
2918 case OP_I_MULTIPLY:
2919 case OP_I_DIVIDE:
2920 case OP_I_MODULO:
2921 case OP_I_ADD:
2922 case OP_I_SUBTRACT:
11343788 2923 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2924 goto nomod;
3280af22 2925 PL_modcount++;
a0d0e21e 2926 break;
b2ffa427 2927
82209a5d
FC
2928 case OP_REPEAT:
2929 if (o->op_flags & OPf_STACKED) {
2930 PL_modcount++;
2931 break;
2932 }
ff781254 2933 if (!(o->op_private & OPpREPEAT_DOLIST))
82209a5d
FC
2934 goto nomod;
2935 else {
2936 const I32 mods = PL_modcount;
ff781254
FC
2937 modkids(cBINOPo->op_first, type);
2938 if (type != OP_AASSIGN)
2939 goto nomod;
5e462669 2940 kid = cBINOPo->op_last;
82209a5d 2941 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
565e104c 2942 const IV iv = SvIV(kSVOP_sv);
82209a5d
FC
2943 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2944 PL_modcount =
2945 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2946 }
2947 else
2948 PL_modcount = RETURN_UNLIMITED_NUMBER;
2949 }
2950 break;
2951
79072805 2952 case OP_COND_EXPR:
ddeae0f1 2953 localize = 1;
e6dae479 2954 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3ad73efd 2955 op_lvalue(kid, type);
79072805
LW
2956 break;
2957
2958 case OP_RV2AV:
2959 case OP_RV2HV:
11343788 2960 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2961 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2962 return o; /* Treat \(@foo) like ordinary list. */
748a9306 2963 }
924ba076 2964 /* FALLTHROUGH */
79072805 2965 case OP_RV2GV:
5dc0d613 2966 if (scalar_mod_type(o, type))
3fe9a6f1 2967 goto nomod;
11343788 2968 ref(cUNOPo->op_first, o->op_type);
924ba076 2969 /* FALLTHROUGH */
79072805
LW
2970 case OP_ASLICE:
2971 case OP_HSLICE:
ddeae0f1 2972 localize = 1;
924ba076 2973 /* FALLTHROUGH */
78f9721b 2974 case OP_AASSIGN:
32cbae3f
FC
2975 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2976 if (type == OP_LEAVESUBLV && (
2977 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2978 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2979 ))
631dbaa2 2980 o->op_private |= OPpMAYBE_LVSUB;
924ba076 2981 /* FALLTHROUGH */
93a17b20
LW
2982 case OP_NEXTSTATE:
2983 case OP_DBSTATE:
e6438c1a 2984 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2985 break;
5cae3edb 2986 case OP_KVHSLICE:
6dd3e0f2 2987 case OP_KVASLICE:
738155d2 2988 case OP_AKEYS:
5cae3edb
RZ
2989 if (type == OP_LEAVESUBLV)
2990 o->op_private |= OPpMAYBE_LVSUB;
2991 goto nomod;
cd642408
FC
2992 case OP_AVHVSWITCH:
2993 if (type == OP_LEAVESUBLV
2994 && (o->op_private & 3) + OP_EACH == OP_KEYS)
2995 o->op_private |= OPpMAYBE_LVSUB;
2996 goto nomod;
28c5b5bc
RGS
2997 case OP_AV2ARYLEN:
2998 PL_hints |= HINT_BLOCK_SCOPE;
2999 if (type == OP_LEAVESUBLV)
3000 o->op_private |= OPpMAYBE_LVSUB;
3001 PL_modcount++;
3002 break;
463ee0b2 3003 case OP_RV2SV:
aeea060c 3004 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 3005 localize = 1;
924ba076 3006 /* FALLTHROUGH */
79072805 3007 case OP_GV:
3280af22 3008 PL_hints |= HINT_BLOCK_SCOPE;
924ba076 3009 /* FALLTHROUGH */
463ee0b2 3010 case OP_SASSIGN:
bf4b1e52
GS
3011 case OP_ANDASSIGN:
3012 case OP_ORASSIGN:
c963b151 3013 case OP_DORASSIGN:
ddeae0f1
DM
3014 PL_modcount++;
3015 break;
3016
8990e307 3017 case OP_AELEMFAST:
93bad3fd 3018 case OP_AELEMFAST_LEX:
6a077020 3019 localize = -1;
3280af22 3020 PL_modcount++;
8990e307
LW
3021 break;
3022
748a9306
LW
3023 case OP_PADAV:
3024 case OP_PADHV:
e6438c1a 3025 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
3026 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3027 return o; /* Treat \(@foo) like ordinary list. */
3028 if (scalar_mod_type(o, type))
3fe9a6f1 3029 goto nomod;
32cbae3f
FC
3030 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3031 && type == OP_LEAVESUBLV)
78f9721b 3032 o->op_private |= OPpMAYBE_LVSUB;
924ba076 3033 /* FALLTHROUGH */
748a9306 3034 case OP_PADSV:
3280af22 3035 PL_modcount++;
ddeae0f1 3036 if (!type) /* local() */
ea9a9e77
FC
3037 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3038 PNfARG(PAD_COMPNAME(o->op_targ)));
e4211fee
FC
3039 if (!(o->op_private & OPpLVAL_INTRO)
3040 || ( type != OP_SASSIGN && type != OP_AASSIGN
3041 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
03414f05 3042 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
3043 break;
3044
748a9306 3045 case OP_PUSHMARK:
ddeae0f1 3046 localize = 0;
748a9306 3047 break;
b2ffa427 3048
69969c6f 3049 case OP_KEYS:
e4fc7082 3050 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
69969c6f 3051 goto nomod;
5d82c453
GA
3052 goto lvalue_func;
3053 case OP_SUBSTR:
3054 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3055 goto nomod;
924ba076 3056 /* FALLTHROUGH */
a0d0e21e 3057 case OP_POS:
463ee0b2 3058 case OP_VEC:
fad4a2e4 3059 lvalue_func:
78f9721b
SM
3060 if (type == OP_LEAVESUBLV)
3061 o->op_private |= OPpMAYBE_LVSUB;
79409ac8
FC
3062 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3063 /* substr and vec */
3064 /* If this op is in merely potential (non-fatal) modifiable
33a10326
FC
3065 context, then apply OP_ENTERSUB context to
3066 the kid op (to avoid croaking). Other-
79409ac8
FC
3067 wise pass this op’s own type so the correct op is mentioned
3068 in error messages. */
3069 op_lvalue(OpSIBLING(cBINOPo->op_first),
33a10326
FC
3070 S_potential_mod_type(type)
3071 ? OP_ENTERSUB
3072 : o->op_type);
79409ac8 3073 }
463ee0b2 3074 break;
a0d0e21e 3075
463ee0b2
LW
3076 case OP_AELEM:
3077 case OP_HELEM:
11343788 3078 ref(cBINOPo->op_first, o->op_type);
68dc0745 3079 if (type == OP_ENTERSUB &&
5dc0d613
MB
3080 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3081 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
3082 if (type == OP_LEAVESUBLV)
3083 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 3084 localize = 1;
3280af22 3085 PL_modcount++;
463ee0b2
LW
3086 break;
3087
463ee0b2 3088 case OP_LEAVE:
a373464f 3089 case OP_LEAVELOOP:
2ec7f6f2 3090 o->op_private |= OPpLVALUE;
924ba076 3091 /* FALLTHROUGH */
2ec7f6f2 3092 case OP_SCOPE:
463ee0b2 3093 case OP_ENTER:
78f9721b 3094 case OP_LINESEQ:
ddeae0f1 3095 localize = 0;
11343788 3096 if (o->op_flags & OPf_KIDS)
3ad73efd 3097 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
3098 break;
3099
3100 case OP_NULL:
ddeae0f1 3101 localize = 0;
638bc118
GS
3102 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3103 goto nomod;
3104 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 3105 break;
11343788 3106 if (o->op_targ != OP_LIST) {
3ad73efd 3107 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
3108 break;
3109 }
924ba076 3110 /* FALLTHROUGH */
463ee0b2 3111 case OP_LIST:
ddeae0f1 3112 localize = 0;
e6dae479 3113 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5c906035
GG
3114 /* elements might be in void context because the list is
3115 in scalar context or because they are attribute sub calls */
3116 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3117 op_lvalue(kid, type);
463ee0b2 3118 break;
78f9721b 3119
1efec5ed
FC
3120 case OP_COREARGS:
3121 return o;
2ec7f6f2
FC
3122
3123 case OP_AND:
3124 case OP_OR:
375879aa
FC
3125 if (type == OP_LEAVESUBLV
3126 || !S_vivifies(cLOGOPo->op_first->op_type))
3127 op_lvalue(cLOGOPo->op_first, type);
3128 if (type == OP_LEAVESUBLV
e6dae479
FC
3129 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3130 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
2ec7f6f2 3131 goto nomod;
26a50d99
FC
3132
3133 case OP_SREFGEN:
d39c26a6
FC
3134 if (type != OP_AASSIGN && type != OP_SASSIGN
3135 && type != OP_ENTERLOOP)
3136 goto nomod;
7664512e 3137 /* Don’t bother applying lvalue context to the ex-list. */
26a50d99 3138 kid = cUNOPx(cUNOPo->op_first)->op_first;
e6dae479 3139 assert (!OpHAS_SIBLING(kid));
217e3565
FC
3140 goto kid_2lvref;
3141 case OP_REFGEN:
3142 if (type != OP_AASSIGN) goto nomod;
7664512e
FC
3143 kid = cUNOPo->op_first;
3144 kid_2lvref:
3145 {
3146 const U8 ec = PL_parser ? PL_parser->error_count : 0;
63702de8 3147 S_lvref(aTHX_ kid, type);
7664512e 3148 if (!PL_parser || PL_parser->error_count == ec) {
baabe3fb 3149 if (!FEATURE_REFALIASING_IS_ENABLED)
7664512e 3150 Perl_croak(aTHX_
baabe3fb 3151 "Experimental aliasing via reference not enabled");
7664512e 3152 Perl_ck_warner_d(aTHX_
baabe3fb
FC
3153 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3154 "Aliasing via reference is experimental");
7664512e
FC
3155 }
3156 }
217e3565
FC
3157 if (o->op_type == OP_REFGEN)
3158 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3159 op_null(o);
26a50d99 3160 return o;
e4e95921
FC
3161
3162 case OP_SPLIT:
3163 kid = cLISTOPo->op_first;
3164 if (kid && kid->op_type == OP_PUSHRE &&
3165 ( kid->op_targ
3166 || o->op_flags & OPf_STACKED
3167#ifdef USE_ITHREADS
3168 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3169#else
3170 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3171#endif
3172 )) {
3173 /* This is actually @array = split. */
3174 PL_modcount = RETURN_UNLIMITED_NUMBER;
3175 break;
3176 }
3177 goto nomod;
569ddb4a
FC
3178
3179 case OP_SCALAR:
3180 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3181 goto nomod;
463ee0b2 3182 }
58d95175 3183
8be1be90
AMS
3184 /* [20011101.069] File test operators interpret OPf_REF to mean that
3185 their argument is a filehandle; thus \stat(".") should not set
3186 it. AMS 20011102 */
3187 if (type == OP_REFGEN &&
ef69c8fc 3188 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
3189 return o;
3190
3191 if (type != OP_LEAVESUBLV)
3192 o->op_flags |= OPf_MOD;
3193
3194 if (type == OP_AASSIGN || type == OP_SASSIGN)
3195 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
3196 else if (!type) { /* local() */
3197 switch (localize) {
3198 case 1:
3199 o->op_private |= OPpLVAL_INTRO;
3200 o->op_flags &= ~OPf_SPECIAL;
3201 PL_hints |= HINT_BLOCK_SCOPE;
3202 break;
3203 case 0:
3204 break;
3205 case -1:
a2a5de95
NC
3206 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3207 "Useless localization of %s", OP_DESC(o));
ddeae0f1 3208 }
463ee0b2 3209 }
8be1be90
AMS
3210 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3211 && type != OP_LEAVESUBLV)
3212 o->op_flags |= OPf_REF;
11343788 3213 return o;
463ee0b2
LW
3214}
3215
864dbfa3 3216STATIC bool
5f66b61c 3217S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
3218{
3219 switch (type) {
32a60974 3220 case OP_POS:
3fe9a6f1 3221 case OP_SASSIGN:
1efec5ed 3222 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 3223 return FALSE;
924ba076 3224 /* FALLTHROUGH */
3fe9a6f1
PP
3225 case OP_PREINC:
3226 case OP_PREDEC:
3227 case OP_POSTINC:
3228 case OP_POSTDEC:
3229 case OP_I_PREINC:
3230 case OP_I_PREDEC:
3231 case OP_I_POSTINC:
3232 case OP_I_POSTDEC:
3233 case OP_POW:
3234 case OP_MULTIPLY:
3235 case OP_DIVIDE:
3236 case OP_MODULO:
3237 case OP_REPEAT:
3238 case OP_ADD:
3239 case OP_SUBTRACT:
3240 case OP_I_MULTIPLY:
3241 case OP_I_DIVIDE:
3242 case OP_I_MODULO:
3243 case OP_I_ADD:
3244 case OP_I_SUBTRACT:
3245 case OP_LEFT_SHIFT:
3246 case OP_RIGHT_SHIFT:
3247 case OP_BIT_AND:
3248 case OP_BIT_XOR:
3249 case OP_BIT_OR:
76734a32
FC
3250 case OP_NBIT_AND:
3251 case OP_NBIT_XOR:
3252 case OP_NBIT_OR:
3253 case OP_SBIT_AND:
3254 case OP_SBIT_XOR:
3255 case OP_SBIT_OR:
3fe9a6f1
PP
3256 case OP_CONCAT:
3257 case OP_SUBST:
3258 case OP_TRANS:
bb16bae8 3259 case OP_TRANSR:
49e9fbe6
GS
3260 case OP_READ:
3261 case OP_SYSREAD:
3262 case OP_RECV:
bf4b1e52
GS
3263 case OP_ANDASSIGN:
3264 case OP_ORASSIGN:
410d09fe 3265 case OP_DORASSIGN:
79409ac8
FC
3266 case OP_VEC:
3267 case OP_SUBSTR:
3fe9a6f1
PP
3268 return TRUE;
3269 default:
3270 return FALSE;
3271 }
3272}
3273
35cd451c 3274STATIC bool
5f66b61c 3275S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 3276{
7918f24d
NC
3277 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3278
35cd451c
GS
3279 switch (o->op_type) {
3280 case OP_PIPE_OP:
3281 case OP_SOCKPAIR:
504618e9 3282 if (numargs == 2)
35cd451c 3283 return TRUE;
924ba076 3284 /* FALLTHROUGH */
35cd451c
GS
3285 case OP_SYSOPEN:
3286 case OP_OPEN:
ded8aa31 3287 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
3288 case OP_SOCKET:
3289 case OP_OPEN_DIR:
3290 case OP_ACCEPT:
504618e9 3291 if (numargs == 1)
35cd451c 3292 return TRUE;
5f66b61c 3293 /* FALLTHROUGH */
35cd451c
GS
3294 default:
3295 return FALSE;
3296 }
3297}
3298
0d86688d
NC
3299static OP *
3300S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 3301{
11343788 3302 if (o && o->op_flags & OPf_KIDS) {
6867be6d 3303 OP *kid;
e6dae479 3304 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
463ee0b2
LW
3305 ref(kid, type);
3306 }
11343788 3307 return o;
463ee0b2
LW
3308}
3309
3310OP *
e4c5ccf3 3311Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 3312{
27da23d5 3313 dVAR;
463ee0b2 3314 OP *kid;
463ee0b2 3315
7918f24d
NC
3316 PERL_ARGS_ASSERT_DOREF;
3317
3dc78631 3318 if (PL_parser && PL_parser->error_count)
11343788 3319 return o;
463ee0b2 3320
11343788 3321 switch (o->op_type) {
a0d0e21e 3322 case OP_ENTERSUB:
f4df43b5 3323 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788 3324 !(o->op_flags & OPf_STACKED)) {
b9a07097 3325 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
11343788 3326 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 3327 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 3328 o->op_flags |= OPf_SPECIAL;
8990e307 3329 }
767eda44 3330 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
3331 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3332 : type == OP_RV2HV ? OPpDEREF_HV
3333 : OPpDEREF_SV);
767eda44
FC
3334 o->op_flags |= OPf_MOD;
3335 }
3336
8990e307 3337 break;
aeea060c 3338
463ee0b2 3339 case OP_COND_EXPR:
e6dae479 3340 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
e4c5ccf3 3341 doref(kid, type, set_op_ref);
463ee0b2 3342 break;
8990e307 3343 case OP_RV2SV:
35cd451c
GS
3344 if (type == OP_DEFINED)
3345 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3346 doref(cUNOPo->op_first, o->op_type, set_op_ref);
924ba076 3347 /* FALLTHROUGH */
4633a7c4 3348 case OP_PADSV:
5f05dabc 3349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3351 : type == OP_RV2HV ? OPpDEREF_HV
3352 : OPpDEREF_SV);
11343788 3353 o->op_flags |= OPf_MOD;
a0d0e21e 3354 }
8990e307 3355 break;
1c846c1f 3356
463ee0b2
LW
3357 case OP_RV2AV:
3358 case OP_RV2HV:
e4c5ccf3
RH
3359 if (set_op_ref)
3360 o->op_flags |= OPf_REF;
924ba076 3361 /* FALLTHROUGH */
463ee0b2 3362 case OP_RV2GV:
35cd451c
GS
3363 if (type == OP_DEFINED)
3364 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3365 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 3366 break;
8990e307 3367
463ee0b2
LW
3368 case OP_PADAV:
3369 case OP_PADHV:
e4c5ccf3
RH
3370 if (set_op_ref)
3371 o->op_flags |= OPf_REF;
79072805 3372 break;
aeea060c 3373
8990e307 3374 case OP_SCALAR:
79072805 3375 case OP_NULL:
518618af 3376 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 3377 break;
e4c5ccf3 3378 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
3379 break;
3380 case OP_AELEM:
3381 case OP_HELEM:
e4c5ccf3 3382 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 3383 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3384 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3385 : type == OP_RV2HV ? OPpDEREF_HV
3386 : OPpDEREF_SV);
11343788 3387 o->op_flags |= OPf_MOD;
8990e307 3388 }
79072805
LW
3389 break;
3390
463ee0b2 3391 case OP_SCOPE:
79072805 3392 case OP_LEAVE:
e4c5ccf3 3393 set_op_ref = FALSE;
924ba076 3394 /* FALLTHROUGH */
79072805 3395 case OP_ENTER:
8990e307 3396 case OP_LIST:
11343788 3397 if (!(o->op_flags & OPf_KIDS))
79072805 3398 break;
e4c5ccf3 3399 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 3400 break;
a0d0e21e
LW
3401 default:
3402 break;
79072805 3403 }
11343788 3404 return scalar(o);
8990e307 3405
79072805
LW
3406}
3407
09bef843
SB
3408STATIC OP *
3409S_dup_attrlist(pTHX_ OP *o)
3410{
0bd48802 3411 OP *rop;
09bef843 3412
7918f24d
NC
3413 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3414
09bef843
SB
3415 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3416 * where the first kid is OP_PUSHMARK and the remaining ones
3417 * are OP_CONST. We need to push the OP_CONST values.
3418 */
3419 if (o->op_type == OP_CONST)
b37c2d43 3420 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
09bef843
SB
3421 else {
3422 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 3423 rop = NULL;
e6dae479 3424 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
09bef843 3425 if (o->op_type == OP_CONST)
2fcb4757 3426 rop = op_append_elem(OP_LIST, rop,
09bef843 3427 newSVOP(OP_CONST, o->op_flags,
b37c2d43 3428 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
3429 }
3430 }
3431 return rop;
3432}
3433
3434STATIC void
ad0dc73b 3435S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 3436{
7918f24d 3437 PERL_ARGS_ASSERT_APPLY_ATTRS;
976258ec
JH
3438 {
3439 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
7918f24d 3440
976258ec 3441 /* fake up C<use attributes $pkg,$rv,@attrs> */
e4783991 3442
09bef843 3443#define ATTRSMODULE "attributes"
95f0a2f1
SB
3444#define ATTRSMODULE_PM "attributes.pm"
3445
976258ec
JH
3446 Perl_load_module(
3447 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3448 newSVpvs(ATTRSMODULE),
3449 NULL,
3450 op_prepend_elem(OP_LIST,
3451 newSVOP(OP_CONST, 0, stashsv),
3452 op_prepend_elem(OP_LIST,
3453 newSVOP(OP_CONST, 0,
3454 newRV(target)),
3455 dup_attrlist(attrs))));
3456 }
09bef843
SB
3457}
3458
95f0a2f1
SB
3459STATIC void
3460S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3461{
3462 OP *pack, *imop, *arg;
ad0dc73b 3463 SV *meth, *stashsv, **svp;
95f0a2f1 3464
7918f24d
NC
3465 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3466
95f0a2f1
SB
3467 if (!attrs)
3468 return;
3469
3470 assert(target->op_type == OP_PADSV ||
3471 target->op_type == OP_PADHV ||
3472 target->op_type == OP_PADAV);
3473
3474 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
3475 /* Don't force the C<use> if we don't need it. */
3476 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3477 if (svp && *svp != &PL_sv_undef)
3478 NOOP; /* already in %INC */
3479 else
3480 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3481 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
3482
3483 /* Need package name for method call. */
6136c704 3484 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
3485
3486 /* Build up the real arg-list. */
976258ec 3487 stashsv = newSVhek(HvNAME_HEK(stash));
5aaec2b4 3488
95f0a2f1
SB
3489 arg = newOP(OP_PADSV, 0);
3490 arg->op_targ = target->op_targ;
2fcb4757 3491 arg = op_prepend_elem(OP_LIST,
95f0a2f1 3492 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 3493 op_prepend_elem(OP_LIST,
95f0a2f1 3494 newUNOP(OP_REFGEN, 0,
a282984d 3495 arg),
95f0a2f1
SB
3496 dup_attrlist(attrs)));
3497
3498 /* Fake up a method call to import */
18916d0d 3499 meth = newSVpvs_share("import");
03d05f6e 3500 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757 3501 op_append_elem(OP_LIST,
6aa68307 3502 op_prepend_elem(OP_LIST, pack, arg),
b46e009d 3503 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
3504
3505 /* Combine the ops. */
2fcb4757 3506 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
3507}
3508
3509/*
3510=notfor apidoc apply_attrs_string
3511
3512Attempts to apply a list of attributes specified by the C<attrstr> and
3513C<len> arguments to the subroutine identified by the C<cv> argument which
3514is expected to be associated with the package identified by the C<stashpv>
3515argument (see L<attributes>). It gets this wrong, though, in that it
3516does not correctly identify the boundaries of the individual attribute
3517specifications within C<attrstr>. This is not really intended for the
3518public API, but has to be listed here for systems such as AIX which
3519need an explicit export list for symbols. (It's called from XS code
3520in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3521to respect attribute syntax properly would be welcome.
3522
3523=cut
3524*/
3525
be3174d2 3526void
6867be6d
AL
3527Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3528 const char *attrstr, STRLEN len)
be3174d2 3529{
5f66b61c 3530 OP *attrs = NULL;
be3174d2 3531
7918f24d
NC
3532 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3533
be3174d2
GS
3534 if (!len) {
3535 len = strlen(attrstr);
3536 }
3537
3538 while (len) {
3539 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3540 if (len) {
890ce7af 3541 const char * const sstr = attrstr;
be3174d2 3542 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 3543 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
3544 newSVOP(OP_CONST, 0,
3545 newSVpvn(sstr, attrstr-sstr)));
3546 }
3547 }
3548
3549 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 3550 newSVpvs(ATTRSMODULE),
2fcb4757 3551 NULL, op_prepend_elem(OP_LIST,
be3174d2 3552 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 3553 op_prepend_elem(OP_LIST,
be3174d2 3554 newSVOP(OP_CONST, 0,
ad64d0ec 3555 newRV(MUTABLE_SV(cv))),
be3174d2
GS
3556 attrs)));
3557}
3558
eedb00fa
PM
3559STATIC void
3560S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3561{
3562 OP *new_proto = NULL;
3563 STRLEN pvlen;
3564 char *pv;
3565 OP *o;
3566
3567 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3568
3569 if (!*attrs)
3570 return;
3571
3572 o = *attrs;
3573 if (o->op_type == OP_CONST) {
3574 pv = SvPV(cSVOPo_sv, pvlen);
3575 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3576 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3577 SV ** const tmpo = cSVOPx_svp(o);
3578 SvREFCNT_dec(cSVOPo_sv);
3579 *tmpo = tmpsv;
3580 new_proto = o;
3581 *attrs = NULL;
3582 }
3583 } else if (o->op_type == OP_LIST) {
e78bc664 3584 OP * lasto;
eedb00fa 3585 assert(o->op_flags & OPf_KIDS);
e78bc664
PM
3586 lasto = cLISTOPo->op_first;
3587 assert(lasto->op_type == OP_PUSHMARK);
e6dae479 3588 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
eedb00fa
PM
3589 if (o->op_type == OP_CONST) {
3590 pv = SvPV(cSVOPo_sv, pvlen);
3591 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3592 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3593 SV ** const tmpo = cSVOPx_svp(o);
3594 SvREFCNT_dec(cSVOPo_sv);
3595 *tmpo = tmpsv;
3596 if (new_proto && ckWARN(WARN_MISC)) {
3597 STRLEN new_len;
3598 const char * newp = SvPV(cSVOPo_sv, new_len);
3599 Perl_warner(aTHX_ packWARN(WARN_MISC),
3600 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3601 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3602 op_free(new_proto);
3603 }
3604 else if (new_proto)
3605 op_free(new_proto);
3606 new_proto = o;
3253bf85
DM
3607 /* excise new_proto from the list */
3608 op_sibling_splice(*attrs, lasto, 1, NULL);
3609 o = lasto;
eedb00fa
PM
3610 continue;
3611 }
3612 }
3613 lasto = o;
3614 }
3615 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3616 would get pulled in with no real need */
e6dae479 3617 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
eedb00fa
PM
3618 op_free(*attrs);
3619 *attrs = NULL;
3620 }
3621 }
3622
3623 if (new_proto) {
3624 SV *svname;
3625 if (isGV(name)) {
3626 svname = sv_newmortal();
3627 gv_efullname3(svname, name, NULL);
3628 }
3629 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3630 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3631 else
3632 svname = (SV *)name;
3633 if (ckWARN(WARN_ILLEGALPROTO))
3634 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3635 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3636 STRLEN old_len, new_len;
3637 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3638 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3639
3640 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3641 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3642 " in %"SVf,
3643 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3644 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3645 SVfARG(svname));
3646 }
3647 if (*proto)
3648 op_free(*proto);
3649 *proto = new_proto;
3650 }
3651}
3652
92bd82a0
FC
3653static void
3654S_cant_declare(pTHX_ OP *o)
3655{
4748e002
FC
3656 if (o->op_type == OP_NULL
3657 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3658 o = cUNOPo->op_first;
92bd82a0 3659 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4748e002
FC
3660 o->op_type == OP_NULL
3661 && o->op_flags & OPf_SPECIAL
3662 ? "do block"
3663 : OP_DESC(o),
92bd82a0
FC
3664 PL_parser->in_my == KEY_our ? "our" :
3665 PL_parser->in_my == KEY_state ? "state" :
3666 "my"));
3667}
3668
09bef843 3669STATIC OP *
95f0a2f1 3670S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 3671{
93a17b20 3672 I32 type;
a1fba7eb 3673 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 3674
7918f24d
NC
3675 PERL_ARGS_ASSERT_MY_KID;
3676
13765c85 3677 if (!o || (PL_parser && PL_parser->error_count))
11343788 3678 return o;
93a17b20 3679
bc61e325 3680 type = o->op_type;
eb8433b7 3681
93a17b20 3682 if (type == OP_LIST) {
6867be6d 3683 OP *kid;
e6dae479 3684 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
95f0a2f1 3685 my_kid(kid, attrs, imopsp);
0865059d 3686 return o;
8b8c1fb9 3687 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 3688 return o;
77ca0c92
LW
3689 } else if (type == OP_RV2SV || /* "our" declaration */
3690 type == OP_RV2AV ||
fbe0543b 3691 type == OP_RV2HV) {
1ce0b88c 3692 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
92bd82a0 3693 S_cant_declare(aTHX_ o);
1ce0b88c 3694 } else if (attrs) {
551405c4 3695 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
316ebaf2 3696 assert(PL_parser);
12bd6ede
DM
3697 PL_parser->in_my = FALSE;
3698 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
3699 apply_attrs(GvSTASH(gv),
3700 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
3701 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3702 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 3703 attrs);