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