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