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