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