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