This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
772b76308e4ed9b403c4ff7ec8fb0d5b1a2df8e0
[perl5.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
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
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  *
10  */
11
12 /*
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"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
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.
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  *
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
102  */
103
104 /*
105
106 Here's an older description from Larry.
107
108 Perl'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
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines.  The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order.  (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again).  As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node.  But
130 it's still not the real execution order.
131
132 The actual execution order is not known till we get a grammar reduction
133 to 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
135 into peep() to do that code's portion of the 3rd pass.  It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138
139 /* To implement user lexical pragmas, there needs to be a way at run time to
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
147    leaf, ignoring any key you've already seen (placeholder or not), storing
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.
155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
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.
159 */
160
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173
174 /* Used to avoid recursion through the op tree in scalarvoid() and
175    op_free()
176 */
177
178 #define dDEFER_OP  \
179     SSize_t defer_stack_alloc = 0; \
180     SSize_t defer_ix = -1; \
181     OP **defer_stack = NULL;
182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
183 #define DEFERRED_OP_STEP 100
184 #define DEFER_OP(o) \
185   STMT_START { \
186     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
187         defer_stack_alloc += DEFERRED_OP_STEP; \
188         assert(defer_stack_alloc > 0); \
189         Renew(defer_stack, defer_stack_alloc, OP *); \
190     } \
191     defer_stack[++defer_ix] = o; \
192   } STMT_END
193 #define DEFER_REVERSE(count)                            \
194     STMT_START {                                        \
195         UV cnt = (count);                               \
196         if (cnt > 1) {                                  \
197             OP **top = defer_stack + defer_ix;          \
198             /* top - (cnt) + 1 isn't safe here */       \
199             OP **bottom = top - (cnt - 1);              \
200             OP *tmp;                                    \
201             assert(bottom >= defer_stack);              \
202             while (top > bottom) {                      \
203                 tmp = *top;                             \
204                 *top-- = *bottom;                       \
205                 *bottom++ = tmp;                        \
206             }                                           \
207         }                                               \
208     } STMT_END;
209
210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
211
212 /* remove any leading "empty" ops from the op_next chain whose first
213  * node's address is stored in op_p. Store the updated address of the
214  * first node in op_p.
215  */
216
217 STATIC void
218 S_prune_chain_head(OP** op_p)
219 {
220     while (*op_p
221         && (   (*op_p)->op_type == OP_NULL
222             || (*op_p)->op_type == OP_SCOPE
223             || (*op_p)->op_type == OP_SCALAR
224             || (*op_p)->op_type == OP_LINESEQ)
225     )
226         *op_p = (*op_p)->op_next;
227 }
228
229
230 /* See the explanatory comments above struct opslab in op.h. */
231
232 #ifdef PERL_DEBUG_READONLY_OPS
233 #  define PERL_SLAB_SIZE 128
234 #  define PERL_MAX_SLAB_SIZE 4096
235 #  include <sys/mman.h>
236 #endif
237
238 #ifndef PERL_SLAB_SIZE
239 #  define PERL_SLAB_SIZE 64
240 #endif
241 #ifndef PERL_MAX_SLAB_SIZE
242 #  define PERL_MAX_SLAB_SIZE 2048
243 #endif
244
245 /* rounds up to nearest pointer */
246 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
247 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
248
249 /* malloc a new op slab (suitable for attaching to PL_compcv) */
250
251 static OPSLAB *
252 S_new_slab(pTHX_ size_t sz)
253 {
254 #ifdef PERL_DEBUG_READONLY_OPS
255     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
256                                    PROT_READ|PROT_WRITE,
257                                    MAP_ANON|MAP_PRIVATE, -1, 0);
258     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
259                           (unsigned long) sz, slab));
260     if (slab == MAP_FAILED) {
261         perror("mmap failed");
262         abort();
263     }
264     slab->opslab_size = (U16)sz;
265 #else
266     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
267 #endif
268 #ifndef WIN32
269     /* The context is unused in non-Windows */
270     PERL_UNUSED_CONTEXT;
271 #endif
272     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
273     return slab;
274 }
275
276 /* requires double parens and aTHX_ */
277 #define DEBUG_S_warn(args)                                             \
278     DEBUG_S(                                                            \
279         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
280     )
281
282 /* Returns a sz-sized block of memory (suitable for holding an op) from
283  * a free slot in the chain of op slabs attached to PL_compcv.
284  * Allocates a new slab if necessary.
285  * if PL_compcv isn't compiling, malloc() instead.
286  */
287
288 void *
289 Perl_Slab_Alloc(pTHX_ size_t sz)
290 {
291     OPSLAB *slab;
292     OPSLAB *slab2;
293     OPSLOT *slot;
294     OP *o;
295     size_t opsz, space;
296
297     /* We only allocate ops from the slab during subroutine compilation.
298        We find the slab via PL_compcv, hence that must be non-NULL. It could
299        also be pointing to a subroutine which is now fully set up (CvROOT()
300        pointing to the top of the optree for that sub), or a subroutine
301        which isn't using the slab allocator. If our sanity checks aren't met,
302        don't use a slab, but allocate the OP directly from the heap.  */
303     if (!PL_compcv || CvROOT(PL_compcv)
304      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
305     {
306         o = (OP*)PerlMemShared_calloc(1, sz);
307         goto gotit;
308     }
309
310     /* While the subroutine is under construction, the slabs are accessed via
311        CvSTART(), to avoid needing to expand PVCV by one pointer for something
312        unneeded at runtime. Once a subroutine is constructed, the slabs are
313        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
314        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
315        details.  */
316     if (!CvSTART(PL_compcv)) {
317         CvSTART(PL_compcv) =
318             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
319         CvSLABBED_on(PL_compcv);
320         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
321     }
322     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
323
324     opsz = SIZE_TO_PSIZE(sz);
325     sz = opsz + OPSLOT_HEADER_P;
326
327     /* The slabs maintain a free list of OPs. In particular, constant folding
328        will free up OPs, so it makes sense to re-use them where possible. A
329        freed up slot is used in preference to a new allocation.  */
330     if (slab->opslab_freed) {
331         OP **too = &slab->opslab_freed;
332         o = *too;
333         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
334         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
335             DEBUG_S_warn((aTHX_ "Alas! too small"));
336             o = *(too = &o->op_next);
337             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
338         }
339         if (o) {
340             *too = o->op_next;
341             Zero(o, opsz, I32 *);
342             o->op_slabbed = 1;
343             goto gotit;
344         }
345     }
346
347 #define INIT_OPSLOT \
348             slot->opslot_slab = slab;                   \
349             slot->opslot_next = slab2->opslab_first;    \
350             slab2->opslab_first = slot;                 \
351             o = &slot->opslot_op;                       \
352             o->op_slabbed = 1
353
354     /* The partially-filled slab is next in the chain. */
355     slab2 = slab->opslab_next ? slab->opslab_next : slab;
356     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
357         /* Remaining space is too small. */
358
359         /* If we can fit a BASEOP, add it to the free chain, so as not
360            to waste it. */
361         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
362             slot = &slab2->opslab_slots;
363             INIT_OPSLOT;
364             o->op_type = OP_FREED;
365             o->op_next = slab->opslab_freed;
366             slab->opslab_freed = o;
367         }
368
369         /* Create a new slab.  Make this one twice as big. */
370         slot = slab2->opslab_first;
371         while (slot->opslot_next) slot = slot->opslot_next;
372         slab2 = S_new_slab(aTHX_
373                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
374                                         ? PERL_MAX_SLAB_SIZE
375                                         : (DIFF(slab2, slot)+1)*2);
376         slab2->opslab_next = slab->opslab_next;
377         slab->opslab_next = slab2;
378     }
379     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
380
381     /* Create a new op slot */
382     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
383     assert(slot >= &slab2->opslab_slots);
384     if (DIFF(&slab2->opslab_slots, slot)
385          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
386         slot = &slab2->opslab_slots;
387     INIT_OPSLOT;
388     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
389
390   gotit:
391     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
392     assert(!o->op_moresib);
393     assert(!o->op_sibparent);
394
395     return (void *)o;
396 }
397
398 #undef INIT_OPSLOT
399
400 #ifdef PERL_DEBUG_READONLY_OPS
401 void
402 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
403 {
404     PERL_ARGS_ASSERT_SLAB_TO_RO;
405
406     if (slab->opslab_readonly) return;
407     slab->opslab_readonly = 1;
408     for (; slab; slab = slab->opslab_next) {
409         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
410                               (unsigned long) slab->opslab_size, slab));*/
411         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
412             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
413                              (unsigned long)slab->opslab_size, errno);
414     }
415 }
416
417 void
418 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
419 {
420     OPSLAB *slab2;
421
422     PERL_ARGS_ASSERT_SLAB_TO_RW;
423
424     if (!slab->opslab_readonly) return;
425     slab2 = slab;
426     for (; slab2; slab2 = slab2->opslab_next) {
427         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
428                               (unsigned long) size, slab2));*/
429         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
430                      PROT_READ|PROT_WRITE)) {
431             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
432                              (unsigned long)slab2->opslab_size, errno);
433         }
434     }
435     slab->opslab_readonly = 0;
436 }
437
438 #else
439 #  define Slab_to_rw(op)    NOOP
440 #endif
441
442 /* This cannot possibly be right, but it was copied from the old slab
443    allocator, to which it was originally added, without explanation, in
444    commit 083fcd5. */
445 #ifdef NETWARE
446 #    define PerlMemShared PerlMem
447 #endif
448
449 /* make freed ops die if they're inadvertently executed */
450 #ifdef DEBUGGING
451 static OP *
452 S_pp_freed(pTHX)
453 {
454     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
455 }
456 #endif
457
458
459 /* Return the block of memory used by an op to the free list of
460  * the OP slab associated with that op.
461  */
462
463 void
464 Perl_Slab_Free(pTHX_ void *op)
465 {
466     OP * const o = (OP *)op;
467     OPSLAB *slab;
468
469     PERL_ARGS_ASSERT_SLAB_FREE;
470
471 #ifdef DEBUGGING
472     o->op_ppaddr = S_pp_freed;
473 #endif
474
475     if (!o->op_slabbed) {
476         if (!o->op_static)
477             PerlMemShared_free(op);
478         return;
479     }
480
481     slab = OpSLAB(o);
482     /* If this op is already freed, our refcount will get screwy. */
483     assert(o->op_type != OP_FREED);
484     o->op_type = OP_FREED;
485     o->op_next = slab->opslab_freed;
486     slab->opslab_freed = o;
487     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
488     OpslabREFCNT_dec_padok(slab);
489 }
490
491 void
492 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
493 {
494     const bool havepad = !!PL_comppad;
495     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
496     if (havepad) {
497         ENTER;
498         PAD_SAVE_SETNULLPAD();
499     }
500     opslab_free(slab);
501     if (havepad) LEAVE;
502 }
503
504 /* Free a chain of OP slabs. Should only be called after all ops contained
505  * in it have been freed. At this point, its reference count should be 1,
506  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
507  * and just directly calls opslab_free().
508  * (Note that the reference count which PL_compcv held on the slab should
509  * have been removed once compilation of the sub was complete).
510  *
511  *
512  */
513
514 void
515 Perl_opslab_free(pTHX_ OPSLAB *slab)
516 {
517     OPSLAB *slab2;
518     PERL_ARGS_ASSERT_OPSLAB_FREE;
519     PERL_UNUSED_CONTEXT;
520     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
521     assert(slab->opslab_refcnt == 1);
522     do {
523         slab2 = slab->opslab_next;
524 #ifdef DEBUGGING
525         slab->opslab_refcnt = ~(size_t)0;
526 #endif
527 #ifdef PERL_DEBUG_READONLY_OPS
528         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
529                                                (void*)slab));
530         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
531             perror("munmap failed");
532             abort();
533         }
534 #else
535         PerlMemShared_free(slab);
536 #endif
537         slab = slab2;
538     } while (slab);
539 }
540
541 /* like opslab_free(), but first calls op_free() on any ops in the slab
542  * not marked as OP_FREED
543  */
544
545 void
546 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
547 {
548     OPSLAB *slab2;
549 #ifdef DEBUGGING
550     size_t savestack_count = 0;
551 #endif
552     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
553     slab2 = slab;
554     do {
555         OPSLOT *slot;
556         for (slot = slab2->opslab_first;
557              slot->opslot_next;
558              slot = slot->opslot_next) {
559             if (slot->opslot_op.op_type != OP_FREED
560              && !(slot->opslot_op.op_savefree
561 #ifdef DEBUGGING
562                   && ++savestack_count
563 #endif
564                  )
565             ) {
566                 assert(slot->opslot_op.op_slabbed);
567                 op_free(&slot->opslot_op);
568                 if (slab->opslab_refcnt == 1) goto free;
569             }
570         }
571     } while ((slab2 = slab2->opslab_next));
572     /* > 1 because the CV still holds a reference count. */
573     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
574 #ifdef DEBUGGING
575         assert(savestack_count == slab->opslab_refcnt-1);
576 #endif
577         /* Remove the CV’s reference count. */
578         slab->opslab_refcnt--;
579         return;
580     }
581    free:
582     opslab_free(slab);
583 }
584
585 #ifdef PERL_DEBUG_READONLY_OPS
586 OP *
587 Perl_op_refcnt_inc(pTHX_ OP *o)
588 {
589     if(o) {
590         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
591         if (slab && slab->opslab_readonly) {
592             Slab_to_rw(slab);
593             ++o->op_targ;
594             Slab_to_ro(slab);
595         } else {
596             ++o->op_targ;
597         }
598     }
599     return o;
600
601 }
602
603 PADOFFSET
604 Perl_op_refcnt_dec(pTHX_ OP *o)
605 {
606     PADOFFSET result;
607     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
608
609     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
610
611     if (slab && slab->opslab_readonly) {
612         Slab_to_rw(slab);
613         result = --o->op_targ;
614         Slab_to_ro(slab);
615     } else {
616         result = --o->op_targ;
617     }
618     return result;
619 }
620 #endif
621 /*
622  * In the following definition, the ", (OP*)0" is just to make the compiler
623  * think the expression is of the right type: croak actually does a Siglongjmp.
624  */
625 #define CHECKOP(type,o) \
626     ((PL_op_mask && PL_op_mask[type])                           \
627      ? ( op_free((OP*)o),                                       \
628          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
629          (OP*)0 )                                               \
630      : PL_check[type](aTHX_ (OP*)o))
631
632 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
633
634 #define OpTYPE_set(o,type) \
635     STMT_START {                                \
636         o->op_type = (OPCODE)type;              \
637         o->op_ppaddr = PL_ppaddr[type];         \
638     } STMT_END
639
640 STATIC OP *
641 S_no_fh_allowed(pTHX_ OP *o)
642 {
643     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
644
645     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
646                  OP_DESC(o)));
647     return o;
648 }
649
650 STATIC OP *
651 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
652 {
653     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
654     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
655     return o;
656 }
657  
658 STATIC OP *
659 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
660 {
661     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
662
663     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
664     return o;
665 }
666
667 STATIC void
668 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
669 {
670     PERL_ARGS_ASSERT_BAD_TYPE_PV;
671
672     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
673                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
674 }
675
676 /* remove flags var, its unused in all callers, move to to right end since gv
677   and kid are always the same */
678 STATIC void
679 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
680 {
681     SV * const namesv = cv_name((CV *)gv, NULL, 0);
682     PERL_ARGS_ASSERT_BAD_TYPE_GV;
683  
684     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
685                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
686 }
687
688 STATIC void
689 S_no_bareword_allowed(pTHX_ OP *o)
690 {
691     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
692
693     qerror(Perl_mess(aTHX_
694                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
695                      SVfARG(cSVOPo_sv)));
696     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
697 }
698
699 /* "register" allocation */
700
701 PADOFFSET
702 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
703 {
704     PADOFFSET off;
705     const bool is_our = (PL_parser->in_my == KEY_our);
706
707     PERL_ARGS_ASSERT_ALLOCMY;
708
709     if (flags & ~SVf_UTF8)
710         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
711                    (UV)flags);
712
713     /* complain about "my $<special_var>" etc etc */
714     if (   len
715         && !(  is_our
716             || isALPHA(name[1])
717             || (   (flags & SVf_UTF8)
718                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
719             || (name[1] == '_' && len > 2)))
720     {
721         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
722          && isASCII(name[1])
723          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
724             /* diag_listed_as: Can't use global %s in "%s" */
725             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
726                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
727                               PL_parser->in_my == KEY_state ? "state" : "my"));
728         } else {
729             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
730                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
731         }
732     }
733
734     /* allocate a spare slot and store the name in that slot */
735
736     off = pad_add_name_pvn(name, len,
737                        (is_our ? padadd_OUR :
738                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
739                     PL_parser->in_my_stash,
740                     (is_our
741                         /* $_ is always in main::, even with our */
742                         ? (PL_curstash && !memEQs(name,len,"$_")
743                             ? PL_curstash
744                             : PL_defstash)
745                         : NULL
746                     )
747     );
748     /* anon sub prototypes contains state vars should always be cloned,
749      * otherwise the state var would be shared between anon subs */
750
751     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
752         CvCLONE_on(PL_compcv);
753
754     return off;
755 }
756
757 /*
758 =head1 Optree Manipulation Functions
759
760 =for apidoc alloccopstash
761
762 Available only under threaded builds, this function allocates an entry in
763 C<PL_stashpad> for the stash passed to it.
764
765 =cut
766 */
767
768 #ifdef USE_ITHREADS
769 PADOFFSET
770 Perl_alloccopstash(pTHX_ HV *hv)
771 {
772     PADOFFSET off = 0, o = 1;
773     bool found_slot = FALSE;
774
775     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
776
777     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
778
779     for (; o < PL_stashpadmax; ++o) {
780         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
781         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
782             found_slot = TRUE, off = o;
783     }
784     if (!found_slot) {
785         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
786         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
787         off = PL_stashpadmax;
788         PL_stashpadmax += 10;
789     }
790
791     PL_stashpad[PL_stashpadix = off] = hv;
792     return off;
793 }
794 #endif
795
796 /* free the body of an op without examining its contents.
797  * Always use this rather than FreeOp directly */
798
799 static void
800 S_op_destroy(pTHX_ OP *o)
801 {
802     FreeOp(o);
803 }
804
805 /* Destructor */
806
807 /*
808 =for apidoc op_free
809
810 Free an op.  Only use this when an op is no longer linked to from any
811 optree.
812
813 =cut
814 */
815
816 void
817 Perl_op_free(pTHX_ OP *o)
818 {
819     dVAR;
820     OPCODE type;
821     dDEFER_OP;
822
823     do {
824
825         /* Though ops may be freed twice, freeing the op after its slab is a
826            big no-no. */
827         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
828         /* During the forced freeing of ops after compilation failure, kidops
829            may be freed before their parents. */
830         if (!o || o->op_type == OP_FREED)
831             continue;
832
833         type = o->op_type;
834
835         /* an op should only ever acquire op_private flags that we know about.
836          * If this fails, you may need to fix something in regen/op_private.
837          * Don't bother testing if:
838          *   * the op_ppaddr doesn't match the op; someone may have
839          *     overridden the op and be doing strange things with it;
840          *   * we've errored, as op flags are often left in an
841          *     inconsistent state then. Note that an error when
842          *     compiling the main program leaves PL_parser NULL, so
843          *     we can't spot faults in the main code, only
844          *     evaled/required code */
845 #ifdef DEBUGGING
846         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
847             && PL_parser
848             && !PL_parser->error_count)
849         {
850             assert(!(o->op_private & ~PL_op_private_valid[type]));
851         }
852 #endif
853
854         if (o->op_private & OPpREFCOUNTED) {
855             switch (type) {
856             case OP_LEAVESUB:
857             case OP_LEAVESUBLV:
858             case OP_LEAVEEVAL:
859             case OP_LEAVE:
860             case OP_SCOPE:
861             case OP_LEAVEWRITE:
862                 {
863                 PADOFFSET refcnt;
864                 OP_REFCNT_LOCK;
865                 refcnt = OpREFCNT_dec(o);
866                 OP_REFCNT_UNLOCK;
867                 if (refcnt) {
868                     /* Need to find and remove any pattern match ops from the list
869                        we maintain for reset().  */
870                     find_and_forget_pmops(o);
871                     continue;
872                 }
873                 }
874                 break;
875             default:
876                 break;
877             }
878         }
879
880         /* Call the op_free hook if it has been set. Do it now so that it's called
881          * at the right time for refcounted ops, but still before all of the kids
882          * are freed. */
883         CALL_OPFREEHOOK(o);
884
885         if (o->op_flags & OPf_KIDS) {
886             OP *kid, *nextkid;
887             assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
888             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
889                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
890                 if (kid->op_type == OP_FREED)
891                     /* During the forced freeing of ops after
892                        compilation failure, kidops may be freed before
893                        their parents. */
894                     continue;
895                 if (!(kid->op_flags & OPf_KIDS))
896                     /* If it has no kids, just free it now */
897                     op_free(kid);
898                 else
899                     DEFER_OP(kid);
900             }
901         }
902         if (type == OP_NULL)
903             type = (OPCODE)o->op_targ;
904
905         if (o->op_slabbed)
906             Slab_to_rw(OpSLAB(o));
907
908         /* COP* is not cleared by op_clear() so that we may track line
909          * numbers etc even after null() */
910         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
911             cop_free((COP*)o);
912         }
913
914         op_clear(o);
915         FreeOp(o);
916         if (PL_op == o)
917             PL_op = NULL;
918     } while ( (o = POP_DEFERRED_OP()) );
919
920     DEFER_OP_CLEANUP;
921 }
922
923 /* S_op_clear_gv(): free a GV attached to an OP */
924
925 STATIC
926 #ifdef USE_ITHREADS
927 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
928 #else
929 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
930 #endif
931 {
932
933     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
934             || o->op_type == OP_MULTIDEREF)
935 #ifdef USE_ITHREADS
936                 && PL_curpad
937                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
938 #else
939                 ? (GV*)(*svp) : NULL;
940 #endif
941     /* It's possible during global destruction that the GV is freed
942        before the optree. Whilst the SvREFCNT_inc is happy to bump from
943        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
944        will trigger an assertion failure, because the entry to sv_clear
945        checks that the scalar is not already freed.  A check of for
946        !SvIS_FREED(gv) turns out to be invalid, because during global
947        destruction the reference count can be forced down to zero
948        (with SVf_BREAK set).  In which case raising to 1 and then
949        dropping to 0 triggers cleanup before it should happen.  I
950        *think* that this might actually be a general, systematic,
951        weakness of the whole idea of SVf_BREAK, in that code *is*
952        allowed to raise and lower references during global destruction,
953        so any *valid* code that happens to do this during global
954        destruction might well trigger premature cleanup.  */
955     bool still_valid = gv && SvREFCNT(gv);
956
957     if (still_valid)
958         SvREFCNT_inc_simple_void(gv);
959 #ifdef USE_ITHREADS
960     if (*ixp > 0) {
961         pad_swipe(*ixp, TRUE);
962         *ixp = 0;
963     }
964 #else
965     SvREFCNT_dec(*svp);
966     *svp = NULL;
967 #endif
968     if (still_valid) {
969         int try_downgrade = SvREFCNT(gv) == 2;
970         SvREFCNT_dec_NN(gv);
971         if (try_downgrade)
972             gv_try_downgrade(gv);
973     }
974 }
975
976
977 void
978 Perl_op_clear(pTHX_ OP *o)
979 {
980
981     dVAR;
982
983     PERL_ARGS_ASSERT_OP_CLEAR;
984
985     switch (o->op_type) {
986     case OP_NULL:       /* Was holding old type, if any. */
987         /* FALLTHROUGH */
988     case OP_ENTERTRY:
989     case OP_ENTEREVAL:  /* Was holding hints. */
990     case OP_ARGDEFELEM: /* Was holding signature index. */
991         o->op_targ = 0;
992         break;
993     default:
994         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
995             break;
996         /* FALLTHROUGH */
997     case OP_GVSV:
998     case OP_GV:
999     case OP_AELEMFAST:
1000 #ifdef USE_ITHREADS
1001             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1002 #else
1003             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1004 #endif
1005         break;
1006     case OP_METHOD_REDIR:
1007     case OP_METHOD_REDIR_SUPER:
1008 #ifdef USE_ITHREADS
1009         if (cMETHOPx(o)->op_rclass_targ) {
1010             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1011             cMETHOPx(o)->op_rclass_targ = 0;
1012         }
1013 #else
1014         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1015         cMETHOPx(o)->op_rclass_sv = NULL;
1016 #endif
1017         /* FALLTHROUGH */
1018     case OP_METHOD_NAMED:
1019     case OP_METHOD_SUPER:
1020         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1021         cMETHOPx(o)->op_u.op_meth_sv = NULL;
1022 #ifdef USE_ITHREADS
1023         if (o->op_targ) {
1024             pad_swipe(o->op_targ, 1);
1025             o->op_targ = 0;
1026         }
1027 #endif
1028         break;
1029     case OP_CONST:
1030     case OP_HINTSEVAL:
1031         SvREFCNT_dec(cSVOPo->op_sv);
1032         cSVOPo->op_sv = NULL;
1033 #ifdef USE_ITHREADS
1034         /** Bug #15654
1035           Even if op_clear does a pad_free for the target of the op,
1036           pad_free doesn't actually remove the sv that exists in the pad;
1037           instead it lives on. This results in that it could be reused as 
1038           a target later on when the pad was reallocated.
1039         **/
1040         if(o->op_targ) {
1041           pad_swipe(o->op_targ,1);
1042           o->op_targ = 0;
1043         }
1044 #endif
1045         break;
1046     case OP_DUMP:
1047     case OP_GOTO:
1048     case OP_NEXT:
1049     case OP_LAST:
1050     case OP_REDO:
1051         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1052             break;
1053         /* FALLTHROUGH */
1054     case OP_TRANS:
1055     case OP_TRANSR:
1056         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1057             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1058         {
1059 #ifdef USE_ITHREADS
1060             if (cPADOPo->op_padix > 0) {
1061                 pad_swipe(cPADOPo->op_padix, TRUE);
1062                 cPADOPo->op_padix = 0;
1063             }
1064 #else
1065             SvREFCNT_dec(cSVOPo->op_sv);
1066             cSVOPo->op_sv = NULL;
1067 #endif
1068         }
1069         else {
1070             PerlMemShared_free(cPVOPo->op_pv);
1071             cPVOPo->op_pv = NULL;
1072         }
1073         break;
1074     case OP_SUBST:
1075         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1076         goto clear_pmop;
1077
1078     case OP_SPLIT:
1079         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1080             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1081         {
1082             if (o->op_private & OPpSPLIT_LEX)
1083                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1084             else
1085 #ifdef USE_ITHREADS
1086                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1087 #else
1088                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1089 #endif
1090         }
1091         /* FALLTHROUGH */
1092     case OP_MATCH:
1093     case OP_QR:
1094     clear_pmop:
1095         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1096             op_free(cPMOPo->op_code_list);
1097         cPMOPo->op_code_list = NULL;
1098         forget_pmop(cPMOPo);
1099         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1100         /* we use the same protection as the "SAFE" version of the PM_ macros
1101          * here since sv_clean_all might release some PMOPs
1102          * after PL_regex_padav has been cleared
1103          * and the clearing of PL_regex_padav needs to
1104          * happen before sv_clean_all
1105          */
1106 #ifdef USE_ITHREADS
1107         if(PL_regex_pad) {        /* We could be in destruction */
1108             const IV offset = (cPMOPo)->op_pmoffset;
1109             ReREFCNT_dec(PM_GETRE(cPMOPo));
1110             PL_regex_pad[offset] = &PL_sv_undef;
1111             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1112                            sizeof(offset));
1113         }
1114 #else
1115         ReREFCNT_dec(PM_GETRE(cPMOPo));
1116         PM_SETRE(cPMOPo, NULL);
1117 #endif
1118
1119         break;
1120
1121     case OP_ARGCHECK:
1122         PerlMemShared_free(cUNOP_AUXo->op_aux);
1123         break;
1124
1125     case OP_MULTICONCAT:
1126         {
1127             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1128             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1129              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1130              * utf8 shared strings */
1131             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1132             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1133             if (p1)
1134                 PerlMemShared_free(p1);
1135             if (p2 && p1 != p2)
1136                 PerlMemShared_free(p2);
1137             PerlMemShared_free(aux);
1138         }
1139         break;
1140
1141     case OP_MULTIDEREF:
1142         {
1143             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1144             UV actions = items->uv;
1145             bool last = 0;
1146             bool is_hash = FALSE;
1147
1148             while (!last) {
1149                 switch (actions & MDEREF_ACTION_MASK) {
1150
1151                 case MDEREF_reload:
1152                     actions = (++items)->uv;
1153                     continue;
1154
1155                 case MDEREF_HV_padhv_helem:
1156                     is_hash = TRUE;
1157                     /* FALLTHROUGH */
1158                 case MDEREF_AV_padav_aelem:
1159                     pad_free((++items)->pad_offset);
1160                     goto do_elem;
1161
1162                 case MDEREF_HV_gvhv_helem:
1163                     is_hash = TRUE;
1164                     /* FALLTHROUGH */
1165                 case MDEREF_AV_gvav_aelem:
1166 #ifdef USE_ITHREADS
1167                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1168 #else
1169                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1170 #endif
1171                     goto do_elem;
1172
1173                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1174                     is_hash = TRUE;
1175                     /* FALLTHROUGH */
1176                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1177 #ifdef USE_ITHREADS
1178                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1179 #else
1180                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1181 #endif
1182                     goto do_vivify_rv2xv_elem;
1183
1184                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1185                     is_hash = TRUE;
1186                     /* FALLTHROUGH */
1187                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1188                     pad_free((++items)->pad_offset);
1189                     goto do_vivify_rv2xv_elem;
1190
1191                 case MDEREF_HV_pop_rv2hv_helem:
1192                 case MDEREF_HV_vivify_rv2hv_helem:
1193                     is_hash = TRUE;
1194                     /* FALLTHROUGH */
1195                 do_vivify_rv2xv_elem:
1196                 case MDEREF_AV_pop_rv2av_aelem:
1197                 case MDEREF_AV_vivify_rv2av_aelem:
1198                 do_elem:
1199                     switch (actions & MDEREF_INDEX_MASK) {
1200                     case MDEREF_INDEX_none:
1201                         last = 1;
1202                         break;
1203                     case MDEREF_INDEX_const:
1204                         if (is_hash) {
1205 #ifdef USE_ITHREADS
1206                             /* see RT #15654 */
1207                             pad_swipe((++items)->pad_offset, 1);
1208 #else
1209                             SvREFCNT_dec((++items)->sv);
1210 #endif
1211                         }
1212                         else
1213                             items++;
1214                         break;
1215                     case MDEREF_INDEX_padsv:
1216                         pad_free((++items)->pad_offset);
1217                         break;
1218                     case MDEREF_INDEX_gvsv:
1219 #ifdef USE_ITHREADS
1220                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1221 #else
1222                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1223 #endif
1224                         break;
1225                     }
1226
1227                     if (actions & MDEREF_FLAG_last)
1228                         last = 1;
1229                     is_hash = FALSE;
1230
1231                     break;
1232
1233                 default:
1234                     assert(0);
1235                     last = 1;
1236                     break;
1237
1238                 } /* switch */
1239
1240                 actions >>= MDEREF_SHIFT;
1241             } /* while */
1242
1243             /* start of malloc is at op_aux[-1], where the length is
1244              * stored */
1245             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1246         }
1247         break;
1248     }
1249
1250     if (o->op_targ > 0) {
1251         pad_free(o->op_targ);
1252         o->op_targ = 0;
1253     }
1254 }
1255
1256 STATIC void
1257 S_cop_free(pTHX_ COP* cop)
1258 {
1259     PERL_ARGS_ASSERT_COP_FREE;
1260
1261     CopFILE_free(cop);
1262     if (! specialWARN(cop->cop_warnings))
1263         PerlMemShared_free(cop->cop_warnings);
1264     cophh_free(CopHINTHASH_get(cop));
1265     if (PL_curcop == cop)
1266        PL_curcop = NULL;
1267 }
1268
1269 STATIC void
1270 S_forget_pmop(pTHX_ PMOP *const o)
1271 {
1272     HV * const pmstash = PmopSTASH(o);
1273
1274     PERL_ARGS_ASSERT_FORGET_PMOP;
1275
1276     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1277         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1278         if (mg) {
1279             PMOP **const array = (PMOP**) mg->mg_ptr;
1280             U32 count = mg->mg_len / sizeof(PMOP**);
1281             U32 i = count;
1282
1283             while (i--) {
1284                 if (array[i] == o) {
1285                     /* Found it. Move the entry at the end to overwrite it.  */
1286                     array[i] = array[--count];
1287                     mg->mg_len = count * sizeof(PMOP**);
1288                     /* Could realloc smaller at this point always, but probably
1289                        not worth it. Probably worth free()ing if we're the
1290                        last.  */
1291                     if(!count) {
1292                         Safefree(mg->mg_ptr);
1293                         mg->mg_ptr = NULL;
1294                     }
1295                     break;
1296                 }
1297             }
1298         }
1299     }
1300     if (PL_curpm == o) 
1301         PL_curpm = NULL;
1302 }
1303
1304 STATIC void
1305 S_find_and_forget_pmops(pTHX_ OP *o)
1306 {
1307     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1308
1309     if (o->op_flags & OPf_KIDS) {
1310         OP *kid = cUNOPo->op_first;
1311         while (kid) {
1312             switch (kid->op_type) {
1313             case OP_SUBST:
1314             case OP_SPLIT:
1315             case OP_MATCH:
1316             case OP_QR:
1317                 forget_pmop((PMOP*)kid);
1318             }
1319             find_and_forget_pmops(kid);
1320             kid = OpSIBLING(kid);
1321         }
1322     }
1323 }
1324
1325 /*
1326 =for apidoc op_null
1327
1328 Neutralizes an op when it is no longer needed, but is still linked to from
1329 other ops.
1330
1331 =cut
1332 */
1333
1334 void
1335 Perl_op_null(pTHX_ OP *o)
1336 {
1337     dVAR;
1338
1339     PERL_ARGS_ASSERT_OP_NULL;
1340
1341     if (o->op_type == OP_NULL)
1342         return;
1343     op_clear(o);
1344     o->op_targ = o->op_type;
1345     OpTYPE_set(o, OP_NULL);
1346 }
1347
1348 void
1349 Perl_op_refcnt_lock(pTHX)
1350   PERL_TSA_ACQUIRE(PL_op_mutex)
1351 {
1352 #ifdef USE_ITHREADS
1353     dVAR;
1354 #endif
1355     PERL_UNUSED_CONTEXT;
1356     OP_REFCNT_LOCK;
1357 }
1358
1359 void
1360 Perl_op_refcnt_unlock(pTHX)
1361   PERL_TSA_RELEASE(PL_op_mutex)
1362 {
1363 #ifdef USE_ITHREADS
1364     dVAR;
1365 #endif
1366     PERL_UNUSED_CONTEXT;
1367     OP_REFCNT_UNLOCK;
1368 }
1369
1370
1371 /*
1372 =for apidoc op_sibling_splice
1373
1374 A general function for editing the structure of an existing chain of
1375 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1376 you to delete zero or more sequential nodes, replacing them with zero or
1377 more different nodes.  Performs the necessary op_first/op_last
1378 housekeeping on the parent node and op_sibling manipulation on the
1379 children.  The last deleted node will be marked as as the last node by
1380 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1381
1382 Note that op_next is not manipulated, and nodes are not freed; that is the
1383 responsibility of the caller.  It also won't create a new list op for an
1384 empty list etc; use higher-level functions like op_append_elem() for that.
1385
1386 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1387 the splicing doesn't affect the first or last op in the chain.
1388
1389 C<start> is the node preceding the first node to be spliced.  Node(s)
1390 following it will be deleted, and ops will be inserted after it.  If it is
1391 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1392 beginning.
1393
1394 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1395 If -1 or greater than or equal to the number of remaining kids, all
1396 remaining kids are deleted.
1397
1398 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1399 If C<NULL>, no nodes are inserted.
1400
1401 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1402 deleted.
1403
1404 For example:
1405
1406     action                    before      after         returns
1407     ------                    -----       -----         -------
1408
1409                               P           P
1410     splice(P, A, 2, X-Y-Z)    |           |             B-C
1411                               A-B-C-D     A-X-Y-Z-D
1412
1413                               P           P
1414     splice(P, NULL, 1, X-Y)   |           |             A
1415                               A-B-C-D     X-Y-B-C-D
1416
1417                               P           P
1418     splice(P, NULL, 3, NULL)  |           |             A-B-C
1419                               A-B-C-D     D
1420
1421                               P           P
1422     splice(P, B, 0, X-Y)      |           |             NULL
1423                               A-B-C-D     A-B-X-Y-C-D
1424
1425
1426 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1427 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1428
1429 =cut
1430 */
1431
1432 OP *
1433 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1434 {
1435     OP *first;
1436     OP *rest;
1437     OP *last_del = NULL;
1438     OP *last_ins = NULL;
1439
1440     if (start)
1441         first = OpSIBLING(start);
1442     else if (!parent)
1443         goto no_parent;
1444     else
1445         first = cLISTOPx(parent)->op_first;
1446
1447     assert(del_count >= -1);
1448
1449     if (del_count && first) {
1450         last_del = first;
1451         while (--del_count && OpHAS_SIBLING(last_del))
1452             last_del = OpSIBLING(last_del);
1453         rest = OpSIBLING(last_del);
1454         OpLASTSIB_set(last_del, NULL);
1455     }
1456     else
1457         rest = first;
1458
1459     if (insert) {
1460         last_ins = insert;
1461         while (OpHAS_SIBLING(last_ins))
1462             last_ins = OpSIBLING(last_ins);
1463         OpMAYBESIB_set(last_ins, rest, NULL);
1464     }
1465     else
1466         insert = rest;
1467
1468     if (start) {
1469         OpMAYBESIB_set(start, insert, NULL);
1470     }
1471     else {
1472         assert(parent);
1473         cLISTOPx(parent)->op_first = insert;
1474         if (insert)
1475             parent->op_flags |= OPf_KIDS;
1476         else
1477             parent->op_flags &= ~OPf_KIDS;
1478     }
1479
1480     if (!rest) {
1481         /* update op_last etc */
1482         U32 type;
1483         OP *lastop;
1484
1485         if (!parent)
1486             goto no_parent;
1487
1488         /* ought to use OP_CLASS(parent) here, but that can't handle
1489          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1490          * either */
1491         type = parent->op_type;
1492         if (type == OP_CUSTOM) {
1493             dTHX;
1494             type = XopENTRYCUSTOM(parent, xop_class);
1495         }
1496         else {
1497             if (type == OP_NULL)
1498                 type = parent->op_targ;
1499             type = PL_opargs[type] & OA_CLASS_MASK;
1500         }
1501
1502         lastop = last_ins ? last_ins : start ? start : NULL;
1503         if (   type == OA_BINOP
1504             || type == OA_LISTOP
1505             || type == OA_PMOP
1506             || type == OA_LOOP
1507         )
1508             cLISTOPx(parent)->op_last = lastop;
1509
1510         if (lastop)
1511             OpLASTSIB_set(lastop, parent);
1512     }
1513     return last_del ? first : NULL;
1514
1515   no_parent:
1516     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1517 }
1518
1519 /*
1520 =for apidoc op_parent
1521
1522 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1523
1524 =cut
1525 */
1526
1527 OP *
1528 Perl_op_parent(OP *o)
1529 {
1530     PERL_ARGS_ASSERT_OP_PARENT;
1531     while (OpHAS_SIBLING(o))
1532         o = OpSIBLING(o);
1533     return o->op_sibparent;
1534 }
1535
1536 /* replace the sibling following start with a new UNOP, which becomes
1537  * the parent of the original sibling; e.g.
1538  *
1539  *  op_sibling_newUNOP(P, A, unop-args...)
1540  *
1541  *  P              P
1542  *  |      becomes |
1543  *  A-B-C          A-U-C
1544  *                   |
1545  *                   B
1546  *
1547  * where U is the new UNOP.
1548  *
1549  * parent and start args are the same as for op_sibling_splice();
1550  * type and flags args are as newUNOP().
1551  *
1552  * Returns the new UNOP.
1553  */
1554
1555 STATIC OP *
1556 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1557 {
1558     OP *kid, *newop;
1559
1560     kid = op_sibling_splice(parent, start, 1, NULL);
1561     newop = newUNOP(type, flags, kid);
1562     op_sibling_splice(parent, start, 0, newop);
1563     return newop;
1564 }
1565
1566
1567 /* lowest-level newLOGOP-style function - just allocates and populates
1568  * the struct. Higher-level stuff should be done by S_new_logop() /
1569  * newLOGOP(). This function exists mainly to avoid op_first assignment
1570  * being spread throughout this file.
1571  */
1572
1573 LOGOP *
1574 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1575 {
1576     dVAR;
1577     LOGOP *logop;
1578     OP *kid = first;
1579     NewOp(1101, logop, 1, LOGOP);
1580     OpTYPE_set(logop, type);
1581     logop->op_first = first;
1582     logop->op_other = other;
1583     if (first)
1584         logop->op_flags = OPf_KIDS;
1585     while (kid && OpHAS_SIBLING(kid))
1586         kid = OpSIBLING(kid);
1587     if (kid)
1588         OpLASTSIB_set(kid, (OP*)logop);
1589     return logop;
1590 }
1591
1592
1593 /* Contextualizers */
1594
1595 /*
1596 =for apidoc op_contextualize
1597
1598 Applies a syntactic context to an op tree representing an expression.
1599 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1600 or C<G_VOID> to specify the context to apply.  The modified op tree
1601 is returned.
1602
1603 =cut
1604 */
1605
1606 OP *
1607 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1608 {
1609     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1610     switch (context) {
1611         case G_SCALAR: return scalar(o);
1612         case G_ARRAY:  return list(o);
1613         case G_VOID:   return scalarvoid(o);
1614         default:
1615             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1616                        (long) context);
1617     }
1618 }
1619
1620 /*
1621
1622 =for apidoc op_linklist
1623 This function is the implementation of the L</LINKLIST> macro.  It should
1624 not be called directly.
1625
1626 =cut
1627 */
1628
1629 OP *
1630 Perl_op_linklist(pTHX_ OP *o)
1631 {
1632     OP *first;
1633
1634     PERL_ARGS_ASSERT_OP_LINKLIST;
1635
1636     if (o->op_next)
1637         return o->op_next;
1638
1639     /* establish postfix order */
1640     first = cUNOPo->op_first;
1641     if (first) {
1642         OP *kid;
1643         o->op_next = LINKLIST(first);
1644         kid = first;
1645         for (;;) {
1646             OP *sibl = OpSIBLING(kid);
1647             if (sibl) {
1648                 kid->op_next = LINKLIST(sibl);
1649                 kid = sibl;
1650             } else {
1651                 kid->op_next = o;
1652                 break;
1653             }
1654         }
1655     }
1656     else
1657         o->op_next = o;
1658
1659     return o->op_next;
1660 }
1661
1662 static OP *
1663 S_scalarkids(pTHX_ OP *o)
1664 {
1665     if (o && o->op_flags & OPf_KIDS) {
1666         OP *kid;
1667         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1668             scalar(kid);
1669     }
1670     return o;
1671 }
1672
1673 STATIC OP *
1674 S_scalarboolean(pTHX_ OP *o)
1675 {
1676     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1677
1678     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1679          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1680         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1681          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1682          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1683         if (ckWARN(WARN_SYNTAX)) {
1684             const line_t oldline = CopLINE(PL_curcop);
1685
1686             if (PL_parser && PL_parser->copline != NOLINE) {
1687                 /* This ensures that warnings are reported at the first line
1688                    of the conditional, not the last.  */
1689                 CopLINE_set(PL_curcop, PL_parser->copline);
1690             }
1691             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1692             CopLINE_set(PL_curcop, oldline);
1693         }
1694     }
1695     return scalar(o);
1696 }
1697
1698 static SV *
1699 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1700 {
1701     assert(o);
1702     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1703            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1704     {
1705         const char funny  = o->op_type == OP_PADAV
1706                          || o->op_type == OP_RV2AV ? '@' : '%';
1707         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1708             GV *gv;
1709             if (cUNOPo->op_first->op_type != OP_GV
1710              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1711                 return NULL;
1712             return varname(gv, funny, 0, NULL, 0, subscript_type);
1713         }
1714         return
1715             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1716     }
1717 }
1718
1719 static SV *
1720 S_op_varname(pTHX_ const OP *o)
1721 {
1722     return S_op_varname_subscript(aTHX_ o, 1);
1723 }
1724
1725 static void
1726 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1727 { /* or not so pretty :-) */
1728     if (o->op_type == OP_CONST) {
1729         *retsv = cSVOPo_sv;
1730         if (SvPOK(*retsv)) {
1731             SV *sv = *retsv;
1732             *retsv = sv_newmortal();
1733             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1734                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1735         }
1736         else if (!SvOK(*retsv))
1737             *retpv = "undef";
1738     }
1739     else *retpv = "...";
1740 }
1741
1742 static void
1743 S_scalar_slice_warning(pTHX_ const OP *o)
1744 {
1745     OP *kid;
1746     const bool h = o->op_type == OP_HSLICE
1747                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1748     const char lbrack =
1749         h ? '{' : '[';
1750     const char rbrack =
1751         h ? '}' : ']';
1752     SV *name;
1753     SV *keysv = NULL; /* just to silence compiler warnings */
1754     const char *key = NULL;
1755
1756     if (!(o->op_private & OPpSLICEWARNING))
1757         return;
1758     if (PL_parser && PL_parser->error_count)
1759         /* This warning can be nonsensical when there is a syntax error. */
1760         return;
1761
1762     kid = cLISTOPo->op_first;
1763     kid = OpSIBLING(kid); /* get past pushmark */
1764     /* weed out false positives: any ops that can return lists */
1765     switch (kid->op_type) {
1766     case OP_BACKTICK:
1767     case OP_GLOB:
1768     case OP_READLINE:
1769     case OP_MATCH:
1770     case OP_RV2AV:
1771     case OP_EACH:
1772     case OP_VALUES:
1773     case OP_KEYS:
1774     case OP_SPLIT:
1775     case OP_LIST:
1776     case OP_SORT:
1777     case OP_REVERSE:
1778     case OP_ENTERSUB:
1779     case OP_CALLER:
1780     case OP_LSTAT:
1781     case OP_STAT:
1782     case OP_READDIR:
1783     case OP_SYSTEM:
1784     case OP_TMS:
1785     case OP_LOCALTIME:
1786     case OP_GMTIME:
1787     case OP_ENTEREVAL:
1788         return;
1789     }
1790
1791     /* Don't warn if we have a nulled list either. */
1792     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1793         return;
1794
1795     assert(OpSIBLING(kid));
1796     name = S_op_varname(aTHX_ OpSIBLING(kid));
1797     if (!name) /* XS module fiddling with the op tree */
1798         return;
1799     S_op_pretty(aTHX_ kid, &keysv, &key);
1800     assert(SvPOK(name));
1801     sv_chop(name,SvPVX(name)+1);
1802     if (key)
1803        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1804         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1805                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1806                    "%c%s%c",
1807                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1808                     lbrack, key, rbrack);
1809     else
1810        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1811         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1812                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1813                     SVf "%c%" SVf "%c",
1814                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1815                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1816 }
1817
1818 OP *
1819 Perl_scalar(pTHX_ OP *o)
1820 {
1821     OP *kid;
1822
1823     /* assumes no premature commitment */
1824     if (!o || (PL_parser && PL_parser->error_count)
1825          || (o->op_flags & OPf_WANT)
1826          || o->op_type == OP_RETURN)
1827     {
1828         return o;
1829     }
1830
1831     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1832
1833     switch (o->op_type) {
1834     case OP_REPEAT:
1835         scalar(cBINOPo->op_first);
1836         if (o->op_private & OPpREPEAT_DOLIST) {
1837             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1838             assert(kid->op_type == OP_PUSHMARK);
1839             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1840                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1841                 o->op_private &=~ OPpREPEAT_DOLIST;
1842             }
1843         }
1844         break;
1845     case OP_OR:
1846     case OP_AND:
1847     case OP_COND_EXPR:
1848         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1849             scalar(kid);
1850         break;
1851         /* FALLTHROUGH */
1852     case OP_SPLIT:
1853     case OP_MATCH:
1854     case OP_QR:
1855     case OP_SUBST:
1856     case OP_NULL:
1857     default:
1858         if (o->op_flags & OPf_KIDS) {
1859             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1860                 scalar(kid);
1861         }
1862         break;
1863     case OP_LEAVE:
1864     case OP_LEAVETRY:
1865         kid = cLISTOPo->op_first;
1866         scalar(kid);
1867         kid = OpSIBLING(kid);
1868     do_kids:
1869         while (kid) {
1870             OP *sib = OpSIBLING(kid);
1871             if (sib && kid->op_type != OP_LEAVEWHEN
1872              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1873                 || (  sib->op_targ != OP_NEXTSTATE
1874                    && sib->op_targ != OP_DBSTATE  )))
1875                 scalarvoid(kid);
1876             else
1877                 scalar(kid);
1878             kid = sib;
1879         }
1880         PL_curcop = &PL_compiling;
1881         break;
1882     case OP_SCOPE:
1883     case OP_LINESEQ:
1884     case OP_LIST:
1885         kid = cLISTOPo->op_first;
1886         goto do_kids;
1887     case OP_SORT:
1888         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1889         break;
1890     case OP_KVHSLICE:
1891     case OP_KVASLICE:
1892     {
1893         /* Warn about scalar context */
1894         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1895         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1896         SV *name;
1897         SV *keysv;
1898         const char *key = NULL;
1899
1900         /* This warning can be nonsensical when there is a syntax error. */
1901         if (PL_parser && PL_parser->error_count)
1902             break;
1903
1904         if (!ckWARN(WARN_SYNTAX)) break;
1905
1906         kid = cLISTOPo->op_first;
1907         kid = OpSIBLING(kid); /* get past pushmark */
1908         assert(OpSIBLING(kid));
1909         name = S_op_varname(aTHX_ OpSIBLING(kid));
1910         if (!name) /* XS module fiddling with the op tree */
1911             break;
1912         S_op_pretty(aTHX_ kid, &keysv, &key);
1913         assert(SvPOK(name));
1914         sv_chop(name,SvPVX(name)+1);
1915         if (key)
1916   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1917             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1918                        "%%%" SVf "%c%s%c in scalar context better written "
1919                        "as $%" SVf "%c%s%c",
1920                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1921                         lbrack, key, rbrack);
1922         else
1923   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1924             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1925                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1926                        "written as $%" SVf "%c%" SVf "%c",
1927                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1928                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1929     }
1930     }
1931     return o;
1932 }
1933
1934 OP *
1935 Perl_scalarvoid(pTHX_ OP *arg)
1936 {
1937     dVAR;
1938     OP *kid;
1939     SV* sv;
1940     OP *o = arg;
1941
1942     PERL_ARGS_ASSERT_SCALARVOID;
1943
1944     while (1) {
1945         U8 want;
1946         SV *useless_sv = NULL;
1947         const char* useless = NULL;
1948         OP * next_kid = NULL;
1949
1950         if (o->op_type == OP_NEXTSTATE
1951             || o->op_type == OP_DBSTATE
1952             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1953                                           || o->op_targ == OP_DBSTATE)))
1954             PL_curcop = (COP*)o;                /* for warning below */
1955
1956         /* assumes no premature commitment */
1957         want = o->op_flags & OPf_WANT;
1958         if ((want && want != OPf_WANT_SCALAR)
1959             || (PL_parser && PL_parser->error_count)
1960             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1961         {
1962             goto get_next_op;
1963         }
1964
1965         if ((o->op_private & OPpTARGET_MY)
1966             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1967         {
1968             /* newASSIGNOP has already applied scalar context, which we
1969                leave, as if this op is inside SASSIGN.  */
1970             goto get_next_op;
1971         }
1972
1973         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1974
1975         switch (o->op_type) {
1976         default:
1977             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1978                 break;
1979             /* FALLTHROUGH */
1980         case OP_REPEAT:
1981             if (o->op_flags & OPf_STACKED)
1982                 break;
1983             if (o->op_type == OP_REPEAT)
1984                 scalar(cBINOPo->op_first);
1985             goto func_ops;
1986         case OP_CONCAT:
1987             if ((o->op_flags & OPf_STACKED) &&
1988                     !(o->op_private & OPpCONCAT_NESTED))
1989                 break;
1990             goto func_ops;
1991         case OP_SUBSTR:
1992             if (o->op_private == 4)
1993                 break;
1994             /* FALLTHROUGH */
1995         case OP_WANTARRAY:
1996         case OP_GV:
1997         case OP_SMARTMATCH:
1998         case OP_AV2ARYLEN:
1999         case OP_REF:
2000         case OP_REFGEN:
2001         case OP_SREFGEN:
2002         case OP_DEFINED:
2003         case OP_HEX:
2004         case OP_OCT:
2005         case OP_LENGTH:
2006         case OP_VEC:
2007         case OP_INDEX:
2008         case OP_RINDEX:
2009         case OP_SPRINTF:
2010         case OP_KVASLICE:
2011         case OP_KVHSLICE:
2012         case OP_UNPACK:
2013         case OP_PACK:
2014         case OP_JOIN:
2015         case OP_LSLICE:
2016         case OP_ANONLIST:
2017         case OP_ANONHASH:
2018         case OP_SORT:
2019         case OP_REVERSE:
2020         case OP_RANGE:
2021         case OP_FLIP:
2022         case OP_FLOP:
2023         case OP_CALLER:
2024         case OP_FILENO:
2025         case OP_EOF:
2026         case OP_TELL:
2027         case OP_GETSOCKNAME:
2028         case OP_GETPEERNAME:
2029         case OP_READLINK:
2030         case OP_TELLDIR:
2031         case OP_GETPPID:
2032         case OP_GETPGRP:
2033         case OP_GETPRIORITY:
2034         case OP_TIME:
2035         case OP_TMS:
2036         case OP_LOCALTIME:
2037         case OP_GMTIME:
2038         case OP_GHBYNAME:
2039         case OP_GHBYADDR:
2040         case OP_GHOSTENT:
2041         case OP_GNBYNAME:
2042         case OP_GNBYADDR:
2043         case OP_GNETENT:
2044         case OP_GPBYNAME:
2045         case OP_GPBYNUMBER:
2046         case OP_GPROTOENT:
2047         case OP_GSBYNAME:
2048         case OP_GSBYPORT:
2049         case OP_GSERVENT:
2050         case OP_GPWNAM:
2051         case OP_GPWUID:
2052         case OP_GGRNAM:
2053         case OP_GGRGID:
2054         case OP_GETLOGIN:
2055         case OP_PROTOTYPE:
2056         case OP_RUNCV:
2057         func_ops:
2058             useless = OP_DESC(o);
2059             break;
2060
2061         case OP_GVSV:
2062         case OP_PADSV:
2063         case OP_PADAV:
2064         case OP_PADHV:
2065         case OP_PADANY:
2066         case OP_AELEM:
2067         case OP_AELEMFAST:
2068         case OP_AELEMFAST_LEX:
2069         case OP_ASLICE:
2070         case OP_HELEM:
2071         case OP_HSLICE:
2072             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2073                 /* Otherwise it's "Useless use of grep iterator" */
2074                 useless = OP_DESC(o);
2075             break;
2076
2077         case OP_SPLIT:
2078             if (!(o->op_private & OPpSPLIT_ASSIGN))
2079                 useless = OP_DESC(o);
2080             break;
2081
2082         case OP_NOT:
2083             kid = cUNOPo->op_first;
2084             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2085                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2086                 goto func_ops;
2087             }
2088             useless = "negative pattern binding (!~)";
2089             break;
2090
2091         case OP_SUBST:
2092             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2093                 useless = "non-destructive substitution (s///r)";
2094             break;
2095
2096         case OP_TRANSR:
2097             useless = "non-destructive transliteration (tr///r)";
2098             break;
2099
2100         case OP_RV2GV:
2101         case OP_RV2SV:
2102         case OP_RV2AV:
2103         case OP_RV2HV:
2104             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2105                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2106                 useless = "a variable";
2107             break;
2108
2109         case OP_CONST:
2110             sv = cSVOPo_sv;
2111             if (cSVOPo->op_private & OPpCONST_STRICT)
2112                 no_bareword_allowed(o);
2113             else {
2114                 if (ckWARN(WARN_VOID)) {
2115                     NV nv;
2116                     /* don't warn on optimised away booleans, eg
2117                      * use constant Foo, 5; Foo || print; */
2118                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2119                         useless = NULL;
2120                     /* the constants 0 and 1 are permitted as they are
2121                        conventionally used as dummies in constructs like
2122                        1 while some_condition_with_side_effects;  */
2123                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2124                         useless = NULL;
2125                     else if (SvPOK(sv)) {
2126                         SV * const dsv = newSVpvs("");
2127                         useless_sv
2128                             = Perl_newSVpvf(aTHX_
2129                                             "a constant (%s)",
2130                                             pv_pretty(dsv, SvPVX_const(sv),
2131                                                       SvCUR(sv), 32, NULL, NULL,
2132                                                       PERL_PV_PRETTY_DUMP
2133                                                       | PERL_PV_ESCAPE_NOCLEAR
2134                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2135                         SvREFCNT_dec_NN(dsv);
2136                     }
2137                     else if (SvOK(sv)) {
2138                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2139                     }
2140                     else
2141                         useless = "a constant (undef)";
2142                 }
2143             }
2144             op_null(o);         /* don't execute or even remember it */
2145             break;
2146
2147         case OP_POSTINC:
2148             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2149             break;
2150
2151         case OP_POSTDEC:
2152             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2153             break;
2154
2155         case OP_I_POSTINC:
2156             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2157             break;
2158
2159         case OP_I_POSTDEC:
2160             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2161             break;
2162
2163         case OP_SASSIGN: {
2164             OP *rv2gv;
2165             UNOP *refgen, *rv2cv;
2166             LISTOP *exlist;
2167
2168             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2169                 break;
2170
2171             rv2gv = ((BINOP *)o)->op_last;
2172             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2173                 break;
2174
2175             refgen = (UNOP *)((BINOP *)o)->op_first;
2176
2177             if (!refgen || (refgen->op_type != OP_REFGEN
2178                             && refgen->op_type != OP_SREFGEN))
2179                 break;
2180
2181             exlist = (LISTOP *)refgen->op_first;
2182             if (!exlist || exlist->op_type != OP_NULL
2183                 || exlist->op_targ != OP_LIST)
2184                 break;
2185
2186             if (exlist->op_first->op_type != OP_PUSHMARK
2187                 && exlist->op_first != exlist->op_last)
2188                 break;
2189
2190             rv2cv = (UNOP*)exlist->op_last;
2191
2192             if (rv2cv->op_type != OP_RV2CV)
2193                 break;
2194
2195             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2196             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2197             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2198
2199             o->op_private |= OPpASSIGN_CV_TO_GV;
2200             rv2gv->op_private |= OPpDONT_INIT_GV;
2201             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2202
2203             break;
2204         }
2205
2206         case OP_AASSIGN: {
2207             inplace_aassign(o);
2208             break;
2209         }
2210
2211         case OP_OR:
2212         case OP_AND:
2213             kid = cLOGOPo->op_first;
2214             if (kid->op_type == OP_NOT
2215                 && (kid->op_flags & OPf_KIDS)) {
2216                 if (o->op_type == OP_AND) {
2217                     OpTYPE_set(o, OP_OR);
2218                 } else {
2219                     OpTYPE_set(o, OP_AND);
2220                 }
2221                 op_null(kid);
2222             }
2223             /* FALLTHROUGH */
2224
2225         case OP_DOR:
2226         case OP_COND_EXPR:
2227         case OP_ENTERGIVEN:
2228         case OP_ENTERWHEN:
2229             next_kid = OpSIBLING(cUNOPo->op_first);
2230         break;
2231
2232         case OP_NULL:
2233             if (o->op_flags & OPf_STACKED)
2234                 break;
2235             /* FALLTHROUGH */
2236         case OP_NEXTSTATE:
2237         case OP_DBSTATE:
2238         case OP_ENTERTRY:
2239         case OP_ENTER:
2240             if (!(o->op_flags & OPf_KIDS))
2241                 break;
2242             /* FALLTHROUGH */
2243         case OP_SCOPE:
2244         case OP_LEAVE:
2245         case OP_LEAVETRY:
2246         case OP_LEAVELOOP:
2247         case OP_LINESEQ:
2248         case OP_LEAVEGIVEN:
2249         case OP_LEAVEWHEN:
2250         kids:
2251             next_kid = cLISTOPo->op_first;
2252             break;
2253         case OP_LIST:
2254             /* If the first kid after pushmark is something that the padrange
2255                optimisation would reject, then null the list and the pushmark.
2256             */
2257             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2258                 && (  !(kid = OpSIBLING(kid))
2259                       || (  kid->op_type != OP_PADSV
2260                             && kid->op_type != OP_PADAV
2261                             && kid->op_type != OP_PADHV)
2262                       || kid->op_private & ~OPpLVAL_INTRO
2263                       || !(kid = OpSIBLING(kid))
2264                       || (  kid->op_type != OP_PADSV
2265                             && kid->op_type != OP_PADAV
2266                             && kid->op_type != OP_PADHV)
2267                       || kid->op_private & ~OPpLVAL_INTRO)
2268             ) {
2269                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2270                 op_null(o); /* NULL the list */
2271             }
2272             goto kids;
2273         case OP_ENTEREVAL:
2274             scalarkids(o);
2275             break;
2276         case OP_SCALAR:
2277             scalar(o);
2278             break;
2279         }
2280
2281         if (useless_sv) {
2282             /* mortalise it, in case warnings are fatal.  */
2283             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2284                            "Useless use of %" SVf " in void context",
2285                            SVfARG(sv_2mortal(useless_sv)));
2286         }
2287         else if (useless) {
2288             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2289                            "Useless use of %s in void context",
2290                            useless);
2291         }
2292
2293       get_next_op:
2294         /* if a kid hasn't been nominated to process, continue with the
2295          * next sibling, or if no siblings left, go back to the parent's
2296          * siblings and so on
2297          */
2298         while (!next_kid) {
2299             if (o == arg)
2300                 return arg; /* at top; no parents/siblings to try */
2301             if (OpHAS_SIBLING(o))
2302                 next_kid = o->op_sibparent;
2303             else
2304                 o = o->op_sibparent; /*try parent's next sibling */
2305         }
2306         o = next_kid;
2307     }
2308
2309     return arg;
2310 }
2311
2312
2313 static OP *
2314 S_listkids(pTHX_ OP *o)
2315 {
2316     if (o && o->op_flags & OPf_KIDS) {
2317         OP *kid;
2318         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2319             list(kid);
2320     }
2321     return o;
2322 }
2323
2324 OP *
2325 Perl_list(pTHX_ OP *o)
2326 {
2327     OP *kid;
2328
2329     /* assumes no premature commitment */
2330     if (!o || (o->op_flags & OPf_WANT)
2331          || (PL_parser && PL_parser->error_count)
2332          || o->op_type == OP_RETURN)
2333     {
2334         return o;
2335     }
2336
2337     if ((o->op_private & OPpTARGET_MY)
2338         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2339     {
2340         return o;                               /* As if inside SASSIGN */
2341     }
2342
2343     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2344
2345     switch (o->op_type) {
2346     case OP_FLOP:
2347         list(cBINOPo->op_first);
2348         break;
2349     case OP_REPEAT:
2350         if (o->op_private & OPpREPEAT_DOLIST
2351          && !(o->op_flags & OPf_STACKED))
2352         {
2353             list(cBINOPo->op_first);
2354             kid = cBINOPo->op_last;
2355             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2356              && SvIVX(kSVOP_sv) == 1)
2357             {
2358                 op_null(o); /* repeat */
2359                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2360                 /* const (rhs): */
2361                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2362             }
2363         }
2364         break;
2365     case OP_OR:
2366     case OP_AND:
2367     case OP_COND_EXPR:
2368         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2369             list(kid);
2370         break;
2371     default:
2372     case OP_MATCH:
2373     case OP_QR:
2374     case OP_SUBST:
2375     case OP_NULL:
2376         if (!(o->op_flags & OPf_KIDS))
2377             break;
2378         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2379             list(cBINOPo->op_first);
2380             return gen_constant_list(o);
2381         }
2382         listkids(o);
2383         break;
2384     case OP_LIST:
2385         listkids(o);
2386         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2387             op_null(cUNOPo->op_first); /* NULL the pushmark */
2388             op_null(o); /* NULL the list */
2389         }
2390         break;
2391     case OP_LEAVE:
2392     case OP_LEAVETRY:
2393         kid = cLISTOPo->op_first;
2394         list(kid);
2395         kid = OpSIBLING(kid);
2396     do_kids:
2397         while (kid) {
2398             OP *sib = OpSIBLING(kid);
2399             if (sib && kid->op_type != OP_LEAVEWHEN)
2400                 scalarvoid(kid);
2401             else
2402                 list(kid);
2403             kid = sib;
2404         }
2405         PL_curcop = &PL_compiling;
2406         break;
2407     case OP_SCOPE:
2408     case OP_LINESEQ:
2409         kid = cLISTOPo->op_first;
2410         goto do_kids;
2411     }
2412     return o;
2413 }
2414
2415 static OP *
2416 S_scalarseq(pTHX_ OP *o)
2417 {
2418     if (o) {
2419         const OPCODE type = o->op_type;
2420
2421         if (type == OP_LINESEQ || type == OP_SCOPE ||
2422             type == OP_LEAVE || type == OP_LEAVETRY)
2423         {
2424             OP *kid, *sib;
2425             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2426                 if ((sib = OpSIBLING(kid))
2427                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2428                     || (  sib->op_targ != OP_NEXTSTATE
2429                        && sib->op_targ != OP_DBSTATE  )))
2430                 {
2431                     scalarvoid(kid);
2432                 }
2433             }
2434             PL_curcop = &PL_compiling;
2435         }
2436         o->op_flags &= ~OPf_PARENS;
2437         if (PL_hints & HINT_BLOCK_SCOPE)
2438             o->op_flags |= OPf_PARENS;
2439     }
2440     else
2441         o = newOP(OP_STUB, 0);
2442     return o;
2443 }
2444
2445 STATIC OP *
2446 S_modkids(pTHX_ OP *o, I32 type)
2447 {
2448     if (o && o->op_flags & OPf_KIDS) {
2449         OP *kid;
2450         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2451             op_lvalue(kid, type);
2452     }
2453     return o;
2454 }
2455
2456
2457 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2458  * const fields. Also, convert CONST keys to HEK-in-SVs.
2459  * rop    is the op that retrieves the hash;
2460  * key_op is the first key
2461  * real   if false, only check (and possibly croak); don't update op
2462  */
2463
2464 STATIC void
2465 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2466 {
2467     PADNAME *lexname;
2468     GV **fields;
2469     bool check_fields;
2470
2471     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2472     if (rop) {
2473         if (rop->op_first->op_type == OP_PADSV)
2474             /* @$hash{qw(keys here)} */
2475             rop = (UNOP*)rop->op_first;
2476         else {
2477             /* @{$hash}{qw(keys here)} */
2478             if (rop->op_first->op_type == OP_SCOPE
2479                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2480                 {
2481                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2482                 }
2483             else
2484                 rop = NULL;
2485         }
2486     }
2487
2488     lexname = NULL; /* just to silence compiler warnings */
2489     fields  = NULL; /* just to silence compiler warnings */
2490
2491     check_fields =
2492             rop
2493          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2494              SvPAD_TYPED(lexname))
2495          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2496          && isGV(*fields) && GvHV(*fields);
2497
2498     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2499         SV **svp, *sv;
2500         if (key_op->op_type != OP_CONST)
2501             continue;
2502         svp = cSVOPx_svp(key_op);
2503
2504         /* make sure it's not a bareword under strict subs */
2505         if (key_op->op_private & OPpCONST_BARE &&
2506             key_op->op_private & OPpCONST_STRICT)
2507         {
2508             no_bareword_allowed((OP*)key_op);
2509         }
2510
2511         /* Make the CONST have a shared SV */
2512         if (   !SvIsCOW_shared_hash(sv = *svp)
2513             && SvTYPE(sv) < SVt_PVMG
2514             && SvOK(sv)
2515             && !SvROK(sv)
2516             && real)
2517         {
2518             SSize_t keylen;
2519             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2520             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2521             SvREFCNT_dec_NN(sv);
2522             *svp = nsv;
2523         }
2524
2525         if (   check_fields
2526             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2527         {
2528             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2529                         "in variable %" PNf " of type %" HEKf,
2530                         SVfARG(*svp), PNfARG(lexname),
2531                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2532         }
2533     }
2534 }
2535
2536 /* info returned by S_sprintf_is_multiconcatable() */
2537
2538 struct sprintf_ismc_info {
2539     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2540     char  *start;     /* start of raw format string */
2541     char  *end;       /* bytes after end of raw format string */
2542     STRLEN total_len; /* total length (in bytes) of format string, not
2543                          including '%s' and  half of '%%' */
2544     STRLEN variant;   /* number of bytes by which total_len_p would grow
2545                          if upgraded to utf8 */
2546     bool   utf8;      /* whether the format is utf8 */
2547 };
2548
2549
2550 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2551  * i.e. its format argument is a const string with only '%s' and '%%'
2552  * formats, and the number of args is known, e.g.
2553  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2554  * but not
2555  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2556  *
2557  * If successful, the sprintf_ismc_info struct pointed to by info will be
2558  * populated.
2559  */
2560
2561 STATIC bool
2562 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2563 {
2564     OP    *pm, *constop, *kid;
2565     SV    *sv;
2566     char  *s, *e, *p;
2567     SSize_t nargs, nformats;
2568     STRLEN cur, total_len, variant;
2569     bool   utf8;
2570
2571     /* if sprintf's behaviour changes, die here so that someone
2572      * can decide whether to enhance this function or skip optimising
2573      * under those new circumstances */
2574     assert(!(o->op_flags & OPf_STACKED));
2575     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2576     assert(!(o->op_private & ~OPpARG4_MASK));
2577
2578     pm = cUNOPo->op_first;
2579     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2580         return FALSE;
2581     constop = OpSIBLING(pm);
2582     if (!constop || constop->op_type != OP_CONST)
2583         return FALSE;
2584     sv = cSVOPx_sv(constop);
2585     if (SvMAGICAL(sv) || !SvPOK(sv))
2586         return FALSE;
2587
2588     s = SvPV(sv, cur);
2589     e = s + cur;
2590
2591     /* Scan format for %% and %s and work out how many %s there are.
2592      * Abandon if other format types are found.
2593      */
2594
2595     nformats  = 0;
2596     total_len = 0;
2597     variant   = 0;
2598
2599     for (p = s; p < e; p++) {
2600         if (*p != '%') {
2601             total_len++;
2602             if (!UTF8_IS_INVARIANT(*p))
2603                 variant++;
2604             continue;
2605         }
2606         p++;
2607         if (p >= e)
2608             return FALSE; /* lone % at end gives "Invalid conversion" */
2609         if (*p == '%')
2610             total_len++;
2611         else if (*p == 's')
2612             nformats++;
2613         else
2614             return FALSE;
2615     }
2616
2617     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2618         return FALSE;
2619
2620     utf8 = cBOOL(SvUTF8(sv));
2621     if (utf8)
2622         variant = 0;
2623
2624     /* scan args; they must all be in scalar cxt */
2625
2626     nargs = 0;
2627     kid = OpSIBLING(constop);
2628
2629     while (kid) {
2630         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2631             return FALSE;
2632         nargs++;
2633         kid = OpSIBLING(kid);
2634     }
2635
2636     if (nargs != nformats)
2637         return FALSE; /* e.g. sprintf("%s%s", $a); */
2638
2639
2640     info->nargs      = nargs;
2641     info->start      = s;
2642     info->end        = e;
2643     info->total_len  = total_len;
2644     info->variant    = variant;
2645     info->utf8       = utf8;
2646
2647     return TRUE;
2648 }
2649
2650
2651
2652 /* S_maybe_multiconcat():
2653  *
2654  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2655  * convert it (and its children) into an OP_MULTICONCAT. See the code
2656  * comments just before pp_multiconcat() for the full details of what
2657  * OP_MULTICONCAT supports.
2658  *
2659  * Basically we're looking for an optree with a chain of OP_CONCATS down
2660  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2661  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2662  *
2663  *      $x = "$a$b-$c"
2664  *
2665  *  looks like
2666  *
2667  *      SASSIGN
2668  *         |
2669  *      STRINGIFY   -- PADSV[$x]
2670  *         |
2671  *         |
2672  *      ex-PUSHMARK -- CONCAT/S
2673  *                        |
2674  *                     CONCAT/S  -- PADSV[$d]
2675  *                        |
2676  *                     CONCAT    -- CONST["-"]
2677  *                        |
2678  *                     PADSV[$a] -- PADSV[$b]
2679  *
2680  * Note that at this stage the OP_SASSIGN may have already been optimised
2681  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2682  */
2683
2684 STATIC void
2685 S_maybe_multiconcat(pTHX_ OP *o)
2686 {
2687     dVAR;
2688     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2689     OP *topop;       /* the top-most op in the concat tree (often equals o,
2690                         unless there are assign/stringify ops above it */
2691     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2692     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2693     OP *targetop;    /* the op corresponding to target=... or target.=... */
2694     OP *stringop;    /* the OP_STRINGIFY op, if any */
2695     OP *nextop;      /* used for recreating the op_next chain without consts */
2696     OP *kid;         /* general-purpose op pointer */
2697     UNOP_AUX_item *aux;
2698     UNOP_AUX_item *lenp;
2699     char *const_str, *p;
2700     struct sprintf_ismc_info sprintf_info;
2701
2702                      /* store info about each arg in args[];
2703                       * toparg is the highest used slot; argp is a general
2704                       * pointer to args[] slots */
2705     struct {
2706         void *p;      /* initially points to const sv (or null for op);
2707                          later, set to SvPV(constsv), with ... */
2708         STRLEN len;   /* ... len set to SvPV(..., len) */
2709     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2710
2711     SSize_t nargs  = 0;
2712     SSize_t nconst = 0;
2713     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2714     STRLEN variant;
2715     bool utf8 = FALSE;
2716     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2717                                  the last-processed arg will the LHS of one,
2718                                  as args are processed in reverse order */
2719     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2720     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2721     U8 flags          = 0;   /* what will become the op_flags and ... */
2722     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2723     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2724     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2725     bool prev_was_const = FALSE; /* previous arg was a const */
2726
2727     /* -----------------------------------------------------------------
2728      * Phase 1:
2729      *
2730      * Examine the optree non-destructively to determine whether it's
2731      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2732      * information about the optree in args[].
2733      */
2734
2735     argp     = args;
2736     targmyop = NULL;
2737     targetop = NULL;
2738     stringop = NULL;
2739     topop    = o;
2740     parentop = o;
2741
2742     assert(   o->op_type == OP_SASSIGN
2743            || o->op_type == OP_CONCAT
2744            || o->op_type == OP_SPRINTF
2745            || o->op_type == OP_STRINGIFY);
2746
2747     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2748
2749     /* first see if, at the top of the tree, there is an assign,
2750      * append and/or stringify */
2751
2752     if (topop->op_type == OP_SASSIGN) {
2753         /* expr = ..... */
2754         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2755             return;
2756         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2757             return;
2758         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2759
2760         parentop = topop;
2761         topop = cBINOPo->op_first;
2762         targetop = OpSIBLING(topop);
2763         if (!targetop) /* probably some sort of syntax error */
2764             return;
2765     }
2766     else if (   topop->op_type == OP_CONCAT
2767              && (topop->op_flags & OPf_STACKED)
2768              && (!(topop->op_private & OPpCONCAT_NESTED))
2769             )
2770     {
2771         /* expr .= ..... */
2772
2773         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2774          * decide what to do about it */
2775         assert(!(o->op_private & OPpTARGET_MY));
2776
2777         /* barf on unknown flags */
2778         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2779         private_flags |= OPpMULTICONCAT_APPEND;
2780         targetop = cBINOPo->op_first;
2781         parentop = topop;
2782         topop    = OpSIBLING(targetop);
2783
2784         /* $x .= <FOO> gets optimised to rcatline instead */
2785         if (topop->op_type == OP_READLINE)
2786             return;
2787     }
2788
2789     if (targetop) {
2790         /* Can targetop (the LHS) if it's a padsv, be be optimised
2791          * away and use OPpTARGET_MY instead?
2792          */
2793         if (    (targetop->op_type == OP_PADSV)
2794             && !(targetop->op_private & OPpDEREF)
2795             && !(targetop->op_private & OPpPAD_STATE)
2796                /* we don't support 'my $x .= ...' */
2797             && (   o->op_type == OP_SASSIGN
2798                 || !(targetop->op_private & OPpLVAL_INTRO))
2799         )
2800             is_targable = TRUE;
2801     }
2802
2803     if (topop->op_type == OP_STRINGIFY) {
2804         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2805             return;
2806         stringop = topop;
2807
2808         /* barf on unknown flags */
2809         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2810
2811         if ((topop->op_private & OPpTARGET_MY)) {
2812             if (o->op_type == OP_SASSIGN)
2813                 return; /* can't have two assigns */
2814             targmyop = topop;
2815         }
2816
2817         private_flags |= OPpMULTICONCAT_STRINGIFY;
2818         parentop = topop;
2819         topop = cBINOPx(topop)->op_first;
2820         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2821         topop = OpSIBLING(topop);
2822     }
2823
2824     if (topop->op_type == OP_SPRINTF) {
2825         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2826             return;
2827         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2828             nargs     = sprintf_info.nargs;
2829             total_len = sprintf_info.total_len;
2830             variant   = sprintf_info.variant;
2831             utf8      = sprintf_info.utf8;
2832             is_sprintf = TRUE;
2833             private_flags |= OPpMULTICONCAT_FAKE;
2834             toparg = argp;
2835             /* we have an sprintf op rather than a concat optree.
2836              * Skip most of the code below which is associated with
2837              * processing that optree. We also skip phase 2, determining
2838              * whether its cost effective to optimise, since for sprintf,
2839              * multiconcat is *always* faster */
2840             goto create_aux;
2841         }
2842         /* note that even if the sprintf itself isn't multiconcatable,
2843          * the expression as a whole may be, e.g. in
2844          *    $x .= sprintf("%d",...)
2845          * the sprintf op will be left as-is, but the concat/S op may
2846          * be upgraded to multiconcat
2847          */
2848     }
2849     else if (topop->op_type == OP_CONCAT) {
2850         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2851             return;
2852
2853         if ((topop->op_private & OPpTARGET_MY)) {
2854             if (o->op_type == OP_SASSIGN || targmyop)
2855                 return; /* can't have two assigns */
2856             targmyop = topop;
2857         }
2858     }
2859
2860     /* Is it safe to convert a sassign/stringify/concat op into
2861      * a multiconcat? */
2862     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2863     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2864     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2865     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2866     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2867                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2868     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2869                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2870
2871     /* Now scan the down the tree looking for a series of
2872      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2873      * stacked). For example this tree:
2874      *
2875      *     |
2876      *   CONCAT/STACKED
2877      *     |
2878      *   CONCAT/STACKED -- EXPR5
2879      *     |
2880      *   CONCAT/STACKED -- EXPR4
2881      *     |
2882      *   CONCAT -- EXPR3
2883      *     |
2884      *   EXPR1  -- EXPR2
2885      *
2886      * corresponds to an expression like
2887      *
2888      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2889      *
2890      * Record info about each EXPR in args[]: in particular, whether it is
2891      * a stringifiable OP_CONST and if so what the const sv is.
2892      *
2893      * The reason why the last concat can't be STACKED is the difference
2894      * between
2895      *
2896      *    ((($a .= $a) .= $a) .= $a) .= $a
2897      *
2898      * and
2899      *    $a . $a . $a . $a . $a
2900      *
2901      * The main difference between the optrees for those two constructs
2902      * is the presence of the last STACKED. As well as modifying $a,
2903      * the former sees the changed $a between each concat, so if $s is
2904      * initially 'a', the first returns 'a' x 16, while the latter returns
2905      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2906      */
2907
2908     kid = topop;
2909
2910     for (;;) {
2911         OP *argop;
2912         SV *sv;
2913         bool last = FALSE;
2914
2915         if (    kid->op_type == OP_CONCAT
2916             && !kid_is_last
2917         ) {
2918             OP *k1, *k2;
2919             k1 = cUNOPx(kid)->op_first;
2920             k2 = OpSIBLING(k1);
2921             /* shouldn't happen except maybe after compile err? */
2922             if (!k2)
2923                 return;
2924
2925             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2926             if (kid->op_private & OPpTARGET_MY)
2927                 kid_is_last = TRUE;
2928
2929             stacked_last = (kid->op_flags & OPf_STACKED);
2930             if (!stacked_last)
2931                 kid_is_last = TRUE;
2932
2933             kid   = k1;
2934             argop = k2;
2935         }
2936         else {
2937             argop = kid;
2938             last = TRUE;
2939         }
2940
2941         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2942             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2943         {
2944             /* At least two spare slots are needed to decompose both
2945              * concat args. If there are no slots left, continue to
2946              * examine the rest of the optree, but don't push new values
2947              * on args[]. If the optree as a whole is legal for conversion
2948              * (in particular that the last concat isn't STACKED), then
2949              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2950              * can be converted into an OP_MULTICONCAT now, with the first
2951              * child of that op being the remainder of the optree -
2952              * which may itself later be converted to a multiconcat op
2953              * too.
2954              */
2955             if (last) {
2956                 /* the last arg is the rest of the optree */
2957                 argp++->p = NULL;
2958                 nargs++;
2959             }
2960         }
2961         else if (   argop->op_type == OP_CONST
2962             && ((sv = cSVOPx_sv(argop)))
2963             /* defer stringification until runtime of 'constant'
2964              * things that might stringify variantly, e.g. the radix
2965              * point of NVs, or overloaded RVs */
2966             && (SvPOK(sv) || SvIOK(sv))
2967             && (!SvGMAGICAL(sv))
2968         ) {
2969             argp++->p = sv;
2970             utf8   |= cBOOL(SvUTF8(sv));
2971             nconst++;
2972             if (prev_was_const)
2973                 /* this const may be demoted back to a plain arg later;
2974                  * make sure we have enough arg slots left */
2975                 nadjconst++;
2976             prev_was_const = !prev_was_const;
2977         }
2978         else {
2979             argp++->p = NULL;
2980             nargs++;
2981             prev_was_const = FALSE;
2982         }
2983
2984         if (last)
2985             break;
2986     }
2987
2988     toparg = argp - 1;
2989
2990     if (stacked_last)
2991         return; /* we don't support ((A.=B).=C)...) */
2992
2993     /* look for two adjacent consts and don't fold them together:
2994      *     $o . "a" . "b"
2995      * should do
2996      *     $o->concat("a")->concat("b")
2997      * rather than
2998      *     $o->concat("ab")
2999      * (but $o .=  "a" . "b" should still fold)
3000      */
3001     {
3002         bool seen_nonconst = FALSE;
3003         for (argp = toparg; argp >= args; argp--) {
3004             if (argp->p == NULL) {
3005                 seen_nonconst = TRUE;
3006                 continue;
3007             }
3008             if (!seen_nonconst)
3009                 continue;
3010             if (argp[1].p) {
3011                 /* both previous and current arg were constants;
3012                  * leave the current OP_CONST as-is */
3013                 argp->p = NULL;
3014                 nconst--;
3015                 nargs++;
3016             }
3017         }
3018     }
3019
3020     /* -----------------------------------------------------------------
3021      * Phase 2:
3022      *
3023      * At this point we have determined that the optree *can* be converted
3024      * into a multiconcat. Having gathered all the evidence, we now decide
3025      * whether it *should*.
3026      */
3027
3028
3029     /* we need at least one concat action, e.g.:
3030      *
3031      *  Y . Z
3032      *  X = Y . Z
3033      *  X .= Y
3034      *
3035      * otherwise we could be doing something like $x = "foo", which
3036      * if treated as as a concat, would fail to COW.
3037      */
3038     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3039         return;
3040
3041     /* Benchmarking seems to indicate that we gain if:
3042      * * we optimise at least two actions into a single multiconcat
3043      *    (e.g concat+concat, sassign+concat);
3044      * * or if we can eliminate at least 1 OP_CONST;
3045      * * or if we can eliminate a padsv via OPpTARGET_MY
3046      */
3047
3048     if (
3049            /* eliminated at least one OP_CONST */
3050            nconst >= 1
3051            /* eliminated an OP_SASSIGN */
3052         || o->op_type == OP_SASSIGN
3053            /* eliminated an OP_PADSV */
3054         || (!targmyop && is_targable)
3055     )
3056         /* definitely a net gain to optimise */
3057         goto optimise;
3058
3059     /* ... if not, what else? */
3060
3061     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3062      * multiconcat is faster (due to not creating a temporary copy of
3063      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3064      * faster.
3065      */
3066     if (   nconst == 0
3067          && nargs == 2
3068          && targmyop
3069          && topop->op_type == OP_CONCAT
3070     ) {
3071         PADOFFSET t = targmyop->op_targ;
3072         OP *k1 = cBINOPx(topop)->op_first;
3073         OP *k2 = cBINOPx(topop)->op_last;
3074         if (   k2->op_type == OP_PADSV
3075             && k2->op_targ == t
3076             && (   k1->op_type != OP_PADSV
3077                 || k1->op_targ != t)
3078         )
3079             goto optimise;
3080     }
3081
3082     /* need at least two concats */
3083     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3084         return;
3085
3086
3087
3088     /* -----------------------------------------------------------------
3089      * Phase 3:
3090      *
3091      * At this point the optree has been verified as ok to be optimised
3092      * into an OP_MULTICONCAT. Now start changing things.
3093      */
3094
3095    optimise:
3096
3097     /* stringify all const args and determine utf8ness */
3098
3099     variant = 0;
3100     for (argp = args; argp <= toparg; argp++) {
3101         SV *sv = (SV*)argp->p;
3102         if (!sv)
3103             continue; /* not a const op */
3104         if (utf8 && !SvUTF8(sv))
3105             sv_utf8_upgrade_nomg(sv);
3106         argp->p = SvPV_nomg(sv, argp->len);
3107         total_len += argp->len;
3108         
3109         /* see if any strings would grow if converted to utf8 */
3110         if (!utf8) {
3111             variant += variant_under_utf8_count((U8 *) argp->p,
3112                                                 (U8 *) argp->p + argp->len);
3113         }
3114     }
3115
3116     /* create and populate aux struct */
3117
3118   create_aux:
3119
3120     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3121                     sizeof(UNOP_AUX_item)
3122                     *  (
3123                            PERL_MULTICONCAT_HEADER_SIZE
3124                          + ((nargs + 1) * (variant ? 2 : 1))
3125                         )
3126                     );
3127     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3128
3129     /* Extract all the non-const expressions from the concat tree then
3130      * dispose of the old tree, e.g. convert the tree from this:
3131      *
3132      *  o => SASSIGN
3133      *         |
3134      *       STRINGIFY   -- TARGET
3135      *         |
3136      *       ex-PUSHMARK -- CONCAT
3137      *                        |
3138      *                      CONCAT -- EXPR5
3139      *                        |
3140      *                      CONCAT -- EXPR4
3141      *                        |
3142      *                      CONCAT -- EXPR3
3143      *                        |
3144      *                      EXPR1  -- EXPR2
3145      *
3146      *
3147      * to:
3148      *
3149      *  o => MULTICONCAT
3150      *         |
3151      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3152      *
3153      * except that if EXPRi is an OP_CONST, it's discarded.
3154      *
3155      * During the conversion process, EXPR ops are stripped from the tree
3156      * and unshifted onto o. Finally, any of o's remaining original
3157      * childen are discarded and o is converted into an OP_MULTICONCAT.
3158      *
3159      * In this middle of this, o may contain both: unshifted args on the
3160      * left, and some remaining original args on the right. lastkidop
3161      * is set to point to the right-most unshifted arg to delineate
3162      * between the two sets.
3163      */
3164
3165
3166     if (is_sprintf) {
3167         /* create a copy of the format with the %'s removed, and record
3168          * the sizes of the const string segments in the aux struct */
3169         char *q, *oldq;
3170         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3171
3172         p    = sprintf_info.start;
3173         q    = const_str;
3174         oldq = q;
3175         for (; p < sprintf_info.end; p++) {
3176             if (*p == '%') {
3177                 p++;
3178                 if (*p != '%') {
3179                     (lenp++)->ssize = q - oldq;
3180                     oldq = q;
3181                     continue;
3182                 }
3183             }
3184             *q++ = *p;
3185         }
3186         lenp->ssize = q - oldq;
3187         assert((STRLEN)(q - const_str) == total_len);
3188
3189         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3190          * may or may not be topop) The pushmark and const ops need to be
3191          * kept in case they're an op_next entry point.
3192          */
3193         lastkidop = cLISTOPx(topop)->op_last;
3194         kid = cUNOPx(topop)->op_first; /* pushmark */
3195         op_null(kid);
3196         op_null(OpSIBLING(kid));       /* const */
3197         if (o != topop) {
3198             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3199             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3200             lastkidop->op_next = o;
3201         }
3202     }
3203     else {
3204         p = const_str;
3205         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3206
3207         lenp->ssize = -1;
3208
3209         /* Concatenate all const strings into const_str.
3210          * Note that args[] contains the RHS args in reverse order, so
3211          * we scan args[] from top to bottom to get constant strings
3212          * in L-R order
3213          */
3214         for (argp = toparg; argp >= args; argp--) {
3215             if (!argp->p)
3216                 /* not a const op */
3217                 (++lenp)->ssize = -1;
3218             else {
3219                 STRLEN l = argp->len;
3220                 Copy(argp->p, p, l, char);
3221                 p += l;
3222                 if (lenp->ssize == -1)
3223                     lenp->ssize = l;
3224                 else
3225                     lenp->ssize += l;
3226             }
3227         }
3228
3229         kid = topop;
3230         nextop = o;
3231         lastkidop = NULL;
3232
3233         for (argp = args; argp <= toparg; argp++) {
3234             /* only keep non-const args, except keep the first-in-next-chain
3235              * arg no matter what it is (but nulled if OP_CONST), because it
3236              * may be the entry point to this subtree from the previous
3237              * op_next.
3238              */
3239             bool last = (argp == toparg);
3240             OP *prev;
3241
3242             /* set prev to the sibling *before* the arg to be cut out,
3243              * e.g. when cutting EXPR:
3244              *
3245              *         |
3246              * kid=  CONCAT
3247              *         |
3248              * prev= CONCAT -- EXPR
3249              *         |
3250              */
3251             if (argp == args && kid->op_type != OP_CONCAT) {
3252                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3253                  * so the expression to be cut isn't kid->op_last but
3254                  * kid itself */
3255                 OP *o1, *o2;
3256                 /* find the op before kid */
3257                 o1 = NULL;
3258                 o2 = cUNOPx(parentop)->op_first;
3259                 while (o2 && o2 != kid) {
3260                     o1 = o2;
3261                     o2 = OpSIBLING(o2);
3262                 }
3263                 assert(o2 == kid);
3264                 prev = o1;
3265                 kid  = parentop;
3266             }
3267             else if (kid == o && lastkidop)
3268                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3269             else
3270                 prev = last ? NULL : cUNOPx(kid)->op_first;
3271
3272             if (!argp->p || last) {
3273                 /* cut RH op */
3274                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3275                 /* and unshift to front of o */
3276                 op_sibling_splice(o, NULL, 0, aop);
3277                 /* record the right-most op added to o: later we will
3278                  * free anything to the right of it */
3279                 if (!lastkidop)
3280                     lastkidop = aop;
3281                 aop->op_next = nextop;
3282                 if (last) {
3283                     if (argp->p)
3284                         /* null the const at start of op_next chain */
3285                         op_null(aop);
3286                 }
3287                 else if (prev)
3288                     nextop = prev->op_next;
3289             }
3290
3291             /* the last two arguments are both attached to the same concat op */
3292             if (argp < toparg - 1)
3293                 kid = prev;
3294         }
3295     }
3296
3297     /* Populate the aux struct */
3298
3299     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3300     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3301     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3302     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3303     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3304
3305     /* if variant > 0, calculate a variant const string and lengths where
3306      * the utf8 version of the string will take 'variant' more bytes than
3307      * the plain one. */
3308
3309     if (variant) {
3310         char              *p = const_str;
3311         STRLEN          ulen = total_len + variant;
3312         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3313         UNOP_AUX_item *ulens = lens + (nargs + 1);
3314         char             *up = (char*)PerlMemShared_malloc(ulen);
3315         SSize_t            n;
3316
3317         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3318         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3319
3320         for (n = 0; n < (nargs + 1); n++) {
3321             SSize_t i;
3322             char * orig_up = up;
3323             for (i = (lens++)->ssize; i > 0; i--) {
3324                 U8 c = *p++;
3325                 append_utf8_from_native_byte(c, (U8**)&up);
3326             }
3327             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3328         }
3329     }
3330
3331     if (stringop) {
3332         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3333          * that op's first child - an ex-PUSHMARK - because the op_next of
3334          * the previous op may point to it (i.e. it's the entry point for
3335          * the o optree)
3336          */
3337         OP *pmop =
3338             (stringop == o)
3339                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3340                 : op_sibling_splice(stringop, NULL, 1, NULL);
3341         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3342         op_sibling_splice(o, NULL, 0, pmop);
3343         if (!lastkidop)
3344             lastkidop = pmop;
3345     }
3346
3347     /* Optimise 
3348      *    target  = A.B.C...
3349      *    target .= A.B.C...
3350      */
3351
3352     if (targetop) {
3353         assert(!targmyop);
3354
3355         if (o->op_type == OP_SASSIGN) {
3356             /* Move the target subtree from being the last of o's children
3357              * to being the last of o's preserved children.
3358              * Note the difference between 'target = ...' and 'target .= ...':
3359              * for the former, target is executed last; for the latter,
3360              * first.
3361              */
3362             kid = OpSIBLING(lastkidop);
3363             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3364             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3365             lastkidop->op_next = kid->op_next;
3366             lastkidop = targetop;
3367         }
3368         else {
3369             /* Move the target subtree from being the first of o's
3370              * original children to being the first of *all* o's children.
3371              */
3372             if (lastkidop) {
3373                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3374                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3375             }
3376             else {
3377                 /* if the RHS of .= doesn't contain a concat (e.g.
3378                  * $x .= "foo"), it gets missed by the "strip ops from the
3379                  * tree and add to o" loop earlier */
3380                 assert(topop->op_type != OP_CONCAT);
3381                 if (stringop) {
3382                     /* in e.g. $x .= "$y", move the $y expression
3383                      * from being a child of OP_STRINGIFY to being the
3384                      * second child of the OP_CONCAT
3385                      */
3386                     assert(cUNOPx(stringop)->op_first == topop);
3387                     op_sibling_splice(stringop, NULL, 1, NULL);
3388                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3389                 }
3390                 assert(topop == OpSIBLING(cBINOPo->op_first));
3391                 if (toparg->p)
3392                     op_null(topop);
3393                 lastkidop = topop;
3394             }
3395         }
3396
3397         if (is_targable) {
3398             /* optimise
3399              *  my $lex  = A.B.C...
3400              *     $lex  = A.B.C...
3401              *     $lex .= A.B.C...
3402              * The original padsv op is kept but nulled in case it's the
3403              * entry point for the optree (which it will be for
3404              * '$lex .=  ... '
3405              */
3406             private_flags |= OPpTARGET_MY;
3407             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3408             o->op_targ = targetop->op_targ;
3409             targetop->op_targ = 0;
3410             op_null(targetop);
3411         }
3412         else
3413             flags |= OPf_STACKED;
3414     }
3415     else if (targmyop) {
3416         private_flags |= OPpTARGET_MY;
3417         if (o != targmyop) {
3418             o->op_targ = targmyop->op_targ;
3419             targmyop->op_targ = 0;
3420         }
3421     }
3422
3423     /* detach the emaciated husk of the sprintf/concat optree and free it */
3424     for (;;) {
3425         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3426         if (!kid)
3427             break;
3428         op_free(kid);
3429     }
3430
3431     /* and convert o into a multiconcat */
3432
3433     o->op_flags        = (flags|OPf_KIDS|stacked_last
3434                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3435     o->op_private      = private_flags;
3436     o->op_type         = OP_MULTICONCAT;
3437     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3438     cUNOP_AUXo->op_aux = aux;
3439 }
3440
3441
3442 /* do all the final processing on an optree (e.g. running the peephole
3443  * optimiser on it), then attach it to cv (if cv is non-null)
3444  */
3445
3446 static void
3447 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3448 {
3449     OP **startp;
3450
3451     /* XXX for some reason, evals, require and main optrees are
3452      * never attached to their CV; instead they just hang off
3453      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3454      * and get manually freed when appropriate */
3455     if (cv)
3456         startp = &CvSTART(cv);
3457     else
3458         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3459
3460     *startp = start;
3461     optree->op_private |= OPpREFCOUNTED;
3462     OpREFCNT_set(optree, 1);
3463     optimize_optree(optree);
3464     CALL_PEEP(*startp);
3465     finalize_optree(optree);
3466     S_prune_chain_head(startp);
3467
3468     if (cv) {
3469         /* now that optimizer has done its work, adjust pad values */
3470         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3471                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3472     }
3473 }
3474
3475
3476 /*
3477 =for apidoc optimize_optree
3478
3479 This function applies some optimisations to the optree in top-down order.
3480 It is called before the peephole optimizer, which processes ops in
3481 execution order. Note that finalize_optree() also does a top-down scan,
3482 but is called *after* the peephole optimizer.
3483
3484 =cut
3485 */
3486
3487 void
3488 Perl_optimize_optree(pTHX_ OP* o)
3489 {
3490     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3491
3492     ENTER;
3493     SAVEVPTR(PL_curcop);
3494
3495     optimize_op(o);
3496
3497     LEAVE;
3498 }
3499
3500
3501 /* helper for optimize_optree() which optimises on op then recurses
3502  * to optimise any children.
3503  */
3504
3505 STATIC void
3506 S_optimize_op(pTHX_ OP* o)
3507 {
3508     dDEFER_OP;
3509
3510     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3511     do {
3512         assert(o->op_type != OP_FREED);
3513
3514         switch (o->op_type) {
3515         case OP_NEXTSTATE:
3516         case OP_DBSTATE:
3517             PL_curcop = ((COP*)o);              /* for warnings */
3518             break;
3519
3520
3521         case OP_CONCAT:
3522         case OP_SASSIGN:
3523         case OP_STRINGIFY:
3524         case OP_SPRINTF:
3525             S_maybe_multiconcat(aTHX_ o);
3526             break;
3527
3528         case OP_SUBST:
3529             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3530                 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3531             break;
3532
3533         default:
3534             break;
3535         }
3536
3537         if (o->op_flags & OPf_KIDS) {
3538             OP *kid;
3539             IV child_count = 0;
3540             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3541                 DEFER_OP(kid);
3542                 ++child_count;
3543             }
3544             DEFER_REVERSE(child_count);
3545         }
3546     } while ( ( o = POP_DEFERRED_OP() ) );
3547
3548     DEFER_OP_CLEANUP;
3549 }
3550
3551
3552 /*
3553 =for apidoc finalize_optree
3554
3555 This function finalizes the optree.  Should be called directly after
3556 the complete optree is built.  It does some additional
3557 checking which can't be done in the normal C<ck_>xxx functions and makes
3558 the tree thread-safe.
3559
3560 =cut
3561 */
3562 void
3563 Perl_finalize_optree(pTHX_ OP* o)
3564 {
3565     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3566
3567     ENTER;
3568     SAVEVPTR(PL_curcop);
3569
3570     finalize_op(o);
3571
3572     LEAVE;
3573 }
3574
3575 #ifdef USE_ITHREADS
3576 /* Relocate sv to the pad for thread safety.
3577  * Despite being a "constant", the SV is written to,
3578  * for reference counts, sv_upgrade() etc. */
3579 PERL_STATIC_INLINE void
3580 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3581 {
3582     PADOFFSET ix;
3583     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3584     if (!*svp) return;
3585     ix = pad_alloc(OP_CONST, SVf_READONLY);
3586     SvREFCNT_dec(PAD_SVl(ix));
3587     PAD_SETSV(ix, *svp);
3588     /* XXX I don't know how this isn't readonly already. */
3589     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3590     *svp = NULL;
3591     *targp = ix;
3592 }
3593 #endif
3594
3595 /*
3596 =for apidoc traverse_op_tree
3597
3598 Return the next op in a depth-first traversal of the op tree,
3599 returning NULL when the traversal is complete.
3600
3601 The initial call must supply the root of the tree as both top and o.
3602
3603 For now it's static, but it may be exposed to the API in the future.
3604
3605 =cut
3606 */
3607
3608 STATIC OP*
3609 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3610     OP *sib;
3611
3612     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3613
3614     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3615         return cUNOPo->op_first;
3616     }
3617     else if ((sib = OpSIBLING(o))) {
3618         return sib;
3619     }
3620     else {
3621         OP *parent = o->op_sibparent;
3622         assert(!(o->op_moresib));
3623         while (parent && parent != top) {
3624             OP *sib = OpSIBLING(parent);
3625             if (sib)
3626                 return sib;
3627             parent = parent->op_sibparent;
3628         }
3629
3630         return NULL;
3631     }
3632 }
3633
3634 STATIC void
3635 S_finalize_op(pTHX_ OP* o)
3636 {
3637     OP * const top = o;
3638     PERL_ARGS_ASSERT_FINALIZE_OP;
3639
3640     do {
3641         assert(o->op_type != OP_FREED);
3642
3643         switch (o->op_type) {
3644         case OP_NEXTSTATE:
3645         case OP_DBSTATE:
3646             PL_curcop = ((COP*)o);              /* for warnings */
3647             break;
3648         case OP_EXEC:
3649             if (OpHAS_SIBLING(o)) {
3650                 OP *sib = OpSIBLING(o);
3651                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3652                     && ckWARN(WARN_EXEC)
3653                     && OpHAS_SIBLING(sib))
3654                 {
3655                     const OPCODE type = OpSIBLING(sib)->op_type;
3656                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3657                         const line_t oldline = CopLINE(PL_curcop);
3658                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3659                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3660                             "Statement unlikely to be reached");
3661                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3662                             "\t(Maybe you meant system() when you said exec()?)\n");
3663                         CopLINE_set(PL_curcop, oldline);
3664                     }
3665                 }
3666             }
3667             break;
3668
3669         case OP_GV:
3670             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3671                 GV * const gv = cGVOPo_gv;
3672                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3673                     /* XXX could check prototype here instead of just carping */
3674                     SV * const sv = sv_newmortal();
3675                     gv_efullname3(sv, gv, NULL);
3676                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3677                                 "%" SVf "() called too early to check prototype",
3678                                 SVfARG(sv));
3679                 }
3680             }
3681             break;
3682
3683         case OP_CONST:
3684             if (cSVOPo->op_private & OPpCONST_STRICT)
3685                 no_bareword_allowed(o);
3686 #ifdef USE_ITHREADS
3687             /* FALLTHROUGH */
3688         case OP_HINTSEVAL:
3689             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3690 #endif
3691             break;
3692
3693 #ifdef USE_ITHREADS
3694             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3695         case OP_METHOD_NAMED:
3696         case OP_METHOD_SUPER:
3697         case OP_METHOD_REDIR:
3698         case OP_METHOD_REDIR_SUPER:
3699             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3700             break;
3701 #endif
3702
3703         case OP_HELEM: {
3704             UNOP *rop;
3705             SVOP *key_op;
3706             OP *kid;
3707
3708             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3709                 break;
3710
3711             rop = (UNOP*)((BINOP*)o)->op_first;
3712
3713             goto check_keys;
3714
3715             case OP_HSLICE:
3716                 S_scalar_slice_warning(aTHX_ o);
3717                 /* FALLTHROUGH */
3718
3719             case OP_KVHSLICE:
3720                 kid = OpSIBLING(cLISTOPo->op_first);
3721             if (/* I bet there's always a pushmark... */
3722                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3723                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3724             {
3725                 break;
3726             }
3727
3728             key_op = (SVOP*)(kid->op_type == OP_CONST
3729                              ? kid
3730                              : OpSIBLING(kLISTOP->op_first));
3731
3732             rop = (UNOP*)((LISTOP*)o)->op_last;
3733
3734         check_keys:
3735             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3736                 rop = NULL;
3737             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3738             break;
3739         }
3740         case OP_NULL:
3741             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3742                 break;
3743             /* FALLTHROUGH */
3744         case OP_ASLICE:
3745             S_scalar_slice_warning(aTHX_ o);
3746             break;
3747
3748         case OP_SUBST: {
3749             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3750                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3751             break;
3752         }
3753         default:
3754             break;
3755         }
3756
3757 #ifdef DEBUGGING
3758         if (o->op_flags & OPf_KIDS) {
3759             OP *kid;
3760
3761             /* check that op_last points to the last sibling, and that
3762              * the last op_sibling/op_sibparent field points back to the
3763              * parent, and that the only ops with KIDS are those which are
3764              * entitled to them */
3765             U32 type = o->op_type;
3766             U32 family;
3767             bool has_last;
3768
3769             if (type == OP_NULL) {
3770                 type = o->op_targ;
3771                 /* ck_glob creates a null UNOP with ex-type GLOB
3772                  * (which is a list op. So pretend it wasn't a listop */
3773                 if (type == OP_GLOB)
3774                     type = OP_NULL;
3775             }
3776             family = PL_opargs[type] & OA_CLASS_MASK;
3777
3778             has_last = (   family == OA_BINOP
3779                         || family == OA_LISTOP
3780                         || family == OA_PMOP
3781                         || family == OA_LOOP
3782                        );
3783             assert(  has_last /* has op_first and op_last, or ...
3784                   ... has (or may have) op_first: */
3785                   || family == OA_UNOP
3786                   || family == OA_UNOP_AUX
3787                   || family == OA_LOGOP
3788                   || family == OA_BASEOP_OR_UNOP
3789                   || family == OA_FILESTATOP
3790                   || family == OA_LOOPEXOP
3791                   || family == OA_METHOP
3792                   || type == OP_CUSTOM
3793                   || type == OP_NULL /* new_logop does this */
3794                   );
3795
3796             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3797                 if (!OpHAS_SIBLING(kid)) {
3798                     if (has_last)
3799                         assert(kid == cLISTOPo->op_last);
3800                     assert(kid->op_sibparent == o);
3801                 }
3802             }
3803         }
3804 #endif
3805     } while (( o = traverse_op_tree(top, o)) != NULL);
3806 }
3807
3808 /*
3809 =for apidoc op_lvalue
3810
3811 Propagate lvalue ("modifiable") context to an op and its children.
3812 C<type> represents the context type, roughly based on the type of op that
3813 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3814 because it has no op type of its own (it is signalled by a flag on
3815 the lvalue op).
3816
3817 This function detects things that can't be modified, such as C<$x+1>, and
3818 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3819 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3820
3821 It also flags things that need to behave specially in an lvalue context,
3822 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3823
3824 =cut
3825 */
3826
3827 static void
3828 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3829 {
3830     CV *cv = PL_compcv;
3831     PadnameLVALUE_on(pn);
3832     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3833         cv = CvOUTSIDE(cv);
3834         /* RT #127786: cv can be NULL due to an eval within the DB package
3835          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3836          * unless they contain an eval, but calling eval within DB
3837          * pretends the eval was done in the caller's scope.
3838          */
3839         if (!cv)
3840             break;
3841         assert(CvPADLIST(cv));
3842         pn =
3843            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3844         assert(PadnameLEN(pn));
3845         PadnameLVALUE_on(pn);
3846     }
3847 }
3848
3849 static bool
3850 S_vivifies(const OPCODE type)
3851 {
3852     switch(type) {
3853     case OP_RV2AV:     case   OP_ASLICE:
3854     case OP_RV2HV:     case OP_KVASLICE:
3855     case OP_RV2SV:     case   OP_HSLICE:
3856     case OP_AELEMFAST: case OP_KVHSLICE:
3857     case OP_HELEM:
3858     case OP_AELEM:
3859         return 1;
3860     }
3861     return 0;
3862 }
3863
3864 static void
3865 S_lvref(pTHX_ OP *o, I32 type)
3866 {
3867     dVAR;
3868     OP *kid;
3869     switch (o->op_type) {
3870     case OP_COND_EXPR:
3871         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3872              kid = OpSIBLING(kid))
3873             S_lvref(aTHX_ kid, type);
3874         /* FALLTHROUGH */
3875     case OP_PUSHMARK:
3876         return;
3877     case OP_RV2AV:
3878         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3879         o->op_flags |= OPf_STACKED;
3880         if (o->op_flags & OPf_PARENS) {
3881             if (o->op_private & OPpLVAL_INTRO) {
3882                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3883                       "localized parenthesized array in list assignment"));
3884                 return;
3885             }
3886           slurpy:
3887             OpTYPE_set(o, OP_LVAVREF);
3888             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3889             o->op_flags |= OPf_MOD|OPf_REF;
3890             return;
3891         }
3892         o->op_private |= OPpLVREF_AV;
3893         goto checkgv;
3894     case OP_RV2CV:
3895         kid = cUNOPo->op_first;
3896         if (kid->op_type == OP_NULL)
3897             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3898                 ->op_first;
3899         o->op_private = OPpLVREF_CV;
3900         if (kid->op_type == OP_GV)
3901             o->op_flags |= OPf_STACKED;
3902         else if (kid->op_type == OP_PADCV) {
3903             o->op_targ = kid->op_targ;
3904             kid->op_targ = 0;
3905             op_free(cUNOPo->op_first);
3906             cUNOPo->op_first = NULL;
3907             o->op_flags &=~ OPf_KIDS;
3908         }
3909         else goto badref;
3910         break;
3911     case OP_RV2HV:
3912         if (o->op_flags & OPf_PARENS) {
3913           parenhash:
3914             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3915                                  "parenthesized hash in list assignment"));
3916                 return;
3917         }
3918         o->op_private |= OPpLVREF_HV;
3919         /* FALLTHROUGH */
3920     case OP_RV2SV:
3921       checkgv:
3922         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3923         o->op_flags |= OPf_STACKED;
3924         break;
3925     case OP_PADHV:
3926         if (o->op_flags & OPf_PARENS) goto parenhash;
3927         o->op_private |= OPpLVREF_HV;
3928         /* FALLTHROUGH */
3929     case OP_PADSV:
3930         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3931         break;
3932     case OP_PADAV:
3933         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3934         if (o->op_flags & OPf_PARENS) goto slurpy;
3935         o->op_private |= OPpLVREF_AV;
3936         break;
3937     case OP_AELEM:
3938     case OP_HELEM:
3939         o->op_private |= OPpLVREF_ELEM;
3940         o->op_flags   |= OPf_STACKED;
3941         break;
3942     case OP_ASLICE:
3943     case OP_HSLICE:
3944         OpTYPE_set(o, OP_LVREFSLICE);
3945         o->op_private &= OPpLVAL_INTRO;
3946         return;
3947     case OP_NULL:
3948         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3949             goto badref;
3950         else if (!(o->op_flags & OPf_KIDS))
3951             return;
3952         if (o->op_targ != OP_LIST) {
3953             S_lvref(aTHX_ cBINOPo->op_first, type);
3954             return;
3955         }
3956         /* FALLTHROUGH */
3957     case OP_LIST:
3958         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3959             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3960             S_lvref(aTHX_ kid, type);
3961         }
3962         return;
3963     case OP_STUB:
3964         if (o->op_flags & OPf_PARENS)
3965             return;
3966         /* FALLTHROUGH */
3967     default:
3968       badref:
3969         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3970         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3971                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3972                       ? "do block"
3973                       : OP_DESC(o),
3974                      PL_op_desc[type]));
3975         return;
3976     }
3977     OpTYPE_set(o, OP_LVREF);
3978     o->op_private &=
3979         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3980     if (type == OP_ENTERLOOP)
3981         o->op_private |= OPpLVREF_ITER;
3982 }
3983
3984 PERL_STATIC_INLINE bool
3985 S_potential_mod_type(I32 type)
3986 {
3987     /* Types that only potentially result in modification.  */
3988     return type == OP_GREPSTART || type == OP_ENTERSUB
3989         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3990 }
3991
3992 OP *
3993 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3994 {
3995     dVAR;
3996     OP *kid;
3997     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3998     int localize = -1;
3999
4000     if (!o || (PL_parser && PL_parser->error_count))
4001         return o;
4002
4003     if ((o->op_private & OPpTARGET_MY)
4004         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4005     {
4006         return o;
4007     }
4008
4009     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4010
4011     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4012
4013     switch (o->op_type) {
4014     case OP_UNDEF:
4015         PL_modcount++;
4016         return o;
4017     case OP_STUB:
4018         if ((o->op_flags & OPf_PARENS))
4019             break;
4020         goto nomod;
4021     case OP_ENTERSUB:
4022         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4023             !(o->op_flags & OPf_STACKED)) {
4024             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4025             assert(cUNOPo->op_first->op_type == OP_NULL);
4026             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4027             break;
4028         }
4029         else {                          /* lvalue subroutine call */
4030             o->op_private |= OPpLVAL_INTRO;
4031             PL_modcount = RETURN_UNLIMITED_NUMBER;
4032             if (S_potential_mod_type(type)) {
4033                 o->op_private |= OPpENTERSUB_INARGS;
4034                 break;
4035             }
4036             else {                      /* Compile-time error message: */
4037                 OP *kid = cUNOPo->op_first;
4038                 CV *cv;
4039                 GV *gv;
4040                 SV *namesv;
4041
4042                 if (kid->op_type != OP_PUSHMARK) {
4043                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4044                         Perl_croak(aTHX_
4045                                 "panic: unexpected lvalue entersub "
4046                                 "args: type/targ %ld:%" UVuf,
4047                                 (long)kid->op_type, (UV)kid->op_targ);
4048                     kid = kLISTOP->op_first;
4049                 }
4050                 while (OpHAS_SIBLING(kid))
4051                     kid = OpSIBLING(kid);
4052                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4053                     break;      /* Postpone until runtime */
4054                 }
4055
4056                 kid = kUNOP->op_first;
4057                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4058                     kid = kUNOP->op_first;
4059                 if (kid->op_type == OP_NULL)
4060                     Perl_croak(aTHX_
4061                                "Unexpected constant lvalue entersub "
4062                                "entry via type/targ %ld:%" UVuf,
4063                                (long)kid->op_type, (UV)kid->op_targ);
4064                 if (kid->op_type != OP_GV) {
4065                     break;
4066                 }
4067
4068                 gv = kGVOP_gv;
4069                 cv = isGV(gv)
4070                     ? GvCV(gv)
4071                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4072                         ? MUTABLE_CV(SvRV(gv))
4073                         : NULL;
4074                 if (!cv)
4075                     break;
4076                 if (CvLVALUE(cv))
4077                     break;
4078                 if (flags & OP_LVALUE_NO_CROAK)
4079                     return NULL;
4080
4081                 namesv = cv_name(cv, NULL, 0);
4082                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4083                                      "subroutine call of &%" SVf " in %s",
4084                                      SVfARG(namesv), PL_op_desc[type]),
4085                            SvUTF8(namesv));
4086                 return o;
4087             }
4088         }
4089         /* FALLTHROUGH */
4090     default:
4091       nomod:
4092         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4093         /* grep, foreach, subcalls, refgen */
4094         if (S_potential_mod_type(type))
4095             break;
4096         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4097                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4098                       ? "do block"
4099                       : OP_DESC(o)),
4100                      type ? PL_op_desc[type] : "local"));
4101         return o;
4102
4103     case OP_PREINC:
4104     case OP_PREDEC:
4105     case OP_POW:
4106     case OP_MULTIPLY:
4107     case OP_DIVIDE:
4108     case OP_MODULO:
4109     case OP_ADD:
4110     case OP_SUBTRACT:
4111     case OP_CONCAT:
4112     case OP_LEFT_SHIFT:
4113     case OP_RIGHT_SHIFT:
4114     case OP_BIT_AND:
4115     case OP_BIT_XOR:
4116     case OP_BIT_OR:
4117     case OP_I_MULTIPLY:
4118     case OP_I_DIVIDE:
4119     case OP_I_MODULO:
4120     case OP_I_ADD:
4121     case OP_I_SUBTRACT:
4122         if (!(o->op_flags & OPf_STACKED))
4123             goto nomod;
4124         PL_modcount++;
4125         break;
4126
4127     case OP_REPEAT:
4128         if (o->op_flags & OPf_STACKED) {
4129             PL_modcount++;
4130             break;
4131         }
4132         if (!(o->op_private & OPpREPEAT_DOLIST))
4133             goto nomod;
4134         else {
4135             const I32 mods = PL_modcount;
4136             modkids(cBINOPo->op_first, type);
4137             if (type != OP_AASSIGN)
4138                 goto nomod;
4139             kid = cBINOPo->op_last;
4140             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4141                 const IV iv = SvIV(kSVOP_sv);
4142                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4143                     PL_modcount =
4144                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4145             }
4146             else
4147                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4148         }
4149         break;
4150
4151     case OP_COND_EXPR:
4152         localize = 1;
4153         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4154             op_lvalue(kid, type);
4155         break;
4156
4157     case OP_RV2AV:
4158     case OP_RV2HV:
4159         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4160            PL_modcount = RETURN_UNLIMITED_NUMBER;
4161            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4162               fiable since some contexts need to know.  */
4163            o->op_flags |= OPf_MOD;
4164            return o;
4165         }
4166         /* FALLTHROUGH */
4167     case OP_RV2GV:
4168         if (scalar_mod_type(o, type))
4169             goto nomod;
4170         ref(cUNOPo->op_first, o->op_type);
4171         /* FALLTHROUGH */
4172     case OP_ASLICE:
4173     case OP_HSLICE:
4174         localize = 1;
4175         /* FALLTHROUGH */
4176     case OP_AASSIGN:
4177         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4178         if (type == OP_LEAVESUBLV && (
4179                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4180              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4181            ))
4182             o->op_private |= OPpMAYBE_LVSUB;
4183         /* FALLTHROUGH */
4184     case OP_NEXTSTATE:
4185     case OP_DBSTATE:
4186        PL_modcount = RETURN_UNLIMITED_NUMBER;
4187         break;
4188     case OP_KVHSLICE:
4189     case OP_KVASLICE:
4190     case OP_AKEYS:
4191         if (type == OP_LEAVESUBLV)
4192             o->op_private |= OPpMAYBE_LVSUB;
4193         goto nomod;
4194     case OP_AVHVSWITCH:
4195         if (type == OP_LEAVESUBLV
4196          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4197             o->op_private |= OPpMAYBE_LVSUB;
4198         goto nomod;
4199     case OP_AV2ARYLEN:
4200         PL_hints |= HINT_BLOCK_SCOPE;
4201         if (type == OP_LEAVESUBLV)
4202             o->op_private |= OPpMAYBE_LVSUB;
4203         PL_modcount++;
4204         break;
4205     case OP_RV2SV:
4206         ref(cUNOPo->op_first, o->op_type);
4207         localize = 1;
4208         /* FALLTHROUGH */
4209     case OP_GV:
4210         PL_hints |= HINT_BLOCK_SCOPE;
4211         /* FALLTHROUGH */
4212     case OP_SASSIGN:
4213     case OP_ANDASSIGN:
4214     case OP_ORASSIGN:
4215     case OP_DORASSIGN:
4216         PL_modcount++;
4217         break;
4218
4219     case OP_AELEMFAST:
4220     case OP_AELEMFAST_LEX:
4221         localize = -1;
4222         PL_modcount++;
4223         break;
4224
4225     case OP_PADAV:
4226     case OP_PADHV:
4227        PL_modcount = RETURN_UNLIMITED_NUMBER;
4228         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4229         {
4230            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4231               fiable since some contexts need to know.  */
4232             o->op_flags |= OPf_MOD;
4233             return o;
4234         }
4235         if (scalar_mod_type(o, type))
4236             goto nomod;
4237         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4238           && type == OP_LEAVESUBLV)
4239             o->op_private |= OPpMAYBE_LVSUB;
4240         /* FALLTHROUGH */
4241     case OP_PADSV:
4242         PL_modcount++;
4243         if (!type) /* local() */
4244             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4245                               PNfARG(PAD_COMPNAME(o->op_targ)));
4246         if (!(o->op_private & OPpLVAL_INTRO)
4247          || (  type != OP_SASSIGN && type != OP_AASSIGN
4248             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4249             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4250         break;
4251
4252     case OP_PUSHMARK:
4253         localize = 0;
4254         break;
4255
4256     case OP_KEYS:
4257         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4258             goto nomod;
4259         goto lvalue_func;
4260     case OP_SUBSTR:
4261         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4262             goto nomod;
4263         /* FALLTHROUGH */
4264     case OP_POS:
4265     case OP_VEC:
4266       lvalue_func:
4267         if (type == OP_LEAVESUBLV)
4268             o->op_private |= OPpMAYBE_LVSUB;
4269         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4270             /* substr and vec */
4271             /* If this op is in merely potential (non-fatal) modifiable
4272                context, then apply OP_ENTERSUB context to
4273                the kid op (to avoid croaking).  Other-
4274                wise pass this op’s own type so the correct op is mentioned
4275                in error messages.  */
4276             op_lvalue(OpSIBLING(cBINOPo->op_first),
4277                       S_potential_mod_type(type)
4278                         ? (I32)OP_ENTERSUB
4279                         : o->op_type);
4280         }
4281         break;
4282
4283     case OP_AELEM:
4284     case OP_HELEM:
4285         ref(cBINOPo->op_first, o->op_type);
4286         if (type == OP_ENTERSUB &&
4287              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4288             o->op_private |= OPpLVAL_DEFER;
4289         if (type == OP_LEAVESUBLV)
4290             o->op_private |= OPpMAYBE_LVSUB;
4291         localize = 1;
4292         PL_modcount++;
4293         break;
4294
4295     case OP_LEAVE:
4296     case OP_LEAVELOOP:
4297         o->op_private |= OPpLVALUE;
4298         /* FALLTHROUGH */
4299     case OP_SCOPE:
4300     case OP_ENTER:
4301     case OP_LINESEQ:
4302         localize = 0;
4303         if (o->op_flags & OPf_KIDS)
4304             op_lvalue(cLISTOPo->op_last, type);
4305         break;
4306
4307     case OP_NULL:
4308         localize = 0;
4309         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4310             goto nomod;
4311         else if (!(o->op_flags & OPf_KIDS))
4312             break;
4313
4314         if (o->op_targ != OP_LIST) {
4315             OP *sib = OpSIBLING(cLISTOPo->op_first);
4316             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4317              * that looks like
4318              *
4319              *   null
4320              *      arg
4321              *      trans
4322              *
4323              * compared with things like OP_MATCH which have the argument
4324              * as a child:
4325              *
4326              *   match
4327              *      arg
4328              *
4329              * so handle specially to correctly get "Can't modify" croaks etc
4330              */
4331
4332             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4333             {
4334                 /* this should trigger a "Can't modify transliteration" err */
4335                 op_lvalue(sib, type);
4336             }
4337             op_lvalue(cBINOPo->op_first, type);
4338             break;
4339         }
4340         /* FALLTHROUGH */
4341     case OP_LIST:
4342         localize = 0;
4343         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4344             /* elements might be in void context because the list is
4345                in scalar context or because they are attribute sub calls */
4346             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4347                 op_lvalue(kid, type);
4348         break;
4349
4350     case OP_COREARGS:
4351         return o;
4352
4353     case OP_AND:
4354     case OP_OR:
4355         if (type == OP_LEAVESUBLV
4356          || !S_vivifies(cLOGOPo->op_first->op_type))
4357             op_lvalue(cLOGOPo->op_first, type);
4358         if (type == OP_LEAVESUBLV
4359          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4360             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4361         goto nomod;
4362
4363     case OP_SREFGEN:
4364         if (type == OP_NULL) { /* local */
4365           local_refgen:
4366             if (!FEATURE_MYREF_IS_ENABLED)
4367                 Perl_croak(aTHX_ "The experimental declared_refs "
4368                                  "feature is not enabled");
4369             Perl_ck_warner_d(aTHX_
4370                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4371                     "Declaring references is experimental");
4372             op_lvalue(cUNOPo->op_first, OP_NULL);
4373             return o;
4374         }
4375         if (type != OP_AASSIGN && type != OP_SASSIGN
4376          && type != OP_ENTERLOOP)
4377             goto nomod;
4378         /* Don’t bother applying lvalue context to the ex-list.  */
4379         kid = cUNOPx(cUNOPo->op_first)->op_first;
4380         assert (!OpHAS_SIBLING(kid));
4381         goto kid_2lvref;
4382     case OP_REFGEN:
4383         if (type == OP_NULL) /* local */
4384             goto local_refgen;
4385         if (type != OP_AASSIGN) goto nomod;
4386         kid = cUNOPo->op_first;
4387       kid_2lvref:
4388         {
4389             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4390             S_lvref(aTHX_ kid, type);
4391             if (!PL_parser || PL_parser->error_count == ec) {
4392                 if (!FEATURE_REFALIASING_IS_ENABLED)
4393                     Perl_croak(aTHX_
4394                        "Experimental aliasing via reference not enabled");
4395                 Perl_ck_warner_d(aTHX_
4396                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4397                                 "Aliasing via reference is experimental");
4398             }
4399         }
4400         if (o->op_type == OP_REFGEN)
4401             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4402         op_null(o);
4403         return o;
4404
4405     case OP_SPLIT:
4406         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4407             /* This is actually @array = split.  */
4408             PL_modcount = RETURN_UNLIMITED_NUMBER;
4409             break;
4410         }
4411         goto nomod;
4412
4413     case OP_SCALAR:
4414         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4415         goto nomod;
4416     }
4417
4418     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4419        their argument is a filehandle; thus \stat(".") should not set
4420        it. AMS 20011102 */
4421     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4422         return o;
4423
4424     if (type != OP_LEAVESUBLV)
4425         o->op_flags |= OPf_MOD;
4426
4427     if (type == OP_AASSIGN || type == OP_SASSIGN)
4428         o->op_flags |= OPf_SPECIAL
4429                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4430     else if (!type) { /* local() */
4431         switch (localize) {
4432         case 1:
4433             o->op_private |= OPpLVAL_INTRO;
4434             o->op_flags &= ~OPf_SPECIAL;
4435             PL_hints |= HINT_BLOCK_SCOPE;
4436             break;
4437         case 0:
4438             break;
4439         case -1:
4440             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4441                            "Useless localization of %s", OP_DESC(o));
4442         }
4443     }
4444     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4445              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4446         o->op_flags |= OPf_REF;
4447     return o;
4448 }
4449
4450 STATIC bool
4451 S_scalar_mod_type(const OP *o, I32 type)
4452 {
4453     switch (type) {
4454     case OP_POS:
4455     case OP_SASSIGN:
4456         if (o && o->op_type == OP_RV2GV)
4457             return FALSE;
4458         /* FALLTHROUGH */
4459     case OP_PREINC:
4460     case OP_PREDEC:
4461     case OP_POSTINC:
4462     case OP_POSTDEC:
4463     case OP_I_PREINC:
4464     case OP_I_PREDEC:
4465     case OP_I_POSTINC:
4466     case OP_I_POSTDEC:
4467     case OP_POW:
4468     case OP_MULTIPLY:
4469     case OP_DIVIDE:
4470     case OP_MODULO:
4471     case OP_REPEAT:
4472     case OP_ADD:
4473     case OP_SUBTRACT:
4474     case OP_I_MULTIPLY:
4475     case OP_I_DIVIDE:
4476     case OP_I_MODULO:
4477     case OP_I_ADD:
4478     case OP_I_SUBTRACT:
4479     case OP_LEFT_SHIFT:
4480     case OP_RIGHT_SHIFT:
4481     case OP_BIT_AND:
4482     case OP_BIT_XOR:
4483     case OP_BIT_OR:
4484     case OP_NBIT_AND:
4485     case OP_NBIT_XOR:
4486     case OP_NBIT_OR:
4487     case OP_SBIT_AND:
4488     case OP_SBIT_XOR:
4489     case OP_SBIT_OR:
4490     case OP_CONCAT:
4491     case OP_SUBST:
4492     case OP_TRANS:
4493     case OP_TRANSR:
4494     case OP_READ:
4495     case OP_SYSREAD:
4496     case OP_RECV:
4497     case OP_ANDASSIGN:
4498     case OP_ORASSIGN:
4499     case OP_DORASSIGN:
4500     case OP_VEC:
4501     case OP_SUBSTR:
4502         return TRUE;
4503     default:
4504         return FALSE;
4505     }
4506 }
4507
4508 STATIC bool
4509 S_is_handle_constructor(const OP *o, I32 numargs)
4510 {
4511     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4512
4513     switch (o->op_type) {
4514     case OP_PIPE_OP:
4515     case OP_SOCKPAIR:
4516         if (numargs == 2)
4517             return TRUE;
4518         /* FALLTHROUGH */
4519     case OP_SYSOPEN:
4520     case OP_OPEN:
4521     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4522     case OP_SOCKET:
4523     case OP_OPEN_DIR:
4524     case OP_ACCEPT:
4525         if (numargs == 1)
4526             return TRUE;
4527         /* FALLTHROUGH */
4528     default:
4529         return FALSE;
4530     }
4531 }
4532
4533 static OP *
4534 S_refkids(pTHX_ OP *o, I32 type)
4535 {
4536     if (o && o->op_flags & OPf_KIDS) {
4537         OP *kid;
4538         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4539             ref(kid, type);
4540     }
4541     return o;
4542 }
4543
4544 OP *
4545 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4546 {
4547     dVAR;
4548     OP *kid;
4549
4550     PERL_ARGS_ASSERT_DOREF;
4551
4552     if (PL_parser && PL_parser->error_count)
4553         return o;
4554
4555     switch (o->op_type) {
4556     case OP_ENTERSUB:
4557         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4558             !(o->op_flags & OPf_STACKED)) {
4559             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4560             assert(cUNOPo->op_first->op_type == OP_NULL);
4561             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4562             o->op_flags |= OPf_SPECIAL;
4563         }
4564         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4565             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4566                               : type == OP_RV2HV ? OPpDEREF_HV
4567                               : OPpDEREF_SV);
4568             o->op_flags |= OPf_MOD;
4569         }
4570
4571         break;
4572
4573     case OP_COND_EXPR:
4574         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4575             doref(kid, type, set_op_ref);
4576         break;
4577     case OP_RV2SV:
4578         if (type == OP_DEFINED)
4579             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4580         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4581         /* FALLTHROUGH */
4582     case OP_PADSV:
4583         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4584             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4585                               : type == OP_RV2HV ? OPpDEREF_HV
4586                               : OPpDEREF_SV);
4587             o->op_flags |= OPf_MOD;
4588         }
4589         break;
4590
4591     case OP_RV2AV:
4592     case OP_RV2HV:
4593         if (set_op_ref)
4594             o->op_flags |= OPf_REF;
4595         /* FALLTHROUGH */
4596     case OP_RV2GV:
4597         if (type == OP_DEFINED)
4598             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4599         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4600         break;
4601
4602     case OP_PADAV:
4603     case OP_PADHV:
4604         if (set_op_ref)
4605             o->op_flags |= OPf_REF;
4606         break;
4607
4608     case OP_SCALAR:
4609     case OP_NULL:
4610         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4611             break;
4612         doref(cBINOPo->op_first, type, set_op_ref);
4613         break;
4614     case OP_AELEM:
4615     case OP_HELEM:
4616         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4617         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4618             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4619                               : type == OP_RV2HV ? OPpDEREF_HV
4620                               : OPpDEREF_SV);
4621             o->op_flags |= OPf_MOD;
4622         }
4623         break;
4624
4625     case OP_SCOPE:
4626     case OP_LEAVE:
4627         set_op_ref = FALSE;
4628         /* FALLTHROUGH */
4629     case OP_ENTER:
4630     case OP_LIST:
4631         if (!(o->op_flags & OPf_KIDS))
4632             break;
4633         doref(cLISTOPo->op_last, type, set_op_ref);
4634         break;
4635     default:
4636         break;
4637     }
4638     return scalar(o);
4639
4640 }
4641
4642 STATIC OP *
4643 S_dup_attrlist(pTHX_ OP *o)
4644 {
4645     OP *rop;
4646
4647     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4648
4649     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4650      * where the first kid is OP_PUSHMARK and the remaining ones
4651      * are OP_CONST.  We need to push the OP_CONST values.
4652      */
4653     if (o->op_type == OP_CONST)
4654         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4655     else {
4656         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4657         rop = NULL;
4658         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4659             if (o->op_type == OP_CONST)
4660                 rop = op_append_elem(OP_LIST, rop,
4661                                   newSVOP(OP_CONST, o->op_flags,
4662                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4663         }
4664     }
4665     return rop;
4666 }
4667
4668 STATIC void
4669 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4670 {
4671     PERL_ARGS_ASSERT_APPLY_ATTRS;
4672     {
4673         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4674
4675         /* fake up C<use attributes $pkg,$rv,@attrs> */
4676
4677 #define ATTRSMODULE "attributes"
4678 #define ATTRSMODULE_PM "attributes.pm"
4679
4680         Perl_load_module(
4681           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4682           newSVpvs(ATTRSMODULE),
4683           NULL,
4684           op_prepend_elem(OP_LIST,
4685                           newSVOP(OP_CONST, 0, stashsv),
4686                           op_prepend_elem(OP_LIST,
4687                                           newSVOP(OP_CONST, 0,
4688                                                   newRV(target)),
4689                                           dup_attrlist(attrs))));
4690     }
4691 }
4692
4693 STATIC void
4694 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4695 {
4696     OP *pack, *imop, *arg;
4697     SV *meth, *stashsv, **svp;
4698
4699     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4700
4701     if (!attrs)
4702         return;
4703
4704     assert(target->op_type == OP_PADSV ||
4705            target->op_type == OP_PADHV ||
4706            target->op_type == OP_PADAV);
4707
4708     /* Ensure that attributes.pm is loaded. */
4709     /* Don't force the C<use> if we don't need it. */
4710     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4711     if (svp && *svp != &PL_sv_undef)
4712         NOOP;   /* already in %INC */
4713     else
4714         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4715                                newSVpvs(ATTRSMODULE), NULL);
4716
4717     /* Need package name for method call. */
4718     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));