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