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