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