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