This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #123223] Make PADNAME a separate type
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC
4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW
10 */
11
12/*
4ac71550
TC
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW
20 */
21
166f8a29
DM
22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM
47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM
62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC
99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
aa9d1253
TC
112/* Used to avoid recursion through the op tree in scalarvoid() and
113 op_free()
114*/
115
116#define DEFERRED_OP_STEP 100
117#define DEFER_OP(o) \
118 STMT_START { \
119 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
120 defer_stack_alloc += DEFERRED_OP_STEP; \
121 assert(defer_stack_alloc > 0); \
122 Renew(defer_stack, defer_stack_alloc, OP *); \
123 } \
124 defer_stack[++defer_ix] = o; \
125 } STMT_END
126
127#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
128
72621f84
DM
129/* remove any leading "empty" ops from the op_next chain whose first
130 * node's address is stored in op_p. Store the updated address of the
131 * first node in op_p.
132 */
133
134STATIC void
dc3bf405 135S_prune_chain_head(OP** op_p)
72621f84
DM
136{
137 while (*op_p
138 && ( (*op_p)->op_type == OP_NULL
139 || (*op_p)->op_type == OP_SCOPE
140 || (*op_p)->op_type == OP_SCALAR
141 || (*op_p)->op_type == OP_LINESEQ)
142 )
143 *op_p = (*op_p)->op_next;
144}
145
146
8be227ab
FC
147/* See the explanatory comments above struct opslab in op.h. */
148
7aef8e5b 149#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
150# define PERL_SLAB_SIZE 128
151# define PERL_MAX_SLAB_SIZE 4096
152# include <sys/mman.h>
7aef8e5b 153#endif
3107b51f 154
7aef8e5b 155#ifndef PERL_SLAB_SIZE
8be227ab 156# define PERL_SLAB_SIZE 64
7aef8e5b
FC
157#endif
158#ifndef PERL_MAX_SLAB_SIZE
e6cee8c0 159# define PERL_MAX_SLAB_SIZE 2048
7aef8e5b 160#endif
8be227ab
FC
161
162/* rounds up to nearest pointer */
7aef8e5b
FC
163#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
164#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
8be227ab
FC
165
166static OPSLAB *
167S_new_slab(pTHX_ size_t sz)
168{
7aef8e5b 169#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
170 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
171 PROT_READ|PROT_WRITE,
172 MAP_ANON|MAP_PRIVATE, -1, 0);
173 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
174 (unsigned long) sz, slab));
175 if (slab == MAP_FAILED) {
176 perror("mmap failed");
177 abort();
178 }
179 slab->opslab_size = (U16)sz;
7aef8e5b 180#else
8be227ab 181 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
7aef8e5b 182#endif
dc3bf405
BF
183#ifndef WIN32
184 /* The context is unused in non-Windows */
185 PERL_UNUSED_CONTEXT;
186#endif
8be227ab
FC
187 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
188 return slab;
189}
190
e7372881
FC
191/* requires double parens and aTHX_ */
192#define DEBUG_S_warn(args) \
193 DEBUG_S( \
194 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
195 )
196
8be227ab
FC
197void *
198Perl_Slab_Alloc(pTHX_ size_t sz)
199{
8be227ab
FC
200 OPSLAB *slab;
201 OPSLAB *slab2;
202 OPSLOT *slot;
203 OP *o;
5cb52f30 204 size_t opsz, space;
8be227ab 205
2073970f
NC
206 /* We only allocate ops from the slab during subroutine compilation.
207 We find the slab via PL_compcv, hence that must be non-NULL. It could
208 also be pointing to a subroutine which is now fully set up (CvROOT()
209 pointing to the top of the optree for that sub), or a subroutine
210 which isn't using the slab allocator. If our sanity checks aren't met,
211 don't use a slab, but allocate the OP directly from the heap. */
8be227ab
FC
212 if (!PL_compcv || CvROOT(PL_compcv)
213 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
29e61fd9
DM
214 {
215 o = (OP*)PerlMemShared_calloc(1, sz);
216 goto gotit;
217 }
8be227ab 218
2073970f
NC
219 /* While the subroutine is under construction, the slabs are accessed via
220 CvSTART(), to avoid needing to expand PVCV by one pointer for something
221 unneeded at runtime. Once a subroutine is constructed, the slabs are
222 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
223 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
224 details. */
225 if (!CvSTART(PL_compcv)) {
8be227ab
FC
226 CvSTART(PL_compcv) =
227 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
228 CvSLABBED_on(PL_compcv);
229 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
230 }
231 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
232
5cb52f30
FC
233 opsz = SIZE_TO_PSIZE(sz);
234 sz = opsz + OPSLOT_HEADER_P;
8be227ab 235
2073970f
NC
236 /* The slabs maintain a free list of OPs. In particular, constant folding
237 will free up OPs, so it makes sense to re-use them where possible. A
238 freed up slot is used in preference to a new allocation. */
8be227ab
FC
239 if (slab->opslab_freed) {
240 OP **too = &slab->opslab_freed;
241 o = *too;
eb212a1c 242 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
8be227ab 243 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
e7372881 244 DEBUG_S_warn((aTHX_ "Alas! too small"));
8be227ab 245 o = *(too = &o->op_next);
eb212a1c 246 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
8be227ab
FC
247 }
248 if (o) {
249 *too = o->op_next;
5cb52f30 250 Zero(o, opsz, I32 *);
8be227ab 251 o->op_slabbed = 1;
29e61fd9 252 goto gotit;
8be227ab
FC
253 }
254 }
255
7aef8e5b 256#define INIT_OPSLOT \
8be227ab
FC
257 slot->opslot_slab = slab; \
258 slot->opslot_next = slab2->opslab_first; \
259 slab2->opslab_first = slot; \
260 o = &slot->opslot_op; \
261 o->op_slabbed = 1
262
263 /* The partially-filled slab is next in the chain. */
264 slab2 = slab->opslab_next ? slab->opslab_next : slab;
265 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
266 /* Remaining space is too small. */
267
8be227ab
FC
268 /* If we can fit a BASEOP, add it to the free chain, so as not
269 to waste it. */
270 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
271 slot = &slab2->opslab_slots;
272 INIT_OPSLOT;
273 o->op_type = OP_FREED;
274 o->op_next = slab->opslab_freed;
275 slab->opslab_freed = o;
276 }
277
278 /* Create a new slab. Make this one twice as big. */
279 slot = slab2->opslab_first;
280 while (slot->opslot_next) slot = slot->opslot_next;
af7751f6
FC
281 slab2 = S_new_slab(aTHX_
282 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
e6cee8c0 283 ? PERL_MAX_SLAB_SIZE
af7751f6 284 : (DIFF(slab2, slot)+1)*2);
9963ffa2
FC
285 slab2->opslab_next = slab->opslab_next;
286 slab->opslab_next = slab2;
8be227ab
FC
287 }
288 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
289
290 /* Create a new op slot */
291 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
292 assert(slot >= &slab2->opslab_slots);
51c777ca
FC
293 if (DIFF(&slab2->opslab_slots, slot)
294 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
295 slot = &slab2->opslab_slots;
8be227ab 296 INIT_OPSLOT;
eb212a1c 297 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
29e61fd9
DM
298
299 gotit:
300 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
301 o->op_lastsib = 1;
302 assert(!o->op_sibling);
303
8be227ab
FC
304 return (void *)o;
305}
306
7aef8e5b 307#undef INIT_OPSLOT
8be227ab 308
7aef8e5b 309#ifdef PERL_DEBUG_READONLY_OPS
3107b51f
FC
310void
311Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
312{
313 PERL_ARGS_ASSERT_SLAB_TO_RO;
314
315 if (slab->opslab_readonly) return;
316 slab->opslab_readonly = 1;
317 for (; slab; slab = slab->opslab_next) {
318 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
319 (unsigned long) slab->opslab_size, slab));*/
320 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
321 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
322 (unsigned long)slab->opslab_size, errno);
323 }
324}
325
7bbbc3c0
NC
326void
327Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
3107b51f 328{
3107b51f
FC
329 OPSLAB *slab2;
330
331 PERL_ARGS_ASSERT_SLAB_TO_RW;
332
3107b51f
FC
333 if (!slab->opslab_readonly) return;
334 slab2 = slab;
335 for (; slab2; slab2 = slab2->opslab_next) {
336 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
337 (unsigned long) size, slab2));*/
338 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
339 PROT_READ|PROT_WRITE)) {
340 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
341 (unsigned long)slab2->opslab_size, errno);
342 }
343 }
344 slab->opslab_readonly = 0;
345}
346
347#else
9e4d7a13 348# define Slab_to_rw(op) NOOP
3107b51f
FC
349#endif
350
8be227ab
FC
351/* This cannot possibly be right, but it was copied from the old slab
352 allocator, to which it was originally added, without explanation, in
353 commit 083fcd5. */
7aef8e5b 354#ifdef NETWARE
8be227ab 355# define PerlMemShared PerlMem
7aef8e5b 356#endif
8be227ab
FC
357
358void
359Perl_Slab_Free(pTHX_ void *op)
360{
361 OP * const o = (OP *)op;
362 OPSLAB *slab;
363
364 PERL_ARGS_ASSERT_SLAB_FREE;
365
366 if (!o->op_slabbed) {
90840c5d
RU
367 if (!o->op_static)
368 PerlMemShared_free(op);
8be227ab
FC
369 return;
370 }
371
372 slab = OpSLAB(o);
373 /* If this op is already freed, our refcount will get screwy. */
374 assert(o->op_type != OP_FREED);
375 o->op_type = OP_FREED;
376 o->op_next = slab->opslab_freed;
377 slab->opslab_freed = o;
eb212a1c 378 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
8be227ab
FC
379 OpslabREFCNT_dec_padok(slab);
380}
381
382void
383Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
384{
8be227ab
FC
385 const bool havepad = !!PL_comppad;
386 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
387 if (havepad) {
388 ENTER;
389 PAD_SAVE_SETNULLPAD();
390 }
391 opslab_free(slab);
392 if (havepad) LEAVE;
393}
394
395void
396Perl_opslab_free(pTHX_ OPSLAB *slab)
397{
398 OPSLAB *slab2;
399 PERL_ARGS_ASSERT_OPSLAB_FREE;
81611534 400 PERL_UNUSED_CONTEXT;
eb212a1c 401 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
8be227ab
FC
402 assert(slab->opslab_refcnt == 1);
403 for (; slab; slab = slab2) {
404 slab2 = slab->opslab_next;
7aef8e5b 405#ifdef DEBUGGING
8be227ab 406 slab->opslab_refcnt = ~(size_t)0;
7aef8e5b
FC
407#endif
408#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 409 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
eb212a1c 410 (void*)slab));
3107b51f
FC
411 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
412 perror("munmap failed");
413 abort();
414 }
7aef8e5b 415#else
8be227ab 416 PerlMemShared_free(slab);
7aef8e5b 417#endif
8be227ab
FC
418 }
419}
420
421void
422Perl_opslab_force_free(pTHX_ OPSLAB *slab)
423{
424 OPSLAB *slab2;
425 OPSLOT *slot;
7aef8e5b 426#ifdef DEBUGGING
8be227ab 427 size_t savestack_count = 0;
7aef8e5b 428#endif
8be227ab
FC
429 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
430 slab2 = slab;
431 do {
432 for (slot = slab2->opslab_first;
433 slot->opslot_next;
434 slot = slot->opslot_next) {
435 if (slot->opslot_op.op_type != OP_FREED
436 && !(slot->opslot_op.op_savefree
7aef8e5b 437#ifdef DEBUGGING
8be227ab 438 && ++savestack_count
7aef8e5b 439#endif
8be227ab
FC
440 )
441 ) {
442 assert(slot->opslot_op.op_slabbed);
8be227ab 443 op_free(&slot->opslot_op);
3bf28c7e 444 if (slab->opslab_refcnt == 1) goto free;
8be227ab
FC
445 }
446 }
447 } while ((slab2 = slab2->opslab_next));
448 /* > 1 because the CV still holds a reference count. */
449 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
7aef8e5b 450#ifdef DEBUGGING
8be227ab 451 assert(savestack_count == slab->opslab_refcnt-1);
7aef8e5b 452#endif
ee5ee853
FC
453 /* Remove the CV’s reference count. */
454 slab->opslab_refcnt--;
8be227ab
FC
455 return;
456 }
457 free:
458 opslab_free(slab);
459}
460
3107b51f
FC
461#ifdef PERL_DEBUG_READONLY_OPS
462OP *
463Perl_op_refcnt_inc(pTHX_ OP *o)
464{
465 if(o) {
372eab01
NC
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
467 if (slab && slab->opslab_readonly) {
83519873 468 Slab_to_rw(slab);
372eab01
NC
469 ++o->op_targ;
470 Slab_to_ro(slab);
471 } else {
472 ++o->op_targ;
473 }
3107b51f
FC
474 }
475 return o;
476
477}
478
479PADOFFSET
480Perl_op_refcnt_dec(pTHX_ OP *o)
481{
372eab01
NC
482 PADOFFSET result;
483 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
484
3107b51f 485 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
372eab01
NC
486
487 if (slab && slab->opslab_readonly) {
83519873 488 Slab_to_rw(slab);
372eab01
NC
489 result = --o->op_targ;
490 Slab_to_ro(slab);
491 } else {
492 result = --o->op_targ;
493 }
494 return result;
3107b51f
FC
495}
496#endif
e50aee73 497/*
ce6f1cbc 498 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 499 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 500 */
11343788 501#define CHECKOP(type,o) \
ce6f1cbc 502 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 503 ? ( op_free((OP*)o), \
cb77fdf0 504 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 505 (OP*)0 ) \
16c91539 506 : PL_check[type](aTHX_ (OP*)o))
e50aee73 507
e6438c1a 508#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 509
cba5a3b0
DG
510#define CHANGE_TYPE(o,type) \
511 STMT_START { \
512 o->op_type = (OPCODE)type; \
513 o->op_ppaddr = PL_ppaddr[type]; \
514 } STMT_END
515
76e3520e 516STATIC OP *
cea2e8a9 517S_no_fh_allowed(pTHX_ OP *o)
79072805 518{
7918f24d
NC
519 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
520
cea2e8a9 521 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 522 OP_DESC(o)));
11343788 523 return o;
79072805
LW
524}
525
76e3520e 526STATIC OP *
ce16c625
BF
527S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
528{
529 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
530 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
531 return o;
532}
533
534STATIC OP *
535S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
536{
537 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 538
ce16c625 539 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 540 return o;
79072805
LW
541}
542
76e3520e 543STATIC void
ce16c625 544S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 545{
ce16c625
BF
546 PERL_ARGS_ASSERT_BAD_TYPE_PV;
547
548 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
549 (int)n, name, t, OP_DESC(kid)), flags);
550}
7918f24d 551
ce16c625 552STATIC void
7b3b0904 553S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
ce16c625 554{
ecf05a58 555 SV * const namesv = cv_name((CV *)gv, NULL, 0);
7b3b0904 556 PERL_ARGS_ASSERT_BAD_TYPE_GV;
ce16c625
BF
557
558 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
559 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW
560}
561
7a52d87a 562STATIC void
eb796c7f 563S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 564{
7918f24d
NC
565 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
566
5a844595 567 qerror(Perl_mess(aTHX_
35c1215d 568 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 569 SVfARG(cSVOPo_sv)));
eb796c7f 570 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS
571}
572
79072805
LW
573/* "register" allocation */
574
575PADOFFSET
d6447115 576Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 577{
a0d0e21e 578 PADOFFSET off;
12bd6ede 579 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 580
7918f24d
NC
581 PERL_ARGS_ASSERT_ALLOCMY;
582
48d0d1be 583 if (flags & ~SVf_UTF8)
d6447115
NC
584 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
585 (UV)flags);
586
59f00321 587 /* complain about "my $<special_var>" etc etc */
d6447115 588 if (len &&
3edf23ff 589 !(is_our ||
155aba94 590 isALPHA(name[1]) ||
b14845b4 591 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 592 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 593 {
b14845b4
FC
594 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
595 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC
596 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
597 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 598 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 599 } else {
ce16c625
BF
600 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
601 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 602 }
a0d0e21e 603 }
4055dbce
RS
604 else if (len == 2 && name[1] == '_' && !is_our)
605 /* diag_listed_as: Use of my $_ is experimental */
606 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
607 "Use of %s $_ is experimental",
608 PL_parser->in_my == KEY_state
609 ? "state"
610 : "my");
748a9306 611
dd2155a4 612 /* allocate a spare slot and store the name in that slot */
93a17b20 613
cc76b5cc 614 off = pad_add_name_pvn(name, len,
48d0d1be 615 (is_our ? padadd_OUR :
2502ffdf 616 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
12bd6ede 617 PL_parser->in_my_stash,
3edf23ff 618 (is_our
133706a6 619 /* $_ is always in main::, even with our */
ef00320b
FC
620 ? (PL_curstash && !memEQs(name,len,"$_")
621 ? PL_curstash
622 : PL_defstash)
5c284bb0 623 : NULL
cca43f78 624 )
dd2155a4 625 );
a74073ad
DM
626 /* anon sub prototypes contains state vars should always be cloned,
627 * otherwise the state var would be shared between anon subs */
628
629 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
630 CvCLONE_on(PL_compcv);
631
dd2155a4 632 return off;
79072805
LW
633}
634
c0b8aebd 635/*
dcccc8ff
KW
636=head1 Optree Manipulation Functions
637
c0b8aebd
FC
638=for apidoc alloccopstash
639
640Available only under threaded builds, this function allocates an entry in
641C<PL_stashpad> for the stash passed to it.
642
643=cut
644*/
645
d4d03940
FC
646#ifdef USE_ITHREADS
647PADOFFSET
1dc74fdb 648Perl_alloccopstash(pTHX_ HV *hv)
d4d03940
FC
649{
650 PADOFFSET off = 0, o = 1;
651 bool found_slot = FALSE;
652
1dc74fdb
FC
653 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
654
655 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
d4d03940 656
1dc74fdb
FC
657 for (; o < PL_stashpadmax; ++o) {
658 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
659 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
d4d03940
FC
660 found_slot = TRUE, off = o;
661 }
662 if (!found_slot) {
1dc74fdb
FC
663 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
664 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
665 off = PL_stashpadmax;
666 PL_stashpadmax += 10;
d4d03940
FC
667 }
668
1dc74fdb 669 PL_stashpad[PL_stashpadix = off] = hv;
d4d03940
FC
670 return off;
671}
672#endif
673
d2c837a0
DM
674/* free the body of an op without examining its contents.
675 * Always use this rather than FreeOp directly */
676
4136a0f7 677static void
d2c837a0
DM
678S_op_destroy(pTHX_ OP *o)
679{
d2c837a0
DM
680 FreeOp(o);
681}
682
79072805
LW
683/* Destructor */
684
6e53b6ca
DD
685/*
686=for apidoc Am|void|op_free|OP *o
687
cc41839b
FC
688Free an op. Only use this when an op is no longer linked to from any
689optree.
6e53b6ca
DD
690
691=cut
692*/
693
79072805 694void
864dbfa3 695Perl_op_free(pTHX_ OP *o)
79072805 696{
27da23d5 697 dVAR;
acb36ea4 698 OPCODE type;
0997db6f
TC
699 SSize_t defer_ix = -1;
700 SSize_t defer_stack_alloc = 0;
701 OP **defer_stack = NULL;
79072805 702
0997db6f 703 do {
79072805 704
0997db6f
TC
705 /* Though ops may be freed twice, freeing the op after its slab is a
706 big no-no. */
707 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
708 /* During the forced freeing of ops after compilation failure, kidops
709 may be freed before their parents. */
710 if (!o || o->op_type == OP_FREED)
711 continue;
d0c8136d 712
0997db6f 713 type = o->op_type;
d0c8136d 714
0997db6f
TC
715 /* an op should only ever acquire op_private flags that we know about.
716 * If this fails, you may need to fix something in regen/op_private */
717 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
718 assert(!(o->op_private & ~PL_op_private_valid[type]));
719 }
7934575e 720
0997db6f
TC
721 if (o->op_private & OPpREFCOUNTED) {
722 switch (type) {
723 case OP_LEAVESUB:
724 case OP_LEAVESUBLV:
725 case OP_LEAVEEVAL:
726 case OP_LEAVE:
727 case OP_SCOPE:
728 case OP_LEAVEWRITE:
729 {
730 PADOFFSET refcnt;
731 OP_REFCNT_LOCK;
732 refcnt = OpREFCNT_dec(o);
733 OP_REFCNT_UNLOCK;
734 if (refcnt) {
735 /* Need to find and remove any pattern match ops from the list
736 we maintain for reset(). */
737 find_and_forget_pmops(o);
738 continue;
739 }
740 }
741 break;
742 default:
743 break;
744 }
745 }
f37b8c3f 746
0997db6f
TC
747 /* Call the op_free hook if it has been set. Do it now so that it's called
748 * at the right time for refcounted ops, but still before all of the kids
749 * are freed. */
750 CALL_OPFREEHOOK(o);
751
752 if (o->op_flags & OPf_KIDS) {
753 OP *kid, *nextkid;
754 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
755 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
756 if (!kid || kid->op_type == OP_FREED)
757 /* During the forced freeing of ops after
758 compilation failure, kidops may be freed before
759 their parents. */
760 continue;
761 if (!(kid->op_flags & OPf_KIDS))
762 /* If it has no kids, just free it now */
763 op_free(kid);
764 else
aa9d1253 765 DEFER_OP(kid);
0997db6f
TC
766 }
767 }
768 if (type == OP_NULL)
769 type = (OPCODE)o->op_targ;
acb36ea4 770
0997db6f
TC
771 if (o->op_slabbed)
772 Slab_to_rw(OpSLAB(o));
fc97af9c 773
0997db6f
TC
774 /* COP* is not cleared by op_clear() so that we may track line
775 * numbers etc even after null() */
776 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
777 cop_free((COP*)o);
778 }
acb36ea4 779
0997db6f
TC
780 op_clear(o);
781 FreeOp(o);
4d494880 782#ifdef DEBUG_LEAKING_SCALARS
0997db6f
TC
783 if (PL_op == o)
784 PL_op = NULL;
4d494880 785#endif
aa9d1253 786 } while ( (o = POP_DEFERRED_OP()) );
0997db6f
TC
787
788 Safefree(defer_stack);
acb36ea4 789}
79072805 790
93c66552
DM
791void
792Perl_op_clear(pTHX_ OP *o)
acb36ea4 793{
13137afc 794
27da23d5 795 dVAR;
7918f24d
NC
796
797 PERL_ARGS_ASSERT_OP_CLEAR;
798
11343788 799 switch (o->op_type) {
acb36ea4 800 case OP_NULL: /* Was holding old type, if any. */
c67159e1 801 /* FALLTHROUGH */
4d193d44 802 case OP_ENTERTRY:
acb36ea4 803 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 804 o->op_targ = 0;
a0d0e21e 805 break;
a6006777 806 default:
ac4c12e7 807 if (!(o->op_flags & OPf_REF)
ef69c8fc 808 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 809 break;
924ba076 810 /* FALLTHROUGH */
463ee0b2 811 case OP_GVSV:
79072805 812 case OP_GV:
a6006777 813 case OP_AELEMFAST:
93bad3fd 814 {
f7461760
Z
815 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
816#ifdef USE_ITHREADS
817 && PL_curpad
818#endif
819 ? cGVOPo_gv : NULL;
b327b36f
NC
820 /* It's possible during global destruction that the GV is freed
821 before the optree. Whilst the SvREFCNT_inc is happy to bump from
822 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
823 will trigger an assertion failure, because the entry to sv_clear
824 checks that the scalar is not already freed. A check of for
825 !SvIS_FREED(gv) turns out to be invalid, because during global
826 destruction the reference count can be forced down to zero
827 (with SVf_BREAK set). In which case raising to 1 and then
828 dropping to 0 triggers cleanup before it should happen. I
829 *think* that this might actually be a general, systematic,
830 weakness of the whole idea of SVf_BREAK, in that code *is*
831 allowed to raise and lower references during global destruction,
832 so any *valid* code that happens to do this during global
833 destruction might well trigger premature cleanup. */
834 bool still_valid = gv && SvREFCNT(gv);
835
836 if (still_valid)
837 SvREFCNT_inc_simple_void(gv);
350de78d 838#ifdef USE_ITHREADS
6a077020 839 if (cPADOPo->op_padix > 0) {
6a077020
DM
840 pad_swipe(cPADOPo->op_padix, TRUE);
841 cPADOPo->op_padix = 0;
842 }
350de78d 843#else
6a077020 844 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 845 cSVOPo->op_sv = NULL;
350de78d 846#endif
b327b36f 847 if (still_valid) {
f7461760 848 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 849 SvREFCNT_dec_NN(gv);
f7461760
Z
850 if (try_downgrade)
851 gv_try_downgrade(gv);
852 }
6a077020 853 }
79072805 854 break;
a1ae71d2 855 case OP_METHOD_NAMED:
7d6c333c 856 case OP_METHOD_SUPER:
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
865 break;
79072805 866 case OP_CONST:
996c9baa 867 case OP_HINTSEVAL:
11343788 868 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 869 cSVOPo->op_sv = NULL;
3b1c21fa
AB
870#ifdef USE_ITHREADS
871 /** Bug #15654
872 Even if op_clear does a pad_free for the target of the op,
6a077020 873 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
874 instead it lives on. This results in that it could be reused as
875 a target later on when the pad was reallocated.
876 **/
877 if(o->op_targ) {
878 pad_swipe(o->op_targ,1);
879 o->op_targ = 0;
880 }
881#endif
79072805 882 break;
c9df4fda 883 case OP_DUMP:
748a9306
LW
884 case OP_GOTO:
885 case OP_NEXT:
886 case OP_LAST:
887 case OP_REDO:
11343788 888 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306 889 break;
924ba076 890 /* FALLTHROUGH */
a0d0e21e 891 case OP_TRANS:
bb16bae8 892 case OP_TRANSR:
acb36ea4 893 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
99a1d0d1 894 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
043e41b8
DM
895#ifdef USE_ITHREADS
896 if (cPADOPo->op_padix > 0) {
897 pad_swipe(cPADOPo->op_padix, TRUE);
898 cPADOPo->op_padix = 0;
899 }
900#else
a0ed51b3 901 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 902 cSVOPo->op_sv = NULL;
043e41b8 903#endif
acb36ea4
GS
904 }
905 else {
ea71c68d 906 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 907 cPVOPo->op_pv = NULL;
acb36ea4 908 }
a0d0e21e
LW
909 break;
910 case OP_SUBST:
20e98b0f 911 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 912 goto clear_pmop;
748a9306 913 case OP_PUSHRE:
971a9dd3 914#ifdef USE_ITHREADS
20e98b0f 915 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
20e98b0f 916 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS
917 }
918#else
ad64d0ec 919 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3 920#endif
924ba076 921 /* FALLTHROUGH */
a0d0e21e 922 case OP_MATCH:
8782bef2 923 case OP_QR:
971a9dd3 924clear_pmop:
867940b8
DM
925 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
926 op_free(cPMOPo->op_code_list);
68e2671b 927 cPMOPo->op_code_list = NULL;
23083432 928 forget_pmop(cPMOPo);
20e98b0f 929 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC
930 /* we use the same protection as the "SAFE" version of the PM_ macros
931 * here since sv_clean_all might release some PMOPs
5f8cb046
DM
932 * after PL_regex_padav has been cleared
933 * and the clearing of PL_regex_padav needs to
934 * happen before sv_clean_all
935 */
13137afc
AB
936#ifdef USE_ITHREADS
937 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 938 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 939 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC
940 PL_regex_pad[offset] = &PL_sv_undef;
941 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
942 sizeof(offset));
13137afc 943 }
9cddf794
NC
944#else
945 ReREFCNT_dec(PM_GETRE(cPMOPo));
946 PM_SETRE(cPMOPo, NULL);
1eb1540c 947#endif
13137afc 948
a0d0e21e 949 break;
79072805
LW
950 }
951
743e66e6 952 if (o->op_targ > 0) {
11343788 953 pad_free(o->op_targ);
743e66e6
GS
954 o->op_targ = 0;
955 }
79072805
LW
956}
957
76e3520e 958STATIC void
3eb57f73
HS
959S_cop_free(pTHX_ COP* cop)
960{
7918f24d
NC
961 PERL_ARGS_ASSERT_COP_FREE;
962
05ec9bb3 963 CopFILE_free(cop);
0453d815 964 if (! specialWARN(cop->cop_warnings))
72dc9ed5 965 PerlMemShared_free(cop->cop_warnings);
20439bc7 966 cophh_free(CopHINTHASH_get(cop));
515abc43
FC
967 if (PL_curcop == cop)
968 PL_curcop = NULL;
3eb57f73
HS
969}
970
c2b1997a 971STATIC void
c4bd3ae5 972S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 973 )
c2b1997a
NC
974{
975 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
976
977 PERL_ARGS_ASSERT_FORGET_PMOP;
978
e39a6381 979 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 980 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
981 if (mg) {
982 PMOP **const array = (PMOP**) mg->mg_ptr;
983 U32 count = mg->mg_len / sizeof(PMOP**);
984 U32 i = count;
985
986 while (i--) {
987 if (array[i] == o) {
988 /* Found it. Move the entry at the end to overwrite it. */
989 array[i] = array[--count];
990 mg->mg_len = count * sizeof(PMOP**);
991 /* Could realloc smaller at this point always, but probably
992 not worth it. Probably worth free()ing if we're the
993 last. */
994 if(!count) {
995 Safefree(mg->mg_ptr);
996 mg->mg_ptr = NULL;
997 }
998 break;
999 }
1000 }
1001 }
1002 }
1cdf7faf
NC
1003 if (PL_curpm == o)
1004 PL_curpm = NULL;
c2b1997a
NC
1005}
1006
bfd0ff22
NC
1007STATIC void
1008S_find_and_forget_pmops(pTHX_ OP *o)
1009{
7918f24d
NC
1010 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1011
bfd0ff22
NC
1012 if (o->op_flags & OPf_KIDS) {
1013 OP *kid = cUNOPo->op_first;
1014 while (kid) {
1015 switch (kid->op_type) {
1016 case OP_SUBST:
1017 case OP_PUSHRE:
1018 case OP_MATCH:
1019 case OP_QR:
23083432 1020 forget_pmop((PMOP*)kid);
bfd0ff22
NC
1021 }
1022 find_and_forget_pmops(kid);
1ed44841 1023 kid = OP_SIBLING(kid);
bfd0ff22
NC
1024 }
1025 }
1026}
1027
6e53b6ca
DD
1028/*
1029=for apidoc Am|void|op_null|OP *o
1030
1031Neutralizes an op when it is no longer needed, but is still linked to from
1032other ops.
1033
1034=cut
1035*/
1036
93c66552
DM
1037void
1038Perl_op_null(pTHX_ OP *o)
8990e307 1039{
27da23d5 1040 dVAR;
7918f24d
NC
1041
1042 PERL_ARGS_ASSERT_OP_NULL;
1043
acb36ea4
GS
1044 if (o->op_type == OP_NULL)
1045 return;
b5bbe64a 1046 op_clear(o);
11343788 1047 o->op_targ = o->op_type;
10884df9 1048 CHANGE_TYPE(o, OP_NULL);
8990e307
LW
1049}
1050
4026c95a
SH
1051void
1052Perl_op_refcnt_lock(pTHX)
1053{
20b7effb 1054#ifdef USE_ITHREADS
27da23d5 1055 dVAR;
20b7effb 1056#endif
96a5add6 1057 PERL_UNUSED_CONTEXT;
4026c95a
SH
1058 OP_REFCNT_LOCK;
1059}
1060
1061void
1062Perl_op_refcnt_unlock(pTHX)
1063{
20b7effb 1064#ifdef USE_ITHREADS
27da23d5 1065 dVAR;
20b7effb 1066#endif
96a5add6 1067 PERL_UNUSED_CONTEXT;
4026c95a
SH
1068 OP_REFCNT_UNLOCK;
1069}
1070
3253bf85
DM
1071
1072/*
1073=for apidoc op_sibling_splice
1074
1075A general function for editing the structure of an existing chain of
7e234f81 1076op_sibling nodes. By analogy with the perl-level splice() function, allows
3253bf85
DM
1077you to delete zero or more sequential nodes, replacing them with zero or
1078more different nodes. Performs the necessary op_first/op_last
29e61fd9 1079housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1080children. The last deleted node will be marked as as the last node by
8ae26bff 1081updating the op_sibling or op_lastsib field as appropriate.
3253bf85
DM
1082
1083Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1084responsibility of the caller. It also won't create a new list op for an
8ae26bff 1085empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85
DM
1086
1087parent is the parent node of the sibling chain.
1088
7e234f81
FC
1089start is the node preceding the first node to be spliced. Node(s)
1090following it will be deleted, and ops will be inserted after it. If it is
3253bf85
DM
1091NULL, the first node onwards is deleted, and nodes are inserted at the
1092beginning.
1093
7e234f81 1094del_count is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1095If -1 or greater than or equal to the number of remaining kids, all
1096remaining kids are deleted.
1097
1098insert is the first of a chain of nodes to be inserted in place of the nodes.
1099If NULL, no nodes are inserted.
1100
8ae26bff 1101The head of the chain of deleted ops is returned, or NULL if no ops were
3253bf85
DM
1102deleted.
1103
1104For example:
1105
1106 action before after returns
1107 ------ ----- ----- -------
1108
1109 P P
8ae26bff
DM
1110 splice(P, A, 2, X-Y-Z) | | B-C
1111 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1112
1113 P P
1114 splice(P, NULL, 1, X-Y) | | A
1115 A-B-C-D X-Y-B-C-D
1116
1117 P P
8ae26bff
DM
1118 splice(P, NULL, 3, NULL) | | A-B-C
1119 A-B-C-D D
3253bf85
DM
1120
1121 P P
1122 splice(P, B, 0, X-Y) | | NULL
1123 A-B-C-D A-B-X-Y-C-D
1124
1125=cut
1126*/
1127
1128OP *
8ae26bff 1129Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1130{
3253bf85
DM
1131 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1132 OP *rest;
1133 OP *last_del = NULL;
1134 OP *last_ins = NULL;
1135
1136 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1137
1138 assert(del_count >= -1);
1139
1140 if (del_count && first) {
1141 last_del = first;
1142 while (--del_count && OP_HAS_SIBLING(last_del))
1143 last_del = OP_SIBLING(last_del);
1144 rest = OP_SIBLING(last_del);
1145 OP_SIBLING_set(last_del, NULL);
29e61fd9 1146 last_del->op_lastsib = 1;
3253bf85
DM
1147 }
1148 else
1149 rest = first;
1150
1151 if (insert) {
1152 last_ins = insert;
1153 while (OP_HAS_SIBLING(last_ins))
1154 last_ins = OP_SIBLING(last_ins);
1155 OP_SIBLING_set(last_ins, rest);
29e61fd9 1156 last_ins->op_lastsib = rest ? 0 : 1;
3253bf85
DM
1157 }
1158 else
1159 insert = rest;
1160
29e61fd9 1161 if (start) {
3253bf85 1162 OP_SIBLING_set(start, insert);
29e61fd9
DM
1163 start->op_lastsib = insert ? 0 : 1;
1164 }
3253bf85
DM
1165 else
1166 cLISTOPx(parent)->op_first = insert;
1167
1168 if (!rest) {
29e61fd9 1169 /* update op_last etc */
3253bf85 1170 U32 type = parent->op_type;
29e61fd9 1171 OP *lastop;
3253bf85
DM
1172
1173 if (type == OP_NULL)
1174 type = parent->op_targ;
1175 type = PL_opargs[type] & OA_CLASS_MASK;
1176
29e61fd9 1177 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1178 if ( type == OA_BINOP
1179 || type == OA_LISTOP
1180 || type == OA_PMOP
1181 || type == OA_LOOP
1182 )
29e61fd9
DM
1183 cLISTOPx(parent)->op_last = lastop;
1184
1185 if (lastop) {
1186 lastop->op_lastsib = 1;
1187#ifdef PERL_OP_PARENT
1188 lastop->op_sibling = parent;
1189#endif
1190 }
3253bf85
DM
1191 }
1192 return last_del ? first : NULL;
1193}
1194
29e61fd9
DM
1195/*
1196=for apidoc op_parent
1197
7e234f81 1198returns the parent OP of o, if it has a parent. Returns NULL otherwise.
29e61fd9
DM
1199(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1200work.
1201
1202=cut
1203*/
1204
1205OP *
8ae26bff 1206Perl_op_parent(OP *o)
29e61fd9
DM
1207{
1208 PERL_ARGS_ASSERT_OP_PARENT;
1209#ifdef PERL_OP_PARENT
1210 while (OP_HAS_SIBLING(o))
1211 o = OP_SIBLING(o);
1212 return o->op_sibling;
1213#else
1214 PERL_UNUSED_ARG(o);
1215 return NULL;
1216#endif
1217}
1218
3253bf85
DM
1219
1220/* replace the sibling following start with a new UNOP, which becomes
1221 * the parent of the original sibling; e.g.
1222 *
1223 * op_sibling_newUNOP(P, A, unop-args...)
1224 *
1225 * P P
1226 * | becomes |
1227 * A-B-C A-U-C
1228 * |
1229 * B
1230 *
1231 * where U is the new UNOP.
1232 *
1233 * parent and start args are the same as for op_sibling_splice();
1234 * type and flags args are as newUNOP().
1235 *
1236 * Returns the new UNOP.
1237 */
1238
1239OP *
1240S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1241{
1242 OP *kid, *newop;
1243
1244 kid = op_sibling_splice(parent, start, 1, NULL);
1245 newop = newUNOP(type, flags, kid);
1246 op_sibling_splice(parent, start, 0, newop);
1247 return newop;
1248}
1249
1250
1251/* lowest-level newLOGOP-style function - just allocates and populates
1252 * the struct. Higher-level stuff should be done by S_new_logop() /
1253 * newLOGOP(). This function exists mainly to avoid op_first assignment
1254 * being spread throughout this file.
1255 */
1256
1257LOGOP *
1258S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1259{
1e8db68a 1260 dVAR;
3253bf85 1261 LOGOP *logop;
29e61fd9 1262 OP *kid = first;
3253bf85 1263 NewOp(1101, logop, 1, LOGOP);
ddacf109 1264 CHANGE_TYPE(logop, type);
3253bf85
DM
1265 logop->op_first = first;
1266 logop->op_other = other;
1267 logop->op_flags = OPf_KIDS;
29e61fd9
DM
1268 while (kid && OP_HAS_SIBLING(kid))
1269 kid = OP_SIBLING(kid);
1270 if (kid) {
1271 kid->op_lastsib = 1;
1272#ifdef PERL_OP_PARENT
1273 kid->op_sibling = (OP*)logop;
1274#endif
1275 }
3253bf85
DM
1276 return logop;
1277}
1278
1279
79072805
LW
1280/* Contextualizers */
1281
d9088386
Z
1282/*
1283=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1284
1285Applies a syntactic context to an op tree representing an expression.
1286I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1287or C<G_VOID> to specify the context to apply. The modified op tree
1288is returned.
1289
1290=cut
1291*/
1292
1293OP *
1294Perl_op_contextualize(pTHX_ OP *o, I32 context)
1295{
1296 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1297 switch (context) {
1298 case G_SCALAR: return scalar(o);
1299 case G_ARRAY: return list(o);
1300 case G_VOID: return scalarvoid(o);
1301 default:
5637ef5b
NC
1302 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1303 (long) context);
d9088386
Z
1304 }
1305}
1306
5983a79d 1307/*
79072805 1308
5983a79d 1309=for apidoc Am|OP*|op_linklist|OP *o
72d33970 1310This function is the implementation of the L</LINKLIST> macro. It should
5983a79d
BM
1311not be called directly.
1312
1313=cut
1314*/
1315
1316OP *
1317Perl_op_linklist(pTHX_ OP *o)
79072805 1318{
3edf23ff 1319 OP *first;
79072805 1320
5983a79d 1321 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1322
11343788
MB
1323 if (o->op_next)
1324 return o->op_next;
79072805
LW
1325
1326 /* establish postfix order */
3edf23ff
AL
1327 first = cUNOPo->op_first;
1328 if (first) {
eb578fdb 1329 OP *kid;
3edf23ff
AL
1330 o->op_next = LINKLIST(first);
1331 kid = first;
1332 for (;;) {
29e61fd9
DM
1333 OP *sibl = OP_SIBLING(kid);
1334 if (sibl) {
1335 kid->op_next = LINKLIST(sibl);
1336 kid = sibl;
3edf23ff 1337 } else {
11343788 1338 kid->op_next = o;
3edf23ff
AL
1339 break;
1340 }
79072805
LW
1341 }
1342 }
1343 else
11343788 1344 o->op_next = o;
79072805 1345
11343788 1346 return o->op_next;
79072805
LW
1347}
1348
1f676739 1349static OP *
2dd5337b 1350S_scalarkids(pTHX_ OP *o)
79072805 1351{
11343788 1352 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1353 OP *kid;
1ed44841 1354 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
79072805
LW
1355 scalar(kid);
1356 }
11343788 1357 return o;
79072805
LW
1358}
1359
76e3520e 1360STATIC OP *
cea2e8a9 1361S_scalarboolean(pTHX_ OP *o)
8990e307 1362{
7918f24d
NC
1363 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1364
6b7c6d95
FC
1365 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1366 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1367 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1368 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1369
2b7cddde
NC
1370 if (PL_parser && PL_parser->copline != NOLINE) {
1371 /* This ensures that warnings are reported at the first line
1372 of the conditional, not the last. */
53a7735b 1373 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1374 }
9014280d 1375 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1376 CopLINE_set(PL_curcop, oldline);
d008e5eb 1377 }
a0d0e21e 1378 }
11343788 1379 return scalar(o);
8990e307
LW
1380}
1381
0920b7fa
FC
1382static SV *
1383S_op_varname(pTHX_ const OP *o)
1384{
1385 assert(o);
1386 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1387 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1388 {
1389 const char funny = o->op_type == OP_PADAV
1390 || o->op_type == OP_RV2AV ? '@' : '%';
1391 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1392 GV *gv;
1393 if (cUNOPo->op_first->op_type != OP_GV
1394 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1395 return NULL;
1396 return varname(gv, funny, 0, NULL, 0, 1);
1397 }
1398 return
1399 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1400 }
1401}
1402
429a2555 1403static void
2186f873
FC
1404S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1405{ /* or not so pretty :-) */
2186f873
FC
1406 if (o->op_type == OP_CONST) {
1407 *retsv = cSVOPo_sv;
1408 if (SvPOK(*retsv)) {
1409 SV *sv = *retsv;
1410 *retsv = sv_newmortal();
1411 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1412 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1413 }
1414 else if (!SvOK(*retsv))
1415 *retpv = "undef";
1416 }
1417 else *retpv = "...";
1418}
1419
1420static void
429a2555
FC
1421S_scalar_slice_warning(pTHX_ const OP *o)
1422{
1423 OP *kid;
1424 const char lbrack =
2186f873 1425 o->op_type == OP_HSLICE ? '{' : '[';
429a2555 1426 const char rbrack =
2186f873 1427 o->op_type == OP_HSLICE ? '}' : ']';
429a2555 1428 SV *name;
32e9ec8f 1429 SV *keysv = NULL; /* just to silence compiler warnings */
429a2555
FC
1430 const char *key = NULL;
1431
1432 if (!(o->op_private & OPpSLICEWARNING))
1433 return;
1434 if (PL_parser && PL_parser->error_count)
1435 /* This warning can be nonsensical when there is a syntax error. */
1436 return;
1437
1438 kid = cLISTOPo->op_first;
1ed44841 1439 kid = OP_SIBLING(kid); /* get past pushmark */
429a2555
FC
1440 /* weed out false positives: any ops that can return lists */
1441 switch (kid->op_type) {
1442 case OP_BACKTICK:
1443 case OP_GLOB:
1444 case OP_READLINE:
1445 case OP_MATCH:
1446 case OP_RV2AV:
1447 case OP_EACH:
1448 case OP_VALUES:
1449 case OP_KEYS:
1450 case OP_SPLIT:
1451 case OP_LIST:
1452 case OP_SORT:
1453 case OP_REVERSE:
1454 case OP_ENTERSUB:
1455 case OP_CALLER:
1456 case OP_LSTAT:
1457 case OP_STAT:
1458 case OP_READDIR:
1459 case OP_SYSTEM:
1460 case OP_TMS:
1461 case OP_LOCALTIME:
1462 case OP_GMTIME:
1463 case OP_ENTEREVAL:
1464 case OP_REACH:
1465 case OP_RKEYS:
1466 case OP_RVALUES:
1467 return;
1468 }
7d3c8a68
SM
1469
1470 /* Don't warn if we have a nulled list either. */
1471 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1472 return;
1473
1ed44841
DM
1474 assert(OP_SIBLING(kid));
1475 name = S_op_varname(aTHX_ OP_SIBLING(kid));
429a2555
FC
1476 if (!name) /* XS module fiddling with the op tree */
1477 return;
2186f873 1478 S_op_pretty(aTHX_ kid, &keysv, &key);
429a2555
FC
1479 assert(SvPOK(name));
1480 sv_chop(name,SvPVX(name)+1);
1481 if (key)
2186f873 1482 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1483 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1484 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
429a2555 1485 "%c%s%c",
2186f873 1486 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
429a2555
FC
1487 lbrack, key, rbrack);
1488 else
2186f873 1489 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
429a2555 1490 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2186f873 1491 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
429a2555 1492 SVf"%c%"SVf"%c",
c1f6cd39
BF
1493 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1494 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
429a2555
FC
1495}
1496
8990e307 1497OP *
864dbfa3 1498Perl_scalar(pTHX_ OP *o)
79072805
LW
1499{
1500 OP *kid;
1501
a0d0e21e 1502 /* assumes no premature commitment */
13765c85
DM
1503 if (!o || (PL_parser && PL_parser->error_count)
1504 || (o->op_flags & OPf_WANT)
5dc0d613 1505 || o->op_type == OP_RETURN)
7e363e51 1506 {
11343788 1507 return o;
7e363e51 1508 }
79072805 1509
5dc0d613 1510 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1511
11343788 1512 switch (o->op_type) {
79072805 1513 case OP_REPEAT:
11343788 1514 scalar(cBINOPo->op_first);
82e4f303
FC
1515 if (o->op_private & OPpREPEAT_DOLIST) {
1516 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1517 assert(kid->op_type == OP_PUSHMARK);
1518 if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
1519 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1520 o->op_private &=~ OPpREPEAT_DOLIST;
1521 }
1522 }
8990e307 1523 break;
79072805
LW
1524 case OP_OR:
1525 case OP_AND:
1526 case OP_COND_EXPR:
1ed44841 1527 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
8990e307 1528 scalar(kid);
79072805 1529 break;
924ba076 1530 /* FALLTHROUGH */
a6d8037e 1531 case OP_SPLIT:
79072805 1532 case OP_MATCH:
8782bef2 1533 case OP_QR:
79072805
LW
1534 case OP_SUBST:
1535 case OP_NULL:
8990e307 1536 default:
11343788 1537 if (o->op_flags & OPf_KIDS) {
1ed44841 1538 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
8990e307
LW
1539 scalar(kid);
1540 }
79072805
LW
1541 break;
1542 case OP_LEAVE:
1543 case OP_LEAVETRY:
5dc0d613 1544 kid = cLISTOPo->op_first;
54310121 1545 scalar(kid);
1ed44841 1546 kid = OP_SIBLING(kid);
25b991bf
VP
1547 do_kids:
1548 while (kid) {
1ed44841 1549 OP *sib = OP_SIBLING(kid);
34b54951
FC
1550 if (sib && kid->op_type != OP_LEAVEWHEN
1551 && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
1552 || ( sib->op_targ != OP_NEXTSTATE
1553 && sib->op_targ != OP_DBSTATE )))
c08f093b
VP
1554 scalarvoid(kid);
1555 else
54310121 1556 scalar(kid);
25b991bf 1557 kid = sib;
54310121 1558 }
11206fdd 1559 PL_curcop = &PL_compiling;
54310121 1560 break;
748a9306 1561 case OP_SCOPE:
79072805 1562 case OP_LINESEQ:
8990e307 1563 case OP_LIST:
25b991bf
VP
1564 kid = cLISTOPo->op_first;
1565 goto do_kids;
a801c63c 1566 case OP_SORT:
a2a5de95 1567 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1568 break;
95a31aad
FC
1569 case OP_KVHSLICE:
1570 case OP_KVASLICE:
2186f873
FC
1571 {
1572 /* Warn about scalar context */
1573 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1574 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1575 SV *name;
1576 SV *keysv;
1577 const char *key = NULL;
1578
1579 /* This warning can be nonsensical when there is a syntax error. */
1580 if (PL_parser && PL_parser->error_count)
1581 break;
1582
1583 if (!ckWARN(WARN_SYNTAX)) break;
1584
1585 kid = cLISTOPo->op_first;
1ed44841
DM
1586 kid = OP_SIBLING(kid); /* get past pushmark */
1587 assert(OP_SIBLING(kid));
1588 name = S_op_varname(aTHX_ OP_SIBLING(kid));
2186f873
FC
1589 if (!name) /* XS module fiddling with the op tree */
1590 break;
1591 S_op_pretty(aTHX_ kid, &keysv, &key);
1592 assert(SvPOK(name));
1593 sv_chop(name,SvPVX(name)+1);
1594 if (key)
1595 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1596 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1597 "%%%"SVf"%c%s%c in scalar context better written "
1598 "as $%"SVf"%c%s%c",
1599 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1600 lbrack, key, rbrack);
1601 else
1602 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1603 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1604 "%%%"SVf"%c%"SVf"%c in scalar context better "
1605 "written as $%"SVf"%c%"SVf"%c",
c1f6cd39
BF
1606 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1607 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2186f873 1608 }
79072805 1609 }
11343788 1610 return o;
79072805
LW
1611}
1612
1613OP *
aa9d1253 1614Perl_scalarvoid(pTHX_ OP *arg)
79072805 1615{
27da23d5 1616 dVAR;
79072805 1617 OP *kid;
8990e307 1618 SV* sv;
2ebea0a1 1619 U8 want;
aa9d1253
TC
1620 SSize_t defer_stack_alloc = 0;
1621 SSize_t defer_ix = -1;
1622 OP **defer_stack = NULL;
1623 OP *o = arg;
2ebea0a1 1624
7918f24d
NC
1625 PERL_ARGS_ASSERT_SCALARVOID;
1626
aa9d1253
TC
1627 do {
1628 SV *useless_sv = NULL;
1629 const char* useless = NULL;
1630
26f0e7d5
TC
1631 if (o->op_type == OP_NEXTSTATE
1632 || o->op_type == OP_DBSTATE
1633 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1634 || o->op_targ == OP_DBSTATE)))
1635 PL_curcop = (COP*)o; /* for warning below */
1636
1637 /* assumes no premature commitment */
1638 want = o->op_flags & OPf_WANT;
1639 if ((want && want != OPf_WANT_SCALAR)
1640 || (PL_parser && PL_parser->error_count)
1641 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1642 {
1643 continue;
1644 }
1c846c1f 1645
26f0e7d5
TC
1646 if ((o->op_private & OPpTARGET_MY)
1647 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1648 {
0d18dd72
FC
1649 /* newASSIGNOP has already applied scalar context, which we
1650 leave, as if this op is inside SASSIGN. */
26f0e7d5
TC
1651 continue;
1652 }
79072805 1653
26f0e7d5 1654 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
75068674 1655
26f0e7d5
TC
1656 switch (o->op_type) {
1657 default:
1658 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1659 break;
1660 /* FALLTHROUGH */
1661 case OP_REPEAT:
1662 if (o->op_flags & OPf_STACKED)
1663 break;
1664 goto func_ops;
1665 case OP_SUBSTR:
1666 if (o->op_private == 4)
1667 break;
1668 /* FALLTHROUGH */
26f0e7d5
TC
1669 case OP_WANTARRAY:
1670 case OP_GV:
1671 case OP_SMARTMATCH:
26f0e7d5
TC
1672 case OP_AV2ARYLEN:
1673 case OP_REF:
1674 case OP_REFGEN:
1675 case OP_SREFGEN:
1676 case OP_DEFINED:
1677 case OP_HEX:
1678 case OP_OCT:
1679 case OP_LENGTH:
1680 case OP_VEC:
1681 case OP_INDEX:
1682 case OP_RINDEX:
1683 case OP_SPRINTF:
26f0e7d5 1684 case OP_KVASLICE:
26f0e7d5
TC
1685 case OP_KVHSLICE:
1686 case OP_UNPACK:
1687 case OP_PACK:
1688 case OP_JOIN:
1689 case OP_LSLICE:
1690 case OP_ANONLIST:
1691 case OP_ANONHASH:
1692 case OP_SORT:
1693 case OP_REVERSE:
1694 case OP_RANGE:
1695 case OP_FLIP:
1696 case OP_FLOP:
1697 case OP_CALLER:
1698 case OP_FILENO:
1699 case OP_EOF:
1700 case OP_TELL:
1701 case OP_GETSOCKNAME:
1702 case OP_GETPEERNAME:
1703 case OP_READLINK:
1704 case OP_TELLDIR:
1705 case OP_GETPPID:
1706 case OP_GETPGRP:
1707 case OP_GETPRIORITY:
1708 case OP_TIME:
1709 case OP_TMS:
1710 case OP_LOCALTIME:
1711 case OP_GMTIME:
1712 case OP_GHBYNAME:
1713 case OP_GHBYADDR:
1714 case OP_GHOSTENT:
1715 case OP_GNBYNAME:
1716 case OP_GNBYADDR:
1717 case OP_GNETENT:
1718 case OP_GPBYNAME:
1719 case OP_GPBYNUMBER:
1720 case OP_GPROTOENT:
1721 case OP_GSBYNAME:
1722 case OP_GSBYPORT:
1723 case OP_GSERVENT:
1724 case OP_GPWNAM:
1725 case OP_GPWUID:
1726 case OP_GGRNAM:
1727 case OP_GGRGID:
1728 case OP_GETLOGIN:
1729 case OP_PROTOTYPE:
1730 case OP_RUNCV:
1731 func_ops:
9e209402
FC
1732 useless = OP_DESC(o);
1733 break;
1734
1735 case OP_GVSV:
1736 case OP_PADSV:
1737 case OP_PADAV:
1738 case OP_PADHV:
1739 case OP_PADANY:
1740 case OP_AELEM:
1741 case OP_AELEMFAST:
1742 case OP_AELEMFAST_LEX:
1743 case OP_ASLICE:
1744 case OP_HELEM:
1745 case OP_HSLICE:
26f0e7d5
TC
1746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1747 /* Otherwise it's "Useless use of grep iterator" */
1748 useless = OP_DESC(o);
1749 break;
1750
1751 case OP_SPLIT:
1752 kid = cLISTOPo->op_first;
1753 if (kid && kid->op_type == OP_PUSHRE
1754 && !kid->op_targ
1755 && !(o->op_flags & OPf_STACKED)
75068674 1756#ifdef USE_ITHREADS
26f0e7d5 1757 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
75068674 1758#else
26f0e7d5 1759 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
75068674 1760#endif
26f0e7d5
TC
1761 )
1762 useless = OP_DESC(o);
1763 break;
1764
1765 case OP_NOT:
1766 kid = cUNOPo->op_first;
1767 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1768 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1769 goto func_ops;
1770 }
1771 useless = "negative pattern binding (!~)";
1772 break;
1773
1774 case OP_SUBST:
1775 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1776 useless = "non-destructive substitution (s///r)";
1777 break;
1778
1779 case OP_TRANSR:
1780 useless = "non-destructive transliteration (tr///r)";
1781 break;
1782
1783 case OP_RV2GV:
1784 case OP_RV2SV:
1785 case OP_RV2AV:
1786 case OP_RV2HV:
1787 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1788 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1789 useless = "a variable";
1790 break;
1791
1792 case OP_CONST:
1793 sv = cSVOPo_sv;
1794 if (cSVOPo->op_private & OPpCONST_STRICT)
1795 no_bareword_allowed(o);
1796 else {
1797 if (ckWARN(WARN_VOID)) {
1798 NV nv;
1799 /* don't warn on optimised away booleans, eg
1800 * use constant Foo, 5; Foo || print; */
1801 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1802 useless = NULL;
1803 /* the constants 0 and 1 are permitted as they are
1804 conventionally used as dummies in constructs like
1805 1 while some_condition_with_side_effects; */
1806 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1807 useless = NULL;
1808 else if (SvPOK(sv)) {
1809 SV * const dsv = newSVpvs("");
1810 useless_sv
1811 = Perl_newSVpvf(aTHX_
1812 "a constant (%s)",
1813 pv_pretty(dsv, SvPVX_const(sv),
1814 SvCUR(sv), 32, NULL, NULL,
1815 PERL_PV_PRETTY_DUMP
1816 | PERL_PV_ESCAPE_NOCLEAR
1817 | PERL_PV_ESCAPE_UNI_DETECT));
1818 SvREFCNT_dec_NN(dsv);
1819 }
1820 else if (SvOK(sv)) {
1821 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1822 }
1823 else
1824 useless = "a constant (undef)";
1825 }
1826 }
1827 op_null(o); /* don't execute or even remember it */
1828 break;
79072805 1829
26f0e7d5
TC
1830 case OP_POSTINC:
1831 CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
1832 break;
79072805 1833
26f0e7d5
TC
1834 case OP_POSTDEC:
1835 CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
1836 break;
79072805 1837
26f0e7d5
TC
1838 case OP_I_POSTINC:
1839 CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
1840 break;
79072805 1841
26f0e7d5
TC
1842 case OP_I_POSTDEC:
1843 CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
1844 break;
679d6c4e 1845
26f0e7d5
TC
1846 case OP_SASSIGN: {
1847 OP *rv2gv;
1848 UNOP *refgen, *rv2cv;
1849 LISTOP *exlist;
679d6c4e 1850
26f0e7d5
TC
1851 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1852 break;
f2f8fd84 1853
26f0e7d5
TC
1854 rv2gv = ((BINOP *)o)->op_last;
1855 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1856 break;
f2f8fd84 1857
26f0e7d5 1858 refgen = (UNOP *)((BINOP *)o)->op_first;
f2f8fd84 1859
26f0e7d5
TC
1860 if (!refgen || (refgen->op_type != OP_REFGEN
1861 && refgen->op_type != OP_SREFGEN))
1862 break;
f2f8fd84 1863
26f0e7d5
TC
1864 exlist = (LISTOP *)refgen->op_first;
1865 if (!exlist || exlist->op_type != OP_NULL
1866 || exlist->op_targ != OP_LIST)
1867 break;
f2f8fd84 1868
26f0e7d5
TC
1869 if (exlist->op_first->op_type != OP_PUSHMARK
1870 && exlist->op_first != exlist->op_last)
1871 break;
f2f8fd84 1872
26f0e7d5 1873 rv2cv = (UNOP*)exlist->op_last;
f2f8fd84 1874
26f0e7d5
TC
1875 if (rv2cv->op_type != OP_RV2CV)
1876 break;
f2f8fd84 1877
26f0e7d5
TC
1878 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1879 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1880 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
f2f8fd84 1881
26f0e7d5
TC
1882 o->op_private |= OPpASSIGN_CV_TO_GV;
1883 rv2gv->op_private |= OPpDONT_INIT_GV;
1884 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
f2f8fd84 1885
26f0e7d5
TC
1886 break;
1887 }
540dd770 1888
26f0e7d5
TC
1889 case OP_AASSIGN: {
1890 inplace_aassign(o);
1891 break;
1892 }
edbe35ea 1893
26f0e7d5
TC
1894 case OP_OR:
1895 case OP_AND:
1896 kid = cLOGOPo->op_first;
1897 if (kid->op_type == OP_NOT
1898 && (kid->op_flags & OPf_KIDS)) {
1899 if (o->op_type == OP_AND) {
1900 CHANGE_TYPE(o, OP_OR);
1901 } else {
1902 CHANGE_TYPE(o, OP_AND);
1903 }
1904 op_null(kid);
1905 }
1906 /* FALLTHROUGH */
5aabfad6 1907
26f0e7d5
TC
1908 case OP_DOR:
1909 case OP_COND_EXPR:
1910 case OP_ENTERGIVEN:
1911 case OP_ENTERWHEN:
1912 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1913 if (!(kid->op_flags & OPf_KIDS))
1914 scalarvoid(kid);
1915 else
1916 DEFER_OP(kid);
aa9d1253 1917 break;
095b19d1 1918
26f0e7d5
TC
1919 case OP_NULL:
1920 if (o->op_flags & OPf_STACKED)
1921 break;
1922 /* FALLTHROUGH */
1923 case OP_NEXTSTATE:
1924 case OP_DBSTATE:
1925 case OP_ENTERTRY:
1926 case OP_ENTER:
1927 if (!(o->op_flags & OPf_KIDS))
1928 break;
1929 /* FALLTHROUGH */
1930 case OP_SCOPE:
1931 case OP_LEAVE:
1932 case OP_LEAVETRY:
1933 case OP_LEAVELOOP:
1934 case OP_LINESEQ:
1935 case OP_LEAVEGIVEN:
1936 case OP_LEAVEWHEN:
1937 kids:
1938 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1939 if (!(kid->op_flags & OPf_KIDS))
1940 scalarvoid(kid);
1941 else
1942 DEFER_OP(kid);
1943 break;
1944 case OP_LIST:
1945 /* If the first kid after pushmark is something that the padrange
1946 optimisation would reject, then null the list and the pushmark.
1947 */
1948 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1949 && ( !(kid = OP_SIBLING(kid))
1950 || ( kid->op_type != OP_PADSV
1951 && kid->op_type != OP_PADAV
1952 && kid->op_type != OP_PADHV)
1953 || kid->op_private & ~OPpLVAL_INTRO
1954 || !(kid = OP_SIBLING(kid))
1955 || ( kid->op_type != OP_PADSV
1956 && kid->op_type != OP_PADAV
1957 && kid->op_type != OP_PADHV)
1958 || kid->op_private & ~OPpLVAL_INTRO)
1959 ) {
1960 op_null(cUNOPo->op_first); /* NULL the pushmark */
1961 op_null(o); /* NULL the list */
1962 }
1963 goto kids;
1964 case OP_ENTEREVAL:
1965 scalarkids(o);
1966 break;
1967 case OP_SCALAR:
1968 scalar(o);
1969 break;
1970 }
1971
1972 if (useless_sv) {
1973 /* mortalise it, in case warnings are fatal. */
1974 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1975 "Useless use of %"SVf" in void context",
1976 SVfARG(sv_2mortal(useless_sv)));
1977 }
1978 else if (useless) {
1979 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1980 "Useless use of %s in void context",
1981 useless);
1982 }
aa9d1253
TC
1983 } while ( (o = POP_DEFERRED_OP()) );
1984
1985 Safefree(defer_stack);
1986
1987 return arg;
79072805
LW
1988}
1989
1f676739 1990static OP *
412da003 1991S_listkids(pTHX_ OP *o)
79072805 1992{
11343788 1993 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1994 OP *kid;
1ed44841 1995 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
79072805
LW
1996 list(kid);
1997 }
11343788 1998 return o;
79072805
LW
1999}
2000
2001OP *
864dbfa3 2002Perl_list(pTHX_ OP *o)
79072805
LW
2003{
2004 OP *kid;
2005
a0d0e21e 2006 /* assumes no premature commitment */
13765c85
DM
2007 if (!o || (o->op_flags & OPf_WANT)
2008 || (PL_parser && PL_parser->error_count)
5dc0d613 2009 || o->op_type == OP_RETURN)
7e363e51 2010 {
11343788 2011 return o;
7e363e51 2012 }
79072805 2013
b162f9ea 2014 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2015 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2016 {
b162f9ea 2017 return o; /* As if inside SASSIGN */
7e363e51 2018 }
1c846c1f 2019
5dc0d613 2020 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 2021
11343788 2022 switch (o->op_type) {
79072805 2023 case OP_FLOP:
11343788 2024 list(cBINOPo->op_first);
79072805 2025 break;
c57eecc5
FC
2026 case OP_REPEAT:
2027 if (o->op_private & OPpREPEAT_DOLIST
2028 && !(o->op_flags & OPf_STACKED))
2029 {
2030 list(cBINOPo->op_first);
2031 kid = cBINOPo->op_last;
2032 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2033 && SvIVX(kSVOP_sv) == 1)
2034 {
2035 op_null(o); /* repeat */
2036 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2037 /* const (rhs): */
2038 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2039 }
2040 }
2041 break;
79072805
LW
2042 case OP_OR:
2043 case OP_AND:
2044 case OP_COND_EXPR:
1ed44841 2045 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
79072805
LW
2046 list(kid);
2047 break;
2048 default:
2049 case OP_MATCH:
8782bef2 2050 case OP_QR:
79072805
LW
2051 case OP_SUBST:
2052 case OP_NULL:
11343788 2053 if (!(o->op_flags & OPf_KIDS))
79072805 2054 break;
11343788
MB
2055 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2056 list(cBINOPo->op_first);
2057 return gen_constant_list(o);
79072805 2058 }
6aa68307
FC
2059 listkids(o);
2060 break;
79072805 2061 case OP_LIST:
11343788 2062 listkids(o);
6aa68307
FC
2063 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2064 op_null(cUNOPo->op_first); /* NULL the pushmark */
2065 op_null(o); /* NULL the list */
2066 }
79072805
LW
2067 break;
2068 case OP_LEAVE:
2069 case OP_LEAVETRY:
5dc0d613 2070 kid = cLISTOPo->op_first;
54310121 2071 list(kid);
1ed44841 2072 kid = OP_SIBLING(kid);
25b991bf
VP
2073 do_kids:
2074 while (kid) {
1ed44841 2075 OP *sib = OP_SIBLING(kid);
c08f093b
VP
2076 if (sib && kid->op_type != OP_LEAVEWHEN)
2077 scalarvoid(kid);
2078 else
54310121 2079 list(kid);
25b991bf 2080 kid = sib;
54310121 2081 }
11206fdd 2082 PL_curcop = &PL_compiling;
54310121 2083 break;
748a9306 2084 case OP_SCOPE:
79072805 2085 case OP_LINESEQ:
25b991bf
VP
2086 kid = cLISTOPo->op_first;
2087 goto do_kids;
79072805 2088 }
11343788 2089 return o;
79072805
LW
2090}
2091
1f676739 2092static OP *
2dd5337b 2093S_scalarseq(pTHX_ OP *o)
79072805 2094{
11343788 2095 if (o) {
1496a290
AL
2096 const OPCODE type = o->op_type;
2097
2098 if (type == OP_LINESEQ || type == OP_SCOPE ||
2099 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2100 {
b7bea5da
FC
2101 OP *kid, *sib;
2102 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2103 if ((sib = OP_SIBLING(kid))
2104 && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
2105 || ( sib->op_targ != OP_NEXTSTATE
2106 && sib->op_targ != OP_DBSTATE )))
2107 {
463ee0b2 2108 scalarvoid(kid);
ed6116ce 2109 }
463ee0b2 2110 }
3280af22 2111 PL_curcop = &PL_compiling;
79072805 2112 }
11343788 2113 o->op_flags &= ~OPf_PARENS;
3280af22 2114 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2115 o->op_flags |= OPf_PARENS;
79072805 2116 }
8990e307 2117 else
11343788
MB
2118 o = newOP(OP_STUB, 0);
2119 return o;
79072805
LW
2120}
2121
76e3520e 2122STATIC OP *
cea2e8a9 2123S_modkids(pTHX_ OP *o, I32 type)
79072805 2124{
11343788 2125 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2126 OP *kid;
1ed44841 2127 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3ad73efd 2128 op_lvalue(kid, type);
79072805 2129 }
11343788 2130 return o;
79072805
LW
2131}
2132
3ad73efd 2133/*
d164302a
GG
2134=for apidoc finalize_optree
2135
72d33970
FC
2136This function finalizes the optree. Should be called directly after
2137the complete optree is built. It does some additional
d164302a
GG
2138checking which can't be done in the normal ck_xxx functions and makes
2139the tree thread-safe.
2140
2141=cut
2142*/
2143void
2144Perl_finalize_optree(pTHX_ OP* o)
2145{
2146 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2147
2148 ENTER;
2149 SAVEVPTR(PL_curcop);
2150
2151 finalize_op(o);
2152
2153 LEAVE;
2154}
2155
b46e009d 2156#ifdef USE_ITHREADS
2157/* Relocate sv to the pad for thread safety.
2158 * Despite being a "constant", the SV is written to,
2159 * for reference counts, sv_upgrade() etc. */
2160PERL_STATIC_INLINE void
2161S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2162{
2163 PADOFFSET ix;
2164 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2165 if (!*svp) return;
2166 ix = pad_alloc(OP_CONST, SVf_READONLY);
2167 SvREFCNT_dec(PAD_SVl(ix));
2168 PAD_SETSV(ix, *svp);
2169 /* XXX I don't know how this isn't readonly already. */
2170 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2171 *svp = NULL;
2172 *targp = ix;
2173}
2174#endif
2175
2176
60dde6b2 2177STATIC void
d164302a
GG
2178S_finalize_op(pTHX_ OP* o)
2179{
2180 PERL_ARGS_ASSERT_FINALIZE_OP;
2181
d164302a
GG
2182
2183 switch (o->op_type) {
2184 case OP_NEXTSTATE:
2185 case OP_DBSTATE:
2186 PL_curcop = ((COP*)o); /* for warnings */
2187 break;
2188 case OP_EXEC:
1ed44841
DM
2189 if (OP_HAS_SIBLING(o)) {
2190 OP *sib = OP_SIBLING(o);
2191 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2192 && ckWARN(WARN_EXEC)
2193 && OP_HAS_SIBLING(sib))
2194 {
2195 const OPCODE type = OP_SIBLING(sib)->op_type;
d164302a
GG
2196 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2197 const line_t oldline = CopLINE(PL_curcop);
1ed44841 2198 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
2199 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2200 "Statement unlikely to be reached");
2201 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2202 "\t(Maybe you meant system() when you said exec()?)\n");
2203 CopLINE_set(PL_curcop, oldline);
2204 }
d164302a 2205 }
1ed44841 2206 }
d164302a
GG
2207 break;
2208
2209 case OP_GV:
2210 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2211 GV * const gv = cGVOPo_gv;
2212 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2213 /* XXX could check prototype here instead of just carping */
2214 SV * const sv = sv_newmortal();
2215 gv_efullname3(sv, gv, NULL);
2216 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2217 "%"SVf"() called too early to check prototype",
2218 SVfARG(sv));
2219 }
2220 }
2221 break;
2222
2223 case OP_CONST:
eb796c7f
GG
2224 if (cSVOPo->op_private & OPpCONST_STRICT)
2225 no_bareword_allowed(o);
2226 /* FALLTHROUGH */
d164302a
GG
2227#ifdef USE_ITHREADS
2228 case OP_HINTSEVAL:
b46e009d 2229 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2230#endif
2231 break;
2232
2233#ifdef USE_ITHREADS
2234 /* Relocate all the METHOP's SVs to the pad for thread safety. */
d164302a 2235 case OP_METHOD_NAMED:
7d6c333c 2236 case OP_METHOD_SUPER:
b46e009d 2237 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2238 break;
d164302a 2239#endif
d164302a
GG
2240
2241 case OP_HELEM: {
2242 UNOP *rop;
a1c2aa4c 2243 PADNAME *lexname;
d164302a 2244 GV **fields;
565e6f7e
FC
2245 SVOP *key_op;
2246 OP *kid;
2247 bool check_fields;
d164302a 2248
565e6f7e 2249 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
d164302a
GG
2250 break;
2251
2252 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 2253
565e6f7e 2254 goto check_keys;
d164302a 2255
565e6f7e 2256 case OP_HSLICE:
429a2555 2257 S_scalar_slice_warning(aTHX_ o);
c67159e1 2258 /* FALLTHROUGH */
429a2555 2259
c5f75dba 2260 case OP_KVHSLICE:
1ed44841 2261 kid = OP_SIBLING(cLISTOPo->op_first);
71323522 2262 if (/* I bet there's always a pushmark... */
7d3c8a68
SM
2263 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2264 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2265 {
d164302a 2266 break;
7d3c8a68 2267 }
565e6f7e
FC
2268
2269 key_op = (SVOP*)(kid->op_type == OP_CONST
2270 ? kid
1ed44841 2271 : OP_SIBLING(kLISTOP->op_first));
565e6f7e
FC
2272
2273 rop = (UNOP*)((LISTOP*)o)->op_last;
2274
2275 check_keys:
2276 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
71323522 2277 rop = NULL;
565e6f7e 2278 else if (rop->op_first->op_type == OP_PADSV)
d164302a
GG
2279 /* @$hash{qw(keys here)} */
2280 rop = (UNOP*)rop->op_first;
565e6f7e 2281 else {
d164302a
GG
2282 /* @{$hash}{qw(keys here)} */
2283 if (rop->op_first->op_type == OP_SCOPE
2284 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2285 {
2286 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2287 }
2288 else
71323522 2289 rop = NULL;
d164302a 2290 }
71323522 2291
32e9ec8f 2292 lexname = NULL; /* just to silence compiler warnings */
03acb648
DM
2293 fields = NULL; /* just to silence compiler warnings */
2294
71323522
FC
2295 check_fields =
2296 rop
9b7476d7 2297 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
71323522 2298 SvPAD_TYPED(lexname))
a1c2aa4c
FC
2299 && (fields =
2300 (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
71323522 2301 && isGV(*fields) && GvHV(*fields);
0e706dd4 2302 for (; key_op;
1ed44841 2303 key_op = (SVOP*)OP_SIBLING(key_op)) {
565e6f7e 2304 SV **svp, *sv;
d164302a
GG
2305 if (key_op->op_type != OP_CONST)
2306 continue;
2307 svp = cSVOPx_svp(key_op);
71323522
FC
2308
2309 /* Make the CONST have a shared SV */
2310 if ((!SvIsCOW_shared_hash(sv = *svp))
2311 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2312 SSize_t keylen;
2313 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2314 SV *nsv = newSVpvn_share(key,
2315 SvUTF8(sv) ? -keylen : keylen, 0);
2316 SvREFCNT_dec_NN(sv);
2317 *svp = nsv;
2318 }
2319
2320 if (check_fields
2321 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
ce16c625 2322 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
a1c2aa4c
FC
2323 "in variable %"PNf" of type %"HEKf,
2324 SVfARG(*svp), PNfARG(lexname),
2325 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
d164302a
GG
2326 }
2327 }
2328 break;
2329 }
429a2555
FC
2330 case OP_ASLICE:
2331 S_scalar_slice_warning(aTHX_ o);
2332 break;
a7fd8ef6 2333
d164302a
GG
2334 case OP_SUBST: {
2335 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2336 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2337 break;
2338 }
2339 default:
2340 break;
2341 }
2342
2343 if (o->op_flags & OPf_KIDS) {
2344 OP *kid;
c4b20975
DM
2345
2346#ifdef DEBUGGING
20220689
DM
2347 /* check that op_last points to the last sibling, and that
2348 * the last op_sibling field points back to the parent, and
2349 * that the only ops with KIDS are those which are entitled to
2350 * them */
c4b20975
DM
2351 U32 type = o->op_type;
2352 U32 family;
20220689 2353 bool has_last;
c4b20975
DM
2354
2355 if (type == OP_NULL) {
2356 type = o->op_targ;
2357 /* ck_glob creates a null UNOP with ex-type GLOB
2358 * (which is a list op. So pretend it wasn't a listop */
2359 if (type == OP_GLOB)
2360 type = OP_NULL;
2361 }
2362 family = PL_opargs[type] & OA_CLASS_MASK;
2363
20220689
DM
2364 has_last = ( family == OA_BINOP
2365 || family == OA_LISTOP
2366 || family == OA_PMOP
2367 || family == OA_LOOP
2368 );
2369 assert( has_last /* has op_first and op_last, or ...
2370 ... has (or may have) op_first: */
2371 || family == OA_UNOP
2372 || family == OA_LOGOP
2373 || family == OA_BASEOP_OR_UNOP
2374 || family == OA_FILESTATOP
2375 || family == OA_LOOPEXOP
b46e009d 2376 || family == OA_METHOP
20220689
DM
2377 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2378 || type == OP_SASSIGN
2379 || type == OP_CUSTOM
2380 || type == OP_NULL /* new_logop does this */
2381 );
2382 /* XXX list form of 'x' is has a null op_last. This is wrong,
2383 * but requires too much hacking (e.g. in Deparse) to fix for
2384 * now */
2385 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2386 assert(has_last);
2387 has_last = 0;
2388 }
2389
2390 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
29e61fd9 2391# ifdef PERL_OP_PARENT
20220689
DM
2392 if (!OP_HAS_SIBLING(kid)) {
2393 if (has_last)
29e61fd9 2394 assert(kid == cLISTOPo->op_last);
20220689
DM
2395 assert(kid->op_sibling == o);
2396 }
29e61fd9 2397# else
20220689
DM
2398 if (OP_HAS_SIBLING(kid)) {
2399 assert(!kid->op_lastsib);
2400 }
2401 else {
2402 assert(kid->op_lastsib);
2403 if (has_last)
29e61fd9 2404 assert(kid == cLISTOPo->op_last);
c4b20975 2405 }
20220689 2406# endif
c4b20975
DM
2407 }
2408#endif
2409
1ed44841 2410 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
d164302a
GG
2411 finalize_op(kid);
2412 }
2413}
2414
2415/*
3ad73efd
Z
2416=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2417
2418Propagate lvalue ("modifiable") context to an op and its children.
2419I<type> represents the context type, roughly based on the type of op that
2420would do the modifying, although C<local()> is represented by OP_NULL,
2421because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
2422the lvalue op).
2423
2424This function detects things that can't be modified, such as C<$x+1>, and
72d33970 2425generates errors for them. For example, C<$x+1 = 2> would cause it to be
001c3c51
FC
2426called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2427
2428It also flags things that need to behave specially in an lvalue context,
2429such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
2430
2431=cut
2432*/
ddeae0f1 2433
03414f05
FC
2434static void
2435S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2436{
2437 CV *cv = PL_compcv;
2438 PadnameLVALUE_on(pn);
2439 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2440 cv = CvOUTSIDE(cv);
2441 assert(cv);
2442 assert(CvPADLIST(cv));
2443 pn =
2444 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2445 assert(PadnameLEN(pn));
2446 PadnameLVALUE_on(pn);
2447 }
2448}
2449
375879aa
FC
2450static bool
2451S_vivifies(const OPCODE type)
2452{
2453 switch(type) {
2454 case OP_RV2AV: case OP_ASLICE:
2455 case OP_RV2HV: case OP_KVASLICE:
2456 case OP_RV2SV: case OP_HSLICE:
2457 case OP_AELEMFAST: case OP_KVHSLICE:
2458 case OP_HELEM:
2459 case OP_AELEM:
2460 return 1;
2461 }
2462 return 0;
2463}
2464
7664512e 2465static void
63702de8 2466S_lvref(pTHX_ OP *o, I32 type)
7664512e 2467{
727d2dc6 2468 dVAR;
7664512e
FC
2469 OP *kid;
2470 switch (o->op_type) {
2471 case OP_COND_EXPR:
2472 for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2473 kid = OP_SIBLING(kid))
63702de8 2474 S_lvref(aTHX_ kid, type);
7664512e
FC
2475 /* FALLTHROUGH */
2476 case OP_PUSHMARK:
2477 return;
2478 case OP_RV2AV:
2479 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2480 o->op_flags |= OPf_STACKED;
2481 if (o->op_flags & OPf_PARENS) {
2482 if (o->op_private & OPpLVAL_INTRO) {
7664512e
FC
2483 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2484 "localized parenthesized array in list assignment"));
2485 return;
2486 }
2487 slurpy:
10884df9 2488 CHANGE_TYPE(o, OP_LVAVREF);
7664512e
FC
2489 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2490 o->op_flags |= OPf_MOD|OPf_REF;
2491 return;
2492 }
2493 o->op_private |= OPpLVREF_AV;
2494 goto checkgv;
408e9044 2495 case OP_RV2CV:
19abb1ea
FC
2496 kid = cUNOPo->op_first;
2497 if (kid->op_type == OP_NULL)
2498 kid = cUNOPx(kUNOP->op_first->op_sibling)
408e9044
FC
2499 ->op_first;
2500 o->op_private = OPpLVREF_CV;
2501 if (kid->op_type == OP_GV)
2502 o->op_flags |= OPf_STACKED;
2503 else if (kid->op_type == OP_PADCV) {
2504 o->op_targ = kid->op_targ;
2505 kid->op_targ = 0;
2506 op_free(cUNOPo->op_first);
2507 cUNOPo->op_first = NULL;
2508 o->op_flags &=~ OPf_KIDS;
2509 }
2510 else goto badref;
2511 break;
7664512e
FC
2512 case OP_RV2HV:
2513 if (o->op_flags & OPf_PARENS) {
2514 parenhash:
7664512e
FC
2515 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2516 "parenthesized hash in list assignment"));
2517 return;
2518 }
2519 o->op_private |= OPpLVREF_HV;
2520 /* FALLTHROUGH */
2521 case OP_RV2SV:
2522 checkgv:
2523 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2524 o->op_flags |= OPf_STACKED;
6f5dab3c
FC
2525 break;
2526 case OP_PADHV:
2527 if (o->op_flags & OPf_PARENS) goto parenhash;
2528 o->op_private |= OPpLVREF_HV;
7664512e
FC
2529 /* FALLTHROUGH */
2530 case OP_PADSV:
6f5dab3c 2531 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2532 break;
2533 case OP_PADAV:
6f5dab3c 2534 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2535 if (o->op_flags & OPf_PARENS) goto slurpy;
2536 o->op_private |= OPpLVREF_AV;
2537 break;
7664512e
FC
2538 case OP_AELEM:
2539 case OP_HELEM:
2540 o->op_private |= OPpLVREF_ELEM;
2541 o->op_flags |= OPf_STACKED;
2542 break;
2543 case OP_ASLICE:
2544 case OP_HSLICE:
10884df9 2545 CHANGE_TYPE(o, OP_LVREFSLICE);
7664512e
FC
2546 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2547 return;
2548 case OP_NULL:
2549 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2550 goto badref;
2551 else if (!(o->op_flags & OPf_KIDS))
2552 return;
2553 if (o->op_targ != OP_LIST) {
63702de8 2554 S_lvref(aTHX_ cBINOPo->op_first, type);
7664512e
FC
2555 return;
2556 }
2557 /* FALLTHROUGH */
2558 case OP_LIST:
2559 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2560 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
63702de8 2561 S_lvref(aTHX_ kid, type);
7664512e
FC
2562 }
2563 return;
2564 case OP_STUB:
2565 if (o->op_flags & OPf_PARENS)
2566 return;
2567 /* FALLTHROUGH */
2568 default:
2569 badref:
cf6e1fa1 2570 /* diag_listed_as: Can't modify reference to %s in %s assignment */
63702de8 2571 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
7664512e
FC
2572 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2573 ? "do block"
63702de8
FC
2574 : OP_DESC(o),
2575 PL_op_desc[type]));
7664512e
FC
2576 return;
2577 }
10884df9 2578 CHANGE_TYPE(o, OP_LVREF);
3ad7d304
FC
2579 o->op_private &=
2580 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
d39c26a6
FC
2581 if (type == OP_ENTERLOOP)
2582 o->op_private |= OPpLVREF_ITER;
7664512e
FC
2583}
2584
79072805 2585OP *
d3d7d28f 2586Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2587{
27da23d5 2588 dVAR;
79072805 2589 OP *kid;
ddeae0f1
DM
2590 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2591 int localize = -1;
79072805 2592
13765c85 2593 if (!o || (PL_parser && PL_parser->error_count))
11343788 2594 return o;
79072805 2595
b162f9ea 2596 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2597 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2598 {
b162f9ea 2599 return o;
7e363e51 2600 }
1c846c1f 2601
5c906035
GG
2602 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2603
69974ce6
FC
2604 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2605
11343788 2606 switch (o->op_type) {
68dc0745 2607 case OP_UNDEF:
3280af22 2608 PL_modcount++;
5dc0d613 2609 return o;
5f05dabc 2610 case OP_STUB:
b5bbe64a 2611 if ((o->op_flags & OPf_PARENS))
5f05dabc
PP
2612 break;
2613 goto nomod;
a0d0e21e 2614 case OP_ENTERSUB:
f79aa60b 2615 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788 2616 !(o->op_flags & OPf_STACKED)) {
10884df9 2617 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2618 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2619 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
2620 break;
2621 }
cd06dffe 2622 else { /* lvalue subroutine call */
9411a3c7 2623 o->op_private |= OPpLVAL_INTRO;
e6438c1a 2624 PL_modcount = RETURN_UNLIMITED_NUMBER;
9411a3c7
FC
2625 if (type == OP_GREPSTART || type == OP_ENTERSUB
2626 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
d0887bf3 2627 /* Potential lvalue context: */
cd06dffe
GS
2628 o->op_private |= OPpENTERSUB_INARGS;
2629 break;
2630 }
2631 else { /* Compile-time error message: */
2632 OP *kid = cUNOPo->op_first;
2633 CV *cv;
2eaf799e 2634 GV *gv;
cd06dffe 2635
3ea285d1
AL
2636 if (kid->op_type != OP_PUSHMARK) {
2637 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2638 Perl_croak(aTHX_
2639 "panic: unexpected lvalue entersub "
2640 "args: type/targ %ld:%"UVuf,
2641 (long)kid->op_type, (UV)kid->op_targ);
2642 kid = kLISTOP->op_first;
2643 }
1ed44841
DM
2644 while (OP_HAS_SIBLING(kid))
2645 kid = OP_SIBLING(kid);
cd06dffe 2646 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2647 break; /* Postpone until runtime */
2648 }
b2ffa427 2649
cd06dffe
GS
2650 kid = kUNOP->op_first;
2651 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2652 kid = kUNOP->op_first;
b2ffa427 2653 if (kid->op_type == OP_NULL)
cd06dffe
GS
2654 Perl_croak(aTHX_
2655 "Unexpected constant lvalue entersub "
55140b79 2656 "entry via type/targ %ld:%"UVuf,
3d811634 2657 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2658 if (kid->op_type != OP_GV) {
cd06dffe
GS
2659 break;
2660 }
b2ffa427 2661
2eaf799e
FC
2662 gv = kGVOP_gv;
2663 cv = isGV(gv)
2664 ? GvCV(gv)
2665 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2666 ? MUTABLE_CV(SvRV(gv))
2667 : NULL;
1c846c1f 2668 if (!cv)
da1dff94 2669 break;
cd06dffe
GS
2670 if (CvLVALUE(cv))
2671 break;
2672 }
2673 }
924ba076 2674 /* FALLTHROUGH */
79072805 2675 default:
a0d0e21e 2676 nomod:
f5d552b4 2677 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2678 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
2679 if (type == OP_GREPSTART || type == OP_ENTERSUB
2680 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2681 break;
cea2e8a9 2682 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2683 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
2684 ? "do block"
2685 : (o->op_type == OP_ENTERSUB
2686 ? "non-lvalue subroutine call"
53e06cf0 2687 : OP_DESC(o))),
22c35a8c 2688 type ? PL_op_desc[type] : "local"));
11343788 2689 return o;
79072805 2690
a0d0e21e
LW
2691 case OP_PREINC:
2692 case OP_PREDEC:
2693 case OP_POW:
2694 case OP_MULTIPLY:
2695 case OP_DIVIDE:
2696 case OP_MODULO:
a0d0e21e
LW
2697 case OP_ADD:
2698 case OP_SUBTRACT:
2699 case OP_CONCAT:
2700 case OP_LEFT_SHIFT:
2701 case OP_RIGHT_SHIFT:
2702 case OP_BIT_AND:
2703 case OP_BIT_XOR:
2704 case OP_BIT_OR:
2705 case OP_I_MULTIPLY:
2706 case OP_I_DIVIDE:
2707 case OP_I_MODULO:
2708 case OP_I_ADD:
2709 case OP_I_SUBTRACT:
11343788 2710 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2711 goto nomod;
3280af22 2712 PL_modcount++;
a0d0e21e 2713 break;
b2ffa427 2714
82209a5d
FC
2715 case OP_REPEAT:
2716 if (o->op_flags & OPf_STACKED) {
2717 PL_modcount++;
2718 break;
2719 }
ff781254 2720 if (!(o->op_private & OPpREPEAT_DOLIST))
82209a5d
FC
2721 goto nomod;
2722 else {
2723 const I32 mods = PL_modcount;
ff781254
FC
2724 modkids(cBINOPo->op_first, type);
2725 if (type != OP_AASSIGN)
2726 goto nomod;
5e462669 2727 kid = cBINOPo->op_last;
82209a5d 2728 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
565e104c 2729 const IV iv = SvIV(kSVOP_sv);
82209a5d
FC
2730 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2731 PL_modcount =
2732 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2733 }
2734 else
2735 PL_modcount = RETURN_UNLIMITED_NUMBER;
2736 }
2737 break;
2738
79072805 2739 case OP_COND_EXPR:
ddeae0f1 2740 localize = 1;
1ed44841 2741 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
3ad73efd 2742 op_lvalue(kid, type);
79072805
LW
2743 break;
2744
2745 case OP_RV2AV:
2746 case OP_RV2HV:
11343788 2747 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2748 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2749 return o; /* Treat \(@foo) like ordinary list. */
748a9306 2750 }
924ba076 2751 /* FALLTHROUGH */
79072805 2752 case OP_RV2GV:
5dc0d613 2753 if (scalar_mod_type(o, type))
3fe9a6f1 2754 goto nomod;
11343788 2755 ref(cUNOPo->op_first, o->op_type);
924ba076 2756 /* FALLTHROUGH */
79072805
LW
2757 case OP_ASLICE:
2758 case OP_HSLICE:
ddeae0f1 2759 localize = 1;
924ba076 2760 /* FALLTHROUGH */
78f9721b 2761 case OP_AASSIGN:
32cbae3f
FC
2762 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2763 if (type == OP_LEAVESUBLV && (
2764 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2765 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2766 ))
631dbaa2 2767 o->op_private |= OPpMAYBE_LVSUB;
924ba076 2768 /* FALLTHROUGH */
93a17b20
LW
2769 case OP_NEXTSTATE:
2770 case OP_DBSTATE:
e6438c1a 2771 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2772 break;
5cae3edb 2773 case OP_KVHSLICE:
6dd3e0f2 2774 case OP_KVASLICE:
5cae3edb
RZ
2775 if (type == OP_LEAVESUBLV)
2776 o->op_private |= OPpMAYBE_LVSUB;
2777 goto nomod;
28c5b5bc
RGS
2778 case OP_AV2ARYLEN:
2779 PL_hints |= HINT_BLOCK_SCOPE;
2780 if (type == OP_LEAVESUBLV)
2781 o->op_private |= OPpMAYBE_LVSUB;
2782 PL_modcount++;
2783 break;
463ee0b2 2784 case OP_RV2SV:
aeea060c 2785 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2786 localize = 1;
924ba076 2787 /* FALLTHROUGH */
79072805 2788 case OP_GV:
3280af22 2789 PL_hints |= HINT_BLOCK_SCOPE;
924ba076 2790 /* FALLTHROUGH */
463ee0b2 2791 case OP_SASSIGN:
bf4b1e52
GS
2792 case OP_ANDASSIGN:
2793 case OP_ORASSIGN:
c963b151 2794 case OP_DORASSIGN:
ddeae0f1
DM
2795 PL_modcount++;
2796 break;
2797
8990e307 2798 case OP_AELEMFAST:
93bad3fd 2799 case OP_AELEMFAST_LEX:
6a077020 2800 localize = -1;
3280af22 2801 PL_modcount++;
8990e307
LW
2802 break;
2803
748a9306
LW
2804 case OP_PADAV:
2805 case OP_PADHV:
e6438c1a 2806 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
2807 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2808 return o; /* Treat \(@foo) like ordinary list. */
2809 if (scalar_mod_type(o, type))
3fe9a6f1 2810 goto nomod;
32cbae3f
FC
2811 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2812 && type == OP_LEAVESUBLV)
78f9721b 2813 o->op_private |= OPpMAYBE_LVSUB;
924ba076 2814 /* FALLTHROUGH */
748a9306 2815 case OP_PADSV:
3280af22 2816 PL_modcount++;
ddeae0f1 2817 if (!type) /* local() */
ea9a9e77
FC
2818 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2819 PNfARG(PAD_COMPNAME(o->op_targ)));
e4211fee
FC
2820 if (!(o->op_private & OPpLVAL_INTRO)
2821 || ( type != OP_SASSIGN && type != OP_AASSIGN
2822 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
03414f05 2823 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
2824 break;
2825
748a9306 2826 case OP_PUSHMARK:
ddeae0f1 2827 localize = 0;
748a9306 2828 break;
b2ffa427 2829
69969c6f 2830 case OP_KEYS:
d8065907 2831 case OP_RKEYS:
fad4a2e4 2832 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2833 goto nomod;
5d82c453
GA
2834 goto lvalue_func;
2835 case OP_SUBSTR:
2836 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2837 goto nomod;
924ba076 2838 /* FALLTHROUGH */
a0d0e21e 2839 case OP_POS:
463ee0b2 2840 case OP_VEC:
fad4a2e4 2841 lvalue_func:
78f9721b
SM
2842 if (type == OP_LEAVESUBLV)
2843 o->op_private |= OPpMAYBE_LVSUB;
11343788 2844 if (o->op_flags & OPf_KIDS)
1ed44841 2845 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
463ee0b2 2846 break;
a0d0e21e 2847
463ee0b2
LW
2848 case OP_AELEM:
2849 case OP_HELEM:
11343788 2850 ref(cBINOPo->op_first, o->op_type);
68dc0745 2851 if (type == OP_ENTERSUB &&
5dc0d613
MB
2852 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2853 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
2854 if (type == OP_LEAVESUBLV)
2855 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2856 localize = 1;
3280af22 2857 PL_modcount++;
463ee0b2
LW
2858 break;
2859
463ee0b2 2860 case OP_LEAVE:
a373464f 2861 case OP_LEAVELOOP:
2ec7f6f2 2862 o->op_private |= OPpLVALUE;
924ba076 2863 /* FALLTHROUGH */
2ec7f6f2 2864 case OP_SCOPE:
463ee0b2 2865 case OP_ENTER:
78f9721b 2866 case OP_LINESEQ:
ddeae0f1 2867 localize = 0;
11343788 2868 if (o->op_flags & OPf_KIDS)
3ad73efd 2869 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2870 break;
2871
2872 case OP_NULL:
ddeae0f1 2873 localize = 0;
638bc118
GS
2874 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2875 goto nomod;
2876 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2877 break;
11343788 2878 if (o->op_targ != OP_LIST) {
3ad73efd 2879 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2880 break;
2881 }
924ba076 2882 /* FALLTHROUGH */
463ee0b2 2883 case OP_LIST:
ddeae0f1 2884 localize = 0;
1ed44841 2885 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
5c906035
GG
2886 /* elements might be in void context because the list is
2887 in scalar context or because they are attribute sub calls */
2888 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2889 op_lvalue(kid, type);
463ee0b2 2890 break;
78f9721b 2891
1efec5ed
FC
2892 case OP_COREARGS:
2893 return o;
2ec7f6f2
FC
2894
2895 case OP_AND:
2896 case OP_OR:
375879aa
FC
2897 if (type == OP_LEAVESUBLV
2898 || !S_vivifies(cLOGOPo->op_first->op_type))
2899 op_lvalue(cLOGOPo->op_first, type);
2900 if (type == OP_LEAVESUBLV
1ed44841
DM
2901 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2902 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2ec7f6f2 2903 goto nomod;
26a50d99
FC
2904
2905 case OP_SREFGEN:
d39c26a6
FC
2906 if (type != OP_AASSIGN && type != OP_SASSIGN
2907 && type != OP_ENTERLOOP)
2908 goto nomod;
7664512e 2909 /* Don’t bother applying lvalue context to the ex-list. */
26a50d99 2910 kid = cUNOPx(cUNOPo->op_first)->op_first;
217e3565
FC
2911 assert (!OP_HAS_SIBLING(kid));
2912 goto kid_2lvref;
2913 case OP_REFGEN:
2914 if (type != OP_AASSIGN) goto nomod;
7664512e
FC
2915 kid = cUNOPo->op_first;
2916 kid_2lvref:
2917 {
2918 const U8 ec = PL_parser ? PL_parser->error_count : 0;
63702de8 2919 S_lvref(aTHX_ kid, type);
7664512e 2920 if (!PL_parser || PL_parser->error_count == ec) {
baabe3fb 2921 if (!FEATURE_REFALIASING_IS_ENABLED)
7664512e 2922 Perl_croak(aTHX_
baabe3fb 2923 "Experimental aliasing via reference not enabled");
7664512e 2924 Perl_ck_warner_d(aTHX_
baabe3fb
FC
2925 packWARN(WARN_EXPERIMENTAL__REFALIASING),
2926 "Aliasing via reference is experimental");
7664512e
FC
2927 }
2928 }
217e3565
FC
2929 if (o->op_type == OP_REFGEN)
2930 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2931 op_null(o);
26a50d99 2932 return o;
e4e95921
FC
2933
2934 case OP_SPLIT:
2935 kid = cLISTOPo->op_first;
2936 if (kid && kid->op_type == OP_PUSHRE &&
2937 ( kid->op_targ
2938 || o->op_flags & OPf_STACKED
2939#ifdef USE_ITHREADS
2940 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2941#else
2942 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2943#endif
2944 )) {
2945 /* This is actually @array = split. */
2946 PL_modcount = RETURN_UNLIMITED_NUMBER;
2947 break;
2948 }
2949 goto nomod;
569ddb4a
FC
2950
2951 case OP_SCALAR:
2952 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
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)