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