This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #121827] Fix repeat stack bugs
[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{
27da23d5 681 dVAR;
acb36ea4 682 OPCODE type;
79072805 683
8be227ab
FC
684 /* Though ops may be freed twice, freeing the op after its slab is a
685 big no-no. */
686 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC
687 /* During the forced freeing of ops after compilation failure, kidops
688 may be freed before their parents. */
689 if (!o || o->op_type == OP_FREED)
79072805
LW
690 return;
691
67566ccd 692 type = o->op_type;
d0c8136d
DM
693
694 /* an op should only ever acquire op_private flags that we know about.
695 * If this fails, you may need to fix something in regen/op_private */
e2a5b720
FC
696 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
697 assert(!(o->op_private & ~PL_op_private_valid[type]));
698 }
d0c8136d 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 1013 o->op_targ = o->op_type;
10884df9 1014 CHANGE_TYPE(o, OP_NULL);
8990e307
LW
1015}
1016
4026c95a
SH
1017void
1018Perl_op_refcnt_lock(pTHX)
1019{
20b7effb 1020#ifdef USE_ITHREADS
27da23d5 1021 dVAR;
20b7effb 1022#endif
96a5add6 1023 PERL_UNUSED_CONTEXT;
4026c95a
SH
1024 OP_REFCNT_LOCK;
1025}
1026
1027void
1028Perl_op_refcnt_unlock(pTHX)
1029{
20b7effb 1030#ifdef USE_ITHREADS
27da23d5 1031 dVAR;
20b7effb 1032#endif
96a5add6 1033 PERL_UNUSED_CONTEXT;
4026c95a
SH
1034 OP_REFCNT_UNLOCK;
1035}
1036
3253bf85
DM
1037
1038/*
1039=for apidoc op_sibling_splice
1040
1041A general function for editing the structure of an existing chain of
7e234f81 1042op_sibling nodes. By analogy with the perl-level splice() function, allows
3253bf85
DM
1043you to delete zero or more sequential nodes, replacing them with zero or
1044more different nodes. Performs the necessary op_first/op_last
29e61fd9 1045housekeeping on the parent node and op_sibling manipulation on the
7e234f81 1046children. The last deleted node will be marked as as the last node by
8ae26bff 1047updating the op_sibling or op_lastsib field as appropriate.
3253bf85
DM
1048
1049Note that op_next is not manipulated, and nodes are not freed; that is the
7e234f81 1050responsibility of the caller. It also won't create a new list op for an
8ae26bff 1051empty list etc; use higher-level functions like op_append_elem() for that.
3253bf85
DM
1052
1053parent is the parent node of the sibling chain.
1054
7e234f81
FC
1055start is the node preceding the first node to be spliced. Node(s)
1056following it will be deleted, and ops will be inserted after it. If it is
3253bf85
DM
1057NULL, the first node onwards is deleted, and nodes are inserted at the
1058beginning.
1059
7e234f81 1060del_count is the number of nodes to delete. If zero, no nodes are deleted.
3253bf85
DM
1061If -1 or greater than or equal to the number of remaining kids, all
1062remaining kids are deleted.
1063
1064insert is the first of a chain of nodes to be inserted in place of the nodes.
1065If NULL, no nodes are inserted.
1066
8ae26bff 1067The head of the chain of deleted ops is returned, or NULL if no ops were
3253bf85
DM
1068deleted.
1069
1070For example:
1071
1072 action before after returns
1073 ------ ----- ----- -------
1074
1075 P P
8ae26bff
DM
1076 splice(P, A, 2, X-Y-Z) | | B-C
1077 A-B-C-D A-X-Y-Z-D
3253bf85
DM
1078
1079 P P
1080 splice(P, NULL, 1, X-Y) | | A
1081 A-B-C-D X-Y-B-C-D
1082
1083 P P
8ae26bff
DM
1084 splice(P, NULL, 3, NULL) | | A-B-C
1085 A-B-C-D D
3253bf85
DM
1086
1087 P P
1088 splice(P, B, 0, X-Y) | | NULL
1089 A-B-C-D A-B-X-Y-C-D
1090
1091=cut
1092*/
1093
1094OP *
8ae26bff 1095Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
3253bf85 1096{
3253bf85
DM
1097 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1098 OP *rest;
1099 OP *last_del = NULL;
1100 OP *last_ins = NULL;
1101
1102 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1103
1104 assert(del_count >= -1);
1105
1106 if (del_count && first) {
1107 last_del = first;
1108 while (--del_count && OP_HAS_SIBLING(last_del))
1109 last_del = OP_SIBLING(last_del);
1110 rest = OP_SIBLING(last_del);
1111 OP_SIBLING_set(last_del, NULL);
29e61fd9 1112 last_del->op_lastsib = 1;
3253bf85
DM
1113 }
1114 else
1115 rest = first;
1116
1117 if (insert) {
1118 last_ins = insert;
1119 while (OP_HAS_SIBLING(last_ins))
1120 last_ins = OP_SIBLING(last_ins);
1121 OP_SIBLING_set(last_ins, rest);
29e61fd9 1122 last_ins->op_lastsib = rest ? 0 : 1;
3253bf85
DM
1123 }
1124 else
1125 insert = rest;
1126
29e61fd9 1127 if (start) {
3253bf85 1128 OP_SIBLING_set(start, insert);
29e61fd9
DM
1129 start->op_lastsib = insert ? 0 : 1;
1130 }
3253bf85
DM
1131 else
1132 cLISTOPx(parent)->op_first = insert;
1133
1134 if (!rest) {
29e61fd9 1135 /* update op_last etc */
3253bf85 1136 U32 type = parent->op_type;
29e61fd9 1137 OP *lastop;
3253bf85
DM
1138
1139 if (type == OP_NULL)
1140 type = parent->op_targ;
1141 type = PL_opargs[type] & OA_CLASS_MASK;
1142
29e61fd9 1143 lastop = last_ins ? last_ins : start ? start : NULL;
3253bf85
DM
1144 if ( type == OA_BINOP
1145 || type == OA_LISTOP
1146 || type == OA_PMOP
1147 || type == OA_LOOP
1148 )
29e61fd9
DM
1149 cLISTOPx(parent)->op_last = lastop;
1150
1151 if (lastop) {
1152 lastop->op_lastsib = 1;
1153#ifdef PERL_OP_PARENT
1154 lastop->op_sibling = parent;
1155#endif
1156 }
3253bf85
DM
1157 }
1158 return last_del ? first : NULL;
1159}
1160
29e61fd9
DM
1161/*
1162=for apidoc op_parent
1163
7e234f81 1164returns the parent OP of o, if it has a parent. Returns NULL otherwise.
29e61fd9
DM
1165(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1166work.
1167
1168=cut
1169*/
1170
1171OP *
8ae26bff 1172Perl_op_parent(OP *o)
29e61fd9
DM
1173{
1174 PERL_ARGS_ASSERT_OP_PARENT;
1175#ifdef PERL_OP_PARENT
1176 while (OP_HAS_SIBLING(o))
1177 o = OP_SIBLING(o);
1178 return o->op_sibling;
1179#else
1180 PERL_UNUSED_ARG(o);
1181 return NULL;
1182#endif
1183}
1184
3253bf85
DM
1185
1186/* replace the sibling following start with a new UNOP, which becomes
1187 * the parent of the original sibling; e.g.
1188 *
1189 * op_sibling_newUNOP(P, A, unop-args...)
1190 *
1191 * P P
1192 * | becomes |
1193 * A-B-C A-U-C
1194 * |
1195 * B
1196 *
1197 * where U is the new UNOP.
1198 *
1199 * parent and start args are the same as for op_sibling_splice();
1200 * type and flags args are as newUNOP().
1201 *
1202 * Returns the new UNOP.
1203 */
1204
1205OP *
1206S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1207{
1208 OP *kid, *newop;
1209
1210 kid = op_sibling_splice(parent, start, 1, NULL);
1211 newop = newUNOP(type, flags, kid);
1212 op_sibling_splice(parent, start, 0, newop);
1213 return newop;
1214}
1215
1216
1217/* lowest-level newLOGOP-style function - just allocates and populates
1218 * the struct. Higher-level stuff should be done by S_new_logop() /
1219 * newLOGOP(). This function exists mainly to avoid op_first assignment
1220 * being spread throughout this file.
1221 */
1222
1223LOGOP *
1224S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1225{
1e8db68a 1226 dVAR;
3253bf85 1227 LOGOP *logop;
29e61fd9 1228 OP *kid = first;
3253bf85 1229 NewOp(1101, logop, 1, LOGOP);
ddacf109 1230 CHANGE_TYPE(logop, 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
SM
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
fd017c00 1698 && !kid->op_targ
ef7999f1 1699 && !(o->op_flags & OPf_STACKED)
75068674
RGS
1700#ifdef USE_ITHREADS
1701 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1702#else
1703 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1704#endif
1705 useless = OP_DESC(o);
8990e307
LW
1706 break;
1707
9f82cd5f
YST
1708 case OP_NOT:
1709 kid = cUNOPo->op_first;
1710 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1711 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST
1712 goto func_ops;
1713 }
1714 useless = "negative pattern binding (!~)";
1715 break;
1716
4f4d7508
DC
1717 case OP_SUBST:
1718 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1719 useless = "non-destructive substitution (s///r)";
4f4d7508
DC
1720 break;
1721
bb16bae8
FC
1722 case OP_TRANSR:
1723 useless = "non-destructive transliteration (tr///r)";
1724 break;
1725
8990e307
LW
1726 case OP_RV2GV:
1727 case OP_RV2SV:
1728 case OP_RV2AV:
1729 case OP_RV2HV:
192587c2 1730 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1ed44841 1731 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
8990e307
LW
1732 useless = "a variable";
1733 break;
79072805
LW
1734
1735 case OP_CONST:
7766f137 1736 sv = cSVOPo_sv;
7a52d87a
GS
1737 if (cSVOPo->op_private & OPpCONST_STRICT)
1738 no_bareword_allowed(o);
1739 else {
d008e5eb 1740 if (ckWARN(WARN_VOID)) {
365c7d0c 1741 NV nv;
e7fec78e 1742 /* don't warn on optimised away booleans, eg
b5a930ec 1743 * use constant Foo, 5; Foo || print; */
e7fec78e 1744 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1745 useless = NULL;
960b4253
MG
1746 /* the constants 0 and 1 are permitted as they are
1747 conventionally used as dummies in constructs like
1748 1 while some_condition_with_side_effects; */
365c7d0c 1749 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
d4c19fe8 1750 useless = NULL;
d008e5eb 1751 else if (SvPOK(sv)) {
1e3f3188
KW
1752 SV * const dsv = newSVpvs("");
1753 useless_sv
1754 = Perl_newSVpvf(aTHX_
1755 "a constant (%s)",
1756 pv_pretty(dsv, SvPVX_const(sv),
1757 SvCUR(sv), 32, NULL, NULL,
1758 PERL_PV_PRETTY_DUMP
1759 | PERL_PV_ESCAPE_NOCLEAR
1760 | PERL_PV_ESCAPE_UNI_DETECT));
1761 SvREFCNT_dec_NN(dsv);
d008e5eb 1762 }
919f76a3 1763 else if (SvOK(sv)) {
c1f6cd39 1764 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
919f76a3
RGS
1765 }
1766 else
1767 useless = "a constant (undef)";
8990e307
LW
1768 }
1769 }
93c66552 1770 op_null(o); /* don't execute or even remember it */
79072805
LW
1771 break;
1772
1773 case OP_POSTINC:
10884df9 1774 CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
79072805
LW
1775 break;
1776
1777 case OP_POSTDEC:
10884df9 1778 CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
79072805
LW
1779 break;
1780
679d6c4e 1781 case OP_I_POSTINC:
10884df9 1782 CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
679d6c4e
HS
1783 break;
1784
1785 case OP_I_POSTDEC:
10884df9 1786 CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
679d6c4e
HS
1787 break;
1788
f2f8fd84
GG
1789 case OP_SASSIGN: {
1790 OP *rv2gv;
1791 UNOP *refgen, *rv2cv;
1792 LISTOP *exlist;
1793
1794 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1795 break;
1796
1797 rv2gv = ((BINOP *)o)->op_last;
1798 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1799 break;
1800
1801 refgen = (UNOP *)((BINOP *)o)->op_first;
1802
18690b0b
FC
1803 if (!refgen || (refgen->op_type != OP_REFGEN
1804 && refgen->op_type != OP_SREFGEN))
f2f8fd84
GG
1805 break;
1806
1807 exlist = (LISTOP *)refgen->op_first;
1808 if (!exlist || exlist->op_type != OP_NULL
1809 || exlist->op_targ != OP_LIST)
1810 break;
1811
18690b0b
FC
1812 if (exlist->op_first->op_type != OP_PUSHMARK
1813 && exlist->op_first != exlist->op_last)
f2f8fd84
GG
1814 break;
1815
1816 rv2cv = (UNOP*)exlist->op_last;
1817
1818 if (rv2cv->op_type != OP_RV2CV)
1819 break;
1820
1821 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1822 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1823 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1824
1825 o->op_private |= OPpASSIGN_CV_TO_GV;
1826 rv2gv->op_private |= OPpDONT_INIT_GV;
1827 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1828
1829 break;
1830 }
1831
540dd770
GG
1832 case OP_AASSIGN: {
1833 inplace_aassign(o);
1834 break;
1835 }
1836
79072805
LW
1837 case OP_OR:
1838 case OP_AND:
edbe35ea
VP
1839 kid = cLOGOPo->op_first;
1840 if (kid->op_type == OP_NOT
b5bbe64a 1841 && (kid->op_flags & OPf_KIDS)) {
edbe35ea 1842 if (o->op_type == OP_AND) {
10884df9 1843 CHANGE_TYPE(o, OP_OR);
edbe35ea 1844 } else {
10884df9 1845 CHANGE_TYPE(o, OP_AND);
edbe35ea
VP
1846 }
1847 op_null(kid);
1848 }
c67159e1 1849 /* FALLTHROUGH */
edbe35ea 1850
c963b151 1851 case OP_DOR:
79072805 1852 case OP_COND_EXPR:
0d863452
RH
1853 case OP_ENTERGIVEN:
1854 case OP_ENTERWHEN:
1ed44841 1855 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
79072805
LW
1856 scalarvoid(kid);
1857 break;
5aabfad6 1858
a0d0e21e 1859 case OP_NULL:
11343788 1860 if (o->op_flags & OPf_STACKED)
a0d0e21e 1861 break;
924ba076 1862 /* FALLTHROUGH */
2ebea0a1
GS
1863 case OP_NEXTSTATE:
1864 case OP_DBSTATE:
79072805
LW
1865 case OP_ENTERTRY:
1866 case OP_ENTER:
11343788 1867 if (!(o->op_flags & OPf_KIDS))
79072805 1868 break;
924ba076 1869 /* FALLTHROUGH */
463ee0b2 1870 case OP_SCOPE:
79072805
LW
1871 case OP_LEAVE:
1872 case OP_LEAVETRY:
a0d0e21e 1873 case OP_LEAVELOOP:
79072805 1874 case OP_LINESEQ:
0d863452
RH
1875 case OP_LEAVEGIVEN:
1876 case OP_LEAVEWHEN:
6aa68307 1877 kids:
1ed44841 1878 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
79072805
LW
1879 scalarvoid(kid);
1880 break;
6aa68307
FC
1881 case OP_LIST:
1882 /* If the first kid after pushmark is something that the padrange
1883 optimisation would reject, then null the list and the pushmark.
1884 */
1885 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1886 && ( !(kid = OP_SIBLING(kid))
1887 || ( kid->op_type != OP_PADSV
1888 && kid->op_type != OP_PADAV
1889 && kid->op_type != OP_PADHV)
8c225ab7
FC
1890 || kid->op_private & ~OPpLVAL_INTRO
1891 || !(kid = OP_SIBLING(kid))
1892 || ( kid->op_type != OP_PADSV
1893 && kid->op_type != OP_PADAV
1894 && kid->op_type != OP_PADHV)
6aa68307
FC
1895 || kid->op_private & ~OPpLVAL_INTRO)
1896 ) {
1897 op_null(cUNOPo->op_first); /* NULL the pushmark */
1898 op_null(o); /* NULL the list */
1899 }
1900 goto kids;
c90c0ff4 1901 case OP_ENTEREVAL:
5196be3e 1902 scalarkids(o);
c90c0ff4 1903 break;
d6483035 1904 case OP_SCALAR:
5196be3e 1905 return scalar(o);
79072805 1906 }
095b19d1
NC
1907
1908 if (useless_sv) {
1909 /* mortalise it, in case warnings are fatal. */
1910 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1911 "Useless use of %"SVf" in void context",
c1f6cd39 1912 SVfARG(sv_2mortal(useless_sv)));
095b19d1
NC
1913 }
1914 else if (useless) {
1915 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1916 "Useless use of %s in void context",
1917 useless);
1918 }
11343788 1919 return o;
79072805
LW
1920}
1921
1f676739 1922static OP *
412da003 1923S_listkids(pTHX_ OP *o)
79072805 1924{
11343788 1925 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1926 OP *kid;
1ed44841 1927 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
79072805
LW
1928 list(kid);
1929 }
11343788 1930 return o;
79072805
LW
1931}
1932
1933OP *
864dbfa3 1934Perl_list(pTHX_ OP *o)
79072805
LW
1935{
1936 OP *kid;
1937
a0d0e21e 1938 /* assumes no premature commitment */
13765c85
DM
1939 if (!o || (o->op_flags & OPf_WANT)
1940 || (PL_parser && PL_parser->error_count)
5dc0d613 1941 || o->op_type == OP_RETURN)
7e363e51 1942 {
11343788 1943 return o;
7e363e51 1944 }
79072805 1945
b162f9ea 1946 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1947 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1948 {
b162f9ea 1949 return o; /* As if inside SASSIGN */
7e363e51 1950 }
1c846c1f 1951
5dc0d613 1952 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1953
11343788 1954 switch (o->op_type) {
79072805 1955 case OP_FLOP:
11343788 1956 list(cBINOPo->op_first);
79072805 1957 break;
c57eecc5
FC
1958 case OP_REPEAT:
1959 if (o->op_private & OPpREPEAT_DOLIST
1960 && !(o->op_flags & OPf_STACKED))
1961 {
1962 list(cBINOPo->op_first);
1963 kid = cBINOPo->op_last;
1964 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
1965 && SvIVX(kSVOP_sv) == 1)
1966 {
1967 op_null(o); /* repeat */
1968 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
1969 /* const (rhs): */
1970 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
1971 }
1972 }
1973 break;
79072805
LW
1974 case OP_OR:
1975 case OP_AND:
1976 case OP_COND_EXPR:
1ed44841 1977 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
79072805
LW
1978 list(kid);
1979 break;
1980 default:
1981 case OP_MATCH:
8782bef2 1982 case OP_QR:
79072805
LW
1983 case OP_SUBST:
1984 case OP_NULL:
11343788 1985 if (!(o->op_flags & OPf_KIDS))
79072805 1986 break;
11343788
MB
1987 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1988 list(cBINOPo->op_first);
1989 return gen_constant_list(o);
79072805 1990 }
6aa68307
FC
1991 listkids(o);
1992 break;
79072805 1993 case OP_LIST:
11343788 1994 listkids(o);
6aa68307
FC
1995 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
1996 op_null(cUNOPo->op_first); /* NULL the pushmark */
1997 op_null(o); /* NULL the list */
1998 }
79072805
LW
1999 break;
2000 case OP_LEAVE:
2001 case OP_LEAVETRY:
5dc0d613 2002 kid = cLISTOPo->op_first;
54310121 2003 list(kid);
1ed44841 2004 kid = OP_SIBLING(kid);
25b991bf
VP
2005 do_kids:
2006 while (kid) {
1ed44841 2007 OP *sib = OP_SIBLING(kid);
c08f093b
VP
2008 if (sib && kid->op_type != OP_LEAVEWHEN)
2009 scalarvoid(kid);
2010 else
54310121 2011 list(kid);
25b991bf 2012 kid = sib;
54310121 2013 }
11206fdd 2014 PL_curcop = &PL_compiling;
54310121 2015 break;
748a9306 2016 case OP_SCOPE:
79072805 2017 case OP_LINESEQ:
25b991bf
VP
2018 kid = cLISTOPo->op_first;
2019 goto do_kids;
79072805 2020 }
11343788 2021 return o;
79072805
LW
2022}
2023
1f676739 2024static OP *
2dd5337b 2025S_scalarseq(pTHX_ OP *o)
79072805 2026{
11343788 2027 if (o) {
1496a290
AL
2028 const OPCODE type = o->op_type;
2029
2030 if (type == OP_LINESEQ || type == OP_SCOPE ||
2031 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 2032 {
6867be6d 2033 OP *kid;
1ed44841
DM
2034 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2035 if (OP_HAS_SIBLING(kid)) {
463ee0b2 2036 scalarvoid(kid);
ed6116ce 2037 }
463ee0b2 2038 }
3280af22 2039 PL_curcop = &PL_compiling;
79072805 2040 }
11343788 2041 o->op_flags &= ~OPf_PARENS;
3280af22 2042 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 2043 o->op_flags |= OPf_PARENS;
79072805 2044 }
8990e307 2045 else
11343788
MB
2046 o = newOP(OP_STUB, 0);
2047 return o;
79072805
LW
2048}
2049
76e3520e 2050STATIC OP *
cea2e8a9 2051S_modkids(pTHX_ OP *o, I32 type)
79072805 2052{
11343788 2053 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2054 OP *kid;
1ed44841 2055 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3ad73efd 2056 op_lvalue(kid, type);
79072805 2057 }
11343788 2058 return o;
79072805
LW
2059}
2060
3ad73efd 2061/*
d164302a
GG
2062=for apidoc finalize_optree
2063
72d33970
FC
2064This function finalizes the optree. Should be called directly after
2065the complete optree is built. It does some additional
d164302a
GG
2066checking which can't be done in the normal ck_xxx functions and makes
2067the tree thread-safe.
2068
2069=cut
2070*/
2071void
2072Perl_finalize_optree(pTHX_ OP* o)
2073{
2074 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2075
2076 ENTER;
2077 SAVEVPTR(PL_curcop);
2078
2079 finalize_op(o);
2080
2081 LEAVE;
2082}
2083
b46e009d 2084#ifdef USE_ITHREADS
2085/* Relocate sv to the pad for thread safety.
2086 * Despite being a "constant", the SV is written to,
2087 * for reference counts, sv_upgrade() etc. */
2088PERL_STATIC_INLINE void
2089S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2090{
2091 PADOFFSET ix;
2092 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2093 if (!*svp) return;
2094 ix = pad_alloc(OP_CONST, SVf_READONLY);
2095 SvREFCNT_dec(PAD_SVl(ix));
2096 PAD_SETSV(ix, *svp);
2097 /* XXX I don't know how this isn't readonly already. */
2098 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2099 *svp = NULL;
2100 *targp = ix;
2101}
2102#endif
2103
2104
60dde6b2 2105STATIC void
d164302a
GG
2106S_finalize_op(pTHX_ OP* o)
2107{
2108 PERL_ARGS_ASSERT_FINALIZE_OP;
2109
d164302a
GG
2110
2111 switch (o->op_type) {
2112 case OP_NEXTSTATE:
2113 case OP_DBSTATE:
2114 PL_curcop = ((COP*)o); /* for warnings */
2115 break;
2116 case OP_EXEC:
1ed44841
DM
2117 if (OP_HAS_SIBLING(o)) {
2118 OP *sib = OP_SIBLING(o);
2119 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2120 && ckWARN(WARN_EXEC)
2121 && OP_HAS_SIBLING(sib))
2122 {
2123 const OPCODE type = OP_SIBLING(sib)->op_type;
d164302a
GG
2124 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2125 const line_t oldline = CopLINE(PL_curcop);
1ed44841 2126 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
d164302a
GG
2127 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2128 "Statement unlikely to be reached");
2129 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2130 "\t(Maybe you meant system() when you said exec()?)\n");
2131 CopLINE_set(PL_curcop, oldline);
2132 }
d164302a 2133 }
1ed44841 2134 }
d164302a
GG
2135 break;
2136
2137 case OP_GV:
2138 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2139 GV * const gv = cGVOPo_gv;
2140 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2141 /* XXX could check prototype here instead of just carping */
2142 SV * const sv = sv_newmortal();
2143 gv_efullname3(sv, gv, NULL);
2144 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2145 "%"SVf"() called too early to check prototype",
2146 SVfARG(sv));
2147 }
2148 }
2149 break;
2150
2151 case OP_CONST:
eb796c7f
GG
2152 if (cSVOPo->op_private & OPpCONST_STRICT)
2153 no_bareword_allowed(o);
2154 /* FALLTHROUGH */
d164302a
GG
2155#ifdef USE_ITHREADS
2156 case OP_HINTSEVAL:
b46e009d 2157 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2158#endif
2159 break;
2160
2161#ifdef USE_ITHREADS
2162 /* Relocate all the METHOP's SVs to the pad for thread safety. */
d164302a 2163 case OP_METHOD_NAMED:
b46e009d 2164 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2165 break;
d164302a 2166#endif
d164302a
GG
2167
2168 case OP_HELEM: {
2169 UNOP *rop;
2170 SV *lexname;
2171 GV **fields;
565e6f7e
FC
2172 SVOP *key_op;
2173 OP *kid;
2174 bool check_fields;
d164302a 2175
565e6f7e 2176 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
d164302a
GG
2177 break;
2178
2179 rop = (UNOP*)((BINOP*)o)->op_first;
e6307ed0 2180
565e6f7e 2181 goto check_keys;
d164302a 2182
565e6f7e 2183 case OP_HSLICE:
429a2555 2184 S_scalar_slice_warning(aTHX_ o);
c67159e1 2185 /* FALLTHROUGH */
429a2555 2186
c5f75dba 2187 case OP_KVHSLICE:
1ed44841 2188 kid = OP_SIBLING(cLISTOPo->op_first);
71323522 2189 if (/* I bet there's always a pushmark... */
7d3c8a68
SM
2190 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2191 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2192 {
d164302a 2193 break;
7d3c8a68 2194 }
565e6f7e
FC
2195
2196 key_op = (SVOP*)(kid->op_type == OP_CONST
2197 ? kid
1ed44841 2198 : OP_SIBLING(kLISTOP->op_first));
565e6f7e
FC
2199
2200 rop = (UNOP*)((LISTOP*)o)->op_last;
2201
2202 check_keys:
2203 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
71323522 2204 rop = NULL;
565e6f7e 2205 else if (rop->op_first->op_type == OP_PADSV)
d164302a
GG
2206 /* @$hash{qw(keys here)} */
2207 rop = (UNOP*)rop->op_first;
565e6f7e 2208 else {
d164302a
GG
2209 /* @{$hash}{qw(keys here)} */
2210 if (rop->op_first->op_type == OP_SCOPE
2211 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2212 {
2213 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2214 }
2215 else
71323522 2216 rop = NULL;
d164302a 2217 }
71323522 2218
32e9ec8f 2219 lexname = NULL; /* just to silence compiler warnings */
03acb648
DM
2220 fields = NULL; /* just to silence compiler warnings */
2221
71323522
FC
2222 check_fields =
2223 rop
2224 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2225 SvPAD_TYPED(lexname))
2226 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2227 && isGV(*fields) && GvHV(*fields);
0e706dd4 2228 for (; key_op;
1ed44841 2229 key_op = (SVOP*)OP_SIBLING(key_op)) {
565e6f7e 2230 SV **svp, *sv;
d164302a
GG
2231 if (key_op->op_type != OP_CONST)
2232 continue;
2233 svp = cSVOPx_svp(key_op);
71323522
FC
2234
2235 /* Make the CONST have a shared SV */
2236 if ((!SvIsCOW_shared_hash(sv = *svp))
2237 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2238 SSize_t keylen;
2239 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2240 SV *nsv = newSVpvn_share(key,
2241 SvUTF8(sv) ? -keylen : keylen, 0);
2242 SvREFCNT_dec_NN(sv);
2243 *svp = nsv;
2244 }
2245
2246 if (check_fields
2247 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
ce16c625 2248 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 2249 "in variable %"SVf" of type %"HEKf,
ce16c625 2250 SVfARG(*svp), SVfARG(lexname),
84cf752c 2251 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
2252 }
2253 }
2254 break;
2255 }
429a2555
FC
2256 case OP_ASLICE:
2257 S_scalar_slice_warning(aTHX_ o);
2258 break;
a7fd8ef6 2259
d164302a
GG
2260 case OP_SUBST: {
2261 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2262 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2263 break;
2264 }
2265 default:
2266 break;
2267 }
2268
2269 if (o->op_flags & OPf_KIDS) {
2270 OP *kid;
c4b20975
DM
2271
2272#ifdef DEBUGGING
20220689
DM
2273 /* check that op_last points to the last sibling, and that
2274 * the last op_sibling field points back to the parent, and
2275 * that the only ops with KIDS are those which are entitled to
2276 * them */
c4b20975
DM
2277 U32 type = o->op_type;
2278 U32 family;
20220689 2279 bool has_last;
c4b20975
DM
2280
2281 if (type == OP_NULL) {
2282 type = o->op_targ;
2283 /* ck_glob creates a null UNOP with ex-type GLOB
2284 * (which is a list op. So pretend it wasn't a listop */
2285 if (type == OP_GLOB)
2286 type = OP_NULL;
2287 }
2288 family = PL_opargs[type] & OA_CLASS_MASK;
2289
20220689
DM
2290 has_last = ( family == OA_BINOP
2291 || family == OA_LISTOP
2292 || family == OA_PMOP
2293 || family == OA_LOOP
2294 );
2295 assert( has_last /* has op_first and op_last, or ...
2296 ... has (or may have) op_first: */
2297 || family == OA_UNOP
2298 || family == OA_LOGOP
2299 || family == OA_BASEOP_OR_UNOP
2300 || family == OA_FILESTATOP
2301 || family == OA_LOOPEXOP
b46e009d 2302 || family == OA_METHOP
20220689
DM
2303 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2304 || type == OP_SASSIGN
2305 || type == OP_CUSTOM
2306 || type == OP_NULL /* new_logop does this */
2307 );
2308 /* XXX list form of 'x' is has a null op_last. This is wrong,
2309 * but requires too much hacking (e.g. in Deparse) to fix for
2310 * now */
2311 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2312 assert(has_last);
2313 has_last = 0;
2314 }
2315
2316 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
29e61fd9 2317# ifdef PERL_OP_PARENT
20220689
DM
2318 if (!OP_HAS_SIBLING(kid)) {
2319 if (has_last)
29e61fd9 2320 assert(kid == cLISTOPo->op_last);
20220689
DM
2321 assert(kid->op_sibling == o);
2322 }
29e61fd9 2323# else
20220689
DM
2324 if (OP_HAS_SIBLING(kid)) {
2325 assert(!kid->op_lastsib);
2326 }
2327 else {
2328 assert(kid->op_lastsib);
2329 if (has_last)
29e61fd9 2330 assert(kid == cLISTOPo->op_last);
c4b20975 2331 }
20220689 2332# endif
c4b20975
DM
2333 }
2334#endif
2335
1ed44841 2336 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
d164302a
GG
2337 finalize_op(kid);
2338 }
2339}
2340
2341/*
3ad73efd
Z
2342=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2343
2344Propagate lvalue ("modifiable") context to an op and its children.
2345I<type> represents the context type, roughly based on the type of op that
2346would do the modifying, although C<local()> is represented by OP_NULL,
2347because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
2348the lvalue op).
2349
2350This function detects things that can't be modified, such as C<$x+1>, and
72d33970 2351generates errors for them. For example, C<$x+1 = 2> would cause it to be
001c3c51
FC
2352called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2353
2354It also flags things that need to behave specially in an lvalue context,
2355such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
2356
2357=cut
2358*/
ddeae0f1 2359
375879aa
FC
2360static bool
2361S_vivifies(const OPCODE type)
2362{
2363 switch(type) {
2364 case OP_RV2AV: case OP_ASLICE:
2365 case OP_RV2HV: case OP_KVASLICE:
2366 case OP_RV2SV: case OP_HSLICE:
2367 case OP_AELEMFAST: case OP_KVHSLICE:
2368 case OP_HELEM:
2369 case OP_AELEM:
2370 return 1;
2371 }
2372 return 0;
2373}
2374
7664512e 2375static void
63702de8 2376S_lvref(pTHX_ OP *o, I32 type)
7664512e 2377{
727d2dc6 2378 dVAR;
7664512e
FC
2379 OP *kid;
2380 switch (o->op_type) {
2381 case OP_COND_EXPR:
2382 for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2383 kid = OP_SIBLING(kid))
63702de8 2384 S_lvref(aTHX_ kid, type);
7664512e
FC
2385 /* FALLTHROUGH */
2386 case OP_PUSHMARK:
2387 return;
2388 case OP_RV2AV:
2389 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2390 o->op_flags |= OPf_STACKED;
2391 if (o->op_flags & OPf_PARENS) {
2392 if (o->op_private & OPpLVAL_INTRO) {
7664512e
FC
2393 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2394 "localized parenthesized array in list assignment"));
2395 return;
2396 }
2397 slurpy:
10884df9 2398 CHANGE_TYPE(o, OP_LVAVREF);
7664512e
FC
2399 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2400 o->op_flags |= OPf_MOD|OPf_REF;
2401 return;
2402 }
2403 o->op_private |= OPpLVREF_AV;
2404 goto checkgv;
408e9044 2405 case OP_RV2CV:
19abb1ea
FC
2406 kid = cUNOPo->op_first;
2407 if (kid->op_type == OP_NULL)
2408 kid = cUNOPx(kUNOP->op_first->op_sibling)
408e9044
FC
2409 ->op_first;
2410 o->op_private = OPpLVREF_CV;
2411 if (kid->op_type == OP_GV)
2412 o->op_flags |= OPf_STACKED;
2413 else if (kid->op_type == OP_PADCV) {
2414 o->op_targ = kid->op_targ;
2415 kid->op_targ = 0;
2416 op_free(cUNOPo->op_first);
2417 cUNOPo->op_first = NULL;
2418 o->op_flags &=~ OPf_KIDS;
2419 }
2420 else goto badref;
2421 break;
7664512e
FC
2422 case OP_RV2HV:
2423 if (o->op_flags & OPf_PARENS) {
2424 parenhash:
7664512e
FC
2425 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2426 "parenthesized hash in list assignment"));
2427 return;
2428 }
2429 o->op_private |= OPpLVREF_HV;
2430 /* FALLTHROUGH */
2431 case OP_RV2SV:
2432 checkgv:
2433 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2434 o->op_flags |= OPf_STACKED;
6f5dab3c
FC
2435 break;
2436 case OP_PADHV:
2437 if (o->op_flags & OPf_PARENS) goto parenhash;
2438 o->op_private |= OPpLVREF_HV;
7664512e
FC
2439 /* FALLTHROUGH */
2440 case OP_PADSV:
6f5dab3c 2441 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2442 break;
2443 case OP_PADAV:
6f5dab3c 2444 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
7664512e
FC
2445 if (o->op_flags & OPf_PARENS) goto slurpy;
2446 o->op_private |= OPpLVREF_AV;
2447 break;
7664512e
FC
2448 case OP_AELEM:
2449 case OP_HELEM:
2450 o->op_private |= OPpLVREF_ELEM;
2451 o->op_flags |= OPf_STACKED;
2452 break;
2453 case OP_ASLICE:
2454 case OP_HSLICE:
10884df9 2455 CHANGE_TYPE(o, OP_LVREFSLICE);
7664512e
FC
2456 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2457 return;
2458 case OP_NULL:
2459 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2460 goto badref;
2461 else if (!(o->op_flags & OPf_KIDS))
2462 return;
2463 if (o->op_targ != OP_LIST) {
63702de8 2464 S_lvref(aTHX_ cBINOPo->op_first, type);
7664512e
FC
2465 return;
2466 }
2467 /* FALLTHROUGH */
2468 case OP_LIST:
2469 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2470 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
63702de8 2471 S_lvref(aTHX_ kid, type);
7664512e
FC
2472 }
2473 return;
2474 case OP_STUB:
2475 if (o->op_flags & OPf_PARENS)
2476 return;
2477 /* FALLTHROUGH */
2478 default:
2479 badref:
cf6e1fa1 2480 /* diag_listed_as: Can't modify reference to %s in %s assignment */
63702de8 2481 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
7664512e
FC
2482 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2483 ? "do block"
63702de8
FC
2484 : OP_DESC(o),
2485 PL_op_desc[type]));
7664512e
FC
2486 return;
2487 }
10884df9 2488 CHANGE_TYPE(o, OP_LVREF);
3ad7d304
FC
2489 o->op_private &=
2490 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
d39c26a6
FC
2491 if (type == OP_ENTERLOOP)
2492 o->op_private |= OPpLVREF_ITER;
7664512e
FC
2493}
2494
79072805 2495OP *
d3d7d28f 2496Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 2497{
27da23d5 2498 dVAR;
79072805 2499 OP *kid;
ddeae0f1
DM
2500 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2501 int localize = -1;
79072805 2502
13765c85 2503 if (!o || (PL_parser && PL_parser->error_count))
11343788 2504 return o;
79072805 2505
b162f9ea 2506 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
2507 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2508 {
b162f9ea 2509 return o;
7e363e51 2510 }
1c846c1f 2511
5c906035
GG
2512 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2513
69974ce6
FC
2514 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2515
11343788 2516 switch (o->op_type) {
68dc0745 2517 case OP_UNDEF:
3280af22 2518 PL_modcount++;
5dc0d613 2519 return o;
5f05dabc 2520 case OP_STUB:
b5bbe64a 2521 if ((o->op_flags & OPf_PARENS))
5f05dabc
PP
2522 break;
2523 goto nomod;
a0d0e21e 2524 case OP_ENTERSUB:
f79aa60b 2525 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788 2526 !(o->op_flags & OPf_STACKED)) {
10884df9 2527 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2528 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2529 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
2530 break;
2531 }
cd06dffe 2532 else { /* lvalue subroutine call */
9411a3c7 2533 o->op_private |= OPpLVAL_INTRO;
e6438c1a 2534 PL_modcount = RETURN_UNLIMITED_NUMBER;
9411a3c7
FC
2535 if (type == OP_GREPSTART || type == OP_ENTERSUB
2536 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
d0887bf3 2537 /* Potential lvalue context: */
cd06dffe
GS
2538 o->op_private |= OPpENTERSUB_INARGS;
2539 break;
2540 }
2541 else { /* Compile-time error message: */
2542 OP *kid = cUNOPo->op_first;
2543 CV *cv;
2eaf799e 2544 GV *gv;
cd06dffe 2545
3ea285d1
AL
2546 if (kid->op_type != OP_PUSHMARK) {
2547 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2548 Perl_croak(aTHX_
2549 "panic: unexpected lvalue entersub "
2550 "args: type/targ %ld:%"UVuf,
2551 (long)kid->op_type, (UV)kid->op_targ);
2552 kid = kLISTOP->op_first;
2553 }
1ed44841
DM
2554 while (OP_HAS_SIBLING(kid))
2555 kid = OP_SIBLING(kid);
cd06dffe 2556 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2557 break; /* Postpone until runtime */
2558 }
b2ffa427 2559
cd06dffe
GS
2560 kid = kUNOP->op_first;
2561 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2562 kid = kUNOP->op_first;
b2ffa427 2563 if (kid->op_type == OP_NULL)
cd06dffe
GS
2564 Perl_croak(aTHX_
2565 "Unexpected constant lvalue entersub "
55140b79 2566 "entry via type/targ %ld:%"UVuf,
3d811634 2567 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2568 if (kid->op_type != OP_GV) {
cd06dffe
GS
2569 break;
2570 }
b2ffa427 2571
2eaf799e
FC
2572 gv = kGVOP_gv;
2573 cv = isGV(gv)
2574 ? GvCV(gv)
2575 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2576 ? MUTABLE_CV(SvRV(gv))
2577 : NULL;
1c846c1f 2578 if (!cv)
da1dff94 2579 break;
cd06dffe
GS
2580 if (CvLVALUE(cv))
2581 break;
2582 }
2583 }
924ba076 2584 /* FALLTHROUGH */
79072805 2585 default:
a0d0e21e 2586 nomod:
f5d552b4 2587 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2588 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
2589 if (type == OP_GREPSTART || type == OP_ENTERSUB
2590 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2591 break;
cea2e8a9 2592 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2593 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
2594 ? "do block"
2595 : (o->op_type == OP_ENTERSUB
2596 ? "non-lvalue subroutine call"
53e06cf0 2597 : OP_DESC(o))),
22c35a8c 2598 type ? PL_op_desc[type] : "local"));
11343788 2599 return o;
79072805 2600
a0d0e21e
LW
2601 case OP_PREINC:
2602 case OP_PREDEC:
2603 case OP_POW:
2604 case OP_MULTIPLY:
2605 case OP_DIVIDE:
2606 case OP_MODULO:
a0d0e21e
LW
2607 case OP_ADD:
2608 case OP_SUBTRACT:
2609 case OP_CONCAT:
2610 case OP_LEFT_SHIFT:
2611 case OP_RIGHT_SHIFT:
2612 case OP_BIT_AND:
2613 case OP_BIT_XOR:
2614 case OP_BIT_OR:
2615 case OP_I_MULTIPLY:
2616 case OP_I_DIVIDE:
2617 case OP_I_MODULO:
2618 case OP_I_ADD:
2619 case OP_I_SUBTRACT:
11343788 2620 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2621 goto nomod;
3280af22 2622 PL_modcount++;
a0d0e21e 2623 break;
b2ffa427 2624
82209a5d
FC
2625 case OP_REPEAT:
2626 if (o->op_flags & OPf_STACKED) {
2627 PL_modcount++;
2628 break;
2629 }
ff781254 2630 if (!(o->op_private & OPpREPEAT_DOLIST))
82209a5d
FC
2631 goto nomod;
2632 else {
2633 const I32 mods = PL_modcount;
ff781254
FC
2634 modkids(cBINOPo->op_first, type);
2635 if (type != OP_AASSIGN)
2636 goto nomod;
5e462669 2637 kid = cBINOPo->op_last;
82209a5d 2638 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
565e104c 2639 const IV iv = SvIV(kSVOP_sv);
82209a5d
FC
2640 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2641 PL_modcount =
2642 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2643 }
2644 else
2645 PL_modcount = RETURN_UNLIMITED_NUMBER;
2646 }
2647 break;
2648
79072805 2649 case OP_COND_EXPR:
ddeae0f1 2650 localize = 1;
1ed44841 2651 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
3ad73efd 2652 op_lvalue(kid, type);
79072805
LW
2653 break;
2654
2655 case OP_RV2AV:
2656 case OP_RV2HV:
11343788 2657 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2658 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2659 return o; /* Treat \(@foo) like ordinary list. */
748a9306 2660 }
924ba076 2661 /* FALLTHROUGH */
79072805 2662 case OP_RV2GV:
5dc0d613 2663 if (scalar_mod_type(o, type))
3fe9a6f1 2664 goto nomod;
11343788 2665 ref(cUNOPo->op_first, o->op_type);
924ba076 2666 /* FALLTHROUGH */
79072805
LW
2667 case OP_ASLICE:
2668 case OP_HSLICE:
ddeae0f1 2669 localize = 1;
924ba076 2670 /* FALLTHROUGH */
78f9721b 2671 case OP_AASSIGN:
32cbae3f
FC
2672 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2673 if (type == OP_LEAVESUBLV && (
2674 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2675 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2676 ))
631dbaa2 2677 o->op_private |= OPpMAYBE_LVSUB;
924ba076 2678 /* FALLTHROUGH */
93a17b20
LW
2679 case OP_NEXTSTATE:
2680 case OP_DBSTATE:
e6438c1a 2681 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2682 break;
5cae3edb 2683 case OP_KVHSLICE:
6dd3e0f2 2684 case OP_KVASLICE:
5cae3edb
RZ
2685 if (type == OP_LEAVESUBLV)
2686 o->op_private |= OPpMAYBE_LVSUB;
2687 goto nomod;
28c5b5bc
RGS
2688 case OP_AV2ARYLEN:
2689 PL_hints |= HINT_BLOCK_SCOPE;
2690 if (type == OP_LEAVESUBLV)
2691 o->op_private |= OPpMAYBE_LVSUB;
2692 PL_modcount++;
2693 break;
463ee0b2 2694 case OP_RV2SV:
aeea060c 2695 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2696 localize = 1;
924ba076 2697 /* FALLTHROUGH */
79072805 2698 case OP_GV:
3280af22 2699 PL_hints |= HINT_BLOCK_SCOPE;
924ba076 2700 /* FALLTHROUGH */
463ee0b2 2701 case OP_SASSIGN:
bf4b1e52
GS
2702 case OP_ANDASSIGN:
2703 case OP_ORASSIGN:
c963b151 2704 case OP_DORASSIGN:
ddeae0f1
DM
2705 PL_modcount++;
2706 break;
2707
8990e307 2708 case OP_AELEMFAST:
93bad3fd 2709 case OP_AELEMFAST_LEX:
6a077020 2710 localize = -1;
3280af22 2711 PL_modcount++;
8990e307
LW
2712 break;
2713
748a9306
LW
2714 case OP_PADAV:
2715 case OP_PADHV:
e6438c1a 2716 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
2717 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2718 return o; /* Treat \(@foo) like ordinary list. */
2719 if (scalar_mod_type(o, type))
3fe9a6f1 2720 goto nomod;
32cbae3f
FC
2721 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2722 && type == OP_LEAVESUBLV)
78f9721b 2723 o->op_private |= OPpMAYBE_LVSUB;
924ba076 2724 /* FALLTHROUGH */
748a9306 2725 case OP_PADSV:
3280af22 2726 PL_modcount++;
ddeae0f1 2727 if (!type) /* local() */
5ede95a0
BF
2728 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2729 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
2730 break;
2731
748a9306 2732 case OP_PUSHMARK:
ddeae0f1 2733 localize = 0;
748a9306 2734 break;
b2ffa427 2735
69969c6f 2736 case OP_KEYS:
d8065907 2737 case OP_RKEYS:
fad4a2e4 2738 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2739 goto nomod;
5d82c453
GA
2740 goto lvalue_func;
2741 case OP_SUBSTR:
2742 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2743 goto nomod;
924ba076 2744 /* FALLTHROUGH */
a0d0e21e 2745 case OP_POS:
463ee0b2 2746 case OP_VEC:
fad4a2e4 2747 lvalue_func:
78f9721b
SM
2748 if (type == OP_LEAVESUBLV)
2749 o->op_private |= OPpMAYBE_LVSUB;
11343788 2750 if (o->op_flags & OPf_KIDS)
1ed44841 2751 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
463ee0b2 2752 break;
a0d0e21e 2753
463ee0b2
LW
2754 case OP_AELEM:
2755 case OP_HELEM:
11343788 2756 ref(cBINOPo->op_first, o->op_type);
68dc0745 2757 if (type == OP_ENTERSUB &&
5dc0d613
MB
2758 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2759 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
2760 if (type == OP_LEAVESUBLV)
2761 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2762 localize = 1;
3280af22 2763 PL_modcount++;
463ee0b2
LW
2764 break;
2765
463ee0b2 2766 case OP_LEAVE:
a373464f 2767 case OP_LEAVELOOP:
2ec7f6f2 2768 o->op_private |= OPpLVALUE;
924ba076 2769 /* FALLTHROUGH */
2ec7f6f2 2770 case OP_SCOPE:
463ee0b2 2771 case OP_ENTER:
78f9721b 2772 case OP_LINESEQ:
ddeae0f1 2773 localize = 0;
11343788 2774 if (o->op_flags & OPf_KIDS)
3ad73efd 2775 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2776 break;
2777
2778 case OP_NULL:
ddeae0f1 2779 localize = 0;
638bc118
GS
2780 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2781 goto nomod;
2782 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2783 break;
11343788 2784 if (o->op_targ != OP_LIST) {
3ad73efd 2785 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2786 break;
2787 }
924ba076 2788 /* FALLTHROUGH */
463ee0b2 2789 case OP_LIST:
ddeae0f1 2790 localize = 0;
1ed44841 2791 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
5c906035
GG
2792 /* elements might be in void context because the list is
2793 in scalar context or because they are attribute sub calls */
2794 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2795 op_lvalue(kid, type);
463ee0b2 2796 break;
78f9721b 2797
1efec5ed
FC
2798 case OP_COREARGS:
2799 return o;
2ec7f6f2
FC
2800
2801 case OP_AND:
2802 case OP_OR:
375879aa
FC
2803 if (type == OP_LEAVESUBLV
2804 || !S_vivifies(cLOGOPo->op_first->op_type))
2805 op_lvalue(cLOGOPo->op_first, type);
2806 if (type == OP_LEAVESUBLV
1ed44841
DM
2807 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2808 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2ec7f6f2 2809 goto nomod;
26a50d99
FC
2810
2811 case OP_SREFGEN:
d39c26a6
FC
2812 if (type != OP_AASSIGN && type != OP_SASSIGN
2813 && type != OP_ENTERLOOP)
2814 goto nomod;
7664512e 2815 /* Don’t bother applying lvalue context to the ex-list. */
26a50d99 2816 kid = cUNOPx(cUNOPo->op_first)->op_first;
217e3565
FC
2817 assert (!OP_HAS_SIBLING(kid));
2818 goto kid_2lvref;
2819 case OP_REFGEN:
2820 if (type != OP_AASSIGN) goto nomod;
7664512e
FC
2821 kid = cUNOPo->op_first;
2822 kid_2lvref:
2823 {
2824 const U8 ec = PL_parser ? PL_parser->error_count : 0;
63702de8 2825 S_lvref(aTHX_ kid, type);
7664512e 2826 if (!PL_parser || PL_parser->error_count == ec) {
baabe3fb 2827 if (!FEATURE_REFALIASING_IS_ENABLED)
7664512e 2828 Perl_croak(aTHX_
baabe3fb 2829 "Experimental aliasing via reference not enabled");
7664512e 2830 Perl_ck_warner_d(aTHX_
baabe3fb
FC
2831 packWARN(WARN_EXPERIMENTAL__REFALIASING),
2832 "Aliasing via reference is experimental");
7664512e
FC
2833 }
2834 }
217e3565
FC
2835 if (o->op_type == OP_REFGEN)
2836 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2837 op_null(o);
26a50d99 2838 return o;
e4e95921
FC
2839
2840 case OP_SPLIT:
2841 kid = cLISTOPo->op_first;
2842 if (kid && kid->op_type == OP_PUSHRE &&
2843 ( kid->op_targ
2844 || o->op_flags & OPf_STACKED
2845#ifdef USE_ITHREADS
2846 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2847#else
2848 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2849#endif
2850 )) {
2851 /* This is actually @array = split. */
2852 PL_modcount = RETURN_UNLIMITED_NUMBER;
2853 break;
2854 }
2855 goto nomod;
463ee0b2 2856 }
58d95175 2857
8be1be90
AMS
2858 /* [20011101.069] File test operators interpret OPf_REF to mean that
2859 their argument is a filehandle; thus \stat(".") should not set
2860 it. AMS 20011102 */
2861 if (type == OP_REFGEN &&
ef69c8fc 2862 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
2863 return o;
2864
2865 if (type != OP_LEAVESUBLV)
2866 o->op_flags |= OPf_MOD;
2867
2868 if (type == OP_AASSIGN || type == OP_SASSIGN)
2869 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
2870 else if (!type) { /* local() */
2871 switch (localize) {
2872 case 1:
2873 o->op_private |= OPpLVAL_INTRO;
2874 o->op_flags &= ~OPf_SPECIAL;
2875 PL_hints |= HINT_BLOCK_SCOPE;
2876 break;
2877 case 0:
2878 break;
2879 case -1:
a2a5de95
NC
2880 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2881 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2882 }
463ee0b2 2883 }
8be1be90
AMS
2884 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2885 && type != OP_LEAVESUBLV)
2886 o->op_flags |= OPf_REF;
11343788 2887 return o;
463ee0b2
LW
2888}
2889
864dbfa3 2890STATIC bool
5f66b61c 2891S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
2892{
2893 switch (type) {
32a60974 2894 case OP_POS:
3fe9a6f1 2895 case OP_SASSIGN:
1efec5ed 2896 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2897 return FALSE;
924ba076 2898 /* FALLTHROUGH */
3fe9a6f1
PP
2899 case OP_PREINC:
2900 case OP_PREDEC:
2901 case OP_POSTINC:
2902 case OP_POSTDEC:
2903 case OP_I_PREINC:
2904 case OP_I_PREDEC:
2905 case OP_I_POSTINC:
2906 case OP_I_POSTDEC:
2907 case OP_POW:
2908 case OP_MULTIPLY:
2909 case OP_DIVIDE:
2910 case OP_MODULO:
2911 case OP_REPEAT:
2912 case OP_ADD:
2913 case OP_SUBTRACT:
2914 case OP_I_MULTIPLY:
2915 case OP_I_DIVIDE:
2916 case OP_I_MODULO:
2917 case OP_I_ADD:
2918 case OP_I_SUBTRACT:
2919 case OP_LEFT_SHIFT:
2920 case OP_RIGHT_SHIFT:
2921 case OP_BIT_AND:
2922 case OP_BIT_XOR:
2923 case OP_BIT_OR:
2924 case OP_CONCAT:
2925 case OP_SUBST:
2926 case OP_TRANS:
bb16bae8 2927 case OP_TRANSR:
49e9fbe6
GS
2928 case OP_READ:
2929 case OP_SYSREAD:
2930 case OP_RECV:
bf4b1e52
GS
2931 case OP_ANDASSIGN:
2932 case OP_ORASSIGN:
410d09fe 2933 case OP_DORASSIGN:
3fe9a6f1
PP
2934 return TRUE;
2935 default:
2936 return FALSE;
2937 }
2938}
2939
35cd451c 2940STATIC bool
5f66b61c 2941S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2942{
7918f24d
NC
2943 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2944
35cd451c
GS
2945 switch (o->op_type) {
2946 case OP_PIPE_OP:
2947 case OP_SOCKPAIR:
504618e9 2948 if (numargs == 2)
35cd451c 2949 return TRUE;
924ba076 2950 /* FALLTHROUGH */
35cd451c
GS
2951 case OP_SYSOPEN:
2952 case OP_OPEN:
ded8aa31 2953 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
2954 case OP_SOCKET:
2955 case OP_OPEN_DIR:
2956 case OP_ACCEPT:
504618e9 2957 if (numargs == 1)
35cd451c 2958 return TRUE;
5f66b61c 2959 /* FALLTHROUGH */
35cd451c
GS
2960 default:
2961 return FALSE;
2962 }
2963}
2964
0d86688d
NC
2965static OP *
2966S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2967{
11343788 2968 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2969 OP *kid;
1ed44841 2970 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
463ee0b2
LW
2971 ref(kid, type);
2972 }
11343788 2973 return o;
463ee0b2
LW
2974}
2975
2976OP *
e4c5ccf3 2977Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2978{
27da23d5 2979 dVAR;
463ee0b2 2980 OP *kid;
463ee0b2 2981
7918f24d
NC
2982 PERL_ARGS_ASSERT_DOREF;
2983
13765c85 2984 if (!o || (PL_parser && PL_parser->error_count))
11343788 2985 return o;
463ee0b2 2986
11343788 2987 switch (o->op_type) {
a0d0e21e 2988 case OP_ENTERSUB:
f4df43b5 2989 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788 2990 !(o->op_flags & OPf_STACKED)) {
10884df9 2991 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
11343788 2992 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2993 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2994 o->op_flags |= OPf_SPECIAL;
8990e307 2995 }
767eda44 2996 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
2997 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2998 : type == OP_RV2HV ? OPpDEREF_HV
2999 : OPpDEREF_SV);
767eda44
FC
3000 o->op_flags |= OPf_MOD;
3001 }
3002
8990e307 3003 break;
aeea060c 3004
463ee0b2 3005 case OP_COND_EXPR:
1ed44841 3006 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
e4c5ccf3 3007 doref(kid, type, set_op_ref);
463ee0b2 3008 break;
8990e307 3009 case OP_RV2SV:
35cd451c
GS
3010 if (type == OP_DEFINED)
3011 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3012 doref(cUNOPo->op_first, o->op_type, set_op_ref);
924ba076 3013 /* FALLTHROUGH */
4633a7c4 3014 case OP_PADSV:
5f05dabc 3015 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3016 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3017 : type == OP_RV2HV ? OPpDEREF_HV
3018 : OPpDEREF_SV);
11343788 3019 o->op_flags |= OPf_MOD;
a0d0e21e 3020 }
8990e307 3021 break;
1c846c1f 3022
463ee0b2
LW
3023 case OP_RV2AV:
3024 case OP_RV2HV:
e4c5ccf3
RH
3025 if (set_op_ref)
3026 o->op_flags |= OPf_REF;
924ba076 3027 /* FALLTHROUGH */
463ee0b2 3028 case OP_RV2GV:
35cd451c
GS
3029 if (type == OP_DEFINED)
3030 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 3031 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 3032 break;
8990e307 3033
463ee0b2
LW
3034 case OP_PADAV:
3035 case OP_PADHV:
e4c5ccf3
RH
3036 if (set_op_ref)
3037 o->op_flags |= OPf_REF;
79072805 3038 break;
aeea060c 3039
8990e307 3040 case OP_SCALAR:
79072805 3041 case OP_NULL:
518618af 3042 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 3043 break;
e4c5ccf3 3044 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
3045 break;
3046 case OP_AELEM:
3047 case OP_HELEM:
e4c5ccf3 3048 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 3049 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
3050 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3051 : type == OP_RV2HV ? OPpDEREF_HV
3052 : OPpDEREF_SV);
11343788 3053 o->op_flags |= OPf_MOD;
8990e307 3054 }
79072805
LW
3055 break;
3056
463ee0b2 3057 case OP_SCOPE:
79072805 3058 case OP_LEAVE:
e4c5ccf3 3059 set_op_ref = FALSE;
924ba076 3060 /* FALLTHROUGH */
79072805 3061 case OP_ENTER:
8990e307 3062 case OP_LIST:
11343788 3063 if (!(o->op_flags & OPf_KIDS))
79072805 3064 break;
e4c5ccf3 3065 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 3066 break;
a0d0e21e
LW
3067 default:
3068 break;
79072805 3069 }
11343788 3070 return scalar(o);
8990e307 3071
79072805
LW
3072}
3073
09bef843
SB
3074STATIC OP *
3075S_dup_attrlist(pTHX_ OP *o)
3076{
0bd48802 3077 OP *rop;
09bef843 3078
7918f24d
NC
3079 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3080
09bef843
SB
3081 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3082 * where the first kid is OP_PUSHMARK and the remaining ones
3083 * are OP_CONST. We need to push the OP_CONST values.
3084 */
3085 if (o->op_type == OP_CONST)
b37c2d43 3086 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
09bef843
SB
3087 else {
3088 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 3089 rop = NULL;
1ed44841 3090 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
09bef843 3091 if (o->op_type == OP_CONST)
2fcb4757 3092 rop = op_append_elem(OP_LIST, rop,
09bef843 3093 newSVOP(OP_CONST, o->op_flags,
b37c2d43 3094 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
3095 }
3096 }
3097 return rop;
3098}
3099
3100STATIC void
ad0dc73b 3101S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 3102{
ad0dc73b 3103 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 3104
7918f24d
NC
3105 PERL_ARGS_ASSERT_APPLY_ATTRS;
3106
09bef843 3107 /* fake up C<use attributes $pkg,$rv,@attrs> */
e4783991 3108
09bef843 3109#define ATTRSMODULE "attributes"
95f0a2f1
SB
3110#define ATTRSMODULE_PM "attributes.pm"
3111
ad0dc73b 3112 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
3113 newSVpvs(ATTRSMODULE),
3114 NULL,
2fcb4757 3115 op_prepend_elem(OP_LIST,
95f0a2f1 3116 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 3117 op_prepend_elem(OP_LIST,
95f0a2f1
SB
3118 newSVOP(OP_CONST, 0,
3119 newRV(target)),
3120 dup_attrlist(attrs))));
09bef843
SB
3121}
3122
95f0a2f1
SB
3123STATIC void
3124S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3125{
3126 OP *pack, *imop, *arg;
ad0dc73b 3127 SV *meth, *stashsv, **svp;
95f0a2f1 3128
7918f24d
NC
3129 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3130
95f0a2f1
SB
3131 if (!attrs)
3132 return;
3133
3134 assert(target->op_type == OP_PADSV ||
3135 target->op_type == OP_PADHV ||
3136 target->op_type == OP_PADAV);
3137
3138 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
3139 /* Don't force the C<use> if we don't need it. */
3140 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3141 if (svp && *svp != &PL_sv_undef)
3142 NOOP; /* already in %INC */
3143 else
3144 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3145 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
3146
3147 /* Need package name for method call. */
6136c704 3148 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
3149
3150 /* Build up the real arg-list. */
5aaec2b4
NC
3151 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3152
95f0a2f1
SB
3153 arg = newOP(OP_PADSV, 0);
3154 arg->op_targ = target->op_targ;
2fcb4757 3155 arg = op_prepend_elem(OP_LIST,
95f0a2f1 3156 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 3157 op_prepend_elem(OP_LIST,
95f0a2f1 3158 newUNOP(OP_REFGEN, 0,
3ad73efd 3159 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB
3160 dup_attrlist(attrs)));
3161
3162 /* Fake up a method call to import */
18916d0d 3163 meth = newSVpvs_share("import");
03d05f6e 3164 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757 3165 op_append_elem(OP_LIST,
6aa68307 3166 op_prepend_elem(OP_LIST, pack, arg),
b46e009d 3167 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
3168
3169 /* Combine the ops. */
2fcb4757 3170 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
3171}
3172
3173/*
3174=notfor apidoc apply_attrs_string
3175
3176Attempts to apply a list of attributes specified by the C<attrstr> and
3177C<len> arguments to the subroutine identified by the C<cv> argument which
3178is expected to be associated with the package identified by the C<stashpv>
3179argument (see L<attributes>). It gets this wrong, though, in that it
3180does not correctly identify the boundaries of the individual attribute
3181specifications within C<attrstr>. This is not really intended for the
3182public API, but has to be listed here for systems such as AIX which
3183need an explicit export list for symbols. (It's called from XS code
3184in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3185to respect attribute syntax properly would be welcome.
3186
3187=cut
3188*/
3189
be3174d2 3190void
6867be6d
AL
3191Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3192 const char *attrstr, STRLEN len)
be3174d2 3193{
5f66b61c 3194 OP *attrs = NULL;
be3174d2 3195
7918f24d
NC
3196 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3197
be3174d2
GS
3198 if (!len) {
3199 len = strlen(attrstr);
3200 }
3201
3202 while (len) {
3203 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3204 if (len) {
890ce7af 3205 const char * const sstr = attrstr;
be3174d2 3206 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 3207 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
3208 newSVOP(OP_CONST, 0,
3209 newSVpvn(sstr, attrstr-sstr)));
3210 }
3211 }
3212
3213 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 3214 newSVpvs(ATTRSMODULE),
2fcb4757 3215 NULL, op_prepend_elem(OP_LIST,
be3174d2 3216 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 3217 op_prepend_elem(OP_LIST,
be3174d2 3218 newSVOP(OP_CONST, 0,
ad64d0ec 3219 newRV(MUTABLE_SV(cv))),
be3174d2
GS
3220 attrs)));
3221}
3222
eedb00fa
PM
3223STATIC void
3224S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3225{
3226 OP *new_proto = NULL;
3227 STRLEN pvlen;
3228 char *pv;
3229 OP *o;
3230
3231 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3232
3233 if (!*attrs)
3234 return;
3235
3236 o = *attrs;
3237 if (o->op_type == OP_CONST) {
3238 pv = SvPV(cSVOPo_sv, pvlen);
3239 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3240 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3241 SV ** const tmpo = cSVOPx_svp(o);
3242 SvREFCNT_dec(cSVOPo_sv);
3243 *tmpo = tmpsv;
3244 new_proto = o;
3245 *attrs = NULL;
3246 }
3247 } else if (o->op_type == OP_LIST) {
e78bc664 3248 OP * lasto;
eedb00fa 3249 assert(o->op_flags & OPf_KIDS);
e78bc664
PM
3250 lasto = cLISTOPo->op_first;
3251 assert(lasto->op_type == OP_PUSHMARK);
1ed44841 3252 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
eedb00fa
PM
3253 if (o->op_type == OP_CONST) {
3254 pv = SvPV(cSVOPo_sv, pvlen);
3255 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3256 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3257 SV ** const tmpo = cSVOPx_svp(o);
3258 SvREFCNT_dec(cSVOPo_sv);
3259 *tmpo = tmpsv;
3260 if (new_proto && ckWARN(WARN_MISC)) {
3261 STRLEN new_len;
3262 const char * newp = SvPV(cSVOPo_sv, new_len);
3263 Perl_warner(aTHX_ packWARN(WARN_MISC),
3264 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3265 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3266 op_free(new_proto);
3267 }
3268 else if (new_proto)
3269 op_free(new_proto);
3270 new_proto = o;
3253bf85
DM
3271 /* excise new_proto from the list */
3272 op_sibling_splice(*attrs, lasto, 1, NULL);
3273 o = lasto;
eedb00fa
PM
3274 continue;
3275 }
3276 }
3277 lasto = o;
3278 }
3279 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3280 would get pulled in with no real need */
1ed44841 3281 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
eedb00fa
PM
3282 op_free(*attrs);
3283 *attrs = NULL;
3284 }
3285 }
3286
3287 if (new_proto) {
3288 SV *svname;
3289 if (isGV(name)) {
3290 svname = sv_newmortal();
3291 gv_efullname3(svname, name, NULL);
3292 }
3293 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3294 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3295 else
3296 svname = (SV *)name;
3297 if (ckWARN(WARN_ILLEGALPROTO))
3298 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3299 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3300 STRLEN old_len, new_len;
3301 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3302 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3303
3304 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3305 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3306 " in %"SVf,
3307 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3308 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3309 SVfARG(svname));
3310 }
3311 if (*proto)
3312 op_free(*proto);
3313 *proto = new_proto;
3314 }
3315}
3316
92bd82a0
FC
3317static void
3318S_cant_declare(pTHX_ OP *o)
3319{
4748e002
FC
3320 if (o->op_type == OP_NULL
3321 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3322 o = cUNOPo->op_first;
92bd82a0 3323 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4748e002
FC
3324 o->op_type == OP_NULL
3325 && o->op_flags & OPf_SPECIAL
3326 ? "do block"
3327 : OP_DESC(o),
92bd82a0
FC
3328 PL_parser->in_my == KEY_our ? "our" :
3329 PL_parser->in_my == KEY_state ? "state" :
3330 "my"));
3331}
3332
09bef843 3333STATIC OP *
95f0a2f1 3334S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 3335{
93a17b20 3336 I32 type;
a1fba7eb 3337 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 3338
7918f24d
NC
3339 PERL_ARGS_ASSERT_MY_KID;
3340
13765c85 3341 if (!o || (PL_parser && PL_parser->error_count))
11343788 3342 return o;
93a17b20 3343
bc61e325 3344 type = o->op_type;
eb8433b7 3345
93a17b20 3346 if (type == OP_LIST) {
6867be6d 3347 OP *kid;
1ed44841 3348 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
95f0a2f1 3349 my_kid(kid, attrs, imopsp);
0865059d 3350 return o;
8b8c1fb9 3351 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 3352 return o;
77ca0c92
LW
3353 } else if (type == OP_RV2SV || /* "our" declaration */
3354 type == OP_RV2AV ||
3355 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 3356 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
92bd82a0 3357 S_cant_declare(aTHX_ o);
1ce0b88c 3358 } else if (attrs) {
551405c4 3359 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
316ebaf2 3360 assert(PL_parser);
12bd6ede
DM
3361 PL_parser->in_my = FALSE;
3362 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
3363 apply_attrs(GvSTASH(gv),
3364 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
3365 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3366 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 3367 attrs);
1ce0b88c 3368 }
192587c2 3369 o->op_private |= OPpOUR_INTRO;
77ca0c92 3370 return o;
95f0a2f1
SB
3371 }
3372 else if (type != OP_PADSV &&
93a17b20
LW
3373 type != OP_PADAV &&
3374 type != OP_PADHV &&
3375 type != OP_PUSHMARK)
3376 {
92bd82a0 3377 S_cant_declare(aTHX_ o);
11343788 3378 return o;
93a17b20 3379 }
09bef843
SB
3380 else if (attrs && type != OP_PUSHMARK) {
3381 HV *stash;
09bef843 3382
316ebaf2 3383 assert(PL_parser);
12bd6ede
DM
3384 PL_parser->in_my = FALSE;
3385 PL_parser->in_my_stash = NULL;
eb64745e 3386
09bef843 3387 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
3388 stash = PAD_COMPNAME_TYPE(o->op_targ);
3389 if (!stash)
09bef843 3390 stash = PL_curstash;
95f0a2f1 3391 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 3392 }
11343788
MB
3393 o->op_flags |= OPf_MOD;
3394 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 3395 if (stately)
952306ac 3396 o->op_private |= OPpPAD_STATE;
11343788 3397 return o;
93a17b20
LW
3398}
3399
3400OP *
09bef843
SB
3401Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3402{
0bd48802 3403 OP *rops;
95f0a2f1
SB
3404 int maybe_scalar = 0;
3405
7918f24d
NC
3406 PERL_ARGS_ASSERT_MY_ATTRS;
3407
d2be0de5 3408/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 3409 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 3410#if 0
09bef843
SB
3411 if (o->op_flags & OPf_PARENS)
3412 list(o);
95f0a2f1
SB
3413 else
3414 maybe_scalar = 1;
d2be0de5
YST
3415#else
3416 maybe_scalar = 1;
3417#endif
09bef843
SB
3418 if (attrs)
3419 SAVEFREEOP(attrs);
5f66b61c 3420 rops = NULL;
95f0a2f1
SB
3421 o = my_kid(o, attrs, &rops);
3422 if (rops) {
3423 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 3424 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB
3425 o->op_private |= OPpLVAL_INTRO;
3426 }
f5d1ed10
FC
3427 else {
3428 /* The listop in rops might have a pushmark at the beginning,
3429 which will mess up list assignment. */
3430 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3431 if (rops->op_type == OP_LIST &&
3432 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3433 {
3434 OP * const pushmark = lrops->op_first;
3253bf85
DM
3435 /* excise pushmark */
3436 op_sibling_splice(rops, NULL, 1, NULL);
f5d1ed10
FC
3437 op_free(pushmark);
3438 }
2fcb4757 3439 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 3440 }
95f0a2f1 3441 }
12bd6ede
DM
3442 PL_parser->in_my = FALSE;
3443 PL_parser->in_my_stash = NULL;
eb64745e 3444 return o;
09bef843
SB
3445}
3446
3447OP *
864dbfa3 3448Perl_sawparens(pTHX_ OP *o)
79072805 3449{
96a5add6 3450 PERL_UNUSED_CONTEXT;
79072805
LW
3451 if (o)
3452 o->op_flags |= OPf_PARENS;
3453 return o;
3454}
3455
3456OP *
864dbfa3 3457Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 3458{
11343788 3459 OP *o;
59f00321 3460 bool ismatchop = 0;
1496a290
AL
3461 const OPCODE ltype = left->op_type;
3462 const OPCODE rtype = right->op_type;
79072805 3463
7918f24d
NC
3464 PERL_ARGS_ASSERT_BIND_MATCH;
3465
1496a290
AL
3466 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3467 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 3468 {
1496a290 3469 const char * const desc
bb16bae8
FC
3470 = PL_op_desc[(
3471 rtype == OP_SUBST || rtype == OP_TRANS
3472 || rtype == OP_TRANSR
3473 )
666ea192 3474 ? (int)rtype : OP_MATCH];
c6771ab6 3475 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
c6771ab6 3476 SV * const name =
0920b7fa 3477 S_op_varname(aTHX_ left);
c6771ab6
FC
3478 if (name)
3479 Perl_warner(aTHX_ packWARN(WARN_MISC),
3480 "Applying %s to %"SVf" will act on scalar(%"SVf")",
c1f6cd39 3481 desc, SVfARG(name), SVfARG(name));
c6771ab6
FC
3482 else {
3483 const char * const sample = (isary
666ea192 3484 ? "@array" : "%hash");
c6771ab6 3485 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 3486 "Applying %s to %s will act on scalar(%s)",
599cee73 3487 desc, sample, sample);
c6771ab6 3488 }
2ae324a7
PP
3489 }
3490
1496a290 3491 if (rtype == OP_CONST &&
5cc9e5c9
RH
3492 cSVOPx(right)->op_private & OPpCONST_BARE &&
3493 cSVOPx(right)->op_private & OPpCONST_STRICT)
3494 {
3495 no_bareword_allowed(right);
3496 }
3497
bb16bae8 3498 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC
3499 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3500 type == OP_NOT)
ce0e31fe 3501 /* diag_listed_as: Using !~ with %s doesn't make sense */
4f4d7508 3502 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8 3503 if (rtype == OP_TRANSR && type == OP_NOT)
ce0e31fe 3504 /* diag_listed_as: Using !~ with %s doesn't make sense */
bb16bae8 3505 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 3506
2474a784
FC
3507 ismatchop = (rtype == OP_MATCH ||
3508 rtype == OP_SUBST ||
bb16bae8 3509 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 3510 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS
3511 if (ismatchop && right->op_private & OPpTARGET_MY) {
3512 right->op_targ = 0;
3513 right->op_private &= ~OPpTARGET_MY;
3514 }
3515 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL
3516 OP *newleft;
3517
79072805 3518 right->op_flags |= OPf_STACKED;
bb16bae8 3519 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 3520 ! (rtype == OP_TRANS &&
4f4d7508
DC
3521 right->op_private & OPpTRANS_IDENTICAL) &&
3522 ! (rtype == OP_SUBST &&
3523 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 3524 newleft = op_lvalue(left, rtype);
1496a290
AL
3525 else
3526 newleft = left;
bb16bae8 3527 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 3528 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 3529 else
2fcb4757 3530 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 3531 if (type == OP_NOT)
11343788
MB
3532 return newUNOP(OP_NOT, 0, scalar(o));
3533 return o;
79072805
LW
3534 }
3535 else
3536 return bind_match(type, left,
d63c20f2 3537 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW
3538}
3539
3540OP *
864dbfa3 3541Perl_invert(pTHX_ OP *o)
79072805 3542{
11343788 3543 if (!o)
1d866c12 3544 return NULL;
11343788 3545 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
3546}
3547
3ad73efd
Z
3548/*
3549=for apidoc Amx|OP *|op_scope|OP *o
3550
3551Wraps up an op tree with some additional ops so that at runtime a dynamic
3552scope will be created. The original ops run in the new dynamic scope,
3553and then, provided that they exit normally, the scope will be unwound.
3554The additional ops used to create and unwind the dynamic scope will
3555normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3556instead if the ops are simple enough to not need the full dynamic scope
3557structure.
3558
3559=cut
3560*/
3561
79072805 3562OP *
3ad73efd 3563Perl_op_scope(pTHX_ OP *o)
79072805 3564{
27da23d5 3565 dVAR;
79072805 3566 if (o) {
284167a5 3567 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 3568 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
10884df9 3569 CHANGE_TYPE(o, OP_LEAVE);
463ee0b2 3570 }
fdb22418
HS
3571 else if (o->op_type == OP_LINESEQ) {
3572 OP *kid;
10884df9 3573 CHANGE_TYPE(o, OP_SCOPE);
fdb22418 3574 kid = ((LISTOP*)o)->op_first;
59110972 3575 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 3576 op_null(kid);
59110972
RH
3577
3578 /* The following deals with things like 'do {1 for 1}' */
1ed44841 3579 kid = OP_SIBLING(kid);
59110972
RH
3580 if (kid &&
3581 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3582 op_null(kid);
3583 }
463ee0b2 3584 }
fdb22418 3585 else
5f66b61c 3586 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
3587 }
3588 return o;
3589}
1930840b 3590
705fe0e5
FC
3591OP *
3592Perl_op_unscope(pTHX_ OP *o)
3593{
3594 if (o && o->op_type == OP_LINESEQ) {
3595 OP *kid = cLISTOPo->op_first;
1ed44841 3596 for(; kid; kid = OP_SIBLING(kid))
705fe0e5
FC
3597 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3598 op_null(kid);
3599 }
3600 return o;
3601}
3602
25f5d540
LM
3603/*
3604=for apidoc Am|int|block_start|int full
3605
9a63e366
FC
3606Handles compile-time scope entry.
3607Arranges for hints to be restored on block
25f5d540 3608exit and also handles pad sequence numbers to make lexical variables scope
9a63e366 3609right. Returns a savestack index for use with C<block_end>.
25f5d540
LM
3610
3611=cut
3612*/
3613
a0d0e21e 3614int
864dbfa3 3615Perl_block_start(pTHX_ int full)
79072805 3616{
73d840c0 3617 const int retval = PL_savestack_ix;
1930840b 3618
dd2155a4 3619 pad_block_start(full);
b3ac6de7 3620 SAVEHINTS();
3280af22 3621 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 3622 SAVECOMPILEWARNINGS();
72dc9ed5 3623 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 3624
a88d97bf 3625 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 3626
a0d0e21e
LW
3627 return retval;
3628}
3629
25f5d540
LM
3630/*
3631=for apidoc Am|OP *|block_end|I32 floor|OP *seq
3632
9a63e366