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