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