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