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