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