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