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