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