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