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