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