op.c

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