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