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