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