op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define dDEFER_OP  \
 179     SSize_t defer_stack_alloc = 0; \
 180     SSize_t defer_ix = -1; \
 181     OP **defer_stack = NULL;
 182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
 183 #define DEFERRED_OP_STEP 100
 184 #define DEFER_OP(o) \
 185   STMT_START { \
 186     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 187         defer_stack_alloc += DEFERRED_OP_STEP; \
 188         assert(defer_stack_alloc > 0); \
 189         Renew(defer_stack, defer_stack_alloc, OP *); \
 190     } \
 191     defer_stack[++defer_ix] = o; \
 192   } STMT_END
 193
 194 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 195
 196 /* remove any leading "empty" ops from the op_next chain whose first
 197  * node's address is stored in op_p. Store the updated address of the
 198  * first node in op_p.
 199  */
 200
 201 STATIC void
 202 S_prune_chain_head(OP** op_p)
 203 {
 204     while (*op_p
 205         && (   (*op_p)->op_type == OP_NULL
 206             || (*op_p)->op_type == OP_SCOPE
 207             || (*op_p)->op_type == OP_SCALAR
 208             || (*op_p)->op_type == OP_LINESEQ)
 209     )
 210         *op_p = (*op_p)->op_next;
 211 }
 212
 213
 214 /* See the explanatory comments above struct opslab in op.h. */
 215
 216 #ifdef PERL_DEBUG_READONLY_OPS
 217 #  define PERL_SLAB_SIZE 128
 218 #  define PERL_MAX_SLAB_SIZE 4096
 219 #  include <sys/mman.h>
 220 #endif
 221
 222 #ifndef PERL_SLAB_SIZE
 223 #  define PERL_SLAB_SIZE 64
 224 #endif
 225 #ifndef PERL_MAX_SLAB_SIZE
 226 #  define PERL_MAX_SLAB_SIZE 2048
 227 #endif
 228
 229 /* rounds up to nearest pointer */
 230 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 231 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 232
 233 static OPSLAB *
 234 S_new_slab(pTHX_ size_t sz)
 235 {
 236 #ifdef PERL_DEBUG_READONLY_OPS
 237     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 238                                    PROT_READ|PROT_WRITE,
 239                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 240     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 241                           (unsigned long) sz, slab));
 242     if (slab == MAP_FAILED) {
 243         perror("mmap failed");
 244         abort();
 245     }
 246     slab->opslab_size = (U16)sz;
 247 #else
 248     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 249 #endif
 250 #ifndef WIN32
 251     /* The context is unused in non-Windows */
 252     PERL_UNUSED_CONTEXT;
 253 #endif
 254     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 255     return slab;
 256 }
 257
 258 /* requires double parens and aTHX_ */
 259 #define DEBUG_S_warn(args)                                             \
 260     DEBUG_S(                                                            \
 261         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 262     )
 263
 264 void *
 265 Perl_Slab_Alloc(pTHX_ size_t sz)
 266 {
 267     OPSLAB *slab;
 268     OPSLAB *slab2;
 269     OPSLOT *slot;
 270     OP *o;
 271     size_t opsz, space;
 272
 273     /* We only allocate ops from the slab during subroutine compilation.
 274        We find the slab via PL_compcv, hence that must be non-NULL. It could
 275        also be pointing to a subroutine which is now fully set up (CvROOT()
 276        pointing to the top of the optree for that sub), or a subroutine
 277        which isn't using the slab allocator. If our sanity checks aren't met,
 278        don't use a slab, but allocate the OP directly from the heap.  */
 279     if (!PL_compcv || CvROOT(PL_compcv)
 280      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 281     {
 282         o = (OP*)PerlMemShared_calloc(1, sz);
 283         goto gotit;
 284     }
 285
 286     /* While the subroutine is under construction, the slabs are accessed via
 287        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 288        unneeded at runtime. Once a subroutine is constructed, the slabs are
 289        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 290        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 291        details.  */
 292     if (!CvSTART(PL_compcv)) {
 293         CvSTART(PL_compcv) =
 294             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 295         CvSLABBED_on(PL_compcv);
 296         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 297     }
 298     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 299
 300     opsz = SIZE_TO_PSIZE(sz);
 301     sz = opsz + OPSLOT_HEADER_P;
 302
 303     /* The slabs maintain a free list of OPs. In particular, constant folding
 304        will free up OPs, so it makes sense to re-use them where possible. A
 305        freed up slot is used in preference to a new allocation.  */
 306     if (slab->opslab_freed) {
 307         OP **too = &slab->opslab_freed;
 308         o = *too;
 309         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 310         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 311             DEBUG_S_warn((aTHX_ "Alas! too small"));
 312             o = *(too = &o->op_next);
 313             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 314         }
 315         if (o) {
 316             *too = o->op_next;
 317             Zero(o, opsz, I32 *);
 318             o->op_slabbed = 1;
 319             goto gotit;
 320         }
 321     }
 322
 323 #define INIT_OPSLOT \
 324             slot->opslot_slab = slab;                   \
 325             slot->opslot_next = slab2->opslab_first;    \
 326             slab2->opslab_first = slot;                 \
 327             o = &slot->opslot_op;                       \
 328             o->op_slabbed = 1
 329
 330     /* The partially-filled slab is next in the chain. */
 331     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 332     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 333         /* Remaining space is too small. */
 334
 335         /* If we can fit a BASEOP, add it to the free chain, so as not
 336            to waste it. */
 337         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 338             slot = &slab2->opslab_slots;
 339             INIT_OPSLOT;
 340             o->op_type = OP_FREED;
 341             o->op_next = slab->opslab_freed;
 342             slab->opslab_freed = o;
 343         }
 344
 345         /* Create a new slab.  Make this one twice as big. */
 346         slot = slab2->opslab_first;
 347         while (slot->opslot_next) slot = slot->opslot_next;
 348         slab2 = S_new_slab(aTHX_
 349                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 350                                         ? PERL_MAX_SLAB_SIZE
 351                                         : (DIFF(slab2, slot)+1)*2);
 352         slab2->opslab_next = slab->opslab_next;
 353         slab->opslab_next = slab2;
 354     }
 355     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 356
 357     /* Create a new op slot */
 358     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 359     assert(slot >= &slab2->opslab_slots);
 360     if (DIFF(&slab2->opslab_slots, slot)
 361          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 362         slot = &slab2->opslab_slots;
 363     INIT_OPSLOT;
 364     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 365
 366   gotit:
 367     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 368     assert(!o->op_moresib);
 369     assert(!o->op_sibparent);
 370
 371     return (void *)o;
 372 }
 373
 374 #undef INIT_OPSLOT
 375
 376 #ifdef PERL_DEBUG_READONLY_OPS
 377 void
 378 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 379 {
 380     PERL_ARGS_ASSERT_SLAB_TO_RO;
 381
 382     if (slab->opslab_readonly) return;
 383     slab->opslab_readonly = 1;
 384     for (; slab; slab = slab->opslab_next) {
 385         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 386                               (unsigned long) slab->opslab_size, slab));*/
 387         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 388             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 389                              (unsigned long)slab->opslab_size, errno);
 390     }
 391 }
 392
 393 void
 394 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 395 {
 396     OPSLAB *slab2;
 397
 398     PERL_ARGS_ASSERT_SLAB_TO_RW;
 399
 400     if (!slab->opslab_readonly) return;
 401     slab2 = slab;
 402     for (; slab2; slab2 = slab2->opslab_next) {
 403         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 404                               (unsigned long) size, slab2));*/
 405         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 406                      PROT_READ|PROT_WRITE)) {
 407             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 408                              (unsigned long)slab2->opslab_size, errno);
 409         }
 410     }
 411     slab->opslab_readonly = 0;
 412 }
 413
 414 #else
 415 #  define Slab_to_rw(op)    NOOP
 416 #endif
 417
 418 /* This cannot possibly be right, but it was copied from the old slab
 419    allocator, to which it was originally added, without explanation, in
 420    commit 083fcd5. */
 421 #ifdef NETWARE
 422 #    define PerlMemShared PerlMem
 423 #endif
 424
 425 /* make freed ops die if they're inadvertently executed */
 426 #ifdef DEBUGGING
 427 static OP *
 428 S_pp_freed(pTHX)
 429 {
 430     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 431 }
 432 #endif
 433
 434 void
 435 Perl_Slab_Free(pTHX_ void *op)
 436 {
 437     OP * const o = (OP *)op;
 438     OPSLAB *slab;
 439
 440     PERL_ARGS_ASSERT_SLAB_FREE;
 441
 442 #ifdef DEBUGGING
 443     o->op_ppaddr = S_pp_freed;
 444 #endif
 445
 446     if (!o->op_slabbed) {
 447         if (!o->op_static)
 448             PerlMemShared_free(op);
 449         return;
 450     }
 451
 452     slab = OpSLAB(o);
 453     /* If this op is already freed, our refcount will get screwy. */
 454     assert(o->op_type != OP_FREED);
 455     o->op_type = OP_FREED;
 456     o->op_next = slab->opslab_freed;
 457     slab->opslab_freed = o;
 458     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 459     OpslabREFCNT_dec_padok(slab);
 460 }
 461
 462 void
 463 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 464 {
 465     const bool havepad = !!PL_comppad;
 466     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 467     if (havepad) {
 468         ENTER;
 469         PAD_SAVE_SETNULLPAD();
 470     }
 471     opslab_free(slab);
 472     if (havepad) LEAVE;
 473 }
 474
 475 void
 476 Perl_opslab_free(pTHX_ OPSLAB *slab)
 477 {
 478     OPSLAB *slab2;
 479     PERL_ARGS_ASSERT_OPSLAB_FREE;
 480     PERL_UNUSED_CONTEXT;
 481     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 482     assert(slab->opslab_refcnt == 1);
 483     do {
 484         slab2 = slab->opslab_next;
 485 #ifdef DEBUGGING
 486         slab->opslab_refcnt = ~(size_t)0;
 487 #endif
 488 #ifdef PERL_DEBUG_READONLY_OPS
 489         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 490                                                (void*)slab));
 491         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 492             perror("munmap failed");
 493             abort();
 494         }
 495 #else
 496         PerlMemShared_free(slab);
 497 #endif
 498         slab = slab2;
 499     } while (slab);
 500 }
 501
 502 void
 503 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 504 {
 505     OPSLAB *slab2;
 506 #ifdef DEBUGGING
 507     size_t savestack_count = 0;
 508 #endif
 509     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 510     slab2 = slab;
 511     do {
 512         OPSLOT *slot;
 513         for (slot = slab2->opslab_first;
 514              slot->opslot_next;
 515              slot = slot->opslot_next) {
 516             if (slot->opslot_op.op_type != OP_FREED
 517              && !(slot->opslot_op.op_savefree
 518 #ifdef DEBUGGING
 519                   && ++savestack_count
 520 #endif
 521                  )
 522             ) {
 523                 assert(slot->opslot_op.op_slabbed);
 524                 op_free(&slot->opslot_op);
 525                 if (slab->opslab_refcnt == 1) goto free;
 526             }
 527         }
 528     } while ((slab2 = slab2->opslab_next));
 529     /* > 1 because the CV still holds a reference count. */
 530     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 531 #ifdef DEBUGGING
 532         assert(savestack_count == slab->opslab_refcnt-1);
 533 #endif
 534         /* Remove the CV’s reference count. */
 535         slab->opslab_refcnt--;
 536         return;
 537     }
 538    free:
 539     opslab_free(slab);
 540 }
 541
 542 #ifdef PERL_DEBUG_READONLY_OPS
 543 OP *
 544 Perl_op_refcnt_inc(pTHX_ OP *o)
 545 {
 546     if(o) {
 547         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 548         if (slab && slab->opslab_readonly) {
 549             Slab_to_rw(slab);
 550             ++o->op_targ;
 551             Slab_to_ro(slab);
 552         } else {
 553             ++o->op_targ;
 554         }
 555     }
 556     return o;
 557
 558 }
 559
 560 PADOFFSET
 561 Perl_op_refcnt_dec(pTHX_ OP *o)
 562 {
 563     PADOFFSET result;
 564     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 565
 566     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 567
 568     if (slab && slab->opslab_readonly) {
 569         Slab_to_rw(slab);
 570         result = --o->op_targ;
 571         Slab_to_ro(slab);
 572     } else {
 573         result = --o->op_targ;
 574     }
 575     return result;
 576 }
 577 #endif
 578 /*
 579  * In the following definition, the ", (OP*)0" is just to make the compiler
 580  * think the expression is of the right type: croak actually does a Siglongjmp.
 581  */
 582 #define CHECKOP(type,o) \
 583     ((PL_op_mask && PL_op_mask[type])                           \
 584      ? ( op_free((OP*)o),                                       \
 585          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 586          (OP*)0 )                                               \
 587      : PL_check[type](aTHX_ (OP*)o))
 588
 589 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 590
 591 #define OpTYPE_set(o,type) \
 592     STMT_START {                                \
 593         o->op_type = (OPCODE)type;              \
 594         o->op_ppaddr = PL_ppaddr[type];         \
 595     } STMT_END
 596
 597 STATIC OP *
 598 S_no_fh_allowed(pTHX_ OP *o)
 599 {
 600     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 601
 602     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 603                  OP_DESC(o)));
 604     return o;
 605 }
 606
 607 STATIC OP *
 608 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 609 {
 610     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 611     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 612     return o;
 613 }
 614
 615 STATIC OP *
 616 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 617 {
 618     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 619
 620     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 621     return o;
 622 }
 623
 624 STATIC void
 625 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 626 {
 627     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 628
 629     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 630                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 631 }
 632
 633 /* remove flags var, its unused in all callers, move to to right end since gv
 634   and kid are always the same */
 635 STATIC void
 636 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 637 {
 638     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 639     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 640
 641     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 642                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 643 }
 644
 645 STATIC void
 646 S_no_bareword_allowed(pTHX_ OP *o)
 647 {
 648     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 649
 650     qerror(Perl_mess(aTHX_
 651                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 652                      SVfARG(cSVOPo_sv)));
 653     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 654 }
 655
 656 /* "register" allocation */
 657
 658 PADOFFSET
 659 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 660 {
 661     PADOFFSET off;
 662     const bool is_our = (PL_parser->in_my == KEY_our);
 663
 664     PERL_ARGS_ASSERT_ALLOCMY;
 665
 666     if (flags & ~SVf_UTF8)
 667         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 668                    (UV)flags);
 669
 670     /* complain about "my $<special_var>" etc etc */
 671     if (   len
 672         && !(  is_our
 673             || isALPHA(name[1])
 674             || (   (flags & SVf_UTF8)
 675                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 676             || (name[1] == '_' && len > 2)))
 677     {
 678         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 679          && isASCII(name[1])
 680          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 681             /* diag_listed_as: Can't use global %s in "%s" */
 682             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 683                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 684                               PL_parser->in_my == KEY_state ? "state" : "my"));
 685         } else {
 686             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 687                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 688         }
 689     }
 690
 691     /* allocate a spare slot and store the name in that slot */
 692
 693     off = pad_add_name_pvn(name, len,
 694                        (is_our ? padadd_OUR :
 695                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 696                     PL_parser->in_my_stash,
 697                     (is_our
 698                         /* $_ is always in main::, even with our */
 699                         ? (PL_curstash && !memEQs(name,len,"$_")
 700                             ? PL_curstash
 701                             : PL_defstash)
 702                         : NULL
 703                     )
 704     );
 705     /* anon sub prototypes contains state vars should always be cloned,
 706      * otherwise the state var would be shared between anon subs */
 707
 708     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 709         CvCLONE_on(PL_compcv);
 710
 711     return off;
 712 }
 713
 714 /*
 715 =head1 Optree Manipulation Functions
 716
 717 =for apidoc alloccopstash
 718
 719 Available only under threaded builds, this function allocates an entry in
 720 C<PL_stashpad> for the stash passed to it.
 721
 722 =cut
 723 */
 724
 725 #ifdef USE_ITHREADS
 726 PADOFFSET
 727 Perl_alloccopstash(pTHX_ HV *hv)
 728 {
 729     PADOFFSET off = 0, o = 1;
 730     bool found_slot = FALSE;
 731
 732     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 733
 734     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 735
 736     for (; o < PL_stashpadmax; ++o) {
 737         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 738         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 739             found_slot = TRUE, off = o;
 740     }
 741     if (!found_slot) {
 742         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 743         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 744         off = PL_stashpadmax;
 745         PL_stashpadmax += 10;
 746     }
 747
 748     PL_stashpad[PL_stashpadix = off] = hv;
 749     return off;
 750 }
 751 #endif
 752
 753 /* free the body of an op without examining its contents.
 754  * Always use this rather than FreeOp directly */
 755
 756 static void
 757 S_op_destroy(pTHX_ OP *o)
 758 {
 759     FreeOp(o);
 760 }
 761
 762 /* Destructor */
 763
 764 /*
 765 =for apidoc Am|void|op_free|OP *o
 766
 767 Free an op.  Only use this when an op is no longer linked to from any
 768 optree.
 769
 770 =cut
 771 */
 772
 773 void
 774 Perl_op_free(pTHX_ OP *o)
 775 {
 776     dVAR;
 777     OPCODE type;
 778     dDEFER_OP;
 779
 780     do {
 781
 782         /* Though ops may be freed twice, freeing the op after its slab is a
 783            big no-no. */
 784         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 785         /* During the forced freeing of ops after compilation failure, kidops
 786            may be freed before their parents. */
 787         if (!o || o->op_type == OP_FREED)
 788             continue;
 789
 790         type = o->op_type;
 791
 792         /* an op should only ever acquire op_private flags that we know about.
 793          * If this fails, you may need to fix something in regen/op_private.
 794          * Don't bother testing if:
 795          *   * the op_ppaddr doesn't match the op; someone may have
 796          *     overridden the op and be doing strange things with it;
 797          *   * we've errored, as op flags are often left in an
 798          *     inconsistent state then. Note that an error when
 799          *     compiling the main program leaves PL_parser NULL, so
 800          *     we can't spot faults in the main code, only
 801          *     evaled/required code */
 802 #ifdef DEBUGGING
 803         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 804             && PL_parser
 805             && !PL_parser->error_count)
 806         {
 807             assert(!(o->op_private & ~PL_op_private_valid[type]));
 808         }
 809 #endif
 810
 811         if (o->op_private & OPpREFCOUNTED) {
 812             switch (type) {
 813             case OP_LEAVESUB:
 814             case OP_LEAVESUBLV:
 815             case OP_LEAVEEVAL:
 816             case OP_LEAVE:
 817             case OP_SCOPE:
 818             case OP_LEAVEWRITE:
 819                 {
 820                 PADOFFSET refcnt;
 821                 OP_REFCNT_LOCK;
 822                 refcnt = OpREFCNT_dec(o);
 823                 OP_REFCNT_UNLOCK;
 824                 if (refcnt) {
 825                     /* Need to find and remove any pattern match ops from the list
 826                        we maintain for reset().  */
 827                     find_and_forget_pmops(o);
 828                     continue;
 829                 }
 830                 }
 831                 break;
 832             default:
 833                 break;
 834             }
 835         }
 836
 837         /* Call the op_free hook if it has been set. Do it now so that it's called
 838          * at the right time for refcounted ops, but still before all of the kids
 839          * are freed. */
 840         CALL_OPFREEHOOK(o);
 841
 842         if (o->op_flags & OPf_KIDS) {
 843             OP *kid, *nextkid;
 844             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 845                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 846                 if (!kid || kid->op_type == OP_FREED)
 847                     /* During the forced freeing of ops after
 848                        compilation failure, kidops may be freed before
 849                        their parents. */
 850                     continue;
 851                 if (!(kid->op_flags & OPf_KIDS))
 852                     /* If it has no kids, just free it now */
 853                     op_free(kid);
 854                 else
 855                     DEFER_OP(kid);
 856             }
 857         }
 858         if (type == OP_NULL)
 859             type = (OPCODE)o->op_targ;
 860
 861         if (o->op_slabbed)
 862             Slab_to_rw(OpSLAB(o));
 863
 864         /* COP* is not cleared by op_clear() so that we may track line
 865          * numbers etc even after null() */
 866         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 867             cop_free((COP*)o);
 868         }
 869
 870         op_clear(o);
 871         FreeOp(o);
 872         if (PL_op == o)
 873             PL_op = NULL;
 874     } while ( (o = POP_DEFERRED_OP()) );
 875
 876     DEFER_OP_CLEANUP;
 877 }
 878
 879 /* S_op_clear_gv(): free a GV attached to an OP */
 880
 881 STATIC
 882 #ifdef USE_ITHREADS
 883 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 884 #else
 885 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 886 #endif
 887 {
 888
 889     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 890             || o->op_type == OP_MULTIDEREF)
 891 #ifdef USE_ITHREADS
 892                 && PL_curpad
 893                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 894 #else
 895                 ? (GV*)(*svp) : NULL;
 896 #endif
 897     /* It's possible during global destruction that the GV is freed
 898        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 899        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 900        will trigger an assertion failure, because the entry to sv_clear
 901        checks that the scalar is not already freed.  A check of for
 902        !SvIS_FREED(gv) turns out to be invalid, because during global
 903        destruction the reference count can be forced down to zero
 904        (with SVf_BREAK set).  In which case raising to 1 and then
 905        dropping to 0 triggers cleanup before it should happen.  I
 906        *think* that this might actually be a general, systematic,
 907        weakness of the whole idea of SVf_BREAK, in that code *is*
 908        allowed to raise and lower references during global destruction,
 909        so any *valid* code that happens to do this during global
 910        destruction might well trigger premature cleanup.  */
 911     bool still_valid = gv && SvREFCNT(gv);
 912
 913     if (still_valid)
 914         SvREFCNT_inc_simple_void(gv);
 915 #ifdef USE_ITHREADS
 916     if (*ixp > 0) {
 917         pad_swipe(*ixp, TRUE);
 918         *ixp = 0;
 919     }
 920 #else
 921     SvREFCNT_dec(*svp);
 922     *svp = NULL;
 923 #endif
 924     if (still_valid) {
 925         int try_downgrade = SvREFCNT(gv) == 2;
 926         SvREFCNT_dec_NN(gv);
 927         if (try_downgrade)
 928             gv_try_downgrade(gv);
 929     }
 930 }
 931
 932
 933 void
 934 Perl_op_clear(pTHX_ OP *o)
 935 {
 936
 937     dVAR;
 938
 939     PERL_ARGS_ASSERT_OP_CLEAR;
 940
 941     switch (o->op_type) {
 942     case OP_NULL:       /* Was holding old type, if any. */
 943         /* FALLTHROUGH */
 944     case OP_ENTERTRY:
 945     case OP_ENTEREVAL:  /* Was holding hints. */
 946     case OP_ARGDEFELEM: /* Was holding signature index. */
 947         o->op_targ = 0;
 948         break;
 949     default:
 950         if (!(o->op_flags & OPf_REF)
 951             || (PL_check[o->op_type] != Perl_ck_ftst))
 952             break;
 953         /* FALLTHROUGH */
 954     case OP_GVSV:
 955     case OP_GV:
 956     case OP_AELEMFAST:
 957 #ifdef USE_ITHREADS
 958             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 959 #else
 960             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 961 #endif
 962         break;
 963     case OP_METHOD_REDIR:
 964     case OP_METHOD_REDIR_SUPER:
 965 #ifdef USE_ITHREADS
 966         if (cMETHOPx(o)->op_rclass_targ) {
 967             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 968             cMETHOPx(o)->op_rclass_targ = 0;
 969         }
 970 #else
 971         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 972         cMETHOPx(o)->op_rclass_sv = NULL;
 973 #endif
 974         /* FALLTHROUGH */
 975     case OP_METHOD_NAMED:
 976     case OP_METHOD_SUPER:
 977         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 978         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 979 #ifdef USE_ITHREADS
 980         if (o->op_targ) {
 981             pad_swipe(o->op_targ, 1);
 982             o->op_targ = 0;
 983         }
 984 #endif
 985         break;
 986     case OP_CONST:
 987     case OP_HINTSEVAL:
 988         SvREFCNT_dec(cSVOPo->op_sv);
 989         cSVOPo->op_sv = NULL;
 990 #ifdef USE_ITHREADS
 991         /** Bug #15654
 992           Even if op_clear does a pad_free for the target of the op,
 993           pad_free doesn't actually remove the sv that exists in the pad;
 994           instead it lives on. This results in that it could be reused as
 995           a target later on when the pad was reallocated.
 996         **/
 997         if(o->op_targ) {
 998           pad_swipe(o->op_targ,1);
 999           o->op_targ = 0;
1000         }
1001 #endif
1002         break;
1003     case OP_DUMP:
1004     case OP_GOTO:
1005     case OP_NEXT:
1006     case OP_LAST:
1007     case OP_REDO:
1008         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1009             break;
1010         /* FALLTHROUGH */
1011     case OP_TRANS:
1012     case OP_TRANSR:
1013         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1014             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1015         {
1016 #ifdef USE_ITHREADS
1017             if (cPADOPo->op_padix > 0) {
1018                 pad_swipe(cPADOPo->op_padix, TRUE);
1019                 cPADOPo->op_padix = 0;
1020             }
1021 #else
1022             SvREFCNT_dec(cSVOPo->op_sv);
1023             cSVOPo->op_sv = NULL;
1024 #endif
1025         }
1026         else {
1027             PerlMemShared_free(cPVOPo->op_pv);
1028             cPVOPo->op_pv = NULL;
1029         }
1030         break;
1031     case OP_SUBST:
1032         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1033         goto clear_pmop;
1034
1035     case OP_SPLIT:
1036         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1037             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1038         {
1039             if (o->op_private & OPpSPLIT_LEX)
1040                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1041             else
1042 #ifdef USE_ITHREADS
1043                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1044 #else
1045                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1046 #endif
1047         }
1048         /* FALLTHROUGH */
1049     case OP_MATCH:
1050     case OP_QR:
1051     clear_pmop:
1052         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1053             op_free(cPMOPo->op_code_list);
1054         cPMOPo->op_code_list = NULL;
1055         forget_pmop(cPMOPo);
1056         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1057         /* we use the same protection as the "SAFE" version of the PM_ macros
1058          * here since sv_clean_all might release some PMOPs
1059          * after PL_regex_padav has been cleared
1060          * and the clearing of PL_regex_padav needs to
1061          * happen before sv_clean_all
1062          */
1063 #ifdef USE_ITHREADS
1064         if(PL_regex_pad) {        /* We could be in destruction */
1065             const IV offset = (cPMOPo)->op_pmoffset;
1066             ReREFCNT_dec(PM_GETRE(cPMOPo));
1067             PL_regex_pad[offset] = &PL_sv_undef;
1068             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1069                            sizeof(offset));
1070         }
1071 #else
1072         ReREFCNT_dec(PM_GETRE(cPMOPo));
1073         PM_SETRE(cPMOPo, NULL);
1074 #endif
1075
1076         break;
1077
1078     case OP_ARGCHECK:
1079         PerlMemShared_free(cUNOP_AUXo->op_aux);
1080         break;
1081
1082     case OP_MULTICONCAT:
1083         {
1084             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1085             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1086              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1087              * utf8 shared strings */
1088             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1089             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1090             if (p1)
1091                 PerlMemShared_free(p1);
1092             if (p2 && p1 != p2)
1093                 PerlMemShared_free(p2);
1094             PerlMemShared_free(aux);
1095         }
1096         break;
1097
1098     case OP_MULTIDEREF:
1099         {
1100             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1101             UV actions = items->uv;
1102             bool last = 0;
1103             bool is_hash = FALSE;
1104
1105             while (!last) {
1106                 switch (actions & MDEREF_ACTION_MASK) {
1107
1108                 case MDEREF_reload:
1109                     actions = (++items)->uv;
1110                     continue;
1111
1112                 case MDEREF_HV_padhv_helem:
1113                     is_hash = TRUE;
1114                     /* FALLTHROUGH */
1115                 case MDEREF_AV_padav_aelem:
1116                     pad_free((++items)->pad_offset);
1117                     goto do_elem;
1118
1119                 case MDEREF_HV_gvhv_helem:
1120                     is_hash = TRUE;
1121                     /* FALLTHROUGH */
1122                 case MDEREF_AV_gvav_aelem:
1123 #ifdef USE_ITHREADS
1124                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1125 #else
1126                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1127 #endif
1128                     goto do_elem;
1129
1130                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1131                     is_hash = TRUE;
1132                     /* FALLTHROUGH */
1133                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1134 #ifdef USE_ITHREADS
1135                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1136 #else
1137                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1138 #endif
1139                     goto do_vivify_rv2xv_elem;
1140
1141                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1142                     is_hash = TRUE;
1143                     /* FALLTHROUGH */
1144                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1145                     pad_free((++items)->pad_offset);
1146                     goto do_vivify_rv2xv_elem;
1147
1148                 case MDEREF_HV_pop_rv2hv_helem:
1149                 case MDEREF_HV_vivify_rv2hv_helem:
1150                     is_hash = TRUE;
1151                     /* FALLTHROUGH */
1152                 do_vivify_rv2xv_elem:
1153                 case MDEREF_AV_pop_rv2av_aelem:
1154                 case MDEREF_AV_vivify_rv2av_aelem:
1155                 do_elem:
1156                     switch (actions & MDEREF_INDEX_MASK) {
1157                     case MDEREF_INDEX_none:
1158                         last = 1;
1159                         break;
1160                     case MDEREF_INDEX_const:
1161                         if (is_hash) {
1162 #ifdef USE_ITHREADS
1163                             /* see RT #15654 */
1164                             pad_swipe((++items)->pad_offset, 1);
1165 #else
1166                             SvREFCNT_dec((++items)->sv);
1167 #endif
1168                         }
1169                         else
1170                             items++;
1171                         break;
1172                     case MDEREF_INDEX_padsv:
1173                         pad_free((++items)->pad_offset);
1174                         break;
1175                     case MDEREF_INDEX_gvsv:
1176 #ifdef USE_ITHREADS
1177                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1178 #else
1179                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1180 #endif
1181                         break;
1182                     }
1183
1184                     if (actions & MDEREF_FLAG_last)
1185                         last = 1;
1186                     is_hash = FALSE;
1187
1188                     break;
1189
1190                 default:
1191                     assert(0);
1192                     last = 1;
1193                     break;
1194
1195                 } /* switch */
1196
1197                 actions >>= MDEREF_SHIFT;
1198             } /* while */
1199
1200             /* start of malloc is at op_aux[-1], where the length is
1201              * stored */
1202             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1203         }
1204         break;
1205     }
1206
1207     if (o->op_targ > 0) {
1208         pad_free(o->op_targ);
1209         o->op_targ = 0;
1210     }
1211 }
1212
1213 STATIC void
1214 S_cop_free(pTHX_ COP* cop)
1215 {
1216     PERL_ARGS_ASSERT_COP_FREE;
1217
1218     CopFILE_free(cop);
1219     if (! specialWARN(cop->cop_warnings))
1220         PerlMemShared_free(cop->cop_warnings);
1221     cophh_free(CopHINTHASH_get(cop));
1222     if (PL_curcop == cop)
1223        PL_curcop = NULL;
1224 }
1225
1226 STATIC void
1227 S_forget_pmop(pTHX_ PMOP *const o)
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 =for apidoc op_parent
1479
1480 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1481
1482 =cut
1483 */
1484
1485 OP *
1486 Perl_op_parent(OP *o)
1487 {
1488     PERL_ARGS_ASSERT_OP_PARENT;
1489     while (OpHAS_SIBLING(o))
1490         o = OpSIBLING(o);
1491     return o->op_sibparent;
1492 }
1493
1494 /* replace the sibling following start with a new UNOP, which becomes
1495  * the parent of the original sibling; e.g.
1496  *
1497  *  op_sibling_newUNOP(P, A, unop-args...)
1498  *
1499  *  P              P
1500  *  |      becomes |
1501  *  A-B-C          A-U-C
1502  *                   |
1503  *                   B
1504  *
1505  * where U is the new UNOP.
1506  *
1507  * parent and start args are the same as for op_sibling_splice();
1508  * type and flags args are as newUNOP().
1509  *
1510  * Returns the new UNOP.
1511  */
1512
1513 STATIC OP *
1514 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1515 {
1516     OP *kid, *newop;
1517
1518     kid = op_sibling_splice(parent, start, 1, NULL);
1519     newop = newUNOP(type, flags, kid);
1520     op_sibling_splice(parent, start, 0, newop);
1521     return newop;
1522 }
1523
1524
1525 /* lowest-level newLOGOP-style function - just allocates and populates
1526  * the struct. Higher-level stuff should be done by S_new_logop() /
1527  * newLOGOP(). This function exists mainly to avoid op_first assignment
1528  * being spread throughout this file.
1529  */
1530
1531 LOGOP *
1532 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1533 {
1534     dVAR;
1535     LOGOP *logop;
1536     OP *kid = first;
1537     NewOp(1101, logop, 1, LOGOP);
1538     OpTYPE_set(logop, type);
1539     logop->op_first = first;
1540     logop->op_other = other;
1541     if (first)
1542         logop->op_flags = OPf_KIDS;
1543     while (kid && OpHAS_SIBLING(kid))
1544         kid = OpSIBLING(kid);
1545     if (kid)
1546         OpLASTSIB_set(kid, (OP*)logop);
1547     return logop;
1548 }
1549
1550
1551 /* Contextualizers */
1552
1553 /*
1554 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1555
1556 Applies a syntactic context to an op tree representing an expression.
1557 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1558 or C<G_VOID> to specify the context to apply.  The modified op tree
1559 is returned.
1560
1561 =cut
1562 */
1563
1564 OP *
1565 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1566 {
1567     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1568     switch (context) {
1569         case G_SCALAR: return scalar(o);
1570         case G_ARRAY:  return list(o);
1571         case G_VOID:   return scalarvoid(o);
1572         default:
1573             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1574                        (long) context);
1575     }
1576 }
1577
1578 /*
1579
1580 =for apidoc Am|OP*|op_linklist|OP *o
1581 This function is the implementation of the L</LINKLIST> macro.  It should
1582 not be called directly.
1583
1584 =cut
1585 */
1586
1587 OP *
1588 Perl_op_linklist(pTHX_ OP *o)
1589 {
1590     OP *first;
1591
1592     PERL_ARGS_ASSERT_OP_LINKLIST;
1593
1594     if (o->op_next)
1595         return o->op_next;
1596
1597     /* establish postfix order */
1598     first = cUNOPo->op_first;
1599     if (first) {
1600         OP *kid;
1601         o->op_next = LINKLIST(first);
1602         kid = first;
1603         for (;;) {
1604             OP *sibl = OpSIBLING(kid);
1605             if (sibl) {
1606                 kid->op_next = LINKLIST(sibl);
1607                 kid = sibl;
1608             } else {
1609                 kid->op_next = o;
1610                 break;
1611             }
1612         }
1613     }
1614     else
1615         o->op_next = o;
1616
1617     return o->op_next;
1618 }
1619
1620 static OP *
1621 S_scalarkids(pTHX_ OP *o)
1622 {
1623     if (o && o->op_flags & OPf_KIDS) {
1624         OP *kid;
1625         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1626             scalar(kid);
1627     }
1628     return o;
1629 }
1630
1631 STATIC OP *
1632 S_scalarboolean(pTHX_ OP *o)
1633 {
1634     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1635
1636     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1637          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1638         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1639          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1640          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1641         if (ckWARN(WARN_SYNTAX)) {
1642             const line_t oldline = CopLINE(PL_curcop);
1643
1644             if (PL_parser && PL_parser->copline != NOLINE) {
1645                 /* This ensures that warnings are reported at the first line
1646                    of the conditional, not the last.  */
1647                 CopLINE_set(PL_curcop, PL_parser->copline);
1648             }
1649             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1650             CopLINE_set(PL_curcop, oldline);
1651         }
1652     }
1653     return scalar(o);
1654 }
1655
1656 static SV *
1657 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1658 {
1659     assert(o);
1660     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1661            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1662     {
1663         const char funny  = o->op_type == OP_PADAV
1664                          || o->op_type == OP_RV2AV ? '@' : '%';
1665         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1666             GV *gv;
1667             if (cUNOPo->op_first->op_type != OP_GV
1668              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1669                 return NULL;
1670             return varname(gv, funny, 0, NULL, 0, subscript_type);
1671         }
1672         return
1673             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1674     }
1675 }
1676
1677 static SV *
1678 S_op_varname(pTHX_ const OP *o)
1679 {
1680     return S_op_varname_subscript(aTHX_ o, 1);
1681 }
1682
1683 static void
1684 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1685 { /* or not so pretty :-) */
1686     if (o->op_type == OP_CONST) {
1687         *retsv = cSVOPo_sv;
1688         if (SvPOK(*retsv)) {
1689             SV *sv = *retsv;
1690             *retsv = sv_newmortal();
1691             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1692                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1693         }
1694         else if (!SvOK(*retsv))
1695             *retpv = "undef";
1696     }
1697     else *retpv = "...";
1698 }
1699
1700 static void
1701 S_scalar_slice_warning(pTHX_ const OP *o)
1702 {
1703     OP *kid;
1704     const bool h = o->op_type == OP_HSLICE
1705                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1706     const char lbrack =
1707         h ? '{' : '[';
1708     const char rbrack =
1709         h ? '}' : ']';
1710     SV *name;
1711     SV *keysv = NULL; /* just to silence compiler warnings */
1712     const char *key = NULL;
1713
1714     if (!(o->op_private & OPpSLICEWARNING))
1715         return;
1716     if (PL_parser && PL_parser->error_count)
1717         /* This warning can be nonsensical when there is a syntax error. */
1718         return;
1719
1720     kid = cLISTOPo->op_first;
1721     kid = OpSIBLING(kid); /* get past pushmark */
1722     /* weed out false positives: any ops that can return lists */
1723     switch (kid->op_type) {
1724     case OP_BACKTICK:
1725     case OP_GLOB:
1726     case OP_READLINE:
1727     case OP_MATCH:
1728     case OP_RV2AV:
1729     case OP_EACH:
1730     case OP_VALUES:
1731     case OP_KEYS:
1732     case OP_SPLIT:
1733     case OP_LIST:
1734     case OP_SORT:
1735     case OP_REVERSE:
1736     case OP_ENTERSUB:
1737     case OP_CALLER:
1738     case OP_LSTAT:
1739     case OP_STAT:
1740     case OP_READDIR:
1741     case OP_SYSTEM:
1742     case OP_TMS:
1743     case OP_LOCALTIME:
1744     case OP_GMTIME:
1745     case OP_ENTEREVAL:
1746         return;
1747     }
1748
1749     /* Don't warn if we have a nulled list either. */
1750     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1751         return;
1752
1753     assert(OpSIBLING(kid));
1754     name = S_op_varname(aTHX_ OpSIBLING(kid));
1755     if (!name) /* XS module fiddling with the op tree */
1756         return;
1757     S_op_pretty(aTHX_ kid, &keysv, &key);
1758     assert(SvPOK(name));
1759     sv_chop(name,SvPVX(name)+1);
1760     if (key)
1761        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1762         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1763                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1764                    "%c%s%c",
1765                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1766                     lbrack, key, rbrack);
1767     else
1768        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1769         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1771                     SVf "%c%" SVf "%c",
1772                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1773                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1774 }
1775
1776 OP *
1777 Perl_scalar(pTHX_ OP *o)
1778 {
1779     OP *kid;
1780
1781     /* assumes no premature commitment */
1782     if (!o || (PL_parser && PL_parser->error_count)
1783          || (o->op_flags & OPf_WANT)
1784          || o->op_type == OP_RETURN)
1785     {
1786         return o;
1787     }
1788
1789     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1790
1791     switch (o->op_type) {
1792     case OP_REPEAT:
1793         scalar(cBINOPo->op_first);
1794         if (o->op_private & OPpREPEAT_DOLIST) {
1795             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1796             assert(kid->op_type == OP_PUSHMARK);
1797             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1798                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1799                 o->op_private &=~ OPpREPEAT_DOLIST;
1800             }
1801         }
1802         break;
1803     case OP_OR:
1804     case OP_AND:
1805     case OP_COND_EXPR:
1806         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1807             scalar(kid);
1808         break;
1809         /* FALLTHROUGH */
1810     case OP_SPLIT:
1811     case OP_MATCH:
1812     case OP_QR:
1813     case OP_SUBST:
1814     case OP_NULL:
1815     default:
1816         if (o->op_flags & OPf_KIDS) {
1817             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1818                 scalar(kid);
1819         }
1820         break;
1821     case OP_LEAVE:
1822     case OP_LEAVETRY:
1823         kid = cLISTOPo->op_first;
1824         scalar(kid);
1825         kid = OpSIBLING(kid);
1826     do_kids:
1827         while (kid) {
1828             OP *sib = OpSIBLING(kid);
1829             if (sib && kid->op_type != OP_LEAVEWHEN
1830              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1831                 || (  sib->op_targ != OP_NEXTSTATE
1832                    && sib->op_targ != OP_DBSTATE  )))
1833                 scalarvoid(kid);
1834             else
1835                 scalar(kid);
1836             kid = sib;
1837         }
1838         PL_curcop = &PL_compiling;
1839         break;
1840     case OP_SCOPE:
1841     case OP_LINESEQ:
1842     case OP_LIST:
1843         kid = cLISTOPo->op_first;
1844         goto do_kids;
1845     case OP_SORT:
1846         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1847         break;
1848     case OP_KVHSLICE:
1849     case OP_KVASLICE:
1850     {
1851         /* Warn about scalar context */
1852         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1853         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1854         SV *name;
1855         SV *keysv;
1856         const char *key = NULL;
1857
1858         /* This warning can be nonsensical when there is a syntax error. */
1859         if (PL_parser && PL_parser->error_count)
1860             break;
1861
1862         if (!ckWARN(WARN_SYNTAX)) break;
1863
1864         kid = cLISTOPo->op_first;
1865         kid = OpSIBLING(kid); /* get past pushmark */
1866         assert(OpSIBLING(kid));
1867         name = S_op_varname(aTHX_ OpSIBLING(kid));
1868         if (!name) /* XS module fiddling with the op tree */
1869             break;
1870         S_op_pretty(aTHX_ kid, &keysv, &key);
1871         assert(SvPOK(name));
1872         sv_chop(name,SvPVX(name)+1);
1873         if (key)
1874   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1875             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1876                        "%%%" SVf "%c%s%c in scalar context better written "
1877                        "as $%" SVf "%c%s%c",
1878                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1879                         lbrack, key, rbrack);
1880         else
1881   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1882             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1883                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1884                        "written as $%" SVf "%c%" SVf "%c",
1885                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1886                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1887     }
1888     }
1889     return o;
1890 }
1891
1892 OP *
1893 Perl_scalarvoid(pTHX_ OP *arg)
1894 {
1895     dVAR;
1896     OP *kid;
1897     SV* sv;
1898     OP *o = arg;
1899     dDEFER_OP;
1900
1901     PERL_ARGS_ASSERT_SCALARVOID;
1902
1903     do {
1904         U8 want;
1905         SV *useless_sv = NULL;
1906         const char* useless = NULL;
1907
1908         if (o->op_type == OP_NEXTSTATE
1909             || o->op_type == OP_DBSTATE
1910             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1911                                           || o->op_targ == OP_DBSTATE)))
1912             PL_curcop = (COP*)o;                /* for warning below */
1913
1914         /* assumes no premature commitment */
1915         want = o->op_flags & OPf_WANT;
1916         if ((want && want != OPf_WANT_SCALAR)
1917             || (PL_parser && PL_parser->error_count)
1918             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1919         {
1920             continue;
1921         }
1922
1923         if ((o->op_private & OPpTARGET_MY)
1924             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1925         {
1926             /* newASSIGNOP has already applied scalar context, which we
1927                leave, as if this op is inside SASSIGN.  */
1928             continue;
1929         }
1930
1931         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1932
1933         switch (o->op_type) {
1934         default:
1935             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1936                 break;
1937             /* FALLTHROUGH */
1938         case OP_REPEAT:
1939             if (o->op_flags & OPf_STACKED)
1940                 break;
1941             if (o->op_type == OP_REPEAT)
1942                 scalar(cBINOPo->op_first);
1943             goto func_ops;
1944         case OP_CONCAT:
1945             if ((o->op_flags & OPf_STACKED) &&
1946                     !(o->op_private & OPpCONCAT_NESTED))
1947                 break;
1948             goto func_ops;
1949         case OP_SUBSTR:
1950             if (o->op_private == 4)
1951                 break;
1952             /* FALLTHROUGH */
1953         case OP_WANTARRAY:
1954         case OP_GV:
1955         case OP_SMARTMATCH:
1956         case OP_AV2ARYLEN:
1957         case OP_REF:
1958         case OP_REFGEN:
1959         case OP_SREFGEN:
1960         case OP_DEFINED:
1961         case OP_HEX:
1962         case OP_OCT:
1963         case OP_LENGTH:
1964         case OP_VEC:
1965         case OP_INDEX:
1966         case OP_RINDEX:
1967         case OP_SPRINTF:
1968         case OP_KVASLICE:
1969         case OP_KVHSLICE:
1970         case OP_UNPACK:
1971         case OP_PACK:
1972         case OP_JOIN:
1973         case OP_LSLICE:
1974         case OP_ANONLIST:
1975         case OP_ANONHASH:
1976         case OP_SORT:
1977         case OP_REVERSE:
1978         case OP_RANGE:
1979         case OP_FLIP:
1980         case OP_FLOP:
1981         case OP_CALLER:
1982         case OP_FILENO:
1983         case OP_EOF:
1984         case OP_TELL:
1985         case OP_GETSOCKNAME:
1986         case OP_GETPEERNAME:
1987         case OP_READLINK:
1988         case OP_TELLDIR:
1989         case OP_GETPPID:
1990         case OP_GETPGRP:
1991         case OP_GETPRIORITY:
1992         case OP_TIME:
1993         case OP_TMS:
1994         case OP_LOCALTIME:
1995         case OP_GMTIME:
1996         case OP_GHBYNAME:
1997         case OP_GHBYADDR:
1998         case OP_GHOSTENT:
1999         case OP_GNBYNAME:
2000         case OP_GNBYADDR:
2001         case OP_GNETENT:
2002         case OP_GPBYNAME:
2003         case OP_GPBYNUMBER:
2004         case OP_GPROTOENT:
2005         case OP_GSBYNAME:
2006         case OP_GSBYPORT:
2007         case OP_GSERVENT:
2008         case OP_GPWNAM:
2009         case OP_GPWUID:
2010         case OP_GGRNAM:
2011         case OP_GGRGID:
2012         case OP_GETLOGIN:
2013         case OP_PROTOTYPE:
2014         case OP_RUNCV:
2015         func_ops:
2016             useless = OP_DESC(o);
2017             break;
2018
2019         case OP_GVSV:
2020         case OP_PADSV:
2021         case OP_PADAV:
2022         case OP_PADHV:
2023         case OP_PADANY:
2024         case OP_AELEM:
2025         case OP_AELEMFAST:
2026         case OP_AELEMFAST_LEX:
2027         case OP_ASLICE:
2028         case OP_HELEM:
2029         case OP_HSLICE:
2030             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2031                 /* Otherwise it's "Useless use of grep iterator" */
2032                 useless = OP_DESC(o);
2033             break;
2034
2035         case OP_SPLIT:
2036             if (!(o->op_private & OPpSPLIT_ASSIGN))
2037                 useless = OP_DESC(o);
2038             break;
2039
2040         case OP_NOT:
2041             kid = cUNOPo->op_first;
2042             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2043                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2044                 goto func_ops;
2045             }
2046             useless = "negative pattern binding (!~)";
2047             break;
2048
2049         case OP_SUBST:
2050             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2051                 useless = "non-destructive substitution (s///r)";
2052             break;
2053
2054         case OP_TRANSR:
2055             useless = "non-destructive transliteration (tr///r)";
2056             break;
2057
2058         case OP_RV2GV:
2059         case OP_RV2SV:
2060         case OP_RV2AV:
2061         case OP_RV2HV:
2062             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2063                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2064                 useless = "a variable";
2065             break;
2066
2067         case OP_CONST:
2068             sv = cSVOPo_sv;
2069             if (cSVOPo->op_private & OPpCONST_STRICT)
2070                 no_bareword_allowed(o);
2071             else {
2072                 if (ckWARN(WARN_VOID)) {
2073                     NV nv;
2074                     /* don't warn on optimised away booleans, eg
2075                      * use constant Foo, 5; Foo || print; */
2076                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2077                         useless = NULL;
2078                     /* the constants 0 and 1 are permitted as they are
2079                        conventionally used as dummies in constructs like
2080                        1 while some_condition_with_side_effects;  */
2081                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2082                         useless = NULL;
2083                     else if (SvPOK(sv)) {
2084                         SV * const dsv = newSVpvs("");
2085                         useless_sv
2086                             = Perl_newSVpvf(aTHX_
2087                                             "a constant (%s)",
2088                                             pv_pretty(dsv, SvPVX_const(sv),
2089                                                       SvCUR(sv), 32, NULL, NULL,
2090                                                       PERL_PV_PRETTY_DUMP
2091                                                       | PERL_PV_ESCAPE_NOCLEAR
2092                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2093                         SvREFCNT_dec_NN(dsv);
2094                     }
2095                     else if (SvOK(sv)) {
2096                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2097                     }
2098                     else
2099                         useless = "a constant (undef)";
2100                 }
2101             }
2102             op_null(o);         /* don't execute or even remember it */
2103             break;
2104
2105         case OP_POSTINC:
2106             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2107             break;
2108
2109         case OP_POSTDEC:
2110             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2111             break;
2112
2113         case OP_I_POSTINC:
2114             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2115             break;
2116
2117         case OP_I_POSTDEC:
2118             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2119             break;
2120
2121         case OP_SASSIGN: {
2122             OP *rv2gv;
2123             UNOP *refgen, *rv2cv;
2124             LISTOP *exlist;
2125
2126             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2127                 break;
2128
2129             rv2gv = ((BINOP *)o)->op_last;
2130             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2131                 break;
2132
2133             refgen = (UNOP *)((BINOP *)o)->op_first;
2134
2135             if (!refgen || (refgen->op_type != OP_REFGEN
2136                             && refgen->op_type != OP_SREFGEN))
2137                 break;
2138
2139             exlist = (LISTOP *)refgen->op_first;
2140             if (!exlist || exlist->op_type != OP_NULL
2141                 || exlist->op_targ != OP_LIST)
2142                 break;
2143
2144             if (exlist->op_first->op_type != OP_PUSHMARK
2145                 && exlist->op_first != exlist->op_last)
2146                 break;
2147
2148             rv2cv = (UNOP*)exlist->op_last;
2149
2150             if (rv2cv->op_type != OP_RV2CV)
2151                 break;
2152
2153             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2154             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2155             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2156
2157             o->op_private |= OPpASSIGN_CV_TO_GV;
2158             rv2gv->op_private |= OPpDONT_INIT_GV;
2159             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2160
2161             break;
2162         }
2163
2164         case OP_AASSIGN: {
2165             inplace_aassign(o);
2166             break;
2167         }
2168
2169         case OP_OR:
2170         case OP_AND:
2171             kid = cLOGOPo->op_first;
2172             if (kid->op_type == OP_NOT
2173                 && (kid->op_flags & OPf_KIDS)) {
2174                 if (o->op_type == OP_AND) {
2175                     OpTYPE_set(o, OP_OR);
2176                 } else {
2177                     OpTYPE_set(o, OP_AND);
2178                 }
2179                 op_null(kid);
2180             }
2181             /* FALLTHROUGH */
2182
2183         case OP_DOR:
2184         case OP_COND_EXPR:
2185         case OP_ENTERGIVEN:
2186         case OP_ENTERWHEN:
2187             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2188                 if (!(kid->op_flags & OPf_KIDS))
2189                     scalarvoid(kid);
2190                 else
2191                     DEFER_OP(kid);
2192         break;
2193
2194         case OP_NULL:
2195             if (o->op_flags & OPf_STACKED)
2196                 break;
2197             /* FALLTHROUGH */
2198         case OP_NEXTSTATE:
2199         case OP_DBSTATE:
2200         case OP_ENTERTRY:
2201         case OP_ENTER:
2202             if (!(o->op_flags & OPf_KIDS))
2203                 break;
2204             /* FALLTHROUGH */
2205         case OP_SCOPE:
2206         case OP_LEAVE:
2207         case OP_LEAVETRY:
2208         case OP_LEAVELOOP:
2209         case OP_LINESEQ:
2210         case OP_LEAVEGIVEN:
2211         case OP_LEAVEWHEN:
2212         kids:
2213             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2214                 if (!(kid->op_flags & OPf_KIDS))
2215                     scalarvoid(kid);
2216                 else
2217                     DEFER_OP(kid);
2218             break;
2219         case OP_LIST:
2220             /* If the first kid after pushmark is something that the padrange
2221                optimisation would reject, then null the list and the pushmark.
2222             */
2223             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2224                 && (  !(kid = OpSIBLING(kid))
2225                       || (  kid->op_type != OP_PADSV
2226                             && kid->op_type != OP_PADAV
2227                             && kid->op_type != OP_PADHV)
2228                       || kid->op_private & ~OPpLVAL_INTRO
2229                       || !(kid = OpSIBLING(kid))
2230                       || (  kid->op_type != OP_PADSV
2231                             && kid->op_type != OP_PADAV
2232                             && kid->op_type != OP_PADHV)
2233                       || kid->op_private & ~OPpLVAL_INTRO)
2234             ) {
2235                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2236                 op_null(o); /* NULL the list */
2237             }
2238             goto kids;
2239         case OP_ENTEREVAL:
2240             scalarkids(o);
2241             break;
2242         case OP_SCALAR:
2243             scalar(o);
2244             break;
2245         }
2246
2247         if (useless_sv) {
2248             /* mortalise it, in case warnings are fatal.  */
2249             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2250                            "Useless use of %" SVf " in void context",
2251                            SVfARG(sv_2mortal(useless_sv)));
2252         }
2253         else if (useless) {
2254             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2255                            "Useless use of %s in void context",
2256                            useless);
2257         }
2258     } while ( (o = POP_DEFERRED_OP()) );
2259
2260     DEFER_OP_CLEANUP;
2261
2262     return arg;
2263 }
2264
2265 static OP *
2266 S_listkids(pTHX_ OP *o)
2267 {
2268     if (o && o->op_flags & OPf_KIDS) {
2269         OP *kid;
2270         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2271             list(kid);
2272     }
2273     return o;
2274 }
2275
2276 OP *
2277 Perl_list(pTHX_ OP *o)
2278 {
2279     OP *kid;
2280
2281     /* assumes no premature commitment */
2282     if (!o || (o->op_flags & OPf_WANT)
2283          || (PL_parser && PL_parser->error_count)
2284          || o->op_type == OP_RETURN)
2285     {
2286         return o;
2287     }
2288
2289     if ((o->op_private & OPpTARGET_MY)
2290         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2291     {
2292         return o;                               /* As if inside SASSIGN */
2293     }
2294
2295     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2296
2297     switch (o->op_type) {
2298     case OP_FLOP:
2299         list(cBINOPo->op_first);
2300         break;
2301     case OP_REPEAT:
2302         if (o->op_private & OPpREPEAT_DOLIST
2303          && !(o->op_flags & OPf_STACKED))
2304         {
2305             list(cBINOPo->op_first);
2306             kid = cBINOPo->op_last;
2307             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2308              && SvIVX(kSVOP_sv) == 1)
2309             {
2310                 op_null(o); /* repeat */
2311                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2312                 /* const (rhs): */
2313                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2314             }
2315         }
2316         break;
2317     case OP_OR:
2318     case OP_AND:
2319     case OP_COND_EXPR:
2320         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2321             list(kid);
2322         break;
2323     default:
2324     case OP_MATCH:
2325     case OP_QR:
2326     case OP_SUBST:
2327     case OP_NULL:
2328         if (!(o->op_flags & OPf_KIDS))
2329             break;
2330         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2331             list(cBINOPo->op_first);
2332             return gen_constant_list(o);
2333         }
2334         listkids(o);
2335         break;
2336     case OP_LIST:
2337         listkids(o);
2338         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2339             op_null(cUNOPo->op_first); /* NULL the pushmark */
2340             op_null(o); /* NULL the list */
2341         }
2342         break;
2343     case OP_LEAVE:
2344     case OP_LEAVETRY:
2345         kid = cLISTOPo->op_first;
2346         list(kid);
2347         kid = OpSIBLING(kid);
2348     do_kids:
2349         while (kid) {
2350             OP *sib = OpSIBLING(kid);
2351             if (sib && kid->op_type != OP_LEAVEWHEN)
2352                 scalarvoid(kid);
2353             else
2354                 list(kid);
2355             kid = sib;
2356         }
2357         PL_curcop = &PL_compiling;
2358         break;
2359     case OP_SCOPE:
2360     case OP_LINESEQ:
2361         kid = cLISTOPo->op_first;
2362         goto do_kids;
2363     }
2364     return o;
2365 }
2366
2367 static OP *
2368 S_scalarseq(pTHX_ OP *o)
2369 {
2370     if (o) {
2371         const OPCODE type = o->op_type;
2372
2373         if (type == OP_LINESEQ || type == OP_SCOPE ||
2374             type == OP_LEAVE || type == OP_LEAVETRY)
2375         {
2376             OP *kid, *sib;
2377             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2378                 if ((sib = OpSIBLING(kid))
2379                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2380                     || (  sib->op_targ != OP_NEXTSTATE
2381                        && sib->op_targ != OP_DBSTATE  )))
2382                 {
2383                     scalarvoid(kid);
2384                 }
2385             }
2386             PL_curcop = &PL_compiling;
2387         }
2388         o->op_flags &= ~OPf_PARENS;
2389         if (PL_hints & HINT_BLOCK_SCOPE)
2390             o->op_flags |= OPf_PARENS;
2391     }
2392     else
2393         o = newOP(OP_STUB, 0);
2394     return o;
2395 }
2396
2397 STATIC OP *
2398 S_modkids(pTHX_ OP *o, I32 type)
2399 {
2400     if (o && o->op_flags & OPf_KIDS) {
2401         OP *kid;
2402         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2403             op_lvalue(kid, type);
2404     }
2405     return o;
2406 }
2407
2408
2409 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2410  * const fields. Also, convert CONST keys to HEK-in-SVs.
2411  * rop is the op that retrieves the hash;
2412  * key_op is the first key
2413  */
2414
2415 STATIC void
2416 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2417 {
2418     PADNAME *lexname;
2419     GV **fields;
2420     bool check_fields;
2421
2422     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2423     if (rop) {
2424         if (rop->op_first->op_type == OP_PADSV)
2425             /* @$hash{qw(keys here)} */
2426             rop = (UNOP*)rop->op_first;
2427         else {
2428             /* @{$hash}{qw(keys here)} */
2429             if (rop->op_first->op_type == OP_SCOPE
2430                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2431                 {
2432                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2433                 }
2434             else
2435                 rop = NULL;
2436         }
2437     }
2438
2439     lexname = NULL; /* just to silence compiler warnings */
2440     fields  = NULL; /* just to silence compiler warnings */
2441
2442     check_fields =
2443             rop
2444          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2445              SvPAD_TYPED(lexname))
2446          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2447          && isGV(*fields) && GvHV(*fields);
2448
2449     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2450         SV **svp, *sv;
2451         if (key_op->op_type != OP_CONST)
2452             continue;
2453         svp = cSVOPx_svp(key_op);
2454
2455         /* make sure it's not a bareword under strict subs */
2456         if (key_op->op_private & OPpCONST_BARE &&
2457             key_op->op_private & OPpCONST_STRICT)
2458         {
2459             no_bareword_allowed((OP*)key_op);
2460         }
2461
2462         /* Make the CONST have a shared SV */
2463         if (   !SvIsCOW_shared_hash(sv = *svp)
2464             && SvTYPE(sv) < SVt_PVMG
2465             && SvOK(sv)
2466             && !SvROK(sv))
2467         {
2468             SSize_t keylen;
2469             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2470             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2471             SvREFCNT_dec_NN(sv);
2472             *svp = nsv;
2473         }
2474
2475         if (   check_fields
2476             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2477         {
2478             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2479                         "in variable %" PNf " of type %" HEKf,
2480                         SVfARG(*svp), PNfARG(lexname),
2481                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2482         }
2483     }
2484 }
2485
2486 /* info returned by S_sprintf_is_multiconcatable() */
2487
2488 struct sprintf_ismc_info {
2489     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2490     char  *start;     /* start of raw format string */
2491     char  *end;       /* bytes after end of raw format string */
2492     STRLEN total_len; /* total length (in bytes) of format string, not
2493                          including '%s' and  half of '%%' */
2494     STRLEN variant;   /* number of bytes by which total_len_p would grow
2495                          if upgraded to utf8 */
2496     bool   utf8;      /* whether the format is utf8 */
2497 };
2498
2499
2500 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2501  * i.e. its format argument is a const string with only '%s' and '%%'
2502  * formats, and the number of args is known, e.g.
2503  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2504  * but not
2505  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2506  *
2507  * If successful, the sprintf_ismc_info struct pointed to by info will be
2508  * populated.
2509  */
2510
2511 STATIC bool
2512 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2513 {
2514     OP    *pm, *constop, *kid;
2515     SV    *sv;
2516     char  *s, *e, *p;
2517     SSize_t nargs, nformats;
2518     STRLEN cur, total_len, variant;
2519     bool   utf8;
2520
2521     /* if sprintf's behaviour changes, die here so that someone
2522      * can decide whether to enhance this function or skip optimising
2523      * under those new circumstances */
2524     assert(!(o->op_flags & OPf_STACKED));
2525     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2526     assert(!(o->op_private & ~OPpARG4_MASK));
2527
2528     pm = cUNOPo->op_first;
2529     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2530         return FALSE;
2531     constop = OpSIBLING(pm);
2532     if (!constop || constop->op_type != OP_CONST)
2533         return FALSE;
2534     sv = cSVOPx_sv(constop);
2535     if (SvMAGICAL(sv) || !SvPOK(sv))
2536         return FALSE;
2537
2538     s = SvPV(sv, cur);
2539     e = s + cur;
2540
2541     /* Scan format for %% and %s and work out how many %s there are.
2542      * Abandon if other format types are found.
2543      */
2544
2545     nformats  = 0;
2546     total_len = 0;
2547     variant   = 0;
2548
2549     for (p = s; p < e; p++) {
2550         if (*p != '%') {
2551             total_len++;
2552             if (!UTF8_IS_INVARIANT(*p))
2553                 variant++;
2554             continue;
2555         }
2556         p++;
2557         if (p >= e)
2558             return FALSE; /* lone % at end gives "Invalid conversion" */
2559         if (*p == '%')
2560             total_len++;
2561         else if (*p == 's')
2562             nformats++;
2563         else
2564             return FALSE;
2565     }
2566
2567     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2568         return FALSE;
2569
2570     utf8 = cBOOL(SvUTF8(sv));
2571     if (utf8)
2572         variant = 0;
2573
2574     /* scan args; they must all be in scalar cxt */
2575
2576     nargs = 0;
2577     kid = OpSIBLING(constop);
2578
2579     while (kid) {
2580         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2581             return FALSE;
2582         nargs++;
2583         kid = OpSIBLING(kid);
2584     }
2585
2586     if (nargs != nformats)
2587         return FALSE; /* e.g. sprintf("%s%s", $a); */
2588
2589
2590     info->nargs      = nargs;
2591     info->start      = s;
2592     info->end        = e;
2593     info->total_len  = total_len;
2594     info->variant    = variant;
2595     info->utf8       = utf8;
2596
2597     return TRUE;
2598 }
2599
2600
2601
2602 /* S_maybe_multiconcat():
2603  *
2604  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2605  * convert it (and its children) into an OP_MULTICONCAT. See the code
2606  * comments just before pp_multiconcat() for the full details of what
2607  * OP_MULTICONCAT supports.
2608  *
2609  * Basically we're looking for an optree with a chain of OP_CONCATS down
2610  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2611  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2612  *
2613  *      $x = "$a$b-$c"
2614  *
2615  *  looks like
2616  *
2617  *      SASSIGN
2618  *         |
2619  *      STRINGIFY   -- PADSV[$x]
2620  *         |
2621  *         |
2622  *      ex-PUSHMARK -- CONCAT/S
2623  *                        |
2624  *                     CONCAT/S  -- PADSV[$d]
2625  *                        |
2626  *                     CONCAT    -- CONST["-"]
2627  *                        |
2628  *                     PADSV[$a] -- PADSV[$b]
2629  *
2630  * Note that at this stage the OP_SASSIGN may have already been optimised
2631  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2632  */
2633
2634 STATIC void
2635 S_maybe_multiconcat(pTHX_ OP *o)
2636 {
2637     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2638     OP *topop;       /* the top-most op in the concat tree (often equals o,
2639                         unless there are assign/stringify ops above it */
2640     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2641     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2642     OP *targetop;    /* the op corresponding to target=... or target.=... */
2643     OP *stringop;    /* the OP_STRINGIFY op, if any */
2644     OP *nextop;      /* used for recreating the op_next chain without consts */
2645     OP *kid;         /* general-purpose op pointer */
2646     UNOP_AUX_item *aux;
2647     UNOP_AUX_item *lenp;
2648     char *const_str, *p;
2649     struct sprintf_ismc_info sprintf_info;
2650
2651                      /* store info about each arg in args[];
2652                       * toparg is the highest used slot; argp is a general
2653                       * pointer to args[] slots */
2654     struct {
2655         void *p;      /* initially points to const sv (or null for op);
2656                          later, set to SvPV(constsv), with ... */
2657         STRLEN len;   /* ... len set to SvPV(..., len) */
2658     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2659
2660     SSize_t nargs  = 0;
2661     SSize_t nconst = 0;
2662     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2663     STRLEN variant;
2664     bool utf8 = FALSE;
2665     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2666                                  the last-processed arg will the LHS of one,
2667                                  as args are processed in reverse order */
2668     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2669     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2670     U8 flags          = 0;   /* what will become the op_flags and ... */
2671     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2672     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2673     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2674     bool prev_was_const = FALSE; /* previous arg was a const */
2675
2676     /* -----------------------------------------------------------------
2677      * Phase 1:
2678      *
2679      * Examine the optree non-destructively to determine whether it's
2680      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2681      * information about the optree in args[].
2682      */
2683
2684     argp     = args;
2685     targmyop = NULL;
2686     targetop = NULL;
2687     stringop = NULL;
2688     topop    = o;
2689     parentop = o;
2690
2691     assert(   o->op_type == OP_SASSIGN
2692            || o->op_type == OP_CONCAT
2693            || o->op_type == OP_SPRINTF
2694            || o->op_type == OP_STRINGIFY);
2695
2696     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2697
2698     /* first see if, at the top of the tree, there is an assign,
2699      * append and/or stringify */
2700
2701     if (topop->op_type == OP_SASSIGN) {
2702         /* expr = ..... */
2703         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2704             return;
2705         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2706             return;
2707         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2708
2709         parentop = topop;
2710         topop = cBINOPo->op_first;
2711         targetop = OpSIBLING(topop);
2712         if (!targetop) /* probably some sort of syntax error */
2713             return;
2714     }
2715     else if (   topop->op_type == OP_CONCAT
2716              && (topop->op_flags & OPf_STACKED)
2717              && (!(topop->op_private & OPpCONCAT_NESTED))
2718             )
2719     {
2720         /* expr .= ..... */
2721
2722         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2723          * decide what to do about it */
2724         assert(!(o->op_private & OPpTARGET_MY));
2725
2726         /* barf on unknown flags */
2727         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2728         private_flags |= OPpMULTICONCAT_APPEND;
2729         targetop = cBINOPo->op_first;
2730         parentop = topop;
2731         topop    = OpSIBLING(targetop);
2732
2733         /* $x .= <FOO> gets optimised to rcatline instead */
2734         if (topop->op_type == OP_READLINE)
2735             return;
2736     }
2737
2738     if (targetop) {
2739         /* Can targetop (the LHS) if it's a padsv, be be optimised
2740          * away and use OPpTARGET_MY instead?
2741          */
2742         if (    (targetop->op_type == OP_PADSV)
2743             && !(targetop->op_private & OPpDEREF)
2744             && !(targetop->op_private & OPpPAD_STATE)
2745                /* we don't support 'my $x .= ...' */
2746             && (   o->op_type == OP_SASSIGN
2747                 || !(targetop->op_private & OPpLVAL_INTRO))
2748         )
2749             is_targable = TRUE;
2750     }
2751
2752     if (topop->op_type == OP_STRINGIFY) {
2753         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2754             return;
2755         stringop = topop;
2756
2757         /* barf on unknown flags */
2758         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2759
2760         if ((topop->op_private & OPpTARGET_MY)) {
2761             if (o->op_type == OP_SASSIGN)
2762                 return; /* can't have two assigns */
2763             targmyop = topop;
2764         }
2765
2766         private_flags |= OPpMULTICONCAT_STRINGIFY;
2767         parentop = topop;
2768         topop = cBINOPx(topop)->op_first;
2769         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2770         topop = OpSIBLING(topop);
2771     }
2772
2773     if (topop->op_type == OP_SPRINTF) {
2774         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2775             return;
2776         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2777             nargs     = sprintf_info.nargs;
2778             total_len = sprintf_info.total_len;
2779             variant   = sprintf_info.variant;
2780             utf8      = sprintf_info.utf8;
2781             is_sprintf = TRUE;
2782             private_flags |= OPpMULTICONCAT_FAKE;
2783             toparg = argp;
2784             /* we have an sprintf op rather than a concat optree.
2785              * Skip most of the code below which is associated with
2786              * processing that optree. We also skip phase 2, determining
2787              * whether its cost effective to optimise, since for sprintf,
2788              * multiconcat is *always* faster */
2789             goto create_aux;
2790         }
2791         /* note that even if the sprintf itself isn't multiconcatable,
2792          * the expression as a whole may be, e.g. in
2793          *    $x .= sprintf("%d",...)
2794          * the sprintf op will be left as-is, but the concat/S op may
2795          * be upgraded to multiconcat
2796          */
2797     }
2798     else if (topop->op_type == OP_CONCAT) {
2799         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2800             return;
2801
2802         if ((topop->op_private & OPpTARGET_MY)) {
2803             if (o->op_type == OP_SASSIGN || targmyop)
2804                 return; /* can't have two assigns */
2805             targmyop = topop;
2806         }
2807     }
2808
2809     /* Is it safe to convert a sassign/stringify/concat op into
2810      * a multiconcat? */
2811     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2812     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2813     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2814     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2815     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2816                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2817     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2818                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2819
2820     /* Now scan the down the tree looking for a series of
2821      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2822      * stacked). For example this tree:
2823      *
2824      *     |
2825      *   CONCAT/STACKED
2826      *     |
2827      *   CONCAT/STACKED -- EXPR5
2828      *     |
2829      *   CONCAT/STACKED -- EXPR4
2830      *     |
2831      *   CONCAT -- EXPR3
2832      *     |
2833      *   EXPR1  -- EXPR2
2834      *
2835      * corresponds to an expression like
2836      *
2837      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2838      *
2839      * Record info about each EXPR in args[]: in particular, whether it is
2840      * a stringifiable OP_CONST and if so what the const sv is.
2841      *
2842      * The reason why the last concat can't be STACKED is the difference
2843      * between
2844      *
2845      *    ((($a .= $a) .= $a) .= $a) .= $a
2846      *
2847      * and
2848      *    $a . $a . $a . $a . $a
2849      *
2850      * The main difference between the optrees for those two constructs
2851      * is the presence of the last STACKED. As well as modifying $a,
2852      * the former sees the changed $a between each concat, so if $s is
2853      * initially 'a', the first returns 'a' x 16, while the latter returns
2854      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2855      */
2856
2857     kid = topop;
2858
2859     for (;;) {
2860         OP *argop;
2861         SV *sv;
2862         bool last = FALSE;
2863
2864         if (    kid->op_type == OP_CONCAT
2865             && !kid_is_last
2866         ) {
2867             OP *k1, *k2;
2868             k1 = cUNOPx(kid)->op_first;
2869             k2 = OpSIBLING(k1);
2870             /* shouldn't happen except maybe after compile err? */
2871             if (!k2)
2872                 return;
2873
2874             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2875             if (kid->op_private & OPpTARGET_MY)
2876                 kid_is_last = TRUE;
2877
2878             stacked_last = (kid->op_flags & OPf_STACKED);
2879             if (!stacked_last)
2880                 kid_is_last = TRUE;
2881
2882             kid   = k1;
2883             argop = k2;
2884         }
2885         else {
2886             argop = kid;
2887             last = TRUE;
2888         }
2889
2890         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2891             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2892         {
2893             /* At least two spare slots are needed to decompose both
2894              * concat args. If there are no slots left, continue to
2895              * examine the rest of the optree, but don't push new values
2896              * on args[]. If the optree as a whole is legal for conversion
2897              * (in particular that the last concat isn't STACKED), then
2898              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2899              * can be converted into an OP_MULTICONCAT now, with the first
2900              * child of that op being the remainder of the optree -
2901              * which may itself later be converted to a multiconcat op
2902              * too.
2903              */
2904             if (last) {
2905                 /* the last arg is the rest of the optree */
2906                 argp++->p = NULL;
2907                 nargs++;
2908             }
2909         }
2910         else if (   argop->op_type == OP_CONST
2911             && ((sv = cSVOPx_sv(argop)))
2912             /* defer stringification until runtime of 'constant'
2913              * things that might stringify variantly, e.g. the radix
2914              * point of NVs, or overloaded RVs */
2915             && (SvPOK(sv) || SvIOK(sv))
2916             && (!SvGMAGICAL(sv))
2917         ) {
2918             argp++->p = sv;
2919             utf8   |= cBOOL(SvUTF8(sv));
2920             nconst++;
2921             if (prev_was_const)
2922                 /* this const may be demoted back to a plain arg later;
2923                  * make sure we have enough arg slots left */
2924                 nadjconst++;
2925             prev_was_const = !prev_was_const;
2926         }
2927         else {
2928             argp++->p = NULL;
2929             nargs++;
2930             prev_was_const = FALSE;
2931         }
2932
2933         if (last)
2934             break;
2935     }
2936
2937     toparg = argp - 1;
2938
2939     if (stacked_last)
2940         return; /* we don't support ((A.=B).=C)...) */
2941
2942     /* look for two adjacent consts and don't fold them together:
2943      *     $o . "a" . "b"
2944      * should do
2945      *     $o->concat("a")->concat("b")
2946      * rather than
2947      *     $o->concat("ab")
2948      * (but $o .=  "a" . "b" should still fold)
2949      */
2950     {
2951         bool seen_nonconst = FALSE;
2952         for (argp = toparg; argp >= args; argp--) {
2953             if (argp->p == NULL) {
2954                 seen_nonconst = TRUE;
2955                 continue;
2956             }
2957             if (!seen_nonconst)
2958                 continue;
2959             if (argp[1].p) {
2960                 /* both previous and current arg were constants;
2961                  * leave the current OP_CONST as-is */
2962                 argp->p = NULL;
2963                 nconst--;
2964                 nargs++;
2965             }
2966         }
2967     }
2968
2969     /* -----------------------------------------------------------------
2970      * Phase 2:
2971      *
2972      * At this point we have determined that the optree *can* be converted
2973      * into a multiconcat. Having gathered all the evidence, we now decide
2974      * whether it *should*.
2975      */
2976
2977
2978     /* we need at least one concat action, e.g.:
2979      *
2980      *  Y . Z
2981      *  X = Y . Z
2982      *  X .= Y
2983      *
2984      * otherwise we could be doing something like $x = "foo", which
2985      * if treated as as a concat, would fail to COW.
2986      */
2987     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2988         return;
2989
2990     /* Benchmarking seems to indicate that we gain if:
2991      * * we optimise at least two actions into a single multiconcat
2992      *    (e.g concat+concat, sassign+concat);
2993      * * or if we can eliminate at least 1 OP_CONST;
2994      * * or if we can eliminate a padsv via OPpTARGET_MY
2995      */
2996
2997     if (
2998            /* eliminated at least one OP_CONST */
2999            nconst >= 1
3000            /* eliminated an OP_SASSIGN */
3001         || o->op_type == OP_SASSIGN
3002            /* eliminated an OP_PADSV */
3003         || (!targmyop && is_targable)
3004     )
3005         /* definitely a net gain to optimise */
3006         goto optimise;
3007
3008     /* ... if not, what else? */
3009
3010     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3011      * multiconcat is faster (due to not creating a temporary copy of
3012      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3013      * faster.
3014      */
3015     if (   nconst == 0
3016          && nargs == 2
3017          && targmyop
3018          && topop->op_type == OP_CONCAT
3019     ) {
3020         PADOFFSET t = targmyop->op_targ;
3021         OP *k1 = cBINOPx(topop)->op_first;
3022         OP *k2 = cBINOPx(topop)->op_last;
3023         if (   k2->op_type == OP_PADSV
3024             && k2->op_targ == t
3025             && (   k1->op_type != OP_PADSV
3026                 || k1->op_targ != t)
3027         )
3028             goto optimise;
3029     }
3030
3031     /* need at least two concats */
3032     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3033         return;
3034
3035
3036
3037     /* -----------------------------------------------------------------
3038      * Phase 3:
3039      *
3040      * At this point the optree has been verified as ok to be optimised
3041      * into an OP_MULTICONCAT. Now start changing things.
3042      */
3043
3044    optimise:
3045
3046     /* stringify all const args and determine utf8ness */
3047
3048     variant = 0;
3049     for (argp = args; argp <= toparg; argp++) {
3050         SV *sv = (SV*)argp->p;
3051         if (!sv)
3052             continue; /* not a const op */
3053         if (utf8 && !SvUTF8(sv))
3054             sv_utf8_upgrade_nomg(sv);
3055         argp->p = SvPV_nomg(sv, argp->len);
3056         total_len += argp->len;
3057
3058         /* see if any strings would grow if converted to utf8 */
3059         if (!utf8) {
3060             char *p    = (char*)argp->p;
3061             STRLEN len = argp->len;
3062             while (len--) {
3063                 U8 c = *p++;
3064                 if (!UTF8_IS_INVARIANT(c))
3065                     variant++;
3066             }
3067         }
3068     }
3069
3070     /* create and populate aux struct */
3071
3072   create_aux:
3073
3074     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3075                     sizeof(UNOP_AUX_item)
3076                     *  (
3077                            PERL_MULTICONCAT_HEADER_SIZE
3078                          + ((nargs + 1) * (variant ? 2 : 1))
3079                         )
3080                     );
3081     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3082
3083     /* Extract all the non-const expressions from the concat tree then
3084      * dispose of the old tree, e.g. convert the tree from this:
3085      *
3086      *  o => SASSIGN
3087      *         |
3088      *       STRINGIFY   -- TARGET
3089      *         |
3090      *       ex-PUSHMARK -- CONCAT
3091      *                        |
3092      *                      CONCAT -- EXPR5
3093      *                        |
3094      *                      CONCAT -- EXPR4
3095      *                        |
3096      *                      CONCAT -- EXPR3
3097      *                        |
3098      *                      EXPR1  -- EXPR2
3099      *
3100      *
3101      * to:
3102      *
3103      *  o => MULTICONCAT
3104      *         |
3105      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3106      *
3107      * except that if EXPRi is an OP_CONST, it's discarded.
3108      *
3109      * During the conversion process, EXPR ops are stripped from the tree
3110      * and unshifted onto o. Finally, any of o's remaining original
3111      * childen are discarded and o is converted into an OP_MULTICONCAT.
3112      *
3113      * In this middle of this, o may contain both: unshifted args on the
3114      * left, and some remaining original args on the right. lastkidop
3115      * is set to point to the right-most unshifted arg to delineate
3116      * between the two sets.
3117      */
3118
3119
3120     if (is_sprintf) {
3121         /* create a copy of the format with the %'s removed, and record
3122          * the sizes of the const string segments in the aux struct */
3123         char *q, *oldq;
3124         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3125
3126         p    = sprintf_info.start;
3127         q    = const_str;
3128         oldq = q;
3129         for (; p < sprintf_info.end; p++) {
3130             if (*p == '%') {
3131                 p++;
3132                 if (*p != '%') {
3133                     (lenp++)->ssize = q - oldq;
3134                     oldq = q;
3135                     continue;
3136                 }
3137             }
3138             *q++ = *p;
3139         }
3140         lenp->ssize = q - oldq;
3141         assert((STRLEN)(q - const_str) == total_len);
3142
3143         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3144          * may or may not be topop) The pushmark and const ops need to be
3145          * kept in case they're an op_next entry point.
3146          */
3147         lastkidop = cLISTOPx(topop)->op_last;
3148         kid = cUNOPx(topop)->op_first; /* pushmark */
3149         op_null(kid);
3150         op_null(OpSIBLING(kid));       /* const */
3151         if (o != topop) {
3152             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3153             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3154             lastkidop->op_next = o;
3155         }
3156     }
3157     else {
3158         p = const_str;
3159         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3160
3161         lenp->ssize = -1;
3162
3163         /* Concatenate all const strings into const_str.
3164          * Note that args[] contains the RHS args in reverse order, so
3165          * we scan args[] from top to bottom to get constant strings
3166          * in L-R order
3167          */
3168         for (argp = toparg; argp >= args; argp--) {
3169             if (!argp->p)
3170                 /* not a const op */
3171                 (++lenp)->ssize = -1;
3172             else {
3173                 STRLEN l = argp->len;
3174                 Copy(argp->p, p, l, char);
3175                 p += l;
3176                 if (lenp->ssize == -1)
3177                     lenp->ssize = l;
3178                 else
3179                     lenp->ssize += l;
3180             }
3181         }
3182
3183         kid = topop;
3184         nextop = o;
3185         lastkidop = NULL;
3186
3187         for (argp = args; argp <= toparg; argp++) {
3188             /* only keep non-const args, except keep the first-in-next-chain
3189              * arg no matter what it is (but nulled if OP_CONST), because it
3190              * may be the entry point to this subtree from the previous
3191              * op_next.
3192              */
3193             bool last = (argp == toparg);
3194             OP *prev;
3195
3196             /* set prev to the sibling *before* the arg to be cut out,
3197              * e.g. when cutting EXPR:
3198              *
3199              *         |
3200              * kid=  CONCAT
3201              *         |
3202              * prev= CONCAT -- EXPR
3203              *         |
3204              */
3205             if (argp == args && kid->op_type != OP_CONCAT) {
3206                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3207                  * so the expression to be cut isn't kid->op_last but
3208                  * kid itself */
3209                 OP *o1, *o2;
3210                 /* find the op before kid */
3211                 o1 = NULL;
3212                 o2 = cUNOPx(parentop)->op_first;
3213                 while (o2 && o2 != kid) {
3214                     o1 = o2;
3215                     o2 = OpSIBLING(o2);
3216                 }
3217                 assert(o2 == kid);
3218                 prev = o1;
3219                 kid  = parentop;
3220             }
3221             else if (kid == o && lastkidop)
3222                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3223             else
3224                 prev = last ? NULL : cUNOPx(kid)->op_first;
3225
3226             if (!argp->p || last) {
3227                 /* cut RH op */
3228                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3229                 /* and unshift to front of o */
3230                 op_sibling_splice(o, NULL, 0, aop);
3231                 /* record the right-most op added to o: later we will
3232                  * free anything to the right of it */
3233                 if (!lastkidop)
3234                     lastkidop = aop;
3235                 aop->op_next = nextop;
3236                 if (last) {
3237                     if (argp->p)
3238                         /* null the const at start of op_next chain */
3239                         op_null(aop);
3240                 }
3241                 else if (prev)
3242                     nextop = prev->op_next;
3243             }
3244
3245             /* the last two arguments are both attached to the same concat op */
3246             if (argp < toparg - 1)
3247                 kid = prev;
3248         }
3249     }
3250
3251     /* Populate the aux struct */
3252
3253     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3254     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3255     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3256     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3257     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3258
3259     /* if variant > 0, calculate a variant const string and lengths where
3260      * the utf8 version of the string will take 'variant' more bytes than
3261      * the plain one. */
3262
3263     if (variant) {
3264         char              *p = const_str;
3265         STRLEN          ulen = total_len + variant;
3266         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3267         UNOP_AUX_item *ulens = lens + (nargs + 1);
3268         char             *up = (char*)PerlMemShared_malloc(ulen);
3269         SSize_t            n;
3270
3271         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3272         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3273
3274         for (n = 0; n < (nargs + 1); n++) {
3275             SSize_t i;
3276             char * orig_up = up;
3277             for (i = (lens++)->ssize; i > 0; i--) {
3278                 U8 c = *p++;
3279                 append_utf8_from_native_byte(c, (U8**)&up);
3280             }
3281             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3282         }
3283     }
3284
3285     if (stringop) {
3286         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3287          * that op's first child - an ex-PUSHMARK - because the op_next of
3288          * the previous op may point to it (i.e. it's the entry point for
3289          * the o optree)
3290          */
3291         OP *pmop =
3292             (stringop == o)
3293                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3294                 : op_sibling_splice(stringop, NULL, 1, NULL);
3295         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3296         op_sibling_splice(o, NULL, 0, pmop);
3297         if (!lastkidop)
3298             lastkidop = pmop;
3299     }
3300
3301     /* Optimise
3302      *    target  = A.B.C...
3303      *    target .= A.B.C...
3304      */
3305
3306     if (targetop) {
3307         assert(!targmyop);
3308
3309         if (o->op_type == OP_SASSIGN) {
3310             /* Move the target subtree from being the last of o's children
3311              * to being the last of o's preserved children.
3312              * Note the difference between 'target = ...' and 'target .= ...':
3313              * for the former, target is executed last; for the latter,
3314              * first.
3315              */
3316             kid = OpSIBLING(lastkidop);
3317             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3318             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3319             lastkidop->op_next = kid->op_next;
3320             lastkidop = targetop;
3321         }
3322         else {
3323             /* Move the target subtree from being the first of o's
3324              * original children to being the first of *all* o's children.
3325              */
3326             if (lastkidop) {
3327                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3328                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3329             }
3330             else {
3331                 /* if the RHS of .= doesn't contain a concat (e.g.
3332                  * $x .= "foo"), it gets missed by the "strip ops from the
3333                  * tree and add to o" loop earlier */
3334                 assert(topop->op_type != OP_CONCAT);
3335                 if (stringop) {
3336                     /* in e.g. $x .= "$y", move the $y expression
3337                      * from being a child of OP_STRINGIFY to being the
3338                      * second child of the OP_CONCAT
3339                      */
3340                     assert(cUNOPx(stringop)->op_first == topop);
3341                     op_sibling_splice(stringop, NULL, 1, NULL);
3342                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3343                 }
3344                 assert(topop == OpSIBLING(cBINOPo->op_first));
3345                 if (toparg->p)
3346                     op_null(topop);
3347                 lastkidop = topop;
3348             }
3349         }
3350
3351         if (is_targable) {
3352             /* optimise
3353              *  my $lex  = A.B.C...
3354              *     $lex  = A.B.C...
3355              *     $lex .= A.B.C...
3356              * The original padsv op is kept but nulled in case it's the
3357              * entry point for the optree (which it will be for
3358              * '$lex .=  ... '
3359              */
3360             private_flags |= OPpTARGET_MY;
3361             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3362             o->op_targ = targetop->op_targ;
3363             targetop->op_targ = 0;
3364             op_null(targetop);
3365         }
3366         else
3367             flags |= OPf_STACKED;
3368     }
3369     else if (targmyop) {
3370         private_flags |= OPpTARGET_MY;
3371         if (o != targmyop) {
3372             o->op_targ = targmyop->op_targ;
3373             targmyop->op_targ = 0;
3374         }
3375     }
3376
3377     /* detach the emaciated husk of the sprintf/concat optree and free it */
3378     for (;;) {
3379         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3380         if (!kid)
3381             break;
3382         op_free(kid);
3383     }
3384
3385     /* and convert o into a multiconcat */
3386
3387     o->op_flags        = (flags|OPf_KIDS|stacked_last
3388                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3389     o->op_private      = private_flags;
3390     o->op_type         = OP_MULTICONCAT;
3391     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3392     cUNOP_AUXo->op_aux = aux;
3393 }
3394
3395
3396 /* do all the final processing on an optree (e.g. running the peephole
3397  * optimiser on it), then attach it to cv (if cv is non-null)
3398  */
3399
3400 static void
3401 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3402 {
3403     OP **startp;
3404
3405     /* XXX for some reason, evals, require and main optrees are
3406      * never attached to their CV; instead they just hang off
3407      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3408      * and get manually freed when appropriate */
3409     if (cv)
3410         startp = &CvSTART(cv);
3411     else
3412         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3413
3414     *startp = start;
3415     optree->op_private |= OPpREFCOUNTED;
3416     OpREFCNT_set(optree, 1);
3417     optimize_optree(optree);
3418     CALL_PEEP(*startp);
3419     finalize_optree(optree);
3420     S_prune_chain_head(startp);
3421
3422     if (cv) {
3423         /* now that optimizer has done its work, adjust pad values */
3424         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3425                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3426     }
3427 }
3428
3429
3430 /*
3431 =for apidoc optimize_optree
3432
3433 This function applies some optimisations to the optree in top-down order.
3434 It is called before the peephole optimizer, which processes ops in
3435 execution order. Note that finalize_optree() also does a top-down scan,
3436 but is called *after* the peephole optimizer.
3437
3438 =cut
3439 */
3440
3441 void
3442 Perl_optimize_optree(pTHX_ OP* o)
3443 {
3444     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3445
3446     ENTER;
3447     SAVEVPTR(PL_curcop);
3448
3449     optimize_op(o);
3450
3451     LEAVE;
3452 }
3453
3454
3455 /* helper for optimize_optree() which optimises on op then recurses
3456  * to optimise any children.
3457  */
3458
3459 STATIC void
3460 S_optimize_op(pTHX_ OP* o)
3461 {
3462     dDEFER_OP;
3463
3464     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3465     do {
3466     assert(o->op_type != OP_FREED);
3467
3468     switch (o->op_type) {
3469     case OP_NEXTSTATE:
3470     case OP_DBSTATE:
3471         PL_curcop = ((COP*)o);          /* for warnings */
3472         break;
3473
3474
3475     case OP_CONCAT:
3476     case OP_SASSIGN:
3477     case OP_STRINGIFY:
3478     case OP_SPRINTF:
3479         S_maybe_multiconcat(aTHX_ o);
3480         break;
3481
3482     case OP_SUBST:
3483         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3484             DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3485         break;
3486
3487     default:
3488         break;
3489     }
3490
3491     if (o->op_flags & OPf_KIDS) {
3492         OP *kid;
3493         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3494             DEFER_OP(kid);
3495     }
3496     } while ( ( o = POP_DEFERRED_OP() ) );
3497
3498     DEFER_OP_CLEANUP;
3499 }
3500
3501
3502 /*
3503 =for apidoc finalize_optree
3504
3505 This function finalizes the optree.  Should be called directly after
3506 the complete optree is built.  It does some additional
3507 checking which can't be done in the normal C<ck_>xxx functions and makes
3508 the tree thread-safe.
3509
3510 =cut
3511 */
3512 void
3513 Perl_finalize_optree(pTHX_ OP* o)
3514 {
3515     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3516
3517     ENTER;
3518     SAVEVPTR(PL_curcop);
3519
3520     finalize_op(o);
3521
3522     LEAVE;
3523 }
3524
3525 #ifdef USE_ITHREADS
3526 /* Relocate sv to the pad for thread safety.
3527  * Despite being a "constant", the SV is written to,
3528  * for reference counts, sv_upgrade() etc. */
3529 PERL_STATIC_INLINE void
3530 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3531 {
3532     PADOFFSET ix;
3533     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3534     if (!*svp) return;
3535     ix = pad_alloc(OP_CONST, SVf_READONLY);
3536     SvREFCNT_dec(PAD_SVl(ix));
3537     PAD_SETSV(ix, *svp);
3538     /* XXX I don't know how this isn't readonly already. */
3539     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3540     *svp = NULL;
3541     *targp = ix;
3542 }
3543 #endif
3544
3545 /*
3546 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3547
3548 Return the next op in a depth-first traversal of the op tree,
3549 returning NULL when the traversal is complete.
3550
3551 The initial call must supply the root of the tree as both top and o.
3552
3553 For now it's static, but it may be exposed to the API in the future.
3554
3555 =cut
3556 */
3557
3558 STATIC OP*
3559 S_traverse_op_tree(OP *top, OP *o) {
3560     OP *sib;
3561
3562     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3563
3564     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3565         return cUNOPo->op_first;
3566     }
3567     else if ((sib = OpSIBLING(o))) {
3568         return sib;
3569     }
3570     else {
3571         OP *parent = o->op_sibparent;
3572         assert(!(o->op_moresib));
3573         while (parent && parent != top) {
3574             OP *sib = OpSIBLING(parent);
3575             if (sib)
3576                 return sib;
3577             parent = parent->op_sibparent;
3578         }
3579
3580         return NULL;
3581     }
3582 }
3583
3584 STATIC void
3585 S_finalize_op(pTHX_ OP* o)
3586 {
3587     OP * const top = o;
3588     PERL_ARGS_ASSERT_FINALIZE_OP;
3589
3590     do {
3591         assert(o->op_type != OP_FREED);
3592
3593         switch (o->op_type) {
3594         case OP_NEXTSTATE:
3595         case OP_DBSTATE:
3596             PL_curcop = ((COP*)o);              /* for warnings */
3597             break;
3598         case OP_EXEC:
3599             if (OpHAS_SIBLING(o)) {
3600                 OP *sib = OpSIBLING(o);
3601                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3602                     && ckWARN(WARN_EXEC)
3603                     && OpHAS_SIBLING(sib))
3604                 {
3605                     const OPCODE type = OpSIBLING(sib)->op_type;
3606                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3607                         const line_t oldline = CopLINE(PL_curcop);
3608                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3609                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3610                             "Statement unlikely to be reached");
3611                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3612                             "\t(Maybe you meant system() when you said exec()?)\n");
3613                         CopLINE_set(PL_curcop, oldline);
3614                     }
3615                 }
3616             }
3617             break;
3618
3619         case OP_GV:
3620             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3621                 GV * const gv = cGVOPo_gv;
3622                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3623                     /* XXX could check prototype here instead of just carping */
3624                     SV * const sv = sv_newmortal();
3625                     gv_efullname3(sv, gv, NULL);
3626                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3627                                 "%" SVf "() called too early to check prototype",
3628                                 SVfARG(sv));
3629                 }
3630             }
3631             break;
3632
3633         case OP_CONST:
3634             if (cSVOPo->op_private & OPpCONST_STRICT)
3635                 no_bareword_allowed(o);
3636 #ifdef USE_ITHREADS
3637             /* FALLTHROUGH */
3638         case OP_HINTSEVAL:
3639             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3640 #endif
3641             break;
3642
3643 #ifdef USE_ITHREADS
3644             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3645         case OP_METHOD_NAMED:
3646         case OP_METHOD_SUPER:
3647         case OP_METHOD_REDIR:
3648         case OP_METHOD_REDIR_SUPER:
3649             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3650             break;
3651 #endif
3652
3653         case OP_HELEM: {
3654             UNOP *rop;
3655             SVOP *key_op;
3656             OP *kid;
3657
3658             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3659                 break;
3660
3661             rop = (UNOP*)((BINOP*)o)->op_first;
3662
3663             goto check_keys;
3664
3665             case OP_HSLICE:
3666                 S_scalar_slice_warning(aTHX_ o);
3667                 /* FALLTHROUGH */
3668
3669             case OP_KVHSLICE:
3670                 kid = OpSIBLING(cLISTOPo->op_first);
3671             if (/* I bet there's always a pushmark... */
3672                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3673                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3674             {
3675                 break;
3676             }
3677
3678             key_op = (SVOP*)(kid->op_type == OP_CONST
3679                              ? kid
3680                              : OpSIBLING(kLISTOP->op_first));
3681
3682             rop = (UNOP*)((LISTOP*)o)->op_last;
3683
3684         check_keys:
3685             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3686                 rop = NULL;
3687             S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3688             break;
3689         }
3690         case OP_NULL:
3691             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3692                 break;
3693             /* FALLTHROUGH */
3694         case OP_ASLICE:
3695             S_scalar_slice_warning(aTHX_ o);
3696             break;
3697
3698         case OP_SUBST: {
3699             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3700                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3701             break;
3702         }
3703         default:
3704             break;
3705         }
3706
3707 #ifdef DEBUGGING
3708         if (o->op_flags & OPf_KIDS) {
3709             OP *kid;
3710
3711             /* check that op_last points to the last sibling, and that
3712              * the last op_sibling/op_sibparent field points back to the
3713              * parent, and that the only ops with KIDS are those which are
3714              * entitled to them */
3715             U32 type = o->op_type;
3716             U32 family;
3717             bool has_last;
3718
3719             if (type == OP_NULL) {
3720                 type = o->op_targ;
3721                 /* ck_glob creates a null UNOP with ex-type GLOB
3722                  * (which is a list op. So pretend it wasn't a listop */
3723                 if (type == OP_GLOB)
3724                     type = OP_NULL;
3725             }
3726             family = PL_opargs[type] & OA_CLASS_MASK;
3727
3728             has_last = (   family == OA_BINOP
3729                         || family == OA_LISTOP
3730                         || family == OA_PMOP
3731                         || family == OA_LOOP
3732                        );
3733             assert(  has_last /* has op_first and op_last, or ...
3734                   ... has (or may have) op_first: */
3735                   || family == OA_UNOP
3736                   || family == OA_UNOP_AUX
3737                   || family == OA_LOGOP
3738                   || family == OA_BASEOP_OR_UNOP
3739                   || family == OA_FILESTATOP
3740                   || family == OA_LOOPEXOP
3741                   || family == OA_METHOP
3742                   || type == OP_CUSTOM
3743                   || type == OP_NULL /* new_logop does this */
3744                   );
3745
3746             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3747                 if (!OpHAS_SIBLING(kid)) {
3748                     if (has_last)
3749                         assert(kid == cLISTOPo->op_last);
3750                     assert(kid->op_sibparent == o);
3751                 }
3752             }
3753         }
3754 #endif
3755     } while (( o = traverse_op_tree(top, o)) != NULL);
3756 }
3757
3758 /*
3759 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3760
3761 Propagate lvalue ("modifiable") context to an op and its children.
3762 C<type> represents the context type, roughly based on the type of op that
3763 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3764 because it has no op type of its own (it is signalled by a flag on
3765 the lvalue op).
3766
3767 This function detects things that can't be modified, such as C<$x+1>, and
3768 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3769 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3770
3771 It also flags things that need to behave specially in an lvalue context,
3772 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3773
3774 =cut
3775 */
3776
3777 static void
3778 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3779 {
3780     CV *cv = PL_compcv;
3781     PadnameLVALUE_on(pn);
3782     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3783         cv = CvOUTSIDE(cv);
3784         /* RT #127786: cv can be NULL due to an eval within the DB package
3785          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3786          * unless they contain an eval, but calling eval within DB
3787          * pretends the eval was done in the caller's scope.
3788          */
3789         if (!cv)
3790             break;
3791         assert(CvPADLIST(cv));
3792         pn =
3793            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3794         assert(PadnameLEN(pn));
3795         PadnameLVALUE_on(pn);
3796     }
3797 }
3798
3799 static bool
3800 S_vivifies(const OPCODE type)
3801 {
3802     switch(type) {
3803     case OP_RV2AV:     case   OP_ASLICE:
3804     case OP_RV2HV:     case OP_KVASLICE:
3805     case OP_RV2SV:     case   OP_HSLICE:
3806     case OP_AELEMFAST: case OP_KVHSLICE:
3807     case OP_HELEM:
3808     case OP_AELEM:
3809         return 1;
3810     }
3811     return 0;
3812 }
3813
3814 static void
3815 S_lvref(pTHX_ OP *o, I32 type)
3816 {
3817     dVAR;
3818     OP *kid;
3819     switch (o->op_type) {
3820     case OP_COND_EXPR:
3821         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3822              kid = OpSIBLING(kid))
3823             S_lvref(aTHX_ kid, type);
3824         /* FALLTHROUGH */
3825     case OP_PUSHMARK:
3826         return;
3827     case OP_RV2AV:
3828         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3829         o->op_flags |= OPf_STACKED;
3830         if (o->op_flags & OPf_PARENS) {
3831             if (o->op_private & OPpLVAL_INTRO) {
3832                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3833                       "localized parenthesized array in list assignment"));
3834                 return;
3835             }
3836           slurpy:
3837             OpTYPE_set(o, OP_LVAVREF);
3838             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3839             o->op_flags |= OPf_MOD|OPf_REF;
3840             return;
3841         }
3842         o->op_private |= OPpLVREF_AV;
3843         goto checkgv;
3844     case OP_RV2CV:
3845         kid = cUNOPo->op_first;
3846         if (kid->op_type == OP_NULL)
3847             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3848                 ->op_first;
3849         o->op_private = OPpLVREF_CV;
3850         if (kid->op_type == OP_GV)
3851             o->op_flags |= OPf_STACKED;
3852         else if (kid->op_type == OP_PADCV) {
3853             o->op_targ = kid->op_targ;
3854             kid->op_targ = 0;
3855             op_free(cUNOPo->op_first);
3856             cUNOPo->op_first = NULL;
3857             o->op_flags &=~ OPf_KIDS;
3858         }
3859         else goto badref;
3860         break;
3861     case OP_RV2HV:
3862         if (o->op_flags & OPf_PARENS) {
3863           parenhash:
3864             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3865                                  "parenthesized hash in list assignment"));
3866                 return;
3867         }
3868         o->op_private |= OPpLVREF_HV;
3869         /* FALLTHROUGH */
3870     case OP_RV2SV:
3871       checkgv:
3872         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3873         o->op_flags |= OPf_STACKED;
3874         break;
3875     case OP_PADHV:
3876         if (o->op_flags & OPf_PARENS) goto parenhash;
3877         o->op_private |= OPpLVREF_HV;
3878         /* FALLTHROUGH */
3879     case OP_PADSV:
3880         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3881         break;
3882     case OP_PADAV:
3883         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3884         if (o->op_flags & OPf_PARENS) goto slurpy;
3885         o->op_private |= OPpLVREF_AV;
3886         break;
3887     case OP_AELEM:
3888     case OP_HELEM:
3889         o->op_private |= OPpLVREF_ELEM;
3890         o->op_flags   |= OPf_STACKED;
3891         break;
3892     case OP_ASLICE:
3893     case OP_HSLICE:
3894         OpTYPE_set(o, OP_LVREFSLICE);
3895         o->op_private &= OPpLVAL_INTRO;
3896         return;
3897     case OP_NULL:
3898         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3899             goto badref;
3900         else if (!(o->op_flags & OPf_KIDS))
3901             return;
3902         if (o->op_targ != OP_LIST) {
3903             S_lvref(aTHX_ cBINOPo->op_first, type);
3904             return;
3905         }
3906         /* FALLTHROUGH */
3907     case OP_LIST:
3908         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3909             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3910             S_lvref(aTHX_ kid, type);
3911         }
3912         return;
3913     case OP_STUB:
3914         if (o->op_flags & OPf_PARENS)
3915             return;
3916         /* FALLTHROUGH */
3917     default:
3918       badref:
3919         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3920         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3921                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3922                       ? "do block"
3923                       : OP_DESC(o),
3924                      PL_op_desc[type]));
3925         return;
3926     }
3927     OpTYPE_set(o, OP_LVREF);
3928     o->op_private &=
3929         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3930     if (type == OP_ENTERLOOP)
3931         o->op_private |= OPpLVREF_ITER;
3932 }
3933
3934 PERL_STATIC_INLINE bool
3935 S_potential_mod_type(I32 type)
3936 {
3937     /* Types that only potentially result in modification.  */
3938     return type == OP_GREPSTART || type == OP_ENTERSUB
3939         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3940 }
3941
3942 OP *
3943 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3944 {
3945     dVAR;
3946     OP *kid;
3947     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3948     int localize = -1;
3949
3950     if (!o || (PL_parser && PL_parser->error_count))
3951         return o;
3952
3953     if ((o->op_private & OPpTARGET_MY)
3954         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3955     {
3956         return o;
3957     }
3958
3959     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3960
3961     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3962
3963     switch (o->op_type) {
3964     case OP_UNDEF:
3965         PL_modcount++;
3966         return o;
3967     case OP_STUB:
3968         if ((o->op_flags & OPf_PARENS))
3969             break;
3970         goto nomod;
3971     case OP_ENTERSUB:
3972         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3973             !(o->op_flags & OPf_STACKED)) {
3974             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3975             assert(cUNOPo->op_first->op_type == OP_NULL);
3976             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3977             break;
3978         }
3979         else {                          /* lvalue subroutine call */
3980             o->op_private |= OPpLVAL_INTRO;
3981             PL_modcount = RETURN_UNLIMITED_NUMBER;
3982             if (S_potential_mod_type(type)) {
3983                 o->op_private |= OPpENTERSUB_INARGS;
3984                 break;
3985             }
3986             else {                      /* Compile-time error message: */
3987                 OP *kid = cUNOPo->op_first;
3988                 CV *cv;
3989                 GV *gv;
3990                 SV *namesv;
3991
3992                 if (kid->op_type != OP_PUSHMARK) {
3993                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3994                         Perl_croak(aTHX_
3995                                 "panic: unexpected lvalue entersub "
3996                                 "args: type/targ %ld:%" UVuf,
3997                                 (long)kid->op_type, (UV)kid->op_targ);
3998                     kid = kLISTOP->op_first;
3999                 }
4000                 while (OpHAS_SIBLING(kid))
4001                     kid = OpSIBLING(kid);
4002                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4003                     break;      /* Postpone until runtime */
4004                 }
4005
4006                 kid = kUNOP->op_first;
4007                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4008                     kid = kUNOP->op_first;
4009                 if (kid->op_type == OP_NULL)
4010                     Perl_croak(aTHX_
4011                                "Unexpected constant lvalue entersub "
4012                                "entry via type/targ %ld:%" UVuf,
4013                                (long)kid->op_type, (UV)kid->op_targ);
4014                 if (kid->op_type != OP_GV) {
4015                     break;
4016                 }
4017
4018                 gv = kGVOP_gv;
4019                 cv = isGV(gv)
4020                     ? GvCV(gv)
4021                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4022                         ? MUTABLE_CV(SvRV(gv))
4023                         : NULL;
4024                 if (!cv)
4025                     break;
4026                 if (CvLVALUE(cv))
4027                     break;
4028                 if (flags & OP_LVALUE_NO_CROAK)
4029                     return NULL;
4030
4031                 namesv = cv_name(cv, NULL, 0);
4032                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4033                                      "subroutine call of &%" SVf " in %s",
4034                                      SVfARG(namesv), PL_op_desc[type]),
4035                            SvUTF8(namesv));
4036                 return o;
4037             }
4038         }
4039         /* FALLTHROUGH */
4040     default:
4041       nomod:
4042         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4043         /* grep, foreach, subcalls, refgen */
4044         if (S_potential_mod_type(type))
4045             break;
4046         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4047                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4048                       ? "do block"
4049                       : OP_DESC(o)),
4050                      type ? PL_op_desc[type] : "local"));
4051         return o;
4052
4053     case OP_PREINC:
4054     case OP_PREDEC:
4055     case OP_POW:
4056     case OP_MULTIPLY:
4057     case OP_DIVIDE:
4058     case OP_MODULO:
4059     case OP_ADD:
4060     case OP_SUBTRACT:
4061     case OP_CONCAT:
4062     case OP_LEFT_SHIFT:
4063     case OP_RIGHT_SHIFT:
4064     case OP_BIT_AND:
4065     case OP_BIT_XOR:
4066     case OP_BIT_OR:
4067     case OP_I_MULTIPLY:
4068     case OP_I_DIVIDE:
4069     case OP_I_MODULO:
4070     case OP_I_ADD:
4071     case OP_I_SUBTRACT:
4072         if (!(o->op_flags & OPf_STACKED))
4073             goto nomod;
4074         PL_modcount++;
4075         break;
4076
4077     case OP_REPEAT:
4078         if (o->op_flags & OPf_STACKED) {
4079             PL_modcount++;
4080             break;
4081         }
4082         if (!(o->op_private & OPpREPEAT_DOLIST))
4083             goto nomod;
4084         else {
4085             const I32 mods = PL_modcount;
4086             modkids(cBINOPo->op_first, type);
4087             if (type != OP_AASSIGN)
4088                 goto nomod;
4089             kid = cBINOPo->op_last;
4090             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4091                 const IV iv = SvIV(kSVOP_sv);
4092                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4093                     PL_modcount =
4094                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4095             }
4096             else
4097                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4098         }
4099         break;
4100
4101     case OP_COND_EXPR:
4102         localize = 1;
4103         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4104             op_lvalue(kid, type);
4105         break;
4106
4107     case OP_RV2AV:
4108     case OP_RV2HV:
4109         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4110            PL_modcount = RETURN_UNLIMITED_NUMBER;
4111            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4112               fiable since some contexts need to know.  */
4113            o->op_flags |= OPf_MOD;
4114            return o;
4115         }
4116         /* FALLTHROUGH */
4117     case OP_RV2GV:
4118         if (scalar_mod_type(o, type))
4119             goto nomod;
4120         ref(cUNOPo->op_first, o->op_type);
4121         /* FALLTHROUGH */
4122     case OP_ASLICE:
4123     case OP_HSLICE:
4124         localize = 1;
4125         /* FALLTHROUGH */
4126     case OP_AASSIGN:
4127         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4128         if (type == OP_LEAVESUBLV && (
4129                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4130              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4131            ))
4132             o->op_private |= OPpMAYBE_LVSUB;
4133         /* FALLTHROUGH */
4134     case OP_NEXTSTATE:
4135     case OP_DBSTATE:
4136        PL_modcount = RETURN_UNLIMITED_NUMBER;
4137         break;
4138     case OP_KVHSLICE:
4139     case OP_KVASLICE:
4140     case OP_AKEYS:
4141         if (type == OP_LEAVESUBLV)
4142             o->op_private |= OPpMAYBE_LVSUB;
4143         goto nomod;
4144     case OP_AVHVSWITCH:
4145         if (type == OP_LEAVESUBLV
4146          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4147             o->op_private |= OPpMAYBE_LVSUB;
4148         goto nomod;
4149     case OP_AV2ARYLEN:
4150         PL_hints |= HINT_BLOCK_SCOPE;
4151         if (type == OP_LEAVESUBLV)
4152             o->op_private |= OPpMAYBE_LVSUB;
4153         PL_modcount++;
4154         break;
4155     case OP_RV2SV:
4156         ref(cUNOPo->op_first, o->op_type);
4157         localize = 1;
4158         /* FALLTHROUGH */
4159     case OP_GV:
4160         PL_hints |= HINT_BLOCK_SCOPE;
4161         /* FALLTHROUGH */
4162     case OP_SASSIGN:
4163     case OP_ANDASSIGN:
4164     case OP_ORASSIGN:
4165     case OP_DORASSIGN:
4166         PL_modcount++;
4167         break;
4168
4169     case OP_AELEMFAST:
4170     case OP_AELEMFAST_LEX:
4171         localize = -1;
4172         PL_modcount++;
4173         break;
4174
4175     case OP_PADAV:
4176     case OP_PADHV:
4177        PL_modcount = RETURN_UNLIMITED_NUMBER;
4178         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4179         {
4180            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4181               fiable since some contexts need to know.  */
4182             o->op_flags |= OPf_MOD;
4183             return o;
4184         }
4185         if (scalar_mod_type(o, type))
4186             goto nomod;
4187         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4188           && type == OP_LEAVESUBLV)
4189             o->op_private |= OPpMAYBE_LVSUB;
4190         /* FALLTHROUGH */
4191     case OP_PADSV:
4192         PL_modcount++;
4193         if (!type) /* local() */
4194             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4195                               PNfARG(PAD_COMPNAME(o->op_targ)));
4196         if (!(o->op_private & OPpLVAL_INTRO)
4197          || (  type != OP_SASSIGN && type != OP_AASSIGN
4198             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4199             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4200         break;
4201
4202     case OP_PUSHMARK:
4203         localize = 0;
4204         break;
4205
4206     case OP_KEYS:
4207         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4208             goto nomod;
4209         goto lvalue_func;
4210     case OP_SUBSTR:
4211         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4212             goto nomod;
4213         /* FALLTHROUGH */
4214     case OP_POS:
4215     case OP_VEC:
4216       lvalue_func:
4217         if (type == OP_LEAVESUBLV)
4218             o->op_private |= OPpMAYBE_LVSUB;
4219         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4220             /* substr and vec */
4221             /* If this op is in merely potential (non-fatal) modifiable
4222                context, then apply OP_ENTERSUB context to
4223                the kid op (to avoid croaking).  Other-
4224                wise pass this op’s own type so the correct op is mentioned
4225                in error messages.  */
4226             op_lvalue(OpSIBLING(cBINOPo->op_first),
4227                       S_potential_mod_type(type)
4228                         ? (I32)OP_ENTERSUB
4229                         : o->op_type);
4230         }
4231         break;
4232
4233     case OP_AELEM:
4234     case OP_HELEM:
4235         ref(cBINOPo->op_first, o->op_type);
4236         if (type == OP_ENTERSUB &&
4237              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4238             o->op_private |= OPpLVAL_DEFER;
4239         if (type == OP_LEAVESUBLV)
4240             o->op_private |= OPpMAYBE_LVSUB;
4241         localize = 1;
4242         PL_modcount++;
4243         break;
4244
4245     case OP_LEAVE:
4246     case OP_LEAVELOOP:
4247         o->op_private |= OPpLVALUE;
4248         /* FALLTHROUGH */
4249     case OP_SCOPE:
4250     case OP_ENTER:
4251     case OP_LINESEQ:
4252         localize = 0;
4253         if (o->op_flags & OPf_KIDS)
4254             op_lvalue(cLISTOPo->op_last, type);
4255         break;
4256
4257     case OP_NULL:
4258         localize = 0;
4259         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4260             goto nomod;
4261         else if (!(o->op_flags & OPf_KIDS))
4262             break;
4263
4264         if (o->op_targ != OP_LIST) {
4265             OP *sib = OpSIBLING(cLISTOPo->op_first);
4266             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4267              * that looks like
4268              *
4269              *   null
4270              *      arg
4271              *      trans
4272              *
4273              * compared with things like OP_MATCH which have the argument
4274              * as a child:
4275              *
4276              *   match
4277              *      arg
4278              *
4279              * so handle specially to correctly get "Can't modify" croaks etc
4280              */
4281
4282             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4283             {
4284                 /* this should trigger a "Can't modify transliteration" err */
4285                 op_lvalue(sib, type);
4286             }
4287             op_lvalue(cBINOPo->op_first, type);
4288             break;
4289         }
4290         /* FALLTHROUGH */
4291     case OP_LIST:
4292         localize = 0;
4293         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4294             /* elements might be in void context because the list is
4295                in scalar context or because they are attribute sub calls */
4296             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4297                 op_lvalue(kid, type);
4298         break;
4299
4300     case OP_COREARGS:
4301         return o;
4302
4303     case OP_AND:
4304     case OP_OR:
4305         if (type == OP_LEAVESUBLV
4306          || !S_vivifies(cLOGOPo->op_first->op_type))
4307             op_lvalue(cLOGOPo->op_first, type);
4308         if (type == OP_LEAVESUBLV
4309          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4310             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4311         goto nomod;
4312
4313     case OP_SREFGEN:
4314         if (type == OP_NULL) { /* local */
4315           local_refgen:
4316             if (!FEATURE_MYREF_IS_ENABLED)
4317                 Perl_croak(aTHX_ "The experimental declared_refs "
4318                                  "feature is not enabled");
4319             Perl_ck_warner_d(aTHX_
4320                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4321                     "Declaring references is experimental");
4322             op_lvalue(cUNOPo->op_first, OP_NULL);
4323             return o;
4324         }
4325         if (type != OP_AASSIGN && type != OP_SASSIGN
4326          && type != OP_ENTERLOOP)
4327             goto nomod;
4328         /* Don’t bother applying lvalue context to the ex-list.  */
4329         kid = cUNOPx(cUNOPo->op_first)->op_first;
4330         assert (!OpHAS_SIBLING(kid));
4331         goto kid_2lvref;
4332     case OP_REFGEN:
4333         if (type == OP_NULL) /* local */
4334             goto local_refgen;
4335         if (type != OP_AASSIGN) goto nomod;
4336         kid = cUNOPo->op_first;
4337       kid_2lvref:
4338         {
4339             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4340             S_lvref(aTHX_ kid, type);
4341             if (!PL_parser || PL_parser->error_count == ec) {
4342                 if (!FEATURE_REFALIASING_IS_ENABLED)
4343                     Perl_croak(aTHX_
4344                        "Experimental aliasing via reference not enabled");
4345                 Perl_ck_warner_d(aTHX_
4346                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4347                                 "Aliasing via reference is experimental");
4348             }
4349         }
4350         if (o->op_type == OP_REFGEN)
4351             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4352         op_null(o);
4353         return o;
4354
4355     case OP_SPLIT:
4356         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4357             /* This is actually @array = split.  */
4358             PL_modcount = RETURN_UNLIMITED_NUMBER;
4359             break;
4360         }
4361         goto nomod;
4362
4363     case OP_SCALAR:
4364         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4365         goto nomod;
4366     }
4367
4368     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4369        their argument is a filehandle; thus \stat(".") should not set
4370        it. AMS 20011102 */
4371     if (type == OP_REFGEN &&
4372         PL_check[o->op_type] == Perl_ck_ftst)
4373         return o;
4374
4375     if (type != OP_LEAVESUBLV)
4376         o->op_flags |= OPf_MOD;
4377
4378     if (type == OP_AASSIGN || type == OP_SASSIGN)
4379         o->op_flags |= OPf_SPECIAL
4380                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4381     else if (!type) { /* local() */
4382         switch (localize) {
4383         case 1:
4384             o->op_private |= OPpLVAL_INTRO;
4385             o->op_flags &= ~OPf_SPECIAL;
4386             PL_hints |= HINT_BLOCK_SCOPE;
4387             break;
4388         case 0:
4389             break;
4390         case -1:
4391             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4392                            "Useless localization of %s", OP_DESC(o));
4393         }
4394     }
4395     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4396              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4397         o->op_flags |= OPf_REF;
4398     return o;
4399 }
4400
4401 STATIC bool
4402 S_scalar_mod_type(const OP *o, I32 type)
4403 {
4404     switch (type) {
4405     case OP_POS:
4406     case OP_SASSIGN:
4407         if (o && o->op_type == OP_RV2GV)
4408             return FALSE;
4409         /* FALLTHROUGH */
4410     case OP_PREINC:
4411     case OP_PREDEC:
4412     case OP_POSTINC:
4413     case OP_POSTDEC:
4414     case OP_I_PREINC:
4415     case OP_I_PREDEC:
4416     case OP_I_POSTINC:
4417     case OP_I_POSTDEC:
4418     case OP_POW:
4419     case OP_MULTIPLY:
4420     case OP_DIVIDE:
4421     case OP_MODULO:
4422     case OP_REPEAT:
4423     case OP_ADD:
4424     case OP_SUBTRACT:
4425     case OP_I_MULTIPLY:
4426     case OP_I_DIVIDE:
4427     case OP_I_MODULO:
4428     case OP_I_ADD:
4429     case OP_I_SUBTRACT:
4430     case OP_LEFT_SHIFT:
4431     case OP_RIGHT_SHIFT:
4432     case OP_BIT_AND:
4433     case OP_BIT_XOR:
4434     case OP_BIT_OR:
4435     case OP_NBIT_AND:
4436     case OP_NBIT_XOR:
4437     case OP_NBIT_OR:
4438     case OP_SBIT_AND:
4439     case OP_SBIT_XOR:
4440     case OP_SBIT_OR:
4441     case OP_CONCAT:
4442     case OP_SUBST:
4443     case OP_TRANS:
4444     case OP_TRANSR:
4445     case OP_READ:
4446     case OP_SYSREAD:
4447     case OP_RECV:
4448     case OP_ANDASSIGN:
4449     case OP_ORASSIGN:
4450     case OP_DORASSIGN:
4451     case OP_VEC:
4452     case OP_SUBSTR:
4453         return TRUE;
4454     default:
4455         return FALSE;
4456     }
4457 }
4458
4459 STATIC bool
4460 S_is_handle_constructor(const OP *o, I32 numargs)
4461 {
4462     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4463
4464     switch (o->op_type) {
4465     case OP_PIPE_OP:
4466     case OP_SOCKPAIR:
4467         if (numargs == 2)
4468             return TRUE;
4469         /* FALLTHROUGH */
4470     case OP_SYSOPEN:
4471     case OP_OPEN:
4472     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4473     case OP_SOCKET:
4474     case OP_OPEN_DIR:
4475     case OP_ACCEPT:
4476         if (numargs == 1)
4477             return TRUE;
4478         /* FALLTHROUGH */
4479     default:
4480         return FALSE;
4481     }
4482 }
4483
4484 static OP *
4485 S_refkids(pTHX_ OP *o, I32 type)
4486 {
4487     if (o && o->op_flags & OPf_KIDS) {
4488         OP *kid;
4489         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4490             ref(kid, type);
4491     }
4492     return o;
4493 }
4494
4495 OP *
4496 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4497 {
4498     dVAR;
4499     OP *kid;
4500
4501     PERL_ARGS_ASSERT_DOREF;
4502
4503     if (PL_parser && PL_parser->error_count)
4504         return o;
4505
4506     switch (o->op_type) {
4507     case OP_ENTERSUB:
4508         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4509             !(o->op_flags & OPf_STACKED)) {
4510             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4511             assert(cUNOPo->op_first->op_type == OP_NULL);
4512             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4513             o->op_flags |= OPf_SPECIAL;
4514         }
4515         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4516             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4517                               : type == OP_RV2HV ? OPpDEREF_HV
4518                               : OPpDEREF_SV);
4519             o->op_flags |= OPf_MOD;
4520         }
4521
4522         break;
4523
4524     case OP_COND_EXPR:
4525         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4526             doref(kid, type, set_op_ref);
4527         break;
4528     case OP_RV2SV:
4529         if (type == OP_DEFINED)
4530             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4531         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4532         /* FALLTHROUGH */
4533     case OP_PADSV:
4534         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4535             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4536                               : type == OP_RV2HV ? OPpDEREF_HV
4537                               : OPpDEREF_SV);
4538             o->op_flags |= OPf_MOD;
4539         }
4540         break;
4541
4542     case OP_RV2AV:
4543     case OP_RV2HV:
4544         if (set_op_ref)
4545             o->op_flags |= OPf_REF;
4546         /* FALLTHROUGH */
4547     case OP_RV2GV:
4548         if (type == OP_DEFINED)
4549             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4550         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4551         break;
4552
4553     case OP_PADAV:
4554     case OP_PADHV:
4555         if (set_op_ref)
4556             o->op_flags |= OPf_REF;
4557         break;
4558
4559     case OP_SCALAR:
4560     case OP_NULL:
4561         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4562             break;
4563         doref(cBINOPo->op_first, type, set_op_ref);
4564         break;
4565     case OP_AELEM:
4566     case OP_HELEM:
4567         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4568         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4569             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4570                               : type == OP_RV2HV ? OPpDEREF_HV
4571                               : OPpDEREF_SV);
4572             o->op_flags |= OPf_MOD;
4573         }
4574         break;
4575
4576     case OP_SCOPE:
4577     case OP_LEAVE:
4578         set_op_ref = FALSE;
4579         /* FALLTHROUGH */
4580     case OP_ENTER:
4581     case OP_LIST:
4582         if (!(o->op_flags & OPf_KIDS))
4583             break;
4584         doref(cLISTOPo->op_last, type, set_op_ref);
4585         break;
4586     default:
4587         break;
4588     }
4589     return scalar(o);
4590
4591 }
4592
4593 STATIC OP *
4594 S_dup_attrlist(pTHX_ OP *o)
4595 {
4596     OP *rop;
4597
4598     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4599
4600     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4601      * where the first kid is OP_PUSHMARK and the remaining ones
4602      * are OP_CONST.  We need to push the OP_CONST values.
4603      */
4604     if (o->op_type == OP_CONST)
4605         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4606     else {
4607         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4608         rop = NULL;
4609         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4610             if (o->op_type == OP_CONST)
4611                 rop = op_append_elem(OP_LIST, rop,
4612                                   newSVOP(OP_CONST, o->op_flags,
4613                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4614         }
4615     }
4616     return rop;
4617 }
4618
4619 STATIC void
4620 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4621 {
4622     PERL_ARGS_ASSERT_APPLY_ATTRS;
4623     {
4624         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4625
4626         /* fake up C<use attributes $pkg,$rv,@attrs> */
4627
4628 #define ATTRSMODULE "attributes"
4629 #define ATTRSMODULE_PM "attributes.pm"
4630
4631         Perl_load_module(
4632           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4633           newSVpvs(ATTRSMODULE),
4634           NULL,
4635           op_prepend_elem(OP_LIST,
4636                           newSVOP(OP_CONST, 0, stashsv),
4637                           op_prepend_elem(OP_LIST,
4638                                           newSVOP(OP_CONST, 0,
4639                                                   newRV(target)),
4640                                           dup_attrlist(attrs))));
4641     }
4642 }
4643
4644 STATIC void
4645 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4646 {
4647     OP *pack, *imop, *arg;
4648     SV *meth, *stashsv, **svp;
4649
4650     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4651
4652     if (!attrs)
4653         return;
4654
4655     assert(target->op_type == OP_PADSV ||
4656            target->op_type == OP_PADHV ||
4657            target->op_type == OP_PADAV);
4658
4659     /* Ensure that attributes.pm is loaded. */
4660     /* Don't force the C<use> if we don't need it. */
4661     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4662     if (svp && *svp != &PL_sv_undef)
4663         NOOP;   /* already in %INC */
4664     else
4665         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4666                                newSVpvs(ATTRSMODULE), NULL);
4667
4668     /* Need package name for method call. */
4669     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4670
4671     /* Build up the real arg-list. */
4672     stashsv = newSVhek(HvNAME_HEK(stash));
4673
4674     arg = newOP(OP_PADSV, 0);
4675     arg->op_targ = target->op_targ;
4676     arg = op_prepend_elem(OP_LIST,
4677                        newSVOP(OP_CONST, 0, stashsv),
4678                        op_prepend_elem(OP_LIST,
4679                                     newUNOP(OP_REFGEN, 0,
4680                                             arg),
4681                                     dup_attrlist(attrs)));
4682
4683     /* Fake up a method call to import */
4684     meth = newSVpvs_share("import");
4685     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4686                    op_append_elem(OP_LIST,
4687                                op_prepend_elem(OP_LIST, pack, arg),
4688                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4689
4690     /* Combine the ops. */
4691     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4692 }
4693
4694 /*
4695 =notfor apidoc apply_attrs_string
4696
4697 Attempts to apply a list of attributes specified by the C<attrstr> and
4698 C<len> arguments to the subroutine identified by the C<cv> argument which
4699 is expected to be associated with the package identified by the C<stashpv>
4700 argument (see L<attributes>).  It gets this wrong, though, in that it
4701 does not correctly identify the boundaries of the individual attribute
4702 specifications within C<attrstr>.  This is not really intended for the
4703 public API, but has to be listed here for systems such as AIX which
4704 need an explicit export list for symbols.  (It's called from XS code
4705 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4706 to respect attribute syntax properly would be welcome.
4707
4708 =cut
4709 */
4710
4711 void
4712 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4713                         const char *attrstr, STRLEN len)
4714 {
4715     OP *attrs = NULL;
4716
4717     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4718
4719     if (!len) {
4720         len = strlen(attrstr);
4721     }
4722
4723     while (len) {
4724         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4725         if (len) {
4726             const char * const sstr = attrstr;
4727             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4728             attrs = op_append_elem(OP_LIST, attrs,
4729                                 newSVOP(OP_CONST, 0,
4730                                         newSVpvn(sstr, attrstr-sstr)));
4731         }
4732     }
4733
4734     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4735                      newSVpvs(ATTRSMODULE),
4736                      NULL, op_prepend_elem(OP_LIST,
4737                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4738                                   op_prepend_elem(OP_LIST,
4739                                                newSVOP(OP_CONST, 0,
4740                                                        newRV(MUTABLE_SV(cv))),
4741                                                attrs)));
4742 }
4743
4744 STATIC void
4745 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4746                         bool curstash)
4747 {
4748     OP *new_proto = NULL;
4749     STRLEN pvlen;
4750     char *pv;
4751     OP *o;
4752
4753     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4754
4755     if (!*attrs)
4756         return;
4757
4758     o = *attrs;
4759     if (o->op_type == OP_CONST) {
4760         pv = SvPV(cSVOPo_sv, pvlen);
4761         if (memBEGINs(pv, pvlen, "prototype(")) {
4762             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4763             SV ** const tmpo = cSVOPx_svp(o);
4764             SvREFCNT_dec(cSVOPo_sv);
4765             *tmpo = tmpsv;
4766             new_proto = o;
4767             *attrs = NULL;
4768         }
4769     } else if (o->op_type == OP_LIST) {
4770         OP * lasto;
4771         assert(o->op_flags & OPf_KIDS);
4772         lasto = cLISTOPo->op_first;
4773         assert(lasto->op_type == OP_PUSHMARK);
4774         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4775             if (o->op_type == OP_CONST) {
4776                 pv = SvPV(cSVOPo_sv, pvlen);
4777                 if (memBEGINs(pv, pvlen, "prototype(")) {
4778                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4779                     SV ** const tmpo = cSVOPx_svp(o);
4780                     SvREFCNT_dec(cSVOPo_sv);
4781                     *tmpo = tmpsv;
4782                     if (new_proto && ckWARN(WARN_MISC)) {
4783                         STRLEN new_len;
4784                         const char * newp = SvPV(cSVOPo_sv, new_len);
4785                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4786                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4787                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4788                         op_free(new_proto);
4789                     }
4790                     else if (new_proto)
4791                         op_free(new_proto);
4792                     new_proto = o;
4793                     /* excise new_proto from the list */
4794                     op_sibling_splice(*attrs, lasto, 1, NULL);
4795                     o = lasto;
4796                     continue;
4797                 }
4798             }
4799             lasto = o;
4800         }
4801         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4802            would get pulled in with no real need */
4803         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4804             op_free(*attrs);
4805             *attrs = NULL;
4806         }
4807     }
4808
4809     if (new_proto) {
4810         SV *svname;
4811         if (isGV(name)) {
4812             svname = sv_newmortal();
4813             gv_efullname3(svname, name, NULL);
4814         }
4815         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4816             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4817         else
4818             svname = (SV *)name;
4819         if (ckWARN(WARN_ILLEGALPROTO))
4820             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4821                                  curstash);
4822         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4823             STRLEN old_len, new_len;
4824             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4825             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4826
4827             if (curstash && svname == (SV *)name
4828              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4829                 svname = sv_2mortal(newSVsv(PL_curstname));
4830                 sv_catpvs(svname, "::");
4831                 sv_catsv(svname, (SV *)name);
4832             }
4833
4834             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4835                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4836                 " in %" SVf,
4837                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4838                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4839                 SVfARG(svname));
4840         }
4841         if (*proto)
4842             op_free(*proto);
4843         *proto = new_proto;
4844     }
4845 }
4846
4847 static void
4848 S_cant_declare(pTHX_ OP *o)
4849 {
4850     if (o->op_type == OP_NULL
4851      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4852         o = cUNOPo->op_first;
4853     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4854                              o->op_type == OP_NULL
4855                                && o->op_flags & OPf_SPECIAL
4856                                  ? "do block"
4857                                  : OP_DESC(o),
4858                              PL_parser->in_my == KEY_our   ? "our"   :
4859                              PL_parser->in_my == KEY_state ? "state" :
4860                                                              "my"));
4861 }
4862
4863 STATIC OP *
4864 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4865 {
4866     I32 type;
4867     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4868
4869     PERL_ARGS_ASSERT_MY_KID;
4870
4871     if (!o || (PL_parser && PL_parser->error_count))
4872         return o;
4873
4874     type = o->op_type;
4875
4876     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4877         OP *kid;
4878         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4879             my_kid(kid, attrs, imopsp);
4880         return o;
4881     } else if (type == OP_UNDEF || type == OP_STUB) {
4882         return o;
4883     } else if (type == OP_RV2SV ||      /* "our" declaration */
4884                type == OP_RV2AV ||
4885                type == OP_RV2HV) {
4886         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4887             S_cant_declare(aTHX_ o);
4888         } else if (attrs) {
4889             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4890             assert(PL_parser);
4891             PL_parser->in_my = FALSE;
4892             PL_parser->in_my_stash = NULL;
4893             apply_attrs(GvSTASH(gv),
4894                         (type == OP_RV2SV ? GvSVn(gv) :
4895                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4896                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4897                         attrs);
4898         }
4899         o->op_private |= OPpOUR_INTRO;
4900         return o;
4901     }
4902     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4903         if (!FEATURE_MYREF_IS_ENABLED)
4904             Perl_croak(aTHX_ "The experimental declared_refs "
4905                              "feature is not enabled");
4906         Perl_ck_warner_d(aTHX_
4907              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4908             "Declaring references is experimental");
4909         /* Kid is a nulled OP_LIST, handled above.  */
4910         my_kid(cUNOPo->op_first, attrs, imopsp);
4911         return o;
4912     }
4913     else if (type != OP_PADSV &&
4914              type != OP_PADAV &&
4915              type != OP_PADHV &&
4916              type != OP_PUSHMARK)
4917     {
4918         S_cant_declare(aTHX_ o);
4919         return o;
4920     }
4921     else if (attrs && type != OP_PUSHMARK) {
4922         HV *stash;
4923
4924         assert(PL_parser);
4925         PL_parser->in_my = FALSE;
4926         PL_parser->in_my_stash = NULL;
4927
4928         /* check for C<my Dog $spot> when deciding package */
4929         stash = PAD_COMPNAME_TYPE(o->op_targ);
4930         if (!stash)
4931             stash = PL_curstash;
4932         apply_attrs_my(stash, o, attrs, imopsp);
4933     }
4934     o->op_flags |= OPf_MOD;
4935     o->op_private |= OPpLVAL_INTRO;
4936     if (stately)
4937         o->op_private |= OPpPAD_STATE;
4938     return o;
4939 }
4940
4941 OP *
4942 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4943 {
4944     OP *rops;
4945     int maybe_scalar = 0;
4946
4947     PERL_ARGS_ASSERT_MY_ATTRS;
4948
4949 /* [perl #17376]: this appears to be premature, and results in code such as
4950    C< our(%x); > executing in list mode rather than void mode */
4951 #if 0
4952     if (o->op_flags & OPf_PARENS)
4953         list(o);
4954     else
4955         maybe_scalar = 1;
4956 #else
4957     maybe_scalar = 1;
4958 #endif
4959     if (attrs)
4960         SAVEFREEOP(attrs);
4961     rops = NULL;
4962     o = my_kid(o, attrs, &rops);
4963     if (rops) {
4964         if (maybe_scalar && o->op_type == OP_PADSV) {
4965             o = scalar(op_append_list(OP_LIST, rops, o));
4966             o->op_private |= OPpLVAL_INTRO;
4967         }
4968         else {
4969             /* The listop in rops might have a pushmark at the beginning,
4970                which will mess up list assignment. */
4971             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4972             if (rops->op_type == OP_LIST &&
4973                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4974             {
4975                 OP * const pushmark = lrops->op_first;
4976                 /* excise pushmark */
4977                 op_sibling_splice(rops, NULL, 1, NULL);
4978                 op_free(pushmark);
4979             }
4980             o = op_append_list(OP_LIST, o, rops);
4981         }
4982     }
4983     PL_parser->in_my = FALSE;
4984     PL_parser->in_my_stash = NULL;
4985     return o;
4986 }
4987
4988 OP *
4989 Perl_sawparens(pTHX_ OP *o)
4990 {
4991     PERL_UNUSED_CONTEXT;
4992     if (o)
4993         o->op_flags |= OPf_PARENS;
4994     return o;
4995 }
4996
4997 OP *
4998 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4999 {
5000     OP *o;
5001     bool ismatchop = 0;
5002     const OPCODE ltype = left->op_type;
5003     const OPCODE rtype = right->op_type;
5004
5005     PERL_ARGS_ASSERT_BIND_MATCH;
5006
5007     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5008           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5009     {
5010       const char * const desc
5011           = PL_op_desc[(
5012                           rtype == OP_SUBST || rtype == OP_TRANS
5013                        || rtype == OP_TRANSR
5014                        )
5015                        ? (int)rtype : OP_MATCH];
5016       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5017       SV * const name =
5018         S_op_varname(aTHX_ left);
5019       if (name)
5020         Perl_warner(aTHX_ packWARN(WARN_MISC),
5021              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5022              desc, SVfARG(name), SVfARG(name));
5023       else {
5024         const char * const sample = (isary
5025              ? "@array" : "%hash");
5026         Perl_warner(aTHX_ packWARN(WARN_MISC),
5027              "Applying %s to %s will act on scalar(%s)",
5028              desc, sample, sample);
5029       }
5030     }
5031
5032     if (rtype == OP_CONST &&
5033         cSVOPx(right)->op_private & OPpCONST_BARE &&
5034         cSVOPx(right)->op_private & OPpCONST_STRICT)
5035     {
5036         no_bareword_allowed(right);
5037     }
5038
5039     /* !~ doesn't make sense with /r, so error on it for now */
5040     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5041         type == OP_NOT)
5042         /* diag_listed_as: Using !~ with %s doesn't make sense */
5043         yyerror("Using !~ with s///r doesn't make sense");
5044     if (rtype == OP_TRANSR && type == OP_NOT)
5045         /* diag_listed_as: Using !~ with %s doesn't make sense */
5046         yyerror("Using !~ with tr///r doesn't make sense");
5047
5048     ismatchop = (rtype == OP_MATCH ||
5049                  rtype == OP_SUBST ||
5050                  rtype == OP_TRANS || rtype == OP_TRANSR)
5051              && !(right->op_flags & OPf_SPECIAL);
5052     if (ismatchop && right->op_private & OPpTARGET_MY) {
5053         right->op_targ = 0;
5054         right->op_private &= ~OPpTARGET_MY;
5055     }
5056     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5057         if (left->op_type == OP_PADSV
5058          && !(left->op_private & OPpLVAL_INTRO))
5059         {
5060             right->op_targ = left->op_targ;
5061             op_free(left);
5062             o = right;
5063         }
5064         else {
5065             right->op_flags |= OPf_STACKED;
5066             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5067             ! (rtype == OP_TRANS &&
5068                right->op_private & OPpTRANS_IDENTICAL) &&
5069             ! (rtype == OP_SUBST &&
5070                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5071                 left = op_lvalue(left, rtype);
5072             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5073                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5074             else
5075                 o = op_prepend_elem(rtype, scalar(left), right);
5076         }
5077         if (type == OP_NOT)
5078             return newUNOP(OP_NOT, 0, scalar(o));
5079         return o;
5080     }
5081     else
5082         return bind_match(type, left,
5083                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5084 }
5085
5086 OP *
5087 Perl_invert(pTHX_ OP *o)
5088 {
5089     if (!o)
5090         return NULL;
5091     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5092 }
5093
5094 /*
5095 =for apidoc Amx|OP *|op_scope|OP *o
5096
5097 Wraps up an op tree with some additional ops so that at runtime a dynamic
5098 scope will be created.  The original ops run in the new dynamic scope,
5099 and then, provided that they exit normally, the scope will be unwound.
5100 The additional ops used to create and unwind the dynamic scope will
5101 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5102 instead if the ops are simple enough to not need the full dynamic scope
5103 structure.
5104
5105 =cut
5106 */
5107
5108 OP *
5109 Perl_op_scope(pTHX_ OP *o)
5110 {
5111     dVAR;
5112     if (o) {
5113         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5114             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5115             OpTYPE_set(o, OP_LEAVE);
5116         }
5117         else if (o->op_type == OP_LINESEQ) {
5118             OP *kid;
5119             OpTYPE_set(o, OP_SCOPE);
5120             kid = ((LISTOP*)o)->op_first;
5121             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5122                 op_null(kid);
5123
5124                 /* The following deals with things like 'do {1 for 1}' */
5125                 kid = OpSIBLING(kid);
5126                 if (kid &&
5127                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5128                     op_null(kid);
5129             }
5130         }
5131         else
5132             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5133     }
5134     return o;
5135 }
5136
5137 OP *
5138 Perl_op_unscope(pTHX_ OP *o)
5139 {
5140     if (o && o->op_type == OP_LINESEQ) {
5141         OP *kid = cLISTOPo->op_first;
5142         for(; kid; kid = OpSIBLING(kid))
5143             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5144                 op_null(kid);
5145     }
5146     return o;
5147 }
5148
5149 /*
5150 =for apidoc Am|int|block_start|int full
5151
5152 Handles compile-time scope entry.
5153 Arranges for hints to be restored on block
5154 exit and also handles pad sequence numbers to make lexical variables scope
5155 right.  Returns a savestack index for use with C<block_end>.
5156
5157 =cut
5158 */
5159
5160 int
5161 Perl_block_start(pTHX_ int full)
5162 {
5163     const int retval = PL_savestack_ix;
5164
5165     PL_compiling.cop_seq = PL_cop_seqmax;
5166     COP_SEQMAX_INC;
5167     pad_block_start(full);
5168     SAVEHINTS();
5169     PL_hints &= ~HINT_BLOCK_SCOPE;
5170     SAVECOMPILEWARNINGS();
5171     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5172     SAVEI32(PL_compiling.cop_seq);
5173     PL_compiling.cop_seq = 0;
5174
5175     CALL_BLOCK_HOOKS(bhk_start, full);
5176
5177     return retval;
5178 }
5179
5180 /*
5181 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5182
5183 Handles compile-time scope exit.  C<floor>
5184 is the savestack index returned by
5185 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5186 possibly modified.
5187
5188 =cut
5189 */
5190
5191 OP*
5192 Perl_block_end(pTHX_ I32 floor, OP *seq)
5193 {
5194     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5195     OP* retval = scalarseq(seq);
5196     OP *o;
5197
5198     /* XXX Is the null PL_parser check necessary here? */
5199     assert(PL_parser); /* Let’s find out under debugging builds.  */
5200     if (PL_parser && PL_parser->parsed_sub) {
5201         o = newSTATEOP(0, NULL, NULL);
5202         op_null(o);
5203         retval = op_append_elem(OP_LINESEQ, retval, o);
5204     }
5205
5206     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5207
5208     LEAVE_SCOPE(floor);
5209     if (needblockscope)
5210         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5211     o = pad_leavemy();
5212
5213     if (o) {
5214         /* pad_leavemy has created a sequence of introcv ops for all my
5215            subs declared in the block.  We have to replicate that list with
5216            clonecv ops, to deal with this situation:
5217
5218                sub {
5219                    my sub s1;
5220                    my sub s2;
5221                    sub s1 { state sub foo { \&s2 } }
5222                }->()
5223
5224            Originally, I was going to have introcv clone the CV and turn
5225            off the stale flag.  Since &s1 is declared before &s2, the
5226            introcv op for &s1 is executed (on sub entry) before the one for
5227            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5228            cloned, since it is a state sub) closes over &s2 and expects
5229            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5230            then &s2 is still marked stale.  Since &s1 is not active, and
5231            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5232            ble will not stay shared’ warning.  Because it is the same stub
5233            that will be used when the introcv op for &s2 is executed, clos-
5234            ing over it is safe.  Hence, we have to turn off the stale flag
5235            on all lexical subs in the block before we clone any of them.
5236            Hence, having introcv clone the sub cannot work.  So we create a
5237            list of ops like this:
5238
5239                lineseq
5240                   |
5241                   +-- introcv
5242                   |
5243                   +-- introcv
5244                   |
5245                   +-- introcv
5246                   |
5247                   .
5248                   .
5249                   .
5250                   |
5251                   +-- clonecv
5252                   |
5253                   +-- clonecv
5254                   |
5255                   +-- clonecv
5256                   |
5257                   .
5258                   .
5259                   .
5260          */
5261         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5262         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5263         for (;; kid = OpSIBLING(kid)) {
5264             OP *newkid = newOP(OP_CLONECV, 0);
5265             newkid->op_targ = kid->op_targ;
5266             o = op_append_elem(OP_LINESEQ, o, newkid);
5267             if (kid == last) break;
5268         }
5269         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5270     }
5271
5272     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5273
5274     return retval;
5275 }
5276
5277 /*
5278 =head1 Compile-time scope hooks
5279
5280 =for apidoc Aox||blockhook_register
5281
5282 Register a set of hooks to be called when the Perl lexical scope changes
5283 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5284
5285 =cut
5286 */
5287
5288 void
5289 Perl_blockhook_register(pTHX_ BHK *hk)
5290 {
5291     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5292
5293     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5294 }
5295
5296 void
5297 Perl_newPROG(pTHX_ OP *o)
5298 {
5299     OP *start;
5300
5301     PERL_ARGS_ASSERT_NEWPROG;
5302
5303     if (PL_in_eval) {
5304         PERL_CONTEXT *cx;
5305         I32 i;
5306         if (PL_eval_root)
5307                 return;
5308         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5309                                ((PL_in_eval & EVAL_KEEPERR)
5310                                 ? OPf_SPECIAL : 0), o);
5311
5312         cx = CX_CUR();
5313         assert(CxTYPE(cx) == CXt_EVAL);
5314
5315         if ((cx->blk_gimme & G_WANT) == G_VOID)
5316             scalarvoid(PL_eval_root);
5317         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5318             list(PL_eval_root);
5319         else
5320             scalar(PL_eval_root);
5321
5322         start = op_linklist(PL_eval_root);
5323         PL_eval_root->op_next = 0;
5324         i = PL_savestack_ix;
5325         SAVEFREEOP(o);
5326         ENTER;
5327         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5328         LEAVE;
5329         PL_savestack_ix = i;
5330     }
5331     else {
5332         if (o->op_type == OP_STUB) {
5333             /* This block is entered if nothing is compiled for the main
5334                program. This will be the case for an genuinely empty main
5335                program, or one which only has BEGIN blocks etc, so already
5336                run and freed.
5337
5338                Historically (5.000) the guard above was !o. However, commit
5339                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5340                c71fccf11fde0068, changed perly.y so that newPROG() is now
5341                called with the output of block_end(), which returns a new
5342                OP_STUB for the case of an empty optree. ByteLoader (and
5343                maybe other things) also take this path, because they set up
5344                PL_main_start and PL_main_root directly, without generating an
5345                optree.
5346
5347                If the parsing the main program aborts (due to parse errors,
5348                or due to BEGIN or similar calling exit), then newPROG()
5349                isn't even called, and hence this code path and its cleanups
5350                are skipped. This shouldn't make a make a difference:
5351                * a non-zero return from perl_parse is a failure, and
5352                  perl_destruct() should be called immediately.
5353                * however, if exit(0) is called during the parse, then
5354                  perl_parse() returns 0, and perl_run() is called. As
5355                  PL_main_start will be NULL, perl_run() will return
5356                  promptly, and the exit code will remain 0.
5357             */
5358
5359             PL_comppad_name = 0;
5360             PL_compcv = 0;
5361             S_op_destroy(aTHX_ o);
5362             return;
5363         }
5364         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5365         PL_curcop = &PL_compiling;
5366         start = LINKLIST(PL_main_root);
5367         PL_main_root->op_next = 0;
5368         S_process_optree(aTHX_ NULL, PL_main_root, start);
5369         cv_forget_slab(PL_compcv);
5370         PL_compcv = 0;
5371
5372         /* Register with debugger */
5373         if (PERLDB_INTER) {
5374             CV * const cv = get_cvs("DB::postponed", 0);
5375             if (cv) {
5376                 dSP;
5377                 PUSHMARK(SP);
5378                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5379                 PUTBACK;
5380                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5381             }
5382         }
5383     }
5384 }
5385
5386 OP *
5387 Perl_localize(pTHX_ OP *o, I32 lex)
5388 {
5389     PERL_ARGS_ASSERT_LOCALIZE;
5390
5391     if (o->op_flags & OPf_PARENS)
5392 /* [perl #17376]: this appears to be premature, and results in code such as
5393    C< our(%x); > executing in list mode rather than void mode */
5394 #if 0
5395         list(o);
5396 #else
5397         NOOP;
5398 #endif
5399     else {
5400         if ( PL_parser->bufptr > PL_parser->oldbufptr
5401             && PL_parser->bufptr[-1] == ','
5402             && ckWARN(WARN_PARENTHESIS))
5403         {
5404             char *s = PL_parser->bufptr;
5405             bool sigil = FALSE;
5406
5407             /* some heuristics to detect a potential error */
5408             while (*s && (strchr(", \t\n", *s)))
5409                 s++;
5410
5411             while (1) {
5412                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5413                        && *++s
5414                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5415                     s++;
5416                     sigil = TRUE;
5417                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5418                         s++;
5419                     while (*s && (strchr(", \t\n", *s)))
5420                         s++;
5421                 }
5422                 else
5423                     break;
5424             }
5425             if (sigil && (*s == ';' || *s == '=')) {
5426                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5427                                 "Parentheses missing around \"%s\" list",
5428                                 lex
5429                                     ? (PL_parser->in_my == KEY_our
5430                                         ? "our"
5431                                         : PL_parser->in_my == KEY_state
5432                                             ? "state"
5433                                             : "my")
5434                                     : "local");
5435             }
5436         }
5437     }
5438     if (lex)
5439         o = my(o);
5440     else
5441         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5442     PL_parser->in_my = FALSE;
5443     PL_parser->in_my_stash = NULL;
5444     return o;
5445 }
5446
5447 OP *
5448 Perl_jmaybe(pTHX_ OP *o)
5449 {
5450     PERL_ARGS_ASSERT_JMAYBE;
5451
5452     if (o->op_type == OP_LIST) {
5453         OP * const o2
5454             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5455         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5456     }
5457     return o;
5458 }
5459
5460 PERL_STATIC_INLINE OP *
5461 S_op_std_init(pTHX_ OP *o)
5462 {
5463     I32 type = o->op_type;
5464
5465     PERL_ARGS_ASSERT_OP_STD_INIT;
5466
5467     if (PL_opargs[type] & OA_RETSCALAR)
5468         scalar(o);
5469     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5470         o->op_targ = pad_alloc(type, SVs_PADTMP);
5471
5472     return o;
5473 }
5474
5475 PERL_STATIC_INLINE OP *
5476 S_op_integerize(pTHX_ OP *o)
5477 {
5478     I32 type = o->op_type;
5479
5480     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5481
5482     /* integerize op. */
5483     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5484     {
5485         dVAR;
5486         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5487     }
5488
5489     if (type == OP_NEGATE)
5490         /* XXX might want a ck_negate() for this */
5491         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5492
5493     return o;
5494 }
5495
5496 /* This function exists solely to provide a scope to limit
5497    setjmp/longjmp() messing with auto variables.
5498  */
5499 PERL_STATIC_INLINE int
5500 S_fold_constants_eval(pTHX) {
5501     int ret = 0;
5502     dJMPENV;
5503
5504     JMPENV_PUSH(ret);
5505
5506     if (ret == 0) {
5507         CALLRUNOPS(aTHX);
5508     }
5509
5510     JMPENV_POP;
5511
5512     return ret;
5513 }
5514
5515 static OP *
5516 S_fold_constants(pTHX_ OP *const o)
5517 {
5518     dVAR;
5519     OP *curop;
5520     OP *newop;
5521     I32 type = o->op_type;
5522     bool is_stringify;
5523     SV *sv = NULL;
5524     int ret = 0;
5525     OP *old_next;
5526     SV * const oldwarnhook = PL_warnhook;
5527     SV * const olddiehook  = PL_diehook;
5528     COP not_compiling;
5529     U8 oldwarn = PL_dowarn;
5530     I32 old_cxix;
5531
5532     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5533
5534     if (!(PL_opargs[type] & OA_FOLDCONST))
5535         goto nope;
5536
5537     switch (type) {
5538     case OP_UCFIRST:
5539     case OP_LCFIRST:
5540     case OP_UC:
5541     case OP_LC:
5542     case OP_FC:
5543 #ifdef USE_LOCALE_CTYPE
5544         if (IN_LC_COMPILETIME(LC_CTYPE))
5545             goto nope;
5546 #endif
5547         break;
5548     case OP_SLT:
5549     case OP_SGT:
5550     case OP_SLE:
5551     case OP_SGE:
5552     case OP_SCMP:
5553 #ifdef USE_LOCALE_COLLATE
5554         if (IN_LC_COMPILETIME(LC_COLLATE))
5555             goto nope;
5556 #endif
5557         break;
5558     case OP_SPRINTF:
5559         /* XXX what about the numeric ops? */
5560 #ifdef USE_LOCALE_NUMERIC
5561         if (IN_LC_COMPILETIME(LC_NUMERIC))
5562             goto nope;
5563 #endif
5564         break;
5565     case OP_PACK:
5566         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5567           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5568             goto nope;
5569         {
5570             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5571             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5572             {
5573                 const char *s = SvPVX_const(sv);
5574                 while (s < SvEND(sv)) {
5575                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5576                     s++;
5577                 }
5578             }
5579         }
5580         break;
5581     case OP_REPEAT:
5582         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5583         break;
5584     case OP_SREFGEN:
5585         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5586          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5587             goto nope;
5588     }
5589
5590     if (PL_parser && PL_parser->error_count)
5591         goto nope;              /* Don't try to run w/ errors */
5592
5593     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5594         switch (curop->op_type) {
5595         case OP_CONST:
5596             if (   (curop->op_private & OPpCONST_BARE)
5597                 && (curop->op_private & OPpCONST_STRICT)) {
5598                 no_bareword_allowed(curop);
5599                 goto nope;
5600             }
5601             /* FALLTHROUGH */
5602         case OP_LIST:
5603         case OP_SCALAR:
5604         case OP_NULL:
5605         case OP_PUSHMARK:
5606             /* Foldable; move to next op in list */
5607             break;
5608
5609         default:
5610             /* No other op types are considered foldable */
5611             goto nope;
5612         }
5613     }
5614
5615     curop = LINKLIST(o);
5616     old_next = o->op_next;
5617     o->op_next = 0;
5618     PL_op = curop;
5619
5620     old_cxix = cxstack_ix;
5621     create_eval_scope(NULL, G_FAKINGEVAL);
5622
5623     /* Verify that we don't need to save it:  */
5624     assert(PL_curcop == &PL_compiling);
5625     StructCopy(&PL_compiling, &not_compiling, COP);
5626     PL_curcop = &not_compiling;
5627     /* The above ensures that we run with all the correct hints of the
5628        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5629     assert(IN_PERL_RUNTIME);
5630     PL_warnhook = PERL_WARNHOOK_FATAL;
5631     PL_diehook  = NULL;
5632
5633     /* Effective $^W=1.  */
5634     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5635         PL_dowarn |= G_WARN_ON;
5636
5637     ret = S_fold_constants_eval(aTHX);
5638
5639     switch (ret) {
5640     case 0:
5641         sv = *(PL_stack_sp--);
5642         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5643             pad_swipe(o->op_targ,  FALSE);
5644         }
5645         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5646             SvREFCNT_inc_simple_void(sv);
5647             SvTEMP_off(sv);
5648         }
5649         else { assert(SvIMMORTAL(sv)); }
5650         break;
5651     case 3:
5652         /* Something tried to die.  Abandon constant folding.  */
5653         /* Pretend the error never happened.  */
5654         CLEAR_ERRSV();
5655         o->op_next = old_next;
5656         break;
5657     default:
5658         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5659         PL_warnhook = oldwarnhook;
5660         PL_diehook  = olddiehook;
5661         /* XXX note that this croak may fail as we've already blown away
5662          * the stack - eg any nested evals */
5663         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5664     }
5665     PL_dowarn   = oldwarn;
5666     PL_warnhook = oldwarnhook;
5667     PL_diehook  = olddiehook;
5668     PL_curcop = &PL_compiling;
5669
5670     /* if we croaked, depending on how we croaked the eval scope
5671      * may or may not have already been popped */
5672     if (cxstack_ix > old_cxix) {
5673         assert(cxstack_ix == old_cxix + 1);
5674         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5675         delete_eval_scope();
5676     }
5677     if (ret)
5678         goto nope;
5679
5680     /* OP_STRINGIFY and constant folding are used to implement qq.
5681        Here the constant folding is an implementation detail that we
5682        want to hide.  If the stringify op is itself already marked
5683        folded, however, then it is actually a folded join.  */
5684     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5685     op_free(o);
5686     assert(sv);
5687     if (is_stringify)
5688         SvPADTMP_off(sv);
5689     else if (!SvIMMORTAL(sv)) {
5690         SvPADTMP_on(sv);
5691         SvREADONLY_on(sv);
5692     }
5693     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5694     if (!is_stringify) newop->op_folded = 1;
5695     return newop;
5696
5697  nope:
5698     return o;
5699 }
5700
5701 static OP *
5702 S_gen_constant_list(pTHX_ OP *o)
5703 {
5704     dVAR;
5705     OP *curop, *old_next;
5706     SV * const oldwarnhook = PL_warnhook;
5707     SV * const olddiehook  = PL_diehook;
5708     COP *old_curcop;
5709     U8 oldwarn = PL_dowarn;
5710     SV **svp;
5711     AV *av;
5712     I32 old_cxix;
5713     COP not_compiling;
5714     int ret = 0;
5715     dJMPENV;
5716     bool op_was_null;
5717
5718     list(o);
5719     if (PL_parser && PL_parser->error_count)
5720         return o;               /* Don't attempt to run with errors */
5721
5722     curop = LINKLIST(o);
5723     old_next = o->op_next;
5724     o->op_next = 0;
5725     op_was_null = o->op_type == OP_NULL;
5726     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5727         o->op_type = OP_CUSTOM;
5728     CALL_PEEP(curop);
5729     if (op_was_null)
5730         o->op_type = OP_NULL;
5731     S_prune_chain_head(&curop);
5732     PL_op = curop;
5733
5734     old_cxix = cxstack_ix;
5735     create_eval_scope(NULL, G_FAKINGEVAL);
5736
5737     old_curcop = PL_curcop;
5738     StructCopy(old_curcop, &not_compiling, COP);
5739     PL_curcop = &not_compiling;
5740     /* The above ensures that we run with all the correct hints of the
5741        current COP, but that IN_PERL_RUNTIME is true. */
5742     assert(IN_PERL_RUNTIME);
5743     PL_warnhook = PERL_WARNHOOK_FATAL;
5744     PL_diehook  = NULL;
5745     JMPENV_PUSH(ret);
5746
5747     /* Effective $^W=1.  */
5748     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5749         PL_dowarn |= G_WARN_ON;
5750
5751     switch (ret) {
5752     case 0:
5753 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5754         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5755 #endif
5756         Perl_pp_pushmark(aTHX);
5757         CALLRUNOPS(aTHX);
5758         PL_op = curop;
5759         assert (!(curop->op_flags & OPf_SPECIAL));
5760         assert(curop->op_type == OP_RANGE);
5761         Perl_pp_anonlist(aTHX);
5762         break;
5763     case 3:
5764         CLEAR_ERRSV();
5765         o->op_next = old_next;
5766         break;
5767     default:
5768         JMPENV_POP;
5769         PL_warnhook = oldwarnhook;
5770         PL_diehook = olddiehook;
5771         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5772             ret);
5773     }
5774
5775     JMPENV_POP;
5776     PL_dowarn = oldwarn;
5777     PL_warnhook = oldwarnhook;
5778     PL_diehook = olddiehook;
5779     PL_curcop = old_curcop;
5780
5781     if (cxstack_ix > old_cxix) {
5782         assert(cxstack_ix == old_cxix + 1);
5783         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5784         delete_eval_scope();
5785     }
5786     if (ret)
5787         return o;
5788
5789     OpTYPE_set(o, OP_RV2AV);
5790     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5791     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5792     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5793     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5794
5795     /* replace subtree with an OP_CONST */
5796     curop = ((UNOP*)o)->op_first;
5797     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5798     op_free(curop);
5799
5800     if (AvFILLp(av) != -1)
5801         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5802         {
5803             SvPADTMP_on(*svp);
5804             SvREADONLY_on(*svp);
5805         }
5806     LINKLIST(o);
5807     return list(o);
5808 }
5809
5810 /*
5811 =head1 Optree Manipulation Functions
5812 */
5813
5814 /* List constructors */
5815
5816 /*
5817 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5818
5819 Append an item to the list of ops contained directly within a list-type
5820 op, returning the lengthened list.  C<first> is the list-type op,
5821 and C<last> is the op to append to the list.  C<optype> specifies the
5822 intended opcode for the list.  If C<first> is not already a list of the
5823 right type, it will be upgraded into one.  If either C<first> or C<last>
5824 is null, the other is returned unchanged.
5825
5826 =cut
5827 */
5828
5829 OP *
5830 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5831 {
5832     if (!first)
5833         return last;
5834
5835     if (!last)
5836         return first;
5837
5838     if (first->op_type != (unsigned)type
5839         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5840     {
5841         return newLISTOP(type, 0, first, last);
5842     }
5843
5844     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5845     first->op_flags |= OPf_KIDS;
5846     return first;
5847 }
5848
5849 /*
5850 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5851
5852 Concatenate the lists of ops contained directly within two list-type ops,
5853 returning the combined list.  C<first> and C<last> are the list-type ops
5854 to concatenate.  C<optype> specifies the intended opcode for the list.
5855 If either C<first> or C<last> is not already a list of the right type,
5856 it will be upgraded into one.  If either C<first> or C<last> is null,
5857 the other is returned unchanged.
5858
5859 =cut
5860 */
5861
5862 OP *
5863 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5864 {
5865     if (!first)
5866         return last;
5867
5868     if (!last)
5869         return first;
5870
5871     if (first->op_type != (unsigned)type)
5872         return op_prepend_elem(type, first, last);
5873
5874     if (last->op_type != (unsigned)type)
5875         return op_append_elem(type, first, last);
5876
5877     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5878     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5879     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5880     first->op_flags |= (last->op_flags & OPf_KIDS);
5881
5882     S_op_destroy(aTHX_ last);
5883
5884     return first;
5885 }
5886
5887 /*
5888 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5889
5890 Prepend an item to the list of ops contained directly within a list-type
5891 op, returning the lengthened list.  C<first> is the op to prepend to the
5892 list, and C<last> is the list-type op.  C<optype> specifies the intended
5893 opcode for the list.  If C<last> is not already a list of the right type,
5894 it will be upgraded into one.  If either C<first> or C<last> is null,
5895 the other is returned unchanged.
5896
5897 =cut
5898 */
5899
5900 OP *
5901 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5902 {
5903     if (!first)
5904         return last;
5905
5906     if (!last)
5907         return first;
5908
5909     if (last->op_type == (unsigned)type) {
5910         if (type == OP_LIST) {  /* already a PUSHMARK there */
5911             /* insert 'first' after pushmark */
5912             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5913             if (!(first->op_flags & OPf_PARENS))
5914                 last->op_flags &= ~OPf_PARENS;
5915         }
5916         else
5917             op_sibling_splice(last, NULL, 0, first);
5918         last->op_flags |= OPf_KIDS;
5919         return last;
5920     }
5921
5922     return newLISTOP(type, 0, first, last);
5923 }
5924
5925 /*
5926 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5927
5928 Converts C<o> into a list op if it is not one already, and then converts it
5929 into the specified C<type>, calling its check function, allocating a target if
5930 it needs one, and folding constants.
5931
5932 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5933 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5934 C<op_convert_list> to make it the right type.
5935
5936 =cut
5937 */
5938
5939 OP *
5940 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5941 {
5942     dVAR;
5943     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5944     if (!o || o->op_type != OP_LIST)
5945         o = force_list(o, 0);
5946     else
5947     {
5948         o->op_flags &= ~OPf_WANT;
5949         o->op_private &= ~OPpLVAL_INTRO;
5950     }
5951
5952     if (!(PL_opargs[type] & OA_MARK))
5953         op_null(cLISTOPo->op_first);
5954     else {
5955         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5956         if (kid2 && kid2->op_type == OP_COREARGS) {
5957             op_null(cLISTOPo->op_first);
5958             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5959         }
5960     }
5961
5962     if (type != OP_SPLIT)
5963         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5964          * ck_split() create a real PMOP and leave the op's type as listop
5965          * for now. Otherwise op_free() etc will crash.
5966          */
5967         OpTYPE_set(o, type);
5968
5969     o->op_flags |= flags;
5970     if (flags & OPf_FOLDED)
5971         o->op_folded = 1;
5972
5973     o = CHECKOP(type, o);
5974     if (o->op_type != (unsigned)type)
5975         return o;
5976
5977     return fold_constants(op_integerize(op_std_init(o)));
5978 }
5979
5980 /* Constructors */
5981
5982
5983 /*
5984 =head1 Optree construction
5985
5986 =for apidoc Am|OP *|newNULLLIST
5987
5988 Constructs, checks, and returns a new C<stub> op, which represents an
5989 empty list expression.
5990
5991 =cut
5992 */
5993
5994 OP *
5995 Perl_newNULLLIST(pTHX)
5996 {
5997     return newOP(OP_STUB, 0);
5998 }
5999
6000 /* promote o and any siblings to be a list if its not already; i.e.
6001  *
6002  *  o - A - B
6003  *
6004  * becomes
6005  *
6006  *  list
6007  *    |
6008  *  pushmark - o - A - B
6009  *
6010  * If nullit it true, the list op is nulled.
6011  */
6012
6013 static OP *
6014 S_force_list(pTHX_ OP *o, bool nullit)
6015 {
6016     if (!o || o->op_type != OP_LIST) {
6017         OP *rest = NULL;
6018         if (o) {
6019             /* manually detach any siblings then add them back later */
6020             rest = OpSIBLING(o);
6021             OpLASTSIB_set(o, NULL);
6022         }
6023         o = newLISTOP(OP_LIST, 0, o, NULL);
6024         if (rest)
6025             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6026     }
6027     if (nullit)
6028         op_null(o);
6029     return o;
6030 }
6031
6032 /*
6033 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6034
6035 Constructs, checks, and returns an op of any list type.  C<type> is
6036 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6037 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6038 supply up to two ops to be direct children of the list op; they are
6039 consumed by this function and become part of the constructed op tree.
6040
6041 For most list operators, the check function expects all the kid ops to be
6042 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6043 appropriate.  What you want to do in that case is create an op of type
6044 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6045 See L</op_convert_list> for more information.
6046
6047
6048 =cut
6049 */
6050
6051 OP *
6052 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6053 {
6054     dVAR;
6055     LISTOP *listop;
6056
6057     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6058         || type == OP_CUSTOM);
6059
6060     NewOp(1101, listop, 1, LISTOP);
6061
6062     OpTYPE_set(listop, type);
6063     if (first || last)
6064         flags |= OPf_KIDS;
6065     listop->op_flags = (U8)flags;
6066
6067     if (!last && first)
6068         last = first;
6069     else if (!first && last)
6070         first = last;
6071     else if (first)
6072         OpMORESIB_set(first, last);
6073     listop->op_first = first;
6074     listop->op_last = last;
6075     if (type == OP_LIST) {
6076         OP* const pushop = newOP(OP_PUSHMARK, 0);
6077         OpMORESIB_set(pushop, first);
6078         listop->op_first = pushop;
6079         listop->op_flags |= OPf_KIDS;
6080         if (!last)
6081             listop->op_last = pushop;
6082     }
6083     if (listop->op_last)
6084         OpLASTSIB_set(listop->op_last, (OP*)listop);
6085
6086     return CHECKOP(type, listop);
6087 }
6088
6089 /*
6090 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6091
6092 Constructs, checks, and returns an op of any base type (any type that
6093 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6094 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6095 of C<op_private>.
6096
6097 =cut
6098 */
6099
6100 OP *
6101 Perl_newOP(pTHX_ I32 type, I32 flags)
6102 {
6103     dVAR;
6104     OP *o;
6105
6106     if (type == -OP_ENTEREVAL) {
6107         type = OP_ENTEREVAL;
6108         flags |= OPpEVAL_BYTES<<8;
6109     }
6110
6111     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6112         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6113         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6114         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6115
6116     NewOp(1101, o, 1, OP);
6117     OpTYPE_set(o, type);
6118     o->op_flags = (U8)flags;
6119
6120     o->op_next = o;
6121     o->op_private = (U8)(0 | (flags >> 8));
6122     if (PL_opargs[type] & OA_RETSCALAR)
6123         scalar(o);
6124     if (PL_opargs[type] & OA_TARGET)
6125         o->op_targ = pad_alloc(type, SVs_PADTMP);
6126     return CHECKOP(type, o);
6127 }
6128
6129 /*
6130 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6131
6132 Constructs, checks, and returns an op of any unary type.  C<type> is
6133 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6134 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6135 bits, the eight bits of C<op_private>, except that the bit with value 1
6136 is automatically set.  C<first> supplies an optional op to be the direct
6137 child of the unary op; it is consumed by this function and become part
6138 of the constructed op tree.
6139
6140 =cut
6141 */
6142
6143 OP *
6144 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6145 {
6146     dVAR;
6147     UNOP *unop;
6148
6149     if (type == -OP_ENTEREVAL) {
6150         type = OP_ENTEREVAL;
6151         flags |= OPpEVAL_BYTES<<8;
6152     }
6153
6154     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6155         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6156         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6157         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6158         || type == OP_SASSIGN
6159         || type == OP_ENTERTRY
6160         || type == OP_CUSTOM
6161         || type == OP_NULL );
6162
6163     if (!first)
6164         first = newOP(OP_STUB, 0);
6165     if (PL_opargs[type] & OA_MARK)
6166         first = force_list(first, 1);
6167
6168     NewOp(1101, unop, 1, UNOP);
6169     OpTYPE_set(unop, type);
6170     unop->op_first = first;
6171     unop->op_flags = (U8)(flags | OPf_KIDS);
6172     unop->op_private = (U8)(1 | (flags >> 8));
6173
6174     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6175         OpLASTSIB_set(first, (OP*)unop);
6176
6177     unop = (UNOP*) CHECKOP(type, unop);
6178     if (unop->op_next)
6179         return (OP*)unop;
6180
6181     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6182 }
6183
6184 /*
6185 =for apidoc newUNOP_AUX
6186
6187 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6188 initialised to C<aux>
6189
6190 =cut
6191 */
6192
6193 OP *
6194 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6195 {
6196     dVAR;
6197     UNOP_AUX *unop;
6198
6199     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6200         || type == OP_CUSTOM);
6201
6202     NewOp(1101, unop, 1, UNOP_AUX);
6203     unop->op_type = (OPCODE)type;
6204     unop->op_ppaddr = PL_ppaddr[type];
6205     unop->op_first = first;
6206     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6207     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6208     unop->op_aux = aux;
6209
6210     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6211         OpLASTSIB_set(first, (OP*)unop);
6212
6213     unop = (UNOP_AUX*) CHECKOP(type, unop);
6214
6215     return op_std_init((OP *) unop);
6216 }
6217
6218 /*
6219 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6220
6221 Constructs, checks, and returns an op of method type with a method name
6222 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6223 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6224 and, shifted up eight bits, the eight bits of C<op_private>, except that
6225 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6226 op which evaluates method name; it is consumed by this function and
6227 become part of the constructed op tree.
6228 Supported optypes: C<OP_METHOD>.
6229
6230 =cut
6231 */
6232
6233 static OP*
6234 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6235     dVAR;
6236     METHOP *methop;
6237
6238     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6239         || type == OP_CUSTOM);
6240
6241     NewOp(1101, methop, 1, METHOP);
6242     if (dynamic_meth) {
6243         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6244         methop->op_flags = (U8)(flags | OPf_KIDS);
6245         methop->op_u.op_first = dynamic_meth;
6246         methop->op_private = (U8)(1 | (flags >> 8));
6247
6248         if (!OpHAS_SIBLING(dynamic_meth))
6249             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6250     }
6251     else {
6252         assert(const_meth);
6253         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6254         methop->op_u.op_meth_sv = const_meth;
6255         methop->op_private = (U8)(0 | (flags >> 8));
6256         methop->op_next = (OP*)methop;
6257     }
6258
6259 #ifdef USE_ITHREADS
6260     methop->op_rclass_targ = 0;
6261 #else
6262     methop->op_rclass_sv = NULL;
6263 #endif
6264
6265     OpTYPE_set(methop, type);
6266     return CHECKOP(type, methop);
6267 }
6268
6269 OP *
6270 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6271     PERL_ARGS_ASSERT_NEWMETHOP;
6272     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6273 }
6274
6275 /*
6276 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6277
6278 Constructs, checks, and returns an op of method type with a constant
6279 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6280 C<op_flags>, and, shifted up eight bits, the eight bits of
6281 C<op_private>.  C<const_meth> supplies a constant method name;
6282 it must be a shared COW string.
6283 Supported optypes: C<OP_METHOD_NAMED>.
6284
6285 =cut
6286 */
6287
6288 OP *
6289 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6290     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6291     return newMETHOP_internal(type, flags, NULL, const_meth);
6292 }
6293
6294 /*
6295 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6296
6297 Constructs, checks, and returns an op of any binary type.  C<type>
6298 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6299 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6300 the eight bits of C<op_private>, except that the bit with value 1 or
6301 2 is automatically set as required.  C<first> and C<last> supply up to
6302 two ops to be the direct children of the binary op; they are consumed
6303 by this function and become part of the constructed op tree.
6304
6305 =cut
6306 */
6307
6308 OP *
6309 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6310 {
6311     dVAR;
6312     BINOP *binop;
6313
6314     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6315         || type == OP_NULL || type == OP_CUSTOM);
6316
6317     NewOp(1101, binop, 1, BINOP);
6318
6319     if (!first)
6320         first = newOP(OP_NULL, 0);
6321
6322     OpTYPE_set(binop, type);
6323     binop->op_first = first;
6324     binop->op_flags = (U8)(flags | OPf_KIDS);
6325     if (!last) {
6326         last = first;
6327         binop->op_private = (U8)(1 | (flags >> 8));
6328     }
6329     else {
6330         binop->op_private = (U8)(2 | (flags >> 8));
6331         OpMORESIB_set(first, last);
6332     }
6333
6334     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6335         OpLASTSIB_set(last, (OP*)binop);
6336
6337     binop->op_last = OpSIBLING(binop->op_first);
6338     if (binop->op_last)
6339         OpLASTSIB_set(binop->op_last, (OP*)binop);
6340
6341     binop = (BINOP*)CHECKOP(type, binop);
6342     if (binop->op_next || binop->op_type != (OPCODE)type)
6343         return (OP*)binop;
6344
6345     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6346 }
6347
6348 /* Helper function for S_pmtrans(): comparison function to sort an array
6349  * of codepoint range pairs. Sorts by start point, or if equal, by end
6350  * point */
6351
6352 static int uvcompare(const void *a, const void *b)
6353     __attribute__nonnull__(1)
6354     __attribute__nonnull__(2)
6355     __attribute__pure__;
6356 static int uvcompare(const void *a, const void *b)
6357 {
6358     if (*((const UV *)a) < (*(const UV *)b))
6359         return -1;
6360     if (*((const UV *)a) > (*(const UV *)b))
6361         return 1;
6362     if (*((const UV *)a+1) < (*(const UV *)b+1))
6363         return -1;
6364     if (*((const UV *)a+1) > (*(const UV *)b+1))
6365         return 1;
6366     return 0;
6367 }
6368
6369 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6370  * containing the search and replacement strings, assemble into
6371  * a translation table attached as o->op_pv.
6372  * Free expr and repl.
6373  * It expects the toker to have already set the
6374  *   OPpTRANS_COMPLEMENT
6375  *   OPpTRANS_SQUASH
6376  *   OPpTRANS_DELETE
6377  * flags as appropriate; this function may add
6378  *   OPpTRANS_FROM_UTF
6379  *   OPpTRANS_TO_UTF
6380  *   OPpTRANS_IDENTICAL
6381  *   OPpTRANS_GROWS
6382  * flags
6383  */
6384
6385 static OP *
6386 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6387 {
6388     SV * const tstr = ((SVOP*)expr)->op_sv;
6389     SV * const rstr = ((SVOP*)repl)->op_sv;
6390     STRLEN tlen;
6391     STRLEN rlen;
6392     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6393     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6394     Size_t i, j;
6395     bool grows = FALSE;
6396     OPtrans_map *tbl;
6397     SSize_t struct_size; /* malloced size of table struct */
6398
6399     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6400     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6401     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6402     SV* swash;
6403
6404     PERL_ARGS_ASSERT_PMTRANS;
6405
6406     PL_hints |= HINT_BLOCK_SCOPE;
6407
6408     if (SvUTF8(tstr))
6409         o->op_private |= OPpTRANS_FROM_UTF;
6410
6411     if (SvUTF8(rstr))
6412         o->op_private |= OPpTRANS_TO_UTF;
6413
6414     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6415
6416         /* for utf8 translations, op_sv will be set to point to a swash
6417          * containing codepoint ranges. This is done by first assembling
6418          * a textual representation of the ranges in listsv then compiling
6419          * it using swash_init(). For more details of the textual format,
6420          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6421          */
6422
6423         SV* const listsv = newSVpvs("# comment\n");
6424         SV* transv = NULL;
6425         const U8* tend = t + tlen;
6426         const U8* rend = r + rlen;
6427         STRLEN ulen;
6428         UV tfirst = 1;
6429         UV tlast = 0;
6430         IV tdiff;
6431         STRLEN tcount = 0;
6432         UV rfirst = 1;
6433         UV rlast = 0;
6434         IV rdiff;
6435         STRLEN rcount = 0;
6436         IV diff;
6437         I32 none = 0;
6438         U32 max = 0;
6439         I32 bits;
6440         I32 havefinal = 0;
6441         U32 final = 0;
6442         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6443         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6444         U8* tsave = NULL;
6445         U8* rsave = NULL;
6446         const U32 flags = UTF8_ALLOW_DEFAULT;
6447
6448         if (!from_utf) {
6449             STRLEN len = tlen;
6450             t = tsave = bytes_to_utf8(t, &len);
6451             tend = t + len;
6452         }
6453         if (!to_utf && rlen) {
6454             STRLEN len = rlen;
6455             r = rsave = bytes_to_utf8(r, &len);
6456             rend = r + len;
6457         }
6458
6459 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6460  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6461  * odd.  */
6462
6463         if (complement) {
6464             /* utf8 and /c:
6465              * replace t/tlen/tend with a version that has the ranges
6466              * complemented
6467              */
6468             U8 tmpbuf[UTF8_MAXBYTES+1];
6469             UV *cp;
6470             UV nextmin = 0;
6471             Newx(cp, 2*tlen, UV);
6472             i = 0;
6473             transv = newSVpvs("");
6474
6475             /* convert search string into array of (start,end) range
6476              * codepoint pairs stored in cp[]. Most "ranges" will start
6477              * and end at the same char */
6478             while (t < tend) {
6479                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6480                 t += ulen;
6481                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6482                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6483                     t++;
6484                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6485                     t += ulen;
6486                 }
6487                 else {
6488                  cp[2*i+1] = cp[2*i];
6489                 }
6490                 i++;
6491             }
6492
6493             /* sort the ranges */
6494             qsort(cp, i, 2*sizeof(UV), uvcompare);
6495
6496             /* Create a utf8 string containing the complement of the
6497              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6498              * then transv will contain the equivalent of:
6499              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6500              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6501              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6502              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6503              * end cp.
6504              */
6505             for (j = 0; j < i; j++) {
6506                 UV  val = cp[2*j];
6507                 diff = val - nextmin;
6508                 if (diff > 0) {
6509                     t = uvchr_to_utf8(tmpbuf,nextmin);
6510                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6511                     if (diff > 1) {
6512                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6513                         t = uvchr_to_utf8(tmpbuf, val - 1);
6514                         sv_catpvn(transv, (char *)&range_mark, 1);
6515                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6516                     }
6517                 }
6518                 val = cp[2*j+1];
6519                 if (val >= nextmin)
6520                     nextmin = val + 1;
6521             }
6522
6523             t = uvchr_to_utf8(tmpbuf,nextmin);
6524             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6525             {
6526                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6527                 sv_catpvn(transv, (char *)&range_mark, 1);
6528             }
6529             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6530             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6531             t = (const U8*)SvPVX_const(transv);
6532             tlen = SvCUR(transv);
6533             tend = t + tlen;
6534             Safefree(cp);
6535         }
6536         else if (!rlen && !del) {
6537             r = t; rlen = tlen; rend = tend;
6538         }
6539
6540         if (!squash) {
6541                 if ((!rlen && !del) || t == r ||
6542                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6543                 {
6544                     o->op_private |= OPpTRANS_IDENTICAL;
6545                 }
6546         }
6547
6548         /* extract char ranges from t and r and append them to listsv */
6549
6550         while (t < tend || tfirst <= tlast) {
6551             /* see if we need more "t" chars */
6552             if (tfirst > tlast) {
6553                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6554                 t += ulen;
6555                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6556                     t++;
6557                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6558                     t += ulen;
6559                 }
6560                 else
6561                     tlast = tfirst;
6562             }
6563
6564             /* now see if we need more "r" chars */
6565             if (rfirst > rlast) {
6566                 if (r < rend) {
6567                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6568                     r += ulen;
6569                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6570                         r++;
6571                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6572                         r += ulen;
6573                     }
6574                     else
6575                         rlast = rfirst;
6576                 }
6577                 else {
6578                     if (!havefinal++)
6579                         final = rlast;
6580                     rfirst = rlast = 0xffffffff;
6581                 }
6582             }
6583
6584             /* now see which range will peter out first, if either. */
6585             tdiff = tlast - tfirst;
6586             rdiff = rlast - rfirst;
6587             tcount += tdiff + 1;
6588             rcount += rdiff + 1;
6589
6590             if (tdiff <= rdiff)
6591                 diff = tdiff;
6592             else
6593                 diff = rdiff;
6594
6595             if (rfirst == 0xffffffff) {
6596                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6597                 if (diff > 0)
6598                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6599                                    (long)tfirst, (long)tlast);
6600                 else
6601                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6602             }
6603             else {
6604                 if (diff > 0)
6605                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6606                                    (long)tfirst, (long)(tfirst + diff),
6607                                    (long)rfirst);
6608                 else
6609                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6610                                    (long)tfirst, (long)rfirst);
6611
6612                 if (rfirst + diff > max)
6613                     max = rfirst + diff;
6614                 if (!grows)
6615                     grows = (tfirst < rfirst &&
6616                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6617                 rfirst += diff + 1;
6618             }
6619             tfirst += diff + 1;
6620         }
6621
6622         /* compile listsv into a swash and attach to o */
6623
6624         none = ++max;
6625         if (del)
6626             ++max;
6627
6628         if (max > 0xffff)
6629             bits = 32;
6630         else if (max > 0xff)
6631             bits = 16;
6632         else
6633             bits = 8;
6634
6635         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6636 #ifdef USE_ITHREADS
6637         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6638         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6639         PAD_SETSV(cPADOPo->op_padix, swash);
6640         SvPADTMP_on(swash);
6641         SvREADONLY_on(swash);
6642 #else
6643         cSVOPo->op_sv = swash;
6644 #endif
6645         SvREFCNT_dec(listsv);
6646         SvREFCNT_dec(transv);
6647
6648         if (!del && havefinal && rlen)
6649             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6650                            newSVuv((UV)final), 0);
6651
6652         Safefree(tsave);
6653         Safefree(rsave);
6654
6655         tlen = tcount;
6656         rlen = rcount;
6657         if (r < rend)
6658             rlen++;
6659         else if (rlast == 0xffffffff)
6660             rlen = 0;
6661
6662         goto warnins;
6663     }
6664
6665     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6666      * table. Entries with the value -1 indicate chars not to be
6667      * translated, while -2 indicates a search char without a
6668      * corresponding replacement char under /d.
6669      *
6670      * Normally, the table has 256 slots. However, in the presence of
6671      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6672      * added, and if there are enough replacement chars to start pairing
6673      * with the \x{100},... search chars, then a larger (> 256) table
6674      * is allocated.
6675      *
6676      * In addition, regardless of whether under /c, an extra slot at the
6677      * end is used to store the final repeating char, or -3 under an empty
6678      * replacement list, or -2 under /d; which makes the runtime code
6679      * easier.
6680      *
6681      * The toker will have already expanded char ranges in t and r.
6682      */
6683
6684     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6685      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6686      * The OPtrans_map struct already contains one slot; hence the -1.
6687      */
6688     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6689     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6690     tbl->size = 256;
6691     cPVOPo->op_pv = (char*)tbl;
6692
6693     if (complement) {
6694         Size_t excess;
6695
6696         /* in this branch, j is a count of 'consumed' (i.e. paired off
6697          * with a search char) replacement chars (so j <= rlen always)
6698          */
6699         for (i = 0; i < tlen; i++)
6700             tbl->map[t[i]] = -1;
6701
6702         for (i = 0, j = 0; i < 256; i++) {
6703             if (!tbl->map[i]) {
6704                 if (j == rlen) {
6705                     if (del)
6706                         tbl->map[i] = -2;
6707                     else if (rlen)
6708                         tbl->map[i] = r[j-1];
6709                     else
6710                         tbl->map[i] = (short)i;
6711                 }
6712                 else {
6713                     tbl->map[i] = r[j++];
6714                 }
6715                 if (   tbl->map[i] >= 0
6716                     &&  UVCHR_IS_INVARIANT((UV)i)
6717                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6718                 )
6719                     grows = TRUE;
6720             }
6721         }
6722
6723         ASSUME(j <= rlen);
6724         excess = rlen - j;
6725
6726         if (excess) {
6727             /* More replacement chars than search chars:
6728              * store excess replacement chars at end of main table.
6729              */
6730
6731             struct_size += excess;
6732             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6733                         struct_size + excess * sizeof(short));
6734             tbl->size += excess;
6735             cPVOPo->op_pv = (char*)tbl;
6736
6737             for (i = 0; i < excess; i++)
6738                 tbl->map[i + 256] = r[j+i];
6739         }
6740         else {
6741             /* no more replacement chars than search chars */
6742             if (!rlen && !del && !squash)
6743                 o->op_private |= OPpTRANS_IDENTICAL;
6744         }
6745
6746         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6747     }
6748     else {
6749         if (!rlen && !del) {
6750             r = t; rlen = tlen;
6751             if (!squash)
6752                 o->op_private |= OPpTRANS_IDENTICAL;
6753         }
6754         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6755             o->op_private |= OPpTRANS_IDENTICAL;
6756         }
6757
6758         for (i = 0; i < 256; i++)
6759             tbl->map[i] = -1;
6760         for (i = 0, j = 0; i < tlen; i++,j++) {
6761             if (j >= rlen) {
6762                 if (del) {
6763                     if (tbl->map[t[i]] == -1)
6764                         tbl->map[t[i]] = -2;
6765                     continue;
6766                 }
6767                 --j;
6768             }
6769             if (tbl->map[t[i]] == -1) {
6770                 if (     UVCHR_IS_INVARIANT(t[i])
6771                     && ! UVCHR_IS_INVARIANT(r[j]))
6772                     grows = TRUE;
6773                 tbl->map[t[i]] = r[j];
6774             }
6775         }
6776         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6777     }
6778
6779     /* both non-utf8 and utf8 code paths end up here */
6780
6781   warnins:
6782     if(del && rlen == tlen) {
6783         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6784     } else if(rlen > tlen && !complement) {
6785         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6786     }
6787
6788     if (grows)
6789         o->op_private |= OPpTRANS_GROWS;
6790     op_free(expr);
6791     op_free(repl);
6792
6793     return o;
6794 }
6795
6796
6797 /*
6798 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6799
6800 Constructs, checks, and returns an op of any pattern matching type.
6801 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6802 and, shifted up eight bits, the eight bits of C<op_private>.
6803
6804 =cut
6805 */
6806
6807 OP *
6808 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6809 {
6810     dVAR;
6811     PMOP *pmop;
6812
6813     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6814         || type == OP_CUSTOM);
6815
6816     NewOp(1101, pmop, 1, PMOP);
6817     OpTYPE_set(pmop, type);
6818     pmop->op_flags = (U8)flags;
6819     pmop->op_private = (U8)(0 | (flags >> 8));
6820     if (PL_opargs[type] & OA_RETSCALAR)
6821         scalar((OP *)pmop);
6822
6823     if (PL_hints & HINT_RE_TAINT)
6824         pmop->op_pmflags |= PMf_RETAINT;
6825 #ifdef USE_LOCALE_CTYPE
6826     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6827         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6828     }
6829     else
6830 #endif
6831          if (IN_UNI_8_BIT) {
6832         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6833     }
6834     if (PL_hints & HINT_RE_FLAGS) {
6835         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6836          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6837         );
6838         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6839         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6840          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6841         );
6842         if (reflags && SvOK(reflags)) {
6843             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6844         }
6845     }
6846
6847
6848 #ifdef USE_ITHREADS
6849     assert(SvPOK(PL_regex_pad[0]));
6850     if (SvCUR(PL_regex_pad[0])) {
6851         /* Pop off the "packed" IV from the end.  */
6852         SV *const repointer_list = PL_regex_pad[0];
6853         const char *p = SvEND(repointer_list) - sizeof(IV);
6854         const IV offset = *((IV*)p);
6855
6856         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6857
6858         SvEND_set(repointer_list, p);
6859
6860         pmop->op_pmoffset = offset;
6861         /* This slot should be free, so assert this:  */
6862         assert(PL_regex_pad[offset] == &PL_sv_undef);
6863     } else {
6864         SV * const repointer = &PL_sv_undef;
6865         av_push(PL_regex_padav, repointer);
6866         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6867         PL_regex_pad = AvARRAY(PL_regex_padav);
6868     }
6869 #endif
6870
6871     return CHECKOP(type, pmop);
6872 }
6873
6874 static void
6875 S_set_haseval(pTHX)
6876 {
6877     PADOFFSET i = 1;
6878     PL_cv_has_eval = 1;
6879     /* Any pad names in scope are potentially lvalues.  */
6880     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6881         PADNAME *pn = PAD_COMPNAME_SV(i);
6882         if (!pn || !PadnameLEN(pn))
6883             continue;
6884         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6885             S_mark_padname_lvalue(aTHX_ pn);
6886     }
6887 }
6888
6889 /* Given some sort of match op o, and an expression expr containing a
6890  * pattern, either compile expr into a regex and attach it to o (if it's
6891  * constant), or convert expr into a runtime regcomp op sequence (if it's
6892  * not)
6893  *
6894  * Flags currently has 2 bits of meaning:
6895  * 1: isreg indicates that the pattern is part of a regex construct, eg
6896  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6897  * split "pattern", which aren't. In the former case, expr will be a list
6898  * if the pattern contains more than one term (eg /a$b/).
6899  * 2: The pattern is for a split.
6900  *
6901  * When the pattern has been compiled within a new anon CV (for
6902  * qr/(?{...})/ ), then floor indicates the savestack level just before
6903  * the new sub was created
6904  */
6905
6906 OP *
6907 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6908 {
6909     PMOP *pm;
6910     LOGOP *rcop;
6911     I32 repl_has_vars = 0;
6912     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6913     bool is_compiletime;
6914     bool has_code;
6915     bool isreg    = cBOOL(flags & 1);
6916     bool is_split = cBOOL(flags & 2);
6917
6918     PERL_ARGS_ASSERT_PMRUNTIME;
6919
6920     if (is_trans) {
6921         return pmtrans(o, expr, repl);
6922     }
6923
6924     /* find whether we have any runtime or code elements;
6925      * at the same time, temporarily set the op_next of each DO block;
6926      * then when we LINKLIST, this will cause the DO blocks to be excluded
6927      * from the op_next chain (and from having LINKLIST recursively
6928      * applied to them). We fix up the DOs specially later */
6929
6930     is_compiletime = 1;
6931     has_code = 0;
6932     if (expr->op_type == OP_LIST) {
6933         OP *o;
6934         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6935             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6936                 has_code = 1;
6937                 assert(!o->op_next);
6938                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6939                     assert(PL_parser && PL_parser->error_count);
6940                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6941                        the op we were expecting to see, to avoid crashing
6942                        elsewhere.  */
6943                     op_sibling_splice(expr, o, 0,
6944                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6945                 }
6946                 o->op_next = OpSIBLING(o);
6947             }
6948             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6949                 is_compiletime = 0;
6950         }
6951     }
6952     else if (expr->op_type != OP_CONST)
6953         is_compiletime = 0;
6954
6955     LINKLIST(expr);
6956
6957     /* fix up DO blocks; treat each one as a separate little sub;
6958      * also, mark any arrays as LIST/REF */
6959
6960     if (expr->op_type == OP_LIST) {
6961         OP *o;
6962         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6963
6964             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6965                 assert( !(o->op_flags  & OPf_WANT));
6966                 /* push the array rather than its contents. The regex
6967                  * engine will retrieve and join the elements later */
6968                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6969                 continue;
6970             }
6971
6972             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6973                 continue;
6974             o->op_next = NULL; /* undo temporary hack from above */
6975             scalar(o);
6976             LINKLIST(o);
6977             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6978                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6979                 /* skip ENTER */
6980                 assert(leaveop->op_first->op_type == OP_ENTER);
6981                 assert(OpHAS_SIBLING(leaveop->op_first));
6982                 o->op_next = OpSIBLING(leaveop->op_first);
6983                 /* skip leave */
6984                 assert(leaveop->op_flags & OPf_KIDS);
6985                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6986                 leaveop->op_next = NULL; /* stop on last op */
6987                 op_null((OP*)leaveop);
6988             }
6989             else {
6990                 /* skip SCOPE */
6991                 OP *scope = cLISTOPo->op_first;
6992                 assert(scope->op_type == OP_SCOPE);
6993                 assert(scope->op_flags & OPf_KIDS);
6994                 scope->op_next = NULL; /* stop on last op */
6995                 op_null(scope);
6996             }
6997
6998             /* XXX optimize_optree() must be called on o before
6999              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7000              * currently cope with a peephole-optimised optree.
7001              * Calling optimize_optree() here ensures that condition
7002              * is met, but may mean optimize_optree() is applied
7003              * to the same optree later (where hopefully it won't do any
7004              * harm as it can't convert an op to multiconcat if it's
7005              * already been converted */
7006             optimize_optree(o);
7007
7008             /* have to peep the DOs individually as we've removed it from
7009              * the op_next chain */
7010             CALL_PEEP(o);
7011             S_prune_chain_head(&(o->op_next));
7012             if (is_compiletime)
7013                 /* runtime finalizes as part of finalizing whole tree */
7014                 finalize_optree(o);
7015         }
7016     }
7017     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7018         assert( !(expr->op_flags  & OPf_WANT));
7019         /* push the array rather than its contents. The regex
7020          * engine will retrieve and join the elements later */
7021         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7022     }
7023
7024     PL_hints |= HINT_BLOCK_SCOPE;
7025     pm = (PMOP*)o;
7026     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7027
7028     if (is_compiletime) {
7029         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7030         regexp_engine const *eng = current_re_engine();
7031
7032         if (is_split) {
7033             /* make engine handle split ' ' specially */
7034             pm->op_pmflags |= PMf_SPLIT;
7035             rx_flags |= RXf_SPLIT;
7036         }
7037
7038         /* Skip compiling if parser found an error for this pattern */
7039         if (pm->op_pmflags & PMf_HAS_ERROR) {
7040             return o;
7041         }
7042
7043         if (!has_code || !eng->op_comp) {
7044             /* compile-time simple constant pattern */
7045
7046             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7047                 /* whoops! we guessed that a qr// had a code block, but we
7048                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7049                  * that isn't required now. Note that we have to be pretty
7050                  * confident that nothing used that CV's pad while the
7051                  * regex was parsed, except maybe op targets for \Q etc.
7052                  * If there were any op targets, though, they should have
7053                  * been stolen by constant folding.
7054                  */
7055 #ifdef DEBUGGING
7056                 SSize_t i = 0;
7057                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7058                 while (++i <= AvFILLp(PL_comppad)) {
7059 #  ifdef USE_PAD_RESET
7060                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7061                      * folded constant with a fresh padtmp */
7062                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7063 #  else
7064                     assert(!PL_curpad[i]);
7065 #  endif
7066                 }
7067 #endif
7068                 /* But we know that one op is using this CV's slab. */
7069                 cv_forget_slab(PL_compcv);
7070                 LEAVE_SCOPE(floor);
7071                 pm->op_pmflags &= ~PMf_HAS_CV;
7072             }
7073
7074             PM_SETRE(pm,
7075                 eng->op_comp
7076                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7077                                         rx_flags, pm->op_pmflags)
7078                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7079                                         rx_flags, pm->op_pmflags)
7080             );
7081             op_free(expr);
7082         }
7083         else {
7084             /* compile-time pattern that includes literal code blocks */
7085             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7086                         rx_flags,
7087                         (pm->op_pmflags |
7088                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7089                     );
7090             PM_SETRE(pm, re);
7091             if (pm->op_pmflags & PMf_HAS_CV) {
7092                 CV *cv;
7093                 /* this QR op (and the anon sub we embed it in) is never
7094                  * actually executed. It's just a placeholder where we can
7095                  * squirrel away expr in op_code_list without the peephole
7096                  * optimiser etc processing it for a second time */
7097                 OP *qr = newPMOP(OP_QR, 0);
7098                 ((PMOP*)qr)->op_code_list = expr;
7099
7100                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7101                 SvREFCNT_inc_simple_void(PL_compcv);
7102                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7103                 ReANY(re)->qr_anoncv = cv;
7104
7105                 /* attach the anon CV to the pad so that
7106                  * pad_fixup_inner_anons() can find it */
7107                 (void)pad_add_anon(cv, o->op_type);
7108                 SvREFCNT_inc_simple_void(cv);
7109             }
7110             else {
7111                 pm->op_code_list = expr;
7112             }
7113         }
7114     }
7115     else {
7116         /* runtime pattern: build chain of regcomp etc ops */
7117         bool reglist;
7118         PADOFFSET cv_targ = 0;
7119
7120         reglist = isreg && expr->op_type == OP_LIST;
7121         if (reglist)
7122             op_null(expr);
7123
7124         if (has_code) {
7125             pm->op_code_list = expr;
7126             /* don't free op_code_list; its ops are embedded elsewhere too */
7127             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7128         }
7129
7130         if (is_split)
7131             /* make engine handle split ' ' specially */
7132             pm->op_pmflags |= PMf_SPLIT;
7133
7134         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7135          * to allow its op_next to be pointed past the regcomp and
7136          * preceding stacking ops;
7137          * OP_REGCRESET is there to reset taint before executing the
7138          * stacking ops */
7139         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7140             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7141
7142         if (pm->op_pmflags & PMf_HAS_CV) {
7143             /* we have a runtime qr with literal code. This means
7144              * that the qr// has been wrapped in a new CV, which
7145              * means that runtime consts, vars etc will have been compiled
7146              * against a new pad. So... we need to execute those ops
7147              * within the environment of the new CV. So wrap them in a call
7148              * to a new anon sub. i.e. for
7149              *
7150              *     qr/a$b(?{...})/,
7151              *
7152              * we build an anon sub that looks like
7153              *
7154              *     sub { "a", $b, '(?{...})' }
7155              *
7156              * and call it, passing the returned list to regcomp.
7157              * Or to put it another way, the list of ops that get executed
7158              * are:
7159              *
7160              *     normal              PMf_HAS_CV
7161              *     ------              -------------------
7162              *                         pushmark (for regcomp)
7163              *                         pushmark (for entersub)
7164              *                         anoncode
7165              *                         srefgen
7166              *                         entersub
7167              *     regcreset                  regcreset
7168              *     pushmark                   pushmark
7169              *     const("a")                 const("a")
7170              *     gvsv(b)                    gvsv(b)
7171              *     const("(?{...})")          const("(?{...})")
7172              *                                leavesub
7173              *     regcomp             regcomp
7174              */
7175
7176             SvREFCNT_inc_simple_void(PL_compcv);
7177             CvLVALUE_on(PL_compcv);
7178             /* these lines are just an unrolled newANONATTRSUB */
7179             expr = newSVOP(OP_ANONCODE, 0,
7180                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7181             cv_targ = expr->op_targ;
7182             expr = newUNOP(OP_REFGEN, 0, expr);
7183
7184             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7185         }
7186
7187         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7188         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7189                            | (reglist ? OPf_STACKED : 0);
7190         rcop->op_targ = cv_targ;
7191
7192         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7193         if (PL_hints & HINT_RE_EVAL)
7194             S_set_haseval(aTHX);
7195
7196         /* establish postfix order */
7197         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7198             LINKLIST(expr);
7199             rcop->op_next = expr;
7200             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7201         }
7202         else {
7203             rcop->op_next = LINKLIST(expr);
7204             expr->op_next = (OP*)rcop;
7205         }
7206
7207         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7208     }
7209
7210     if (repl) {
7211         OP *curop = repl;
7212         bool konst;
7213         /* If we are looking at s//.../e with a single statement, get past
7214            the implicit do{}. */
7215         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7216              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7217              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7218          {
7219             OP *sib;
7220             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7221             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7222              && !OpHAS_SIBLING(sib))
7223                 curop = sib;
7224         }
7225         if (curop->op_type == OP_CONST)
7226             konst = TRUE;
7227         else if (( (curop->op_type == OP_RV2SV ||
7228                     curop->op_type == OP_RV2AV ||
7229                     curop->op_type == OP_RV2HV ||
7230                     curop->op_type == OP_RV2GV)
7231                    && cUNOPx(curop)->op_first
7232                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7233                 || curop->op_type == OP_PADSV
7234                 || curop->op_type == OP_PADAV
7235                 || curop->op_type == OP_PADHV
7236                 || curop->op_type == OP_PADANY) {
7237             repl_has_vars = 1;
7238             konst = TRUE;
7239         }
7240         else konst = FALSE;
7241         if (konst
7242             && !(repl_has_vars
7243                  && (!PM_GETRE(pm)
7244                      || !RX_PRELEN(PM_GETRE(pm))
7245                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7246         {
7247             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7248             op_prepend_elem(o->op_type, scalar(repl), o);
7249         }
7250         else {
7251             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7252             rcop->op_private = 1;
7253
7254             /* establish postfix order */
7255             rcop->op_next = LINKLIST(repl);
7256             repl->op_next = (OP*)rcop;
7257
7258             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7259             assert(!(pm->op_pmflags & PMf_ONCE));
7260             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7261             rcop->op_next = 0;
7262         }
7263     }
7264
7265     return (OP*)pm;
7266 }
7267
7268 /*
7269 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7270
7271 Constructs, checks, and returns an op of any type that involves an
7272 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7273 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7274 takes ownership of one reference to it.
7275
7276 =cut
7277 */
7278
7279 OP *
7280 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7281 {
7282     dVAR;
7283     SVOP *svop;
7284
7285     PERL_ARGS_ASSERT_NEWSVOP;
7286
7287     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7288         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7289         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7290         || type == OP_CUSTOM);
7291
7292     NewOp(1101, svop, 1, SVOP);
7293     OpTYPE_set(svop, type);
7294     svop->op_sv = sv;
7295     svop->op_next = (OP*)svop;
7296     svop->op_flags = (U8)flags;
7297     svop->op_private = (U8)(0 | (flags >> 8));
7298     if (PL_opargs[type] & OA_RETSCALAR)
7299         scalar((OP*)svop);
7300     if (PL_opargs[type] & OA_TARGET)
7301         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7302     return CHECKOP(type, svop);
7303 }
7304
7305 /*
7306 =for apidoc Am|OP *|newDEFSVOP|
7307
7308 Constructs and returns an op to access C<$_>.
7309
7310 =cut
7311 */
7312
7313 OP *
7314 Perl_newDEFSVOP(pTHX)
7315 {
7316         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7317 }
7318
7319 #ifdef USE_ITHREADS
7320
7321 /*
7322 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7323
7324 Constructs, checks, and returns an op of any type that involves a
7325 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7326 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7327 is populated with C<sv>; this function takes ownership of one reference
7328 to it.
7329
7330 This function only exists if Perl has been compiled to use ithreads.
7331
7332 =cut
7333 */
7334
7335 OP *
7336 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7337 {
7338     dVAR;
7339     PADOP *padop;
7340
7341     PERL_ARGS_ASSERT_NEWPADOP;
7342
7343     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7344         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7345         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7346         || type == OP_CUSTOM);
7347
7348     NewOp(1101, padop, 1, PADOP);
7349     OpTYPE_set(padop, type);
7350     padop->op_padix =
7351         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7352     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7353     PAD_SETSV(padop->op_padix, sv);
7354     assert(sv);
7355     padop->op_next = (OP*)padop;
7356     padop->op_flags = (U8)flags;
7357     if (PL_opargs[type] & OA_RETSCALAR)
7358         scalar((OP*)padop);
7359     if (PL_opargs[type] & OA_TARGET)
7360         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7361     return CHECKOP(type, padop);
7362 }
7363
7364 #endif /* USE_ITHREADS */
7365
7366 /*
7367 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7368
7369 Constructs, checks, and returns an op of any type that involves an
7370 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7371 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7372 reference; calling this function does not transfer ownership of any
7373 reference to it.
7374
7375 =cut
7376 */
7377
7378 OP *
7379 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7380 {
7381     PERL_ARGS_ASSERT_NEWGVOP;
7382
7383 #ifdef USE_ITHREADS
7384     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7385 #else
7386     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7387 #endif
7388 }
7389
7390 /*
7391 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7392
7393 Constructs, checks, and returns an op of any type that involves an
7394 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7395 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7396 Depending on the op type, the memory referenced by C<pv> may be freed
7397 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7398 have been allocated using C<PerlMemShared_malloc>.
7399
7400 =cut
7401 */
7402
7403 OP *
7404 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7405 {
7406     dVAR;
7407     const bool utf8 = cBOOL(flags & SVf_UTF8);
7408     PVOP *pvop;
7409
7410     flags &= ~SVf_UTF8;
7411
7412     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7413         || type == OP_RUNCV || type == OP_CUSTOM
7414         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7415
7416     NewOp(1101, pvop, 1, PVOP);
7417     OpTYPE_set(pvop, type);
7418     pvop->op_pv = pv;
7419     pvop->op_next = (OP*)pvop;
7420     pvop->op_flags = (U8)flags;
7421     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7422     if (PL_opargs[type] & OA_RETSCALAR)
7423         scalar((OP*)pvop);
7424     if (PL_opargs[type] & OA_TARGET)
7425         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7426     return CHECKOP(type, pvop);
7427 }
7428
7429 void
7430 Perl_package(pTHX_ OP *o)
7431 {
7432     SV *const sv = cSVOPo->op_sv;
7433
7434     PERL_ARGS_ASSERT_PACKAGE;
7435
7436     SAVEGENERICSV(PL_curstash);
7437     save_item(PL_curstname);
7438
7439     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7440
7441     sv_setsv(PL_curstname, sv);
7442
7443     PL_hints |= HINT_BLOCK_SCOPE;
7444     PL_parser->copline = NOLINE;
7445
7446     op_free(o);
7447 }
7448
7449 void
7450 Perl_package_version( pTHX_ OP *v )
7451 {
7452     U32 savehints = PL_hints;
7453     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7454     PL_hints &= ~HINT_STRICT_VARS;
7455     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7456     PL_hints = savehints;
7457     op_free(v);
7458 }
7459
7460 void
7461 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7462 {
7463     OP *pack;
7464     OP *imop;
7465     OP *veop;
7466     SV *use_version = NULL;
7467
7468     PERL_ARGS_ASSERT_UTILIZE;
7469
7470     if (idop->op_type != OP_CONST)
7471         Perl_croak(aTHX_ "Module name must be constant");
7472
7473     veop = NULL;
7474
7475     if (version) {
7476         SV * const vesv = ((SVOP*)version)->op_sv;
7477
7478         if (!arg && !SvNIOKp(vesv)) {
7479             arg = version;
7480         }
7481         else {
7482             OP *pack;
7483             SV *meth;
7484
7485             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7486                 Perl_croak(aTHX_ "Version number must be a constant number");
7487
7488             /* Make copy of idop so we don't free it twice */
7489             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7490
7491             /* Fake up a method call to VERSION */
7492             meth = newSVpvs_share("VERSION");
7493             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7494                             op_append_elem(OP_LIST,
7495                                         op_prepend_elem(OP_LIST, pack, version),
7496                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7497         }
7498     }
7499
7500     /* Fake up an import/unimport */
7501     if (arg && arg->op_type == OP_STUB) {
7502         imop = arg;             /* no import on explicit () */
7503     }
7504     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7505         imop = NULL;            /* use 5.0; */
7506         if (aver)
7507             use_version = ((SVOP*)idop)->op_sv;
7508         else
7509             idop->op_private |= OPpCONST_NOVER;
7510     }
7511     else {
7512         SV *meth;
7513
7514         /* Make copy of idop so we don't free it twice */
7515         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7516
7517         /* Fake up a method call to import/unimport */
7518         meth = aver
7519             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7520         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7521                        op_append_elem(OP_LIST,
7522                                    op_prepend_elem(OP_LIST, pack, arg),
7523                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7524                        ));
7525     }
7526
7527     /* Fake up the BEGIN {}, which does its thing immediately. */
7528     newATTRSUB(floor,
7529         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7530         NULL,
7531         NULL,
7532         op_append_elem(OP_LINESEQ,
7533             op_append_elem(OP_LINESEQ,
7534                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7535                 newSTATEOP(0, NULL, veop)),
7536             newSTATEOP(0, NULL, imop) ));
7537
7538     if (use_version) {
7539         /* Enable the
7540          * feature bundle that corresponds to the required version. */
7541         use_version = sv_2mortal(new_version(use_version));
7542         S_enable_feature_bundle(aTHX_ use_version);
7543
7544         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7545         if (vcmp(use_version,
7546                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7547             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7548                 PL_hints |= HINT_STRICT_REFS;
7549             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7550                 PL_hints |= HINT_STRICT_SUBS;
7551             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7552                 PL_hints |= HINT_STRICT_VARS;
7553         }
7554         /* otherwise they are off */
7555         else {
7556             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7557                 PL_hints &= ~HINT_STRICT_REFS;
7558             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7559                 PL_hints &= ~HINT_STRICT_SUBS;
7560             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7561                 PL_hints &= ~HINT_STRICT_VARS;
7562         }
7563     }
7564
7565     /* The "did you use incorrect case?" warning used to be here.
7566      * The problem is that on case-insensitive filesystems one
7567      * might get false positives for "use" (and "require"):
7568      * "use Strict" or "require CARP" will work.  This causes
7569      * portability problems for the script: in case-strict
7570      * filesystems the script will stop working.
7571      *
7572      * The "incorrect case" warning checked whether "use Foo"
7573      * imported "Foo" to your namespace, but that is wrong, too:
7574      * there is no requirement nor promise in the language that
7575      * a Foo.pm should or would contain anything in package "Foo".
7576      *
7577      * There is very little Configure-wise that can be done, either:
7578      * the case-sensitivity of the build filesystem of Perl does not
7579      * help in guessing the case-sensitivity of the runtime environment.
7580      */
7581
7582     PL_hints |= HINT_BLOCK_SCOPE;
7583     PL_parser->copline = NOLINE;
7584     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7585 }
7586
7587 /*
7588 =head1 Embedding Functions
7589
7590 =for apidoc load_module
7591
7592 Loads the module whose name is pointed to by the string part of C<name>.
7593 Note that the actual module name, not its filename, should be given.
7594 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7595 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7596 trailing arguments can be used to specify arguments to the module's C<import()>
7597 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7598 on the flags. The flags argument is a bitwise-ORed collection of any of
7599 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7600 (or 0 for no flags).
7601
7602 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7603 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7604 the trailing optional arguments may be omitted entirely. Otherwise, if
7605 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7606 exactly one C<OP*>, containing the op tree that produces the relevant import
7607 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7608 will be used as import arguments; and the list must be terminated with C<(SV*)
7609 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7610 set, the trailing C<NULL> pointer is needed even if no import arguments are
7611 desired. The reference count for each specified C<SV*> argument is
7612 decremented. In addition, the C<name> argument is modified.
7613
7614 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7615 than C<use>.
7616
7617 =cut */
7618
7619 void
7620 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7621 {
7622     va_list args;
7623
7624     PERL_ARGS_ASSERT_LOAD_MODULE;
7625
7626     va_start(args, ver);
7627     vload_module(flags, name, ver, &args);
7628     va_end(args);
7629 }
7630
7631 #ifdef PERL_IMPLICIT_CONTEXT
7632 void
7633 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7634 {
7635     dTHX;
7636     va_list args;
7637     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7638     va_start(args, ver);
7639     vload_module(flags, name, ver, &args);
7640     va_end(args);
7641 }
7642 #endif
7643
7644 void
7645 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7646 {
7647     OP *veop, *imop;
7648     OP * const modname = newSVOP(OP_CONST, 0, name);
7649
7650     PERL_ARGS_ASSERT_VLOAD_MODULE;
7651
7652     modname->op_private |= OPpCONST_BARE;
7653     if (ver) {
7654         veop = newSVOP(OP_CONST, 0, ver);
7655     }
7656     else
7657         veop = NULL;
7658     if (flags & PERL_LOADMOD_NOIMPORT) {
7659         imop = sawparens(newNULLLIST());
7660     }
7661     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7662         imop = va_arg(*args, OP*);
7663     }
7664     else {
7665         SV *sv;
7666         imop = NULL;
7667         sv = va_arg(*args, SV*);
7668         while (sv) {
7669             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7670             sv = va_arg(*args, SV*);
7671         }
7672     }
7673
7674     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7675      * that it has a PL_parser to play with while doing that, and also
7676      * that it doesn't mess with any existing parser, by creating a tmp
7677      * new parser with lex_start(). This won't actually be used for much,
7678      * since pp_require() will create another parser for the real work.
7679      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7680
7681     ENTER;
7682     SAVEVPTR(PL_curcop);
7683     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7684     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7685             veop, modname, imop);
7686     LEAVE;
7687 }
7688
7689 PERL_STATIC_INLINE OP *
7690 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7691 {
7692     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7693                    newLISTOP(OP_LIST, 0, arg,
7694                              newUNOP(OP_RV2CV, 0,
7695                                      newGVOP(OP_GV, 0, gv))));
7696 }
7697
7698 OP *
7699 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7700 {
7701     OP *doop;
7702     GV *gv;
7703
7704     PERL_ARGS_ASSERT_DOFILE;
7705
7706     if (!force_builtin && (gv = gv_override("do", 2))) {
7707         doop = S_new_entersubop(aTHX_ gv, term);
7708     }
7709     else {
7710         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7711     }
7712     return doop;
7713 }
7714
7715 /*
7716 =head1 Optree construction
7717
7718 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7719
7720 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7721 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7722 be set automatically, and, shifted up eight bits, the eight bits of
7723 C<op_private>, except that the bit with value 1 or 2 is automatically
7724 set as required.  C<listval> and C<subscript> supply the parameters of
7725 the slice; they are consumed by this function and become part of the
7726 constructed op tree.
7727
7728 =cut
7729 */
7730
7731 OP *
7732 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7733 {
7734     return newBINOP(OP_LSLICE, flags,
7735             list(force_list(subscript, 1)),
7736             list(force_list(listval,   1)) );
7737 }
7738
7739 #define ASSIGN_LIST   1
7740 #define ASSIGN_REF    2
7741
7742 STATIC I32
7743 S_assignment_type(pTHX_ const OP *o)
7744 {
7745     unsigned type;
7746     U8 flags;
7747     U8 ret;
7748
7749     if (!o)
7750         return TRUE;
7751
7752     if (o->op_type == OP_SREFGEN)
7753     {
7754         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7755         type = kid->op_type;
7756         flags = o->op_flags | kid->op_flags;
7757         if (!(flags & OPf_PARENS)
7758           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7759               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7760             return ASSIGN_REF;
7761         ret = ASSIGN_REF;
7762     } else {
7763         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7764             o = cUNOPo->op_first;
7765         flags = o->op_flags;
7766         type = o->op_type;
7767         ret = 0;
7768     }
7769
7770     if (type == OP_COND_EXPR) {
7771         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7772         const I32 t = assignment_type(sib);
7773         const I32 f = assignment_type(OpSIBLING(sib));
7774
7775         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7776             return ASSIGN_LIST;
7777         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7778             yyerror("Assignment to both a list and a scalar");
7779         return FALSE;
7780     }
7781
7782     if (type == OP_LIST &&
7783         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7784         o->op_private & OPpLVAL_INTRO)
7785         return ret;
7786
7787     if (type == OP_LIST || flags & OPf_PARENS ||
7788         type == OP_RV2AV || type == OP_RV2HV ||
7789         type == OP_ASLICE || type == OP_HSLICE ||
7790         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7791         return TRUE;
7792
7793     if (type == OP_PADAV || type == OP_PADHV)
7794         return TRUE;
7795
7796     if (type == OP_RV2SV)
7797         return ret;
7798
7799     return ret;
7800 }
7801
7802 static OP *
7803 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7804 {
7805     const PADOFFSET target = padop->op_targ;
7806     OP *const other = newOP(OP_PADSV,
7807                             padop->op_flags
7808                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7809     OP *const first = newOP(OP_NULL, 0);
7810     OP *const nullop = newCONDOP(0, first, initop, other);
7811     /* XXX targlex disabled for now; see ticket #124160
7812         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7813      */
7814     OP *const condop = first->op_next;
7815
7816     OpTYPE_set(condop, OP_ONCE);
7817     other->op_targ = target;
7818     nullop->op_flags |= OPf_WANT_SCALAR;
7819
7820     /* Store the initializedness of state vars in a separate
7821        pad entry.  */
7822     condop->op_targ =
7823       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7824     /* hijacking PADSTALE for uninitialized state variables */
7825     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7826
7827     return nullop;
7828 }
7829
7830 /*
7831 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7832
7833 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7834 supply the parameters of the assignment; they are consumed by this
7835 function and become part of the constructed op tree.
7836
7837 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7838 a suitable conditional optree is constructed.  If C<optype> is the opcode
7839 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7840 performs the binary operation and assigns the result to the left argument.
7841 Either way, if C<optype> is non-zero then C<flags> has no effect.
7842
7843 If C<optype> is zero, then a plain scalar or list assignment is
7844 constructed.  Which type of assignment it is is automatically determined.
7845 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7846 will be set automatically, and, shifted up eight bits, the eight bits
7847 of C<op_private>, except that the bit with value 1 or 2 is automatically
7848 set as required.
7849
7850 =cut
7851 */
7852
7853 OP *
7854 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7855 {
7856     OP *o;
7857     I32 assign_type;
7858
7859     if (optype) {
7860         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7861             right = scalar(right);
7862             return newLOGOP(optype, 0,
7863                 op_lvalue(scalar(left), optype),
7864                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7865         }
7866         else {
7867             return newBINOP(optype, OPf_STACKED,
7868                 op_lvalue(scalar(left), optype), scalar(right));
7869         }
7870     }
7871
7872     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7873         OP *state_var_op = NULL;
7874         static const char no_list_state[] = "Initialization of state variables"
7875             " in list currently forbidden";
7876         OP *curop;
7877
7878         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7879             left->op_private &= ~ OPpSLICEWARNING;
7880
7881         PL_modcount = 0;
7882         left = op_lvalue(left, OP_AASSIGN);
7883         curop = list(force_list(left, 1));
7884         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7885         o->op_private = (U8)(0 | (flags >> 8));
7886
7887         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7888         {
7889             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7890             if (!(left->op_flags & OPf_PARENS) &&
7891                     lop->op_type == OP_PUSHMARK &&
7892                     (vop = OpSIBLING(lop)) &&
7893                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7894                     !(vop->op_flags & OPf_PARENS) &&
7895                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7896                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7897                     (eop = OpSIBLING(vop)) &&
7898                     eop->op_type == OP_ENTERSUB &&
7899                     !OpHAS_SIBLING(eop)) {
7900                 state_var_op = vop;
7901             } else {
7902                 while (lop) {
7903                     if ((lop->op_type == OP_PADSV ||
7904                          lop->op_type == OP_PADAV ||
7905                          lop->op_type == OP_PADHV ||
7906                          lop->op_type == OP_PADANY)
7907                       && (lop->op_private & OPpPAD_STATE)
7908                     )
7909                         yyerror(no_list_state);
7910                     lop = OpSIBLING(lop);
7911                 }
7912             }
7913         }
7914         else if (  (left->op_private & OPpLVAL_INTRO)
7915                 && (left->op_private & OPpPAD_STATE)
7916                 && (   left->op_type == OP_PADSV
7917                     || left->op_type == OP_PADAV
7918                     || left->op_type == OP_PADHV
7919                     || left->op_type == OP_PADANY)
7920         ) {
7921                 /* All single variable list context state assignments, hence
7922                    state ($a) = ...
7923                    (state $a) = ...
7924                    state @a = ...
7925                    state (@a) = ...
7926                    (state @a) = ...
7927                    state %a = ...
7928                    state (%a) = ...
7929                    (state %a) = ...
7930                 */
7931                 if (left->op_flags & OPf_PARENS)
7932                     yyerror(no_list_state);
7933                 else
7934                     state_var_op = left;
7935         }
7936
7937         /* optimise @a = split(...) into:
7938         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7939         * @a, my @a, local @a:  split(...)          (where @a is attached to
7940         *                                            the split op itself)
7941         */
7942
7943         if (   right
7944             && right->op_type == OP_SPLIT
7945             /* don't do twice, e.g. @b = (@a = split) */
7946             && !(right->op_private & OPpSPLIT_ASSIGN))
7947         {
7948             OP *gvop = NULL;
7949
7950             if (   (  left->op_type == OP_RV2AV
7951                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7952                 || left->op_type == OP_PADAV)
7953             {
7954                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7955                 OP *tmpop;
7956                 if (gvop) {
7957 #ifdef USE_ITHREADS
7958                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7959                         = cPADOPx(gvop)->op_padix;
7960                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7961 #else
7962                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7963                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7964                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7965 #endif
7966                     right->op_private |=
7967                         left->op_private & OPpOUR_INTRO;
7968                 }
7969                 else {
7970                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7971                     left->op_targ = 0;  /* steal it */
7972                     right->op_private |= OPpSPLIT_LEX;
7973                 }
7974                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7975
7976               detach_split:
7977                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7978                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7979                 assert(OpSIBLING(tmpop) == right);
7980                 assert(!OpHAS_SIBLING(right));
7981                 /* detach the split subtreee from the o tree,
7982                  * then free the residual o tree */
7983                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7984                 op_free(o);                     /* blow off assign */
7985                 right->op_private |= OPpSPLIT_ASSIGN;
7986                 right->op_flags &= ~OPf_WANT;
7987                         /* "I don't know and I don't care." */
7988                 return right;
7989             }
7990             else if (left->op_type == OP_RV2AV) {
7991                 /* @{expr} */
7992
7993                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7994                 assert(OpSIBLING(pushop) == left);
7995                 /* Detach the array ...  */
7996                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7997                 /* ... and attach it to the split.  */
7998                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7999                                   0, left);
8000                 right->op_flags |= OPf_STACKED;
8001                 /* Detach split and expunge aassign as above.  */
8002                 goto detach_split;
8003             }
8004             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8005                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8006             {
8007                 /* convert split(...,0) to split(..., PL_modcount+1) */
8008                 SV ** const svp =
8009                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8010                 SV * const sv = *svp;
8011                 if (SvIOK(sv) && SvIVX(sv) == 0)
8012                 {
8013                   if (right->op_private & OPpSPLIT_IMPLIM) {
8014                     /* our own SV, created in ck_split */
8015                     SvREADONLY_off(sv);
8016                     sv_setiv(sv, PL_modcount+1);
8017                   }
8018                   else {
8019                     /* SV may belong to someone else */
8020                     SvREFCNT_dec(sv);
8021                     *svp = newSViv(PL_modcount+1);
8022                   }
8023                 }
8024             }
8025         }
8026
8027         if (state_var_op)
8028             o = S_newONCEOP(aTHX_ o, state_var_op);
8029         return o;
8030     }
8031     if (assign_type == ASSIGN_REF)
8032         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8033     if (!right)
8034         right = newOP(OP_UNDEF, 0);
8035     if (right->op_type == OP_READLINE) {
8036         right->op_flags |= OPf_STACKED;
8037         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8038                 scalar(right));
8039     }
8040     else {
8041         o = newBINOP(OP_SASSIGN, flags,
8042             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8043     }
8044     return o;
8045 }
8046
8047 /*
8048 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8049
8050 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8051 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8052 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8053 If C<label> is non-null, it supplies the name of a label to attach to
8054 the state op; this function takes ownership of the memory pointed at by
8055 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8056 for the state op.
8057
8058 If C<o> is null, the state op is returned.  Otherwise the state op is
8059 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8060 is consumed by this function and becomes part of the returned op tree.
8061
8062 =cut
8063 */
8064
8065 OP *
8066 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8067 {
8068     dVAR;
8069     const U32 seq = intro_my();
8070     const U32 utf8 = flags & SVf_UTF8;
8071     COP *cop;
8072
8073     PL_parser->parsed_sub = 0;
8074
8075     flags &= ~SVf_UTF8;
8076
8077     NewOp(1101, cop, 1, COP);
8078     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8079         OpTYPE_set(cop, OP_DBSTATE);
8080     }
8081     else {
8082         OpTYPE_set(cop, OP_NEXTSTATE);
8083     }
8084     cop->op_flags = (U8)flags;
8085     CopHINTS_set(cop, PL_hints);
8086 #ifdef VMS
8087     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8088 #endif
8089     cop->op_next = (OP*)cop;
8090
8091     cop->cop_seq = seq;
8092     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8093     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8094     if (label) {
8095         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8096
8097         PL_hints |= HINT_BLOCK_SCOPE;
8098         /* It seems that we need to defer freeing this pointer, as other parts
8099            of the grammar end up wanting to copy it after this op has been
8100            created. */
8101         SAVEFREEPV(label);
8102     }
8103
8104     if (PL_parser->preambling != NOLINE) {
8105         CopLINE_set(cop, PL_parser->preambling);
8106         PL_parser->copline = NOLINE;
8107     }
8108     else if (PL_parser->copline == NOLINE)
8109         CopLINE_set(cop, CopLINE(PL_curcop));
8110     else {
8111         CopLINE_set(cop, PL_parser->copline);
8112         PL_parser->copline = NOLINE;
8113     }
8114 #ifdef USE_ITHREADS
8115     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8116 #else
8117     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8118 #endif
8119     CopSTASH_set(cop, PL_curstash);
8120
8121     if (cop->op_type == OP_DBSTATE) {
8122         /* this line can have a breakpoint - store the cop in IV */
8123         AV *av = CopFILEAVx(PL_curcop);
8124         if (av) {
8125             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8126             if (svp && *svp != &PL_sv_undef ) {
8127                 (void)SvIOK_on(*svp);
8128                 SvIV_set(*svp, PTR2IV(cop));
8129             }
8130         }
8131     }
8132
8133     if (flags & OPf_SPECIAL)
8134         op_null((OP*)cop);
8135     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8136 }
8137
8138 /*
8139 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8140
8141 Constructs, checks, and returns a logical (flow control) op.  C<type>
8142 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8143 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8144 the eight bits of C<op_private>, except that the bit with value 1 is
8145 automatically set.  C<first> supplies the expression controlling the
8146 flow, and C<other> supplies the side (alternate) chain of ops; they are
8147 consumed by this function and become part of the constructed op tree.
8148
8149 =cut
8150 */
8151
8152 OP *
8153 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8154 {
8155     PERL_ARGS_ASSERT_NEWLOGOP;
8156
8157     return new_logop(type, flags, &first, &other);
8158 }
8159
8160 STATIC OP *
8161 S_search_const(pTHX_ OP *o)
8162 {
8163     PERL_ARGS_ASSERT_SEARCH_CONST;
8164
8165     switch (o->op_type) {
8166         case OP_CONST:
8167             return o;
8168         case OP_NULL:
8169             if (o->op_flags & OPf_KIDS)
8170                 return search_const(cUNOPo->op_first);
8171             break;
8172         case OP_LEAVE:
8173         case OP_SCOPE:
8174         case OP_LINESEQ:
8175         {
8176             OP *kid;
8177             if (!(o->op_flags & OPf_KIDS))
8178                 return NULL;
8179             kid = cLISTOPo->op_first;
8180             do {
8181                 switch (kid->op_type) {
8182                     case OP_ENTER:
8183                     case OP_NULL:
8184                     case OP_NEXTSTATE:
8185                         kid = OpSIBLING(kid);
8186                         break;
8187                     default:
8188                         if (kid != cLISTOPo->op_last)
8189                             return NULL;
8190                         goto last;
8191                 }
8192             } while (kid);
8193             if (!kid)
8194                 kid = cLISTOPo->op_last;
8195           last:
8196             return search_const(kid);
8197         }
8198     }
8199
8200     return NULL;
8201 }
8202
8203 STATIC OP *
8204 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8205 {
8206     dVAR;
8207     LOGOP *logop;
8208     OP *o;
8209     OP *first;
8210     OP *other;
8211     OP *cstop = NULL;
8212     int prepend_not = 0;
8213
8214     PERL_ARGS_ASSERT_NEW_LOGOP;
8215
8216     first = *firstp;
8217     other = *otherp;
8218
8219     /* [perl #59802]: Warn about things like "return $a or $b", which
8220        is parsed as "(return $a) or $b" rather than "return ($a or
8221        $b)".  NB: This also applies to xor, which is why we do it
8222        here.
8223      */
8224     switch (first->op_type) {
8225     case OP_NEXT:
8226     case OP_LAST:
8227     case OP_REDO:
8228         /* XXX: Perhaps we should emit a stronger warning for these.
8229            Even with the high-precedence operator they don't seem to do
8230            anything sensible.
8231
8232            But until we do, fall through here.
8233          */
8234     case OP_RETURN:
8235     case OP_EXIT:
8236     case OP_DIE:
8237     case OP_GOTO:
8238         /* XXX: Currently we allow people to "shoot themselves in the
8239            foot" by explicitly writing "(return $a) or $b".
8240
8241            Warn unless we are looking at the result from folding or if
8242            the programmer explicitly grouped the operators like this.
8243            The former can occur with e.g.
8244
8245                 use constant FEATURE => ( $] >= ... );
8246                 sub { not FEATURE and return or do_stuff(); }
8247          */
8248         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8249             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8250                            "Possible precedence issue with control flow operator");
8251         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8252            the "or $b" part)?
8253         */
8254         break;
8255     }
8256
8257     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8258         return newBINOP(type, flags, scalar(first), scalar(other));
8259
8260     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8261         || type == OP_CUSTOM);
8262
8263     scalarboolean(first);
8264
8265     /* search for a constant op that could let us fold the test */
8266     if ((cstop = search_const(first))) {
8267         if (cstop->op_private & OPpCONST_STRICT)
8268             no_bareword_allowed(cstop);
8269         else if ((cstop->op_private & OPpCONST_BARE))
8270                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8271         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8272             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8273             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8274             /* Elide the (constant) lhs, since it can't affect the outcome */
8275             *firstp = NULL;
8276             if (other->op_type == OP_CONST)
8277                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8278             op_free(first);
8279             if (other->op_type == OP_LEAVE)
8280                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8281             else if (other->op_type == OP_MATCH
8282                   || other->op_type == OP_SUBST
8283                   || other->op_type == OP_TRANSR
8284                   || other->op_type == OP_TRANS)
8285                 /* Mark the op as being unbindable with =~ */
8286                 other->op_flags |= OPf_SPECIAL;
8287
8288             other->op_folded = 1;
8289             return other;
8290         }
8291         else {
8292             /* Elide the rhs, since the outcome is entirely determined by
8293              * the (constant) lhs */
8294
8295             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8296             const OP *o2 = other;
8297             if ( ! (o2->op_type == OP_LIST
8298                     && (( o2 = cUNOPx(o2)->op_first))
8299                     && o2->op_type == OP_PUSHMARK
8300                     && (( o2 = OpSIBLING(o2))) )
8301             )
8302                 o2 = other;
8303             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8304                         || o2->op_type == OP_PADHV)
8305                 && o2->op_private & OPpLVAL_INTRO
8306                 && !(o2->op_private & OPpPAD_STATE))
8307             {
8308         Perl_croak(aTHX_ "This use of my() in false conditional is "
8309                           "no longer allowed");
8310             }
8311
8312             *otherp = NULL;
8313             if (cstop->op_type == OP_CONST)
8314                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8315             op_free(other);
8316             return first;
8317         }
8318     }
8319     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8320         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8321     {
8322         const OP * const k1 = ((UNOP*)first)->op_first;
8323         const OP * const k2 = OpSIBLING(k1);
8324         OPCODE warnop = 0;
8325         switch (first->op_type)
8326         {
8327         case OP_NULL:
8328             if (k2 && k2->op_type == OP_READLINE
8329                   && (k2->op_flags & OPf_STACKED)
8330                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8331             {
8332                 warnop = k2->op_type;
8333             }
8334             break;
8335
8336         case OP_SASSIGN:
8337             if (k1->op_type == OP_READDIR
8338                   || k1->op_type == OP_GLOB
8339                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8340                  || k1->op_type == OP_EACH
8341                  || k1->op_type == OP_AEACH)
8342             {
8343                 warnop = ((k1->op_type == OP_NULL)
8344                           ? (OPCODE)k1->op_targ : k1->op_type);
8345             }
8346             break;
8347         }
8348         if (warnop) {
8349             const line_t oldline = CopLINE(PL_curcop);
8350             /* This ensures that warnings are reported at the first line
8351                of the construction, not the last.  */
8352             CopLINE_set(PL_curcop, PL_parser->copline);
8353             Perl_warner(aTHX_ packWARN(WARN_MISC),
8354                  "Value of %s%s can be \"0\"; test with defined()",
8355                  PL_op_desc[warnop],
8356                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8357                   ? " construct" : "() operator"));
8358             CopLINE_set(PL_curcop, oldline);
8359         }
8360     }
8361
8362     /* optimize AND and OR ops that have NOTs as children */
8363     if (first->op_type == OP_NOT
8364         && (first->op_flags & OPf_KIDS)
8365         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8366             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8367         ) {
8368         if (type == OP_AND || type == OP_OR) {
8369             if (type == OP_AND)
8370                 type = OP_OR;
8371             else
8372                 type = OP_AND;
8373             op_null(first);
8374             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8375                 op_null(other);
8376                 prepend_not = 1; /* prepend a NOT op later */
8377             }
8378         }
8379     }
8380
8381     logop = alloc_LOGOP(type, first, LINKLIST(other));
8382     logop->op_flags |= (U8)flags;
8383     logop->op_private = (U8)(1 | (flags >> 8));
8384
8385     /* establish postfix order */
8386     logop->op_next = LINKLIST(first);
8387     first->op_next = (OP*)logop;
8388     assert(!OpHAS_SIBLING(first));
8389     op_sibling_splice((OP*)logop, first, 0, other);
8390
8391     CHECKOP(type,logop);
8392
8393     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8394                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8395                 (OP*)logop);
8396     other->op_next = o;
8397
8398     return o;
8399 }
8400
8401 /*
8402 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8403
8404 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8405 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8406 will be set automatically, and, shifted up eight bits, the eight bits of
8407 C<op_private>, except that the bit with value 1 is automatically set.
8408 C<first> supplies the expression selecting between the two branches,
8409 and C<trueop> and C<falseop> supply the branches; they are consumed by
8410 this function and become part of the constructed op tree.
8411
8412 =cut
8413 */
8414
8415 OP *
8416 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8417 {
8418     dVAR;
8419     LOGOP *logop;
8420     OP *start;
8421     OP *o;
8422     OP *cstop;
8423
8424     PERL_ARGS_ASSERT_NEWCONDOP;
8425
8426     if (!falseop)
8427         return newLOGOP(OP_AND, 0, first, trueop);
8428     if (!trueop)
8429         return newLOGOP(OP_OR, 0, first, falseop);
8430
8431     scalarboolean(first);
8432     if ((cstop = search_const(first))) {
8433         /* Left or right arm of the conditional?  */
8434         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8435         OP *live = left ? trueop : falseop;
8436         OP *const dead = left ? falseop : trueop;
8437         if (cstop->op_private & OPpCONST_BARE &&
8438             cstop->op_private & OPpCONST_STRICT) {
8439             no_bareword_allowed(cstop);
8440         }
8441         op_free(first);
8442         op_free(dead);
8443         if (live->op_type == OP_LEAVE)
8444             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8445         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8446               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8447             /* Mark the op as being unbindable with =~ */
8448             live->op_flags |= OPf_SPECIAL;
8449         live->op_folded = 1;
8450         return live;
8451     }
8452     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8453     logop->op_flags |= (U8)flags;
8454     logop->op_private = (U8)(1 | (flags >> 8));
8455     logop->op_next = LINKLIST(falseop);
8456
8457     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8458             logop);
8459
8460     /* establish postfix order */
8461     start = LINKLIST(first);
8462     first->op_next = (OP*)logop;
8463
8464     /* make first, trueop, falseop siblings */
8465     op_sibling_splice((OP*)logop, first,  0, trueop);
8466     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8467
8468     o = newUNOP(OP_NULL, 0, (OP*)logop);
8469
8470     trueop->op_next = falseop->op_next = o;
8471
8472     o->op_next = start;
8473     return o;
8474 }
8475
8476 /*
8477 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8478
8479 Constructs and returns a C<range> op, with subordinate C<flip> and
8480 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8481 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8482 for both the C<flip> and C<range> ops, except that the bit with value
8483 1 is automatically set.  C<left> and C<right> supply the expressions
8484 controlling the endpoints of the range; they are consumed by this function
8485 and become part of the constructed op tree.
8486
8487 =cut
8488 */
8489
8490 OP *
8491 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8492 {
8493     LOGOP *range;
8494     OP *flip;
8495     OP *flop;
8496     OP *leftstart;
8497     OP *o;
8498
8499     PERL_ARGS_ASSERT_NEWRANGE;
8500
8501     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8502     range->op_flags = OPf_KIDS;
8503     leftstart = LINKLIST(left);
8504     range->op_private = (U8)(1 | (flags >> 8));
8505
8506     /* make left and right siblings */
8507     op_sibling_splice((OP*)range, left, 0, right);
8508
8509     range->op_next = (OP*)range;
8510     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8511     flop = newUNOP(OP_FLOP, 0, flip);
8512     o = newUNOP(OP_NULL, 0, flop);
8513     LINKLIST(flop);
8514     range->op_next = leftstart;
8515
8516     left->op_next = flip;
8517     right->op_next = flop;
8518
8519     range->op_targ =
8520         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8521     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8522     flip->op_targ =
8523         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8524     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8525     SvPADTMP_on(PAD_SV(flip->op_targ));
8526
8527     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8528     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8529
8530     /* check barewords before they might be optimized aways */
8531     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8532         no_bareword_allowed(left);
8533     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8534         no_bareword_allowed(right);
8535
8536     flip->op_next = o;
8537     if (!flip->op_private || !flop->op_private)
8538         LINKLIST(o);            /* blow off optimizer unless constant */
8539
8540     return o;
8541 }
8542
8543 /*
8544 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8545
8546 Constructs, checks, and returns an op tree expressing a loop.  This is
8547 only a loop in the control flow through the op tree; it does not have
8548 the heavyweight loop structure that allows exiting the loop by C<last>
8549 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8550 top-level op, except that some bits will be set automatically as required.
8551 C<expr> supplies the expression controlling loop iteration, and C<block>
8552 supplies the body of the loop; they are consumed by this function and
8553 become part of the constructed op tree.  C<debuggable> is currently
8554 unused and should always be 1.
8555
8556 =cut
8557 */
8558
8559 OP *
8560 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8561 {
8562     OP* listop;
8563     OP* o;
8564     const bool once = block && block->op_flags & OPf_SPECIAL &&
8565                       block->op_type == OP_NULL;
8566
8567     PERL_UNUSED_ARG(debuggable);
8568
8569     if (expr) {
8570         if (once && (
8571               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8572            || (  expr->op_type == OP_NOT
8573               && cUNOPx(expr)->op_first->op_type == OP_CONST
8574               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8575               )
8576            ))
8577             /* Return the block now, so that S_new_logop does not try to
8578                fold it away. */
8579             return block;       /* do {} while 0 does once */
8580         if (expr->op_type == OP_READLINE
8581             || expr->op_type == OP_READDIR
8582             || expr->op_type == OP_GLOB
8583             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8584             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8585             expr = newUNOP(OP_DEFINED, 0,
8586                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8587         } else if (expr->op_flags & OPf_KIDS) {
8588             const OP * const k1 = ((UNOP*)expr)->op_first;
8589             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8590             switch (expr->op_type) {
8591               case OP_NULL:
8592                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8593                       && (k2->op_flags & OPf_STACKED)
8594                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8595                     expr = newUNOP(OP_DEFINED, 0, expr);
8596                 break;
8597
8598               case OP_SASSIGN:
8599                 if (k1 && (k1->op_type == OP_READDIR
8600                       || k1->op_type == OP_GLOB
8601                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8602                      || k1->op_type == OP_EACH
8603                      || k1->op_type == OP_AEACH))
8604                     expr = newUNOP(OP_DEFINED, 0, expr);
8605                 break;
8606             }
8607         }
8608     }
8609
8610     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8611      * op, in listop. This is wrong. [perl #27024] */
8612     if (!block)
8613         block = newOP(OP_NULL, 0);
8614     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8615     o = new_logop(OP_AND, 0, &expr, &listop);
8616
8617     if (once) {
8618         ASSUME(listop);
8619     }
8620
8621     if (listop)
8622         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8623
8624     if (once && o != listop)
8625     {
8626         assert(cUNOPo->op_first->op_type == OP_AND
8627             || cUNOPo->op_first->op_type == OP_OR);
8628         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8629     }
8630
8631     if (o == listop)
8632         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8633
8634     o->op_flags |= flags;
8635     o = op_scope(o);
8636     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8637     return o;
8638 }
8639
8640 /*
8641 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8642
8643 Constructs, checks, and returns an op tree expressing a C<while> loop.
8644 This is a heavyweight loop, with structure that allows exiting the loop
8645 by C<last> and suchlike.
8646
8647 C<loop> is an optional preconstructed C<enterloop> op to use in the
8648 loop; if it is null then a suitable op will be constructed automatically.
8649 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8650 main body of the loop, and C<cont> optionally supplies a C<continue> block
8651 that operates as a second half of the body.  All of these optree inputs
8652 are consumed by this function and become part of the constructed op tree.
8653
8654 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8655 op and, shifted up eight bits, the eight bits of C<op_private> for
8656 the C<leaveloop> op, except that (in both cases) some bits will be set
8657 automatically.  C<debuggable> is currently unused and should always be 1.
8658 C<has_my> can be supplied as true to force the
8659 loop body to be enclosed in its own scope.
8660
8661 =cut
8662 */
8663
8664 OP *
8665 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8666         OP *expr, OP *block, OP *cont, I32 has_my)
8667 {
8668     dVAR;
8669     OP *redo;
8670     OP *next = NULL;
8671     OP *listop;
8672     OP *o;
8673     U8 loopflags = 0;
8674
8675     PERL_UNUSED_ARG(debuggable);
8676
8677     if (expr) {
8678         if (expr->op_type == OP_READLINE
8679          || expr->op_type == OP_READDIR
8680          || expr->op_type == OP_GLOB
8681          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8682                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8683             expr = newUNOP(OP_DEFINED, 0,
8684                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8685         } else if (expr->op_flags & OPf_KIDS) {
8686             const OP * const k1 = ((UNOP*)expr)->op_first;
8687             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8688             switch (expr->op_type) {
8689               case OP_NULL:
8690                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8691                       && (k2->op_flags & OPf_STACKED)
8692                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8693                     expr = newUNOP(OP_DEFINED, 0, expr);
8694                 break;
8695
8696               case OP_SASSIGN:
8697                 if (k1 && (k1->op_type == OP_READDIR
8698                       || k1->op_type == OP_GLOB
8699                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8700                      || k1->op_type == OP_EACH
8701                      || k1->op_type == OP_AEACH))
8702                     expr = newUNOP(OP_DEFINED, 0, expr);
8703                 break;
8704             }
8705         }
8706     }
8707
8708     if (!block)
8709         block = newOP(OP_NULL, 0);
8710     else if (cont || has_my) {
8711         block = op_scope(block);
8712     }
8713
8714     if (cont) {
8715         next = LINKLIST(cont);
8716     }
8717     if (expr) {
8718         OP * const unstack = newOP(OP_UNSTACK, 0);
8719         if (!next)
8720             next = unstack;
8721         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8722     }
8723
8724     assert(block);
8725     listop = op_append_list(OP_LINESEQ, block, cont);
8726     assert(listop);
8727     redo = LINKLIST(listop);
8728
8729     if (expr) {
8730         scalar(listop);
8731         o = new_logop(OP_AND, 0, &expr, &listop);
8732         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8733             op_free((OP*)loop);
8734             return expr;                /* listop already freed by new_logop */
8735         }
8736         if (listop)
8737             ((LISTOP*)listop)->op_last->op_next =
8738                 (o == listop ? redo : LINKLIST(o));
8739     }
8740     else
8741         o = listop;
8742
8743     if (!loop) {
8744         NewOp(1101,loop,1,LOOP);
8745         OpTYPE_set(loop, OP_ENTERLOOP);
8746         loop->op_private = 0;
8747         loop->op_next = (OP*)loop;
8748     }
8749
8750     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8751
8752     loop->op_redoop = redo;
8753     loop->op_lastop = o;
8754     o->op_private |= loopflags;
8755
8756     if (next)
8757         loop->op_nextop = next;
8758     else
8759         loop->op_nextop = o;
8760
8761     o->op_flags |= flags;
8762     o->op_private |= (flags >> 8);
8763     return o;
8764 }
8765
8766 /*
8767 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8768
8769 Constructs, checks, and returns an op tree expressing a C<foreach>
8770 loop (iteration through a list of values).  This is a heavyweight loop,
8771 with structure that allows exiting the loop by C<last> and suchlike.
8772
8773 C<sv> optionally supplies the variable that will be aliased to each
8774 item in turn; if null, it defaults to C<$_>.
8775 C<expr> supplies the list of values to iterate over.  C<block> supplies
8776 the main body of the loop, and C<cont> optionally supplies a C<continue>
8777 block that operates as a second half of the body.  All of these optree
8778 inputs are consumed by this function and become part of the constructed
8779 op tree.
8780
8781 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8782 op and, shifted up eight bits, the eight bits of C<op_private> for
8783 the C<leaveloop> op, except that (in both cases) some bits will be set
8784 automatically.
8785
8786 =cut
8787 */
8788
8789 OP *
8790 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8791 {
8792     dVAR;
8793     LOOP *loop;
8794     OP *wop;
8795     PADOFFSET padoff = 0;
8796     I32 iterflags = 0;
8797     I32 iterpflags = 0;
8798
8799     PERL_ARGS_ASSERT_NEWFOROP;
8800
8801     if (sv) {
8802         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8803             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8804             OpTYPE_set(sv, OP_RV2GV);
8805
8806             /* The op_type check is needed to prevent a possible segfault
8807              * if the loop variable is undeclared and 'strict vars' is in
8808              * effect. This is illegal but is nonetheless parsed, so we
8809              * may reach this point with an OP_CONST where we're expecting
8810              * an OP_GV.
8811              */
8812             if (cUNOPx(sv)->op_first->op_type == OP_GV
8813              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8814                 iterpflags |= OPpITER_DEF;
8815         }
8816         else if (sv->op_type == OP_PADSV) { /* private variable */
8817             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8818             padoff = sv->op_targ;
8819             sv->op_targ = 0;
8820             op_free(sv);
8821             sv = NULL;
8822             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8823         }
8824         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8825             NOOP;
8826         else
8827             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8828         if (padoff) {
8829             PADNAME * const pn = PAD_COMPNAME(padoff);
8830             const char * const name = PadnamePV(pn);
8831
8832             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8833                 iterpflags |= OPpITER_DEF;
8834         }
8835     }
8836     else {
8837         sv = newGVOP(OP_GV, 0, PL_defgv);
8838         iterpflags |= OPpITER_DEF;
8839     }
8840
8841     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8842         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8843         iterflags |= OPf_STACKED;
8844     }
8845     else if (expr->op_type == OP_NULL &&
8846              (expr->op_flags & OPf_KIDS) &&
8847              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8848     {
8849         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8850          * set the STACKED flag to indicate that these values are to be
8851          * treated as min/max values by 'pp_enteriter'.
8852          */
8853         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8854         LOGOP* const range = (LOGOP*) flip->op_first;
8855         OP* const left  = range->op_first;
8856         OP* const right = OpSIBLING(left);
8857         LISTOP* listop;
8858
8859         range->op_flags &= ~OPf_KIDS;
8860         /* detach range's children */
8861         op_sibling_splice((OP*)range, NULL, -1, NULL);
8862
8863         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8864         listop->op_first->op_next = range->op_next;
8865         left->op_next = range->op_other;
8866         right->op_next = (OP*)listop;
8867         listop->op_next = listop->op_first;
8868
8869         op_free(expr);
8870         expr = (OP*)(listop);
8871         op_null(expr);
8872         iterflags |= OPf_STACKED;
8873     }
8874     else {
8875         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8876     }
8877
8878     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8879                                   op_append_elem(OP_LIST, list(expr),
8880                                                  scalar(sv)));
8881     assert(!loop->op_next);
8882     /* for my  $x () sets OPpLVAL_INTRO;
8883      * for our $x () sets OPpOUR_INTRO */
8884     loop->op_private = (U8)iterpflags;
8885     if (loop->op_slabbed
8886      && DIFF(loop, OpSLOT(loop)->opslot_next)
8887          < SIZE_TO_PSIZE(sizeof(LOOP)))
8888     {
8889         LOOP *tmp;
8890         NewOp(1234,tmp,1,LOOP);
8891         Copy(loop,tmp,1,LISTOP);
8892         assert(loop->op_last->op_sibparent == (OP*)loop);
8893         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8894         S_op_destroy(aTHX_ (OP*)loop);
8895         loop = tmp;
8896     }
8897     else if (!loop->op_slabbed)
8898     {
8899         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8900         OpLASTSIB_set(loop->op_last, (OP*)loop);
8901     }
8902     loop->op_targ = padoff;
8903     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8904     return wop;
8905 }
8906
8907 /*
8908 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8909
8910 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8911 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8912 determining the target of the op; it is consumed by this function and
8913 becomes part of the constructed op tree.
8914
8915 =cut
8916 */
8917
8918 OP*
8919 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8920 {
8921     OP *o = NULL;
8922
8923     PERL_ARGS_ASSERT_NEWLOOPEX;
8924
8925     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8926         || type == OP_CUSTOM);
8927
8928     if (type != OP_GOTO) {
8929         /* "last()" means "last" */
8930         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8931             o = newOP(type, OPf_SPECIAL);
8932         }
8933     }
8934     else {
8935         /* Check whether it's going to be a goto &function */
8936         if (label->op_type == OP_ENTERSUB
8937                 && !(label->op_flags & OPf_STACKED))
8938             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8939     }
8940
8941     /* Check for a constant argument */
8942     if (label->op_type == OP_CONST) {
8943             SV * const sv = ((SVOP *)label)->op_sv;
8944             STRLEN l;
8945             const char *s = SvPV_const(sv,l);
8946             if (l == strlen(s)) {
8947                 o = newPVOP(type,
8948                             SvUTF8(((SVOP*)label)->op_sv),
8949                             savesharedpv(
8950                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8951             }
8952     }
8953
8954     /* If we have already created an op, we do not need the label. */
8955     if (o)
8956                 op_free(label);
8957     else o = newUNOP(type, OPf_STACKED, label);
8958
8959     PL_hints |= HINT_BLOCK_SCOPE;
8960     return o;
8961 }
8962
8963 /* if the condition is a literal array or hash
8964    (or @{ ... } etc), make a reference to it.
8965  */
8966 STATIC OP *
8967 S_ref_array_or_hash(pTHX_ OP *cond)
8968 {
8969     if (cond
8970     && (cond->op_type == OP_RV2AV
8971     ||  cond->op_type == OP_PADAV
8972     ||  cond->op_type == OP_RV2HV
8973     ||  cond->op_type == OP_PADHV))
8974
8975         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8976
8977     else if(cond
8978     && (cond->op_type == OP_ASLICE
8979     ||  cond->op_type == OP_KVASLICE
8980     ||  cond->op_type == OP_HSLICE
8981     ||  cond->op_type == OP_KVHSLICE)) {
8982
8983         /* anonlist now needs a list from this op, was previously used in
8984          * scalar context */
8985         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8986         cond->op_flags |= OPf_WANT_LIST;
8987
8988         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8989     }
8990
8991     else
8992         return cond;
8993 }
8994
8995 /* These construct the optree fragments representing given()
8996    and when() blocks.
8997
8998    entergiven and enterwhen are LOGOPs; the op_other pointer
8999    points up to the associated leave op. We need this so we
9000    can put it in the context and make break/continue work.
9001    (Also, of course, pp_enterwhen will jump straight to
9002    op_other if the match fails.)
9003  */
9004
9005 STATIC OP *
9006 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9007                    I32 enter_opcode, I32 leave_opcode,
9008                    PADOFFSET entertarg)
9009 {
9010     dVAR;
9011     LOGOP *enterop;
9012     OP *o;
9013
9014     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9015     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9016
9017     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9018     enterop->op_targ = 0;
9019     enterop->op_private = 0;
9020
9021     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9022
9023     if (cond) {
9024         /* prepend cond if we have one */
9025         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9026
9027         o->op_next = LINKLIST(cond);
9028         cond->op_next = (OP *) enterop;
9029     }
9030     else {
9031         /* This is a default {} block */
9032         enterop->op_flags |= OPf_SPECIAL;
9033         o      ->op_flags |= OPf_SPECIAL;
9034
9035         o->op_next = (OP *) enterop;
9036     }
9037
9038     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9039                                        entergiven and enterwhen both
9040                                        use ck_null() */
9041
9042     enterop->op_next = LINKLIST(block);
9043     block->op_next = enterop->op_other = o;
9044
9045     return o;
9046 }
9047
9048 /* Does this look like a boolean operation? For these purposes
9049    a boolean operation is:
9050      - a subroutine call [*]
9051      - a logical connective
9052      - a comparison operator
9053      - a filetest operator, with the exception of -s -M -A -C
9054      - defined(), exists() or eof()
9055      - /$re/ or $foo =~ /$re/
9056
9057    [*] possibly surprising
9058  */
9059 STATIC bool
9060 S_looks_like_bool(pTHX_ const OP *o)
9061 {
9062     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9063
9064     switch(o->op_type) {
9065         case OP_OR:
9066         case OP_DOR:
9067             return looks_like_bool(cLOGOPo->op_first);
9068
9069         case OP_AND:
9070         {
9071             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9072             ASSUME(sibl);
9073             return (
9074                 looks_like_bool(cLOGOPo->op_first)
9075              && looks_like_bool(sibl));
9076         }
9077
9078         case OP_NULL:
9079         case OP_SCALAR:
9080             return (
9081                 o->op_flags & OPf_KIDS
9082             && looks_like_bool(cUNOPo->op_first));
9083
9084         case OP_ENTERSUB:
9085
9086         case OP_NOT:    case OP_XOR:
9087
9088         case OP_EQ:     case OP_NE:     case OP_LT:
9089         case OP_GT:     case OP_LE:     case OP_GE:
9090
9091         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9092         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9093
9094         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9095         case OP_SGT:    case OP_SLE:    case OP_SGE:
9096
9097         case OP_SMARTMATCH:
9098
9099         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9100         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9101         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9102         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9103         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9104         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9105         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9106         case OP_FTTEXT:   case OP_FTBINARY:
9107
9108         case OP_DEFINED: case OP_EXISTS:
9109         case OP_MATCH:   case OP_EOF:
9110
9111         case OP_FLOP:
9112
9113             return TRUE;
9114
9115         case OP_INDEX:
9116         case OP_RINDEX:
9117             /* optimised-away (index() != -1) or similar comparison */
9118             if (o->op_private & OPpTRUEBOOL)
9119                 return TRUE;
9120             return FALSE;
9121
9122         case OP_CONST:
9123             /* Detect comparisons that have been optimized away */
9124             if (cSVOPo->op_sv == &PL_sv_yes
9125             ||  cSVOPo->op_sv == &PL_sv_no)
9126
9127                 return TRUE;
9128             else
9129                 return FALSE;
9130         /* FALLTHROUGH */
9131         default:
9132             return FALSE;
9133     }
9134 }
9135
9136 /*
9137 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9138
9139 Constructs, checks, and returns an op tree expressing a C<given> block.
9140 C<cond> supplies the expression to whose value C<$_> will be locally
9141 aliased, and C<block> supplies the body of the C<given> construct; they
9142 are consumed by this function and become part of the constructed op tree.
9143 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9144
9145 =cut
9146 */
9147
9148 OP *
9149 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9150 {
9151     PERL_ARGS_ASSERT_NEWGIVENOP;
9152     PERL_UNUSED_ARG(defsv_off);
9153
9154     assert(!defsv_off);
9155     return newGIVWHENOP(
9156         ref_array_or_hash(cond),
9157         block,
9158         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9159         0);
9160 }
9161
9162 /*
9163 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9164
9165 Constructs, checks, and returns an op tree expressing a C<when> block.
9166 C<cond> supplies the test expression, and C<block> supplies the block
9167 that will be executed if the test evaluates to true; they are consumed
9168 by this function and become part of the constructed op tree.  C<cond>
9169 will be interpreted DWIMically, often as a comparison against C<$_>,
9170 and may be null to generate a C<default> block.
9171
9172 =cut
9173 */
9174
9175 OP *
9176 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9177 {
9178     const bool cond_llb = (!cond || looks_like_bool(cond));
9179     OP *cond_op;
9180
9181     PERL_ARGS_ASSERT_NEWWHENOP;
9182
9183     if (cond_llb)
9184         cond_op = cond;
9185     else {
9186         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9187                 newDEFSVOP(),
9188                 scalar(ref_array_or_hash(cond)));
9189     }
9190
9191     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9192 }
9193
9194 /* must not conflict with SVf_UTF8 */
9195 #define CV_CKPROTO_CURSTASH     0x1
9196
9197 void
9198 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9199                     const STRLEN len, const U32 flags)
9200 {
9201     SV *name = NULL, *msg;
9202     const char * cvp = SvROK(cv)
9203                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9204                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9205                            : ""
9206                         : CvPROTO(cv);
9207     STRLEN clen = CvPROTOLEN(cv), plen = len;
9208
9209     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9210
9211     if (p == NULL && cvp == NULL)
9212         return;
9213
9214     if (!ckWARN_d(WARN_PROTOTYPE))
9215         return;
9216
9217     if (p && cvp) {
9218         p = S_strip_spaces(aTHX_ p, &plen);
9219         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9220         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9221             if (plen == clen && memEQ(cvp, p, plen))
9222                 return;
9223         } else {
9224             if (flags & SVf_UTF8) {
9225                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9226                     return;
9227             }
9228             else {
9229                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9230                     return;
9231             }
9232         }
9233     }
9234
9235     msg = sv_newmortal();
9236
9237     if (gv)
9238     {
9239         if (isGV(gv))
9240             gv_efullname3(name = sv_newmortal(), gv, NULL);
9241         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9242             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9243         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9244             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9245             sv_catpvs(name, "::");
9246             if (SvROK(gv)) {
9247                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9248                 assert (CvNAMED(SvRV_const(gv)));
9249                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9250             }
9251             else sv_catsv(name, (SV *)gv);
9252         }
9253         else name = (SV *)gv;
9254     }
9255     sv_setpvs(msg, "Prototype mismatch:");
9256     if (name)
9257         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9258     if (cvp)
9259         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9260             UTF8fARG(SvUTF8(cv),clen,cvp)
9261         );
9262     else
9263         sv_catpvs(msg, ": none");
9264     sv_catpvs(msg, " vs ");
9265     if (p)
9266         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9267     else
9268         sv_catpvs(msg, "none");
9269     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9270 }
9271
9272 static void const_sv_xsub(pTHX_ CV* cv);
9273 static void const_av_xsub(pTHX_ CV* cv);
9274
9275 /*
9276
9277 =head1 Optree Manipulation Functions
9278
9279 =for apidoc cv_const_sv
9280
9281 If C<cv> is a constant sub eligible for inlining, returns the constant
9282 value returned by the sub.  Otherwise, returns C<NULL>.
9283
9284 Constant subs can be created with C<newCONSTSUB> or as described in
9285 L<perlsub/"Constant Functions">.
9286
9287 =cut
9288 */
9289 SV *
9290 Perl_cv_const_sv(const CV *const cv)
9291 {
9292     SV *sv;
9293     if (!cv)
9294         return NULL;
9295     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9296         return NULL;
9297     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9298     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9299     return sv;
9300 }
9301
9302 SV *
9303 Perl_cv_const_sv_or_av(const CV * const cv)
9304 {
9305     if (!cv)
9306         return NULL;
9307     if (SvROK(cv)) return SvRV((SV *)cv);
9308     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9309     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9310 }
9311
9312 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9313  * Can be called in 2 ways:
9314  *
9315  * !allow_lex
9316  *      look for a single OP_CONST with attached value: return the value
9317  *
9318  * allow_lex && !CvCONST(cv);
9319  *
9320  *      examine the clone prototype, and if contains only a single
9321  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9322  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9323  *      a candidate for "constizing" at clone time, and return NULL.
9324  */
9325
9326 static SV *
9327 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9328 {
9329     SV *sv = NULL;
9330     bool padsv = FALSE;
9331
9332     assert(o);
9333     assert(cv);
9334
9335     for (; o; o = o->op_next) {
9336         const OPCODE type = o->op_type;
9337
9338         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9339              || type == OP_NULL
9340              || type == OP_PUSHMARK)
9341                 continue;
9342         if (type == OP_DBSTATE)
9343                 continue;
9344         if (type == OP_LEAVESUB)
9345             break;
9346         if (sv)
9347             return NULL;
9348         if (type == OP_CONST && cSVOPo->op_sv)
9349             sv = cSVOPo->op_sv;
9350         else if (type == OP_UNDEF && !o->op_private) {
9351             sv = newSV(0);
9352             SAVEFREESV(sv);
9353         }
9354         else if (allow_lex && type == OP_PADSV) {
9355                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9356                 {
9357                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9358                     padsv = TRUE;
9359                 }
9360                 else
9361                     return NULL;
9362         }
9363         else {
9364             return NULL;
9365         }
9366     }
9367     if (padsv) {
9368         CvCONST_on(cv);
9369         return NULL;
9370     }
9371     return sv;
9372 }
9373
9374 static void
9375 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9376                         PADNAME * const name, SV ** const const_svp)
9377 {
9378     assert (cv);
9379     assert (o || name);
9380     assert (const_svp);
9381     if (!block) {
9382         if (CvFLAGS(PL_compcv)) {
9383             /* might have had built-in attrs applied */
9384             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9385             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9386              && ckWARN(WARN_MISC))
9387             {
9388                 /* protect against fatal warnings leaking compcv */
9389                 SAVEFREESV(PL_compcv);
9390                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9391                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9392             }
9393             CvFLAGS(cv) |=
9394                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9395                   & ~(CVf_LVALUE * pureperl));
9396         }
9397         return;
9398     }
9399
9400     /* redundant check for speed: */
9401     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9402         const line_t oldline = CopLINE(PL_curcop);
9403         SV *namesv = o
9404             ? cSVOPo->op_sv
9405             : sv_2mortal(newSVpvn_utf8(
9406                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9407               ));
9408         if (PL_parser && PL_parser->copline != NOLINE)
9409             /* This ensures that warnings are reported at the first
9410                line of a redefinition, not the last.  */
9411             CopLINE_set(PL_curcop, PL_parser->copline);
9412         /* protect against fatal warnings leaking compcv */
9413         SAVEFREESV(PL_compcv);
9414         report_redefined_cv(namesv, cv, const_svp);
9415         SvREFCNT_inc_simple_void_NN(PL_compcv);
9416         CopLINE_set(PL_curcop, oldline);
9417     }
9418     SAVEFREESV(cv);
9419     return;
9420 }
9421
9422 CV *
9423 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9424 {
9425     CV **spot;
9426     SV **svspot;
9427     const char *ps;
9428     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9429     U32 ps_utf8 = 0;
9430     CV *cv = NULL;
9431     CV *compcv = PL_compcv;
9432     SV *const_sv;
9433     PADNAME *name;
9434     PADOFFSET pax = o->op_targ;
9435     CV *outcv = CvOUTSIDE(PL_compcv);
9436     CV *clonee = NULL;
9437     HEK *hek = NULL;
9438     bool reusable = FALSE;
9439     OP *start = NULL;
9440 #ifdef PERL_DEBUG_READONLY_OPS
9441     OPSLAB *slab = NULL;
9442 #endif
9443
9444     PERL_ARGS_ASSERT_NEWMYSUB;
9445
9446     PL_hints |= HINT_BLOCK_SCOPE;
9447
9448     /* Find the pad slot for storing the new sub.
9449        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9450        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9451        ing sub.  And then we need to dig deeper if this is a lexical from
9452        outside, as in:
9453            my sub foo; sub { sub foo { } }
9454      */
9455   redo:
9456     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9457     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9458         pax = PARENT_PAD_INDEX(name);
9459         outcv = CvOUTSIDE(outcv);
9460         assert(outcv);
9461         goto redo;
9462     }
9463     svspot =
9464         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9465                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9466     spot = (CV **)svspot;
9467
9468     if (!(PL_parser && PL_parser->error_count))
9469         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9470
9471     if (proto) {
9472         assert(proto->op_type == OP_CONST);
9473         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9474         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9475     }
9476     else
9477         ps = NULL;
9478
9479     if (proto)
9480         SAVEFREEOP(proto);
9481     if (attrs)
9482         SAVEFREEOP(attrs);
9483
9484     if (PL_parser && PL_parser->error_count) {
9485         op_free(block);
9486         SvREFCNT_dec(PL_compcv);
9487         PL_compcv = 0;
9488         goto done;
9489     }
9490
9491     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9492         cv = *spot;
9493         svspot = (SV **)(spot = &clonee);
9494     }
9495     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9496         cv = *spot;
9497     else {
9498         assert (SvTYPE(*spot) == SVt_PVCV);
9499         if (CvNAMED(*spot))
9500             hek = CvNAME_HEK(*spot);
9501         else {
9502             dVAR;
9503             U32 hash;
9504             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9505             CvNAME_HEK_set(*spot, hek =
9506                 share_hek(
9507                     PadnamePV(name)+1,
9508                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9509                     hash
9510                 )
9511             );
9512             CvLEXICAL_on(*spot);
9513         }
9514         cv = PadnamePROTOCV(name);
9515         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9516     }
9517
9518     if (block) {
9519         /* This makes sub {}; work as expected.  */
9520         if (block->op_type == OP_STUB) {
9521             const line_t l = PL_parser->copline;
9522             op_free(block);
9523             block = newSTATEOP(0, NULL, 0);
9524             PL_parser->copline = l;
9525         }
9526         block = CvLVALUE(compcv)
9527              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9528                    ? newUNOP(OP_LEAVESUBLV, 0,
9529                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9530                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9531         start = LINKLIST(block);
9532         block->op_next = 0;
9533         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9534             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9535         else
9536             const_sv = NULL;
9537     }
9538     else
9539         const_sv = NULL;
9540
9541     if (cv) {
9542         const bool exists = CvROOT(cv) || CvXSUB(cv);
9543
9544         /* if the subroutine doesn't exist and wasn't pre-declared
9545          * with a prototype, assume it will be AUTOLOADed,
9546          * skipping the prototype check
9547          */
9548         if (exists || SvPOK(cv))
9549             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9550                                  ps_utf8);
9551         /* already defined? */
9552         if (exists) {
9553             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9554             if (block)
9555                 cv = NULL;
9556             else {
9557                 if (attrs)
9558                     goto attrs;
9559                 /* just a "sub foo;" when &foo is already defined */
9560                 SAVEFREESV(compcv);
9561                 goto done;
9562             }
9563         }
9564         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9565             cv = NULL;
9566             reusable = TRUE;
9567         }
9568     }
9569
9570     if (const_sv) {
9571         SvREFCNT_inc_simple_void_NN(const_sv);
9572         SvFLAGS(const_sv) |= SVs_PADTMP;
9573         if (cv) {
9574             assert(!CvROOT(cv) && !CvCONST(cv));
9575             cv_forget_slab(cv);
9576         }
9577         else {
9578             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9579             CvFILE_set_from_cop(cv, PL_curcop);
9580             CvSTASH_set(cv, PL_curstash);
9581             *spot = cv;
9582         }
9583         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9584         CvXSUBANY(cv).any_ptr = const_sv;
9585         CvXSUB(cv) = const_sv_xsub;
9586         CvCONST_on(cv);
9587         CvISXSUB_on(cv);
9588         PoisonPADLIST(cv);
9589         CvFLAGS(cv) |= CvMETHOD(compcv);
9590         op_free(block);
9591         SvREFCNT_dec(compcv);
9592         PL_compcv = NULL;
9593         goto setname;
9594     }
9595
9596     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9597        determine whether this sub definition is in the same scope as its
9598        declaration.  If this sub definition is inside an inner named pack-
9599        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9600        the package sub.  So check PadnameOUTER(name) too.
9601      */
9602     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9603         assert(!CvWEAKOUTSIDE(compcv));
9604         SvREFCNT_dec(CvOUTSIDE(compcv));
9605         CvWEAKOUTSIDE_on(compcv);
9606     }
9607     /* XXX else do we have a circular reference? */
9608
9609     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9610         /* transfer PL_compcv to cv */
9611         if (block) {
9612             cv_flags_t preserved_flags =
9613                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9614             PADLIST *const temp_padl = CvPADLIST(cv);
9615             CV *const temp_cv = CvOUTSIDE(cv);
9616             const cv_flags_t other_flags =
9617                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9618             OP * const cvstart = CvSTART(cv);
9619
9620             SvPOK_off(cv);
9621             CvFLAGS(cv) =
9622                 CvFLAGS(compcv) | preserved_flags;
9623             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9624             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9625             CvPADLIST_set(cv, CvPADLIST(compcv));
9626             CvOUTSIDE(compcv) = temp_cv;
9627             CvPADLIST_set(compcv, temp_padl);
9628             CvSTART(cv) = CvSTART(compcv);
9629             CvSTART(compcv) = cvstart;
9630             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9631             CvFLAGS(compcv) |= other_flags;
9632
9633             if (CvFILE(cv) && CvDYNFILE(cv)) {
9634                 Safefree(CvFILE(cv));
9635             }
9636
9637             /* inner references to compcv must be fixed up ... */
9638             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9639             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9640                 ++PL_sub_generation;
9641         }
9642         else {
9643             /* Might have had built-in attributes applied -- propagate them. */
9644             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9645         }
9646         /* ... before we throw it away */
9647         SvREFCNT_dec(compcv);
9648         PL_compcv = compcv = cv;
9649     }
9650     else {
9651         cv = compcv;
9652         *spot = cv;
9653     }
9654
9655   setname:
9656     CvLEXICAL_on(cv);
9657     if (!CvNAME_HEK(cv)) {
9658         if (hek) (void)share_hek_hek(hek);
9659         else {
9660             dVAR;
9661             U32 hash;
9662             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9663             hek = share_hek(PadnamePV(name)+1,
9664                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9665                       hash);
9666         }
9667         CvNAME_HEK_set(cv, hek);
9668     }
9669
9670     if (const_sv)
9671         goto clone;
9672
9673     CvFILE_set_from_cop(cv, PL_curcop);
9674     CvSTASH_set(cv, PL_curstash);
9675
9676     if (ps) {
9677         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9678         if (ps_utf8)
9679             SvUTF8_on(MUTABLE_SV(cv));
9680     }
9681
9682     if (block) {
9683         /* If we assign an optree to a PVCV, then we've defined a
9684          * subroutine that the debugger could be able to set a breakpoint
9685          * in, so signal to pp_entereval that it should not throw away any
9686          * saved lines at scope exit.  */
9687
9688         PL_breakable_sub_gen++;
9689         CvROOT(cv) = block;
9690         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9691            itself has a refcount. */
9692         CvSLABBED_off(cv);
9693         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9694 #ifdef PERL_DEBUG_READONLY_OPS
9695         slab = (OPSLAB *)CvSTART(cv);
9696 #endif
9697         S_process_optree(aTHX_ cv, block, start);
9698     }
9699
9700   attrs:
9701     if (attrs) {
9702         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9703         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9704     }
9705
9706     if (block) {
9707         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9708             SV * const tmpstr = sv_newmortal();
9709             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9710                                                   GV_ADDMULTI, SVt_PVHV);
9711             HV *hv;
9712             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9713                                           CopFILE(PL_curcop),
9714                                           (long)PL_subline,
9715                                           (long)CopLINE(PL_curcop));
9716             if (HvNAME_HEK(PL_curstash)) {
9717                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9718                 sv_catpvs(tmpstr, "::");
9719             }
9720             else
9721                 sv_setpvs(tmpstr, "__ANON__::");
9722
9723             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9724                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9725             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9726                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9727             hv = GvHVn(db_postponed);
9728             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9729                 CV * const pcv = GvCV(db_postponed);
9730                 if (pcv) {
9731                     dSP;
9732                     PUSHMARK(SP);
9733                     XPUSHs(tmpstr);
9734                     PUTBACK;
9735                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9736                 }
9737             }
9738         }
9739     }
9740
9741   clone:
9742     if (clonee) {
9743         assert(CvDEPTH(outcv));
9744         spot = (CV **)
9745             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9746         if (reusable)
9747             cv_clone_into(clonee, *spot);
9748         else *spot = cv_clone(clonee);
9749         SvREFCNT_dec_NN(clonee);
9750         cv = *spot;
9751     }
9752
9753     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9754         PADOFFSET depth = CvDEPTH(outcv);
9755         while (--depth) {
9756             SV *oldcv;
9757             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9758             oldcv = *svspot;
9759             *svspot = SvREFCNT_inc_simple_NN(cv);
9760             SvREFCNT_dec(oldcv);
9761         }
9762     }
9763
9764   done:
9765     if (PL_parser)
9766         PL_parser->copline = NOLINE;
9767     LEAVE_SCOPE(floor);
9768 #ifdef PERL_DEBUG_READONLY_OPS
9769     if (slab)
9770         Slab_to_ro(slab);
9771 #endif
9772     op_free(o);
9773     return cv;
9774 }
9775
9776 /*
9777 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9778
9779 Construct a Perl subroutine, also performing some surrounding jobs.
9780
9781 This function is expected to be called in a Perl compilation context,
9782 and some aspects of the subroutine are taken from global variables
9783 associated with compilation.  In particular, C<PL_compcv> represents
9784 the subroutine that is currently being compiled.  It must be non-null
9785 when this function is called, and some aspects of the subroutine being
9786 constructed are taken from it.  The constructed subroutine may actually
9787 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9788
9789 If C<block> is null then the subroutine will have no body, and for the
9790 time being it will be an error to call it.  This represents a forward
9791 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9792 non-null then it provides the Perl code of the subroutine body, which
9793 will be executed when the subroutine is called.  This body includes
9794 any argument unwrapping code resulting from a subroutine signature or
9795 similar.  The pad use of the code must correspond to the pad attached
9796 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9797 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9798 by this function and will become part of the constructed subroutine.
9799
9800 C<proto> specifies the subroutine's prototype, unless one is supplied
9801 as an attribute (see below).  If C<proto> is null, then the subroutine
9802 will not have a prototype.  If C<proto> is non-null, it must point to a
9803 C<const> op whose value is a string, and the subroutine will have that
9804 string as its prototype.  If a prototype is supplied as an attribute, the
9805 attribute takes precedence over C<proto>, but in that case C<proto> should
9806 preferably be null.  In any case, C<proto> is consumed by this function.
9807
9808 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9809 attributes take effect by built-in means, being applied to C<PL_compcv>
9810 immediately when seen.  Other attributes are collected up and attached
9811 to the subroutine by this route.  C<attrs> may be null to supply no
9812 attributes, or point to a C<const> op for a single attribute, or point
9813 to a C<list> op whose children apart from the C<pushmark> are C<const>
9814 ops for one or more attributes.  Each C<const> op must be a string,
9815 giving the attribute name optionally followed by parenthesised arguments,
9816 in the manner in which attributes appear in Perl source.  The attributes
9817 will be applied to the sub by this function.  C<attrs> is consumed by
9818 this function.
9819
9820 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9821 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9822 must point to a C<const> op, which will be consumed by this function,
9823 and its string value supplies a name for the subroutine.  The name may
9824 be qualified or unqualified, and if it is unqualified then a default
9825 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9826 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9827 by which the subroutine will be named.
9828
9829 If there is already a subroutine of the specified name, then the new
9830 sub will either replace the existing one in the glob or be merged with
9831 the existing one.  A warning may be generated about redefinition.
9832
9833 If the subroutine has one of a few special names, such as C<BEGIN> or
9834 C<END>, then it will be claimed by the appropriate queue for automatic
9835 running of phase-related subroutines.  In this case the relevant glob will
9836 be left not containing any subroutine, even if it did contain one before.
9837 In the case of C<BEGIN>, the subroutine will be executed and the reference
9838 to it disposed of before this function returns.
9839
9840 The function returns a pointer to the constructed subroutine.  If the sub
9841 is anonymous then ownership of one counted reference to the subroutine
9842 is transferred to the caller.  If the sub is named then the caller does
9843 not get ownership of a reference.  In most such cases, where the sub
9844 has a non-phase name, the sub will be alive at the point it is returned
9845 by virtue of being contained in the glob that names it.  A phase-named
9846 subroutine will usually be alive by virtue of the reference owned by the
9847 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9848 been executed, will quite likely have been destroyed already by the
9849 time this function returns, making it erroneous for the caller to make
9850 any use of the returned pointer.  It is the caller's responsibility to
9851 ensure that it knows which of these situations applies.
9852
9853 =cut
9854 */
9855
9856 /* _x = extended */
9857 CV *
9858 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9859                             OP *block, bool o_is_gv)
9860 {
9861     GV *gv;
9862     const char *ps;
9863     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9864     U32 ps_utf8 = 0;
9865     CV *cv = NULL;     /* the previous CV with this name, if any */
9866     SV *const_sv;
9867     const bool ec = PL_parser && PL_parser->error_count;
9868     /* If the subroutine has no body, no attributes, and no builtin attributes
9869        then it's just a sub declaration, and we may be able to get away with
9870        storing with a placeholder scalar in the symbol table, rather than a
9871        full CV.  If anything is present then it will take a full CV to
9872        store it.  */
9873     const I32 gv_fetch_flags
9874         = ec ? GV_NOADD_NOINIT :
9875         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9876         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9877     STRLEN namlen = 0;
9878     const char * const name =
9879          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9880     bool has_name;
9881     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9882     bool evanescent = FALSE;
9883     OP *start = NULL;
9884 #ifdef PERL_DEBUG_READONLY_OPS
9885     OPSLAB *slab = NULL;
9886 #endif
9887
9888     if (o_is_gv) {
9889         gv = (GV*)o;
9890         o = NULL;
9891         has_name = TRUE;
9892     } else if (name) {
9893         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9894            hek and CvSTASH pointer together can imply the GV.  If the name
9895            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9896            CvSTASH, so forego the optimisation if we find any.
9897            Also, we may be called from load_module at run time, so
9898            PL_curstash (which sets CvSTASH) may not point to the stash the
9899            sub is stored in.  */
9900         /* XXX This optimization is currently disabled for packages other
9901                than main, since there was too much CPAN breakage.  */
9902         const I32 flags =
9903            ec ? GV_NOADD_NOINIT
9904               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9905                || PL_curstash != PL_defstash
9906                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9907                     ? gv_fetch_flags
9908                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9909         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9910         has_name = TRUE;
9911     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9912         SV * const sv = sv_newmortal();
9913         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9914                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9915                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9916         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9917         has_name = TRUE;
9918     } else if (PL_curstash) {
9919         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9920         has_name = FALSE;
9921     } else {
9922         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9923         has_name = FALSE;
9924     }
9925
9926     if (!ec) {
9927         if (isGV(gv)) {
9928             move_proto_attr(&proto, &attrs, gv, 0);
9929         } else {
9930             assert(cSVOPo);
9931             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9932         }
9933     }
9934
9935     if (proto) {
9936         assert(proto->op_type == OP_CONST);
9937         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9938         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9939     }
9940     else
9941         ps = NULL;
9942
9943     if (o)
9944         SAVEFREEOP(o);
9945     if (proto)
9946         SAVEFREEOP(proto);
9947     if (attrs)
9948         SAVEFREEOP(attrs);
9949
9950     if (ec) {
9951         op_free(block);
9952
9953         if (name)
9954             SvREFCNT_dec(PL_compcv);
9955         else
9956             cv = PL_compcv;
9957
9958         PL_compcv = 0;
9959         if (name && block) {
9960             const char *s = (char *) my_memrchr(name, ':', namlen);
9961             s = s ? s+1 : name;
9962             if (strEQ(s, "BEGIN")) {
9963                 if (PL_in_eval & EVAL_KEEPERR)
9964                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9965                 else {
9966                     SV * const errsv = ERRSV;
9967                     /* force display of errors found but not reported */
9968                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9969                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9970                 }
9971             }
9972         }
9973         goto done;
9974     }
9975
9976     if (!block && SvTYPE(gv) != SVt_PVGV) {
9977         /* If we are not defining a new sub and the existing one is not a
9978            full GV + CV... */
9979         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9980             /* We are applying attributes to an existing sub, so we need it
9981                upgraded if it is a constant.  */
9982             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9983                 gv_init_pvn(gv, PL_curstash, name, namlen,
9984                             SVf_UTF8 * name_is_utf8);
9985         }
9986         else {                  /* Maybe prototype now, and had at maximum
9987                                    a prototype or const/sub ref before.  */
9988             if (SvTYPE(gv) > SVt_NULL) {
9989                 cv_ckproto_len_flags((const CV *)gv,
9990                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9991                                     ps_len, ps_utf8);
9992             }
9993
9994             if (!SvROK(gv)) {
9995                 if (ps) {
9996                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9997                     if (ps_utf8)
9998                         SvUTF8_on(MUTABLE_SV(gv));
9999                 }
10000                 else
10001                     sv_setiv(MUTABLE_SV(gv), -1);
10002             }
10003
10004             SvREFCNT_dec(PL_compcv);
10005             cv = PL_compcv = NULL;
10006             goto done;
10007         }
10008     }
10009
10010     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10011         ? NULL
10012         : isGV(gv)
10013             ? GvCV(gv)
10014             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10015                 ? (CV *)SvRV(gv)
10016                 : NULL;
10017
10018     if (block) {
10019         assert(PL_parser);
10020         /* This makes sub {}; work as expected.  */
10021         if (block->op_type == OP_STUB) {
10022             const line_t l = PL_parser->copline;
10023             op_free(block);
10024             block = newSTATEOP(0, NULL, 0);
10025             PL_parser->copline = l;
10026         }
10027         block = CvLVALUE(PL_compcv)
10028              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10029                     && (!isGV(gv) || !GvASSUMECV(gv)))
10030                    ? newUNOP(OP_LEAVESUBLV, 0,
10031                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10032                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10033         start = LINKLIST(block);
10034         block->op_next = 0;
10035         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10036             const_sv =
10037                 S_op_const_sv(aTHX_ start, PL_compcv,
10038                                         cBOOL(CvCLONE(PL_compcv)));
10039         else
10040             const_sv = NULL;
10041     }
10042     else
10043         const_sv = NULL;
10044
10045     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10046         cv_ckproto_len_flags((const CV *)gv,
10047                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10048                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10049         if (SvROK(gv)) {
10050             /* All the other code for sub redefinition warnings expects the
10051                clobbered sub to be a CV.  Instead of making all those code
10052                paths more complex, just inline the RV version here.  */
10053             const line_t oldline = CopLINE(PL_curcop);
10054             assert(IN_PERL_COMPILETIME);
10055             if (PL_parser && PL_parser->copline != NOLINE)
10056                 /* This ensures that warnings are reported at the first
10057                    line of a redefinition, not the last.  */
10058                 CopLINE_set(PL_curcop, PL_parser->copline);
10059             /* protect against fatal warnings leaking compcv */
10060             SAVEFREESV(PL_compcv);
10061
10062             if (ckWARN(WARN_REDEFINE)
10063              || (  ckWARN_d(WARN_REDEFINE)
10064                 && (  !const_sv || SvRV(gv) == const_sv
10065                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10066                 assert(cSVOPo);
10067                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10068                           "Constant subroutine %" SVf " redefined",
10069                           SVfARG(cSVOPo->op_sv));
10070             }
10071
10072             SvREFCNT_inc_simple_void_NN(PL_compcv);
10073             CopLINE_set(PL_curcop, oldline);
10074             SvREFCNT_dec(SvRV(gv));
10075         }
10076     }
10077
10078     if (cv) {
10079         const bool exists = CvROOT(cv) || CvXSUB(cv);
10080
10081         /* if the subroutine doesn't exist and wasn't pre-declared
10082          * with a prototype, assume it will be AUTOLOADed,
10083          * skipping the prototype check
10084          */
10085         if (exists || SvPOK(cv))
10086             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10087         /* already defined (or promised)? */
10088         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10089             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10090             if (block)
10091                 cv = NULL;
10092             else {
10093                 if (attrs)
10094                     goto attrs;
10095                 /* just a "sub foo;" when &foo is already defined */
10096                 SAVEFREESV(PL_compcv);
10097                 goto done;
10098             }
10099         }
10100     }
10101
10102     if (const_sv) {
10103         SvREFCNT_inc_simple_void_NN(const_sv);
10104         SvFLAGS(const_sv) |= SVs_PADTMP;
10105         if (cv) {
10106             assert(!CvROOT(cv) && !CvCONST(cv));
10107             cv_forget_slab(cv);
10108             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10109             CvXSUBANY(cv).any_ptr = const_sv;
10110             CvXSUB(cv) = const_sv_xsub;
10111             CvCONST_on(cv);
10112             CvISXSUB_on(cv);
10113             PoisonPADLIST(cv);
10114             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10115         }
10116         else {
10117             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10118                 if (name && isGV(gv))
10119                     GvCV_set(gv, NULL);
10120                 cv = newCONSTSUB_flags(
10121                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10122                     const_sv
10123                 );
10124                 assert(cv);
10125                 assert(SvREFCNT((SV*)cv) != 0);
10126                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10127             }
10128             else {
10129                 if (!SvROK(gv)) {
10130                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10131                     prepare_SV_for_RV((SV *)gv);
10132                     SvOK_off((SV *)gv);
10133                     SvROK_on(gv);
10134                 }
10135                 SvRV_set(gv, const_sv);
10136             }
10137         }
10138         op_free(block);
10139         SvREFCNT_dec(PL_compcv);
10140         PL_compcv = NULL;
10141         goto done;
10142     }
10143
10144     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10145     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10146         cv = NULL;
10147
10148     if (cv) {                           /* must reuse cv if autoloaded */
10149         /* transfer PL_compcv to cv */
10150         if (block) {
10151             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10152             PADLIST *const temp_av = CvPADLIST(cv);
10153             CV *const temp_cv = CvOUTSIDE(cv);
10154             const cv_flags_t other_flags =
10155                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10156             OP * const cvstart = CvSTART(cv);
10157
10158             if (isGV(gv)) {
10159                 CvGV_set(cv,gv);
10160                 assert(!CvCVGV_RC(cv));
10161                 assert(CvGV(cv) == gv);
10162             }
10163             else {
10164                 dVAR;
10165                 U32 hash;
10166                 PERL_HASH(hash, name, namlen);
10167                 CvNAME_HEK_set(cv,
10168                                share_hek(name,
10169                                          name_is_utf8
10170                                             ? -(SSize_t)namlen
10171                                             :  (SSize_t)namlen,
10172                                          hash));
10173             }
10174
10175             SvPOK_off(cv);
10176             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10177                                              | CvNAMED(cv);
10178             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10179             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10180             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10181             CvOUTSIDE(PL_compcv) = temp_cv;
10182             CvPADLIST_set(PL_compcv, temp_av);
10183             CvSTART(cv) = CvSTART(PL_compcv);
10184             CvSTART(PL_compcv) = cvstart;
10185             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10186             CvFLAGS(PL_compcv) |= other_flags;
10187
10188             if (CvFILE(cv) && CvDYNFILE(cv)) {
10189                 Safefree(CvFILE(cv));
10190             }
10191             CvFILE_set_from_cop(cv, PL_curcop);
10192             CvSTASH_set(cv, PL_curstash);
10193
10194             /* inner references to PL_compcv must be fixed up ... */
10195             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10196             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10197                 ++PL_sub_generation;
10198         }
10199         else {
10200             /* Might have had built-in attributes applied -- propagate them. */
10201             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10202         }
10203         /* ... before we throw it away */
10204         SvREFCNT_dec(PL_compcv);
10205         PL_compcv = cv;
10206     }
10207     else {
10208         cv = PL_compcv;
10209         if (name && isGV(gv)) {
10210             GvCV_set(gv, cv);
10211             GvCVGEN(gv) = 0;
10212             if (HvENAME_HEK(GvSTASH(gv)))
10213                 /* sub Foo::bar { (shift)+1 } */
10214                 gv_method_changed(gv);
10215         }
10216         else if (name) {
10217             if (!SvROK(gv)) {
10218                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10219                 prepare_SV_for_RV((SV *)gv);
10220                 SvOK_off((SV *)gv);
10221                 SvROK_on(gv);
10222             }
10223             SvRV_set(gv, (SV *)cv);
10224             if (HvENAME_HEK(PL_curstash))
10225                 mro_method_changed_in(PL_curstash);
10226         }
10227     }
10228     assert(cv);
10229     assert(SvREFCNT((SV*)cv) != 0);
10230
10231     if (!CvHASGV(cv)) {
10232         if (isGV(gv))
10233             CvGV_set(cv, gv);
10234         else {
10235             dVAR;
10236             U32 hash;
10237             PERL_HASH(hash, name, namlen);
10238             CvNAME_HEK_set(cv, share_hek(name,
10239                                          name_is_utf8
10240                                             ? -(SSize_t)namlen
10241                                             :  (SSize_t)namlen,
10242                                          hash));
10243         }
10244         CvFILE_set_from_cop(cv, PL_curcop);
10245         CvSTASH_set(cv, PL_curstash);
10246     }
10247
10248     if (ps) {
10249         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10250         if ( ps_utf8 )
10251             SvUTF8_on(MUTABLE_SV(cv));
10252     }
10253
10254     if (block) {
10255         /* If we assign an optree to a PVCV, then we've defined a
10256          * subroutine that the debugger could be able to set a breakpoint
10257          * in, so signal to pp_entereval that it should not throw away any
10258          * saved lines at scope exit.  */
10259
10260         PL_breakable_sub_gen++;
10261         CvROOT(cv) = block;
10262         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10263            itself has a refcount. */
10264         CvSLABBED_off(cv);
10265         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10266 #ifdef PERL_DEBUG_READONLY_OPS
10267         slab = (OPSLAB *)CvSTART(cv);
10268 #endif
10269         S_process_optree(aTHX_ cv, block, start);
10270     }
10271
10272   attrs:
10273     if (attrs) {
10274         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10275         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10276                         ? GvSTASH(CvGV(cv))
10277                         : PL_curstash;
10278         if (!name)
10279             SAVEFREESV(cv);
10280         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10281         if (!name)
10282             SvREFCNT_inc_simple_void_NN(cv);
10283     }
10284
10285     if (block && has_name) {
10286         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10287             SV * const tmpstr = cv_name(cv,NULL,0);
10288             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10289                                                   GV_ADDMULTI, SVt_PVHV);
10290             HV *hv;
10291             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10292                                           CopFILE(PL_curcop),
10293                                           (long)PL_subline,
10294                                           (long)CopLINE(PL_curcop));
10295             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10296                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10297             hv = GvHVn(db_postponed);
10298             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10299                 CV * const pcv = GvCV(db_postponed);
10300                 if (pcv) {
10301                     dSP;
10302                     PUSHMARK(SP);
10303                     XPUSHs(tmpstr);
10304                     PUTBACK;
10305                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10306                 }
10307             }
10308         }
10309
10310         if (name) {
10311             if (PL_parser && PL_parser->error_count)
10312                 clear_special_blocks(name, gv, cv);
10313             else
10314                 evanescent =
10315                     process_special_blocks(floor, name, gv, cv);
10316         }
10317     }
10318     assert(cv);
10319
10320   done:
10321     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10322     if (PL_parser)
10323         PL_parser->copline = NOLINE;
10324     LEAVE_SCOPE(floor);
10325
10326     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10327     if (!evanescent) {
10328 #ifdef PERL_DEBUG_READONLY_OPS
10329     if (slab)
10330         Slab_to_ro(slab);
10331 #endif
10332     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10333         pad_add_weakref(cv);
10334     }
10335     return cv;
10336 }
10337
10338 STATIC void
10339 S_clear_special_blocks(pTHX_ const char *const fullname,
10340                        GV *const gv, CV *const cv) {
10341     const char *colon;
10342     const char *name;
10343
10344     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10345
10346     colon = strrchr(fullname,':');
10347     name = colon ? colon + 1 : fullname;
10348
10349     if ((*name == 'B' && strEQ(name, "BEGIN"))
10350         || (*name == 'E' && strEQ(name, "END"))
10351         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10352         || (*name == 'C' && strEQ(name, "CHECK"))
10353         || (*name == 'I' && strEQ(name, "INIT"))) {
10354         if (!isGV(gv)) {
10355             (void)CvGV(cv);
10356             assert(isGV(gv));
10357         }
10358         GvCV_set(gv, NULL);
10359         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10360     }
10361 }
10362
10363 /* Returns true if the sub has been freed.  */
10364 STATIC bool
10365 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10366                          GV *const gv,
10367                          CV *const cv)
10368 {
10369     const char *const colon = strrchr(fullname,':');
10370     const char *const name = colon ? colon + 1 : fullname;
10371
10372     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10373
10374     if (*name == 'B') {
10375         if (strEQ(name, "BEGIN")) {
10376             const I32 oldscope = PL_scopestack_ix;
10377             dSP;
10378             (void)CvGV(cv);
10379             if (floor) LEAVE_SCOPE(floor);
10380             ENTER;
10381             PUSHSTACKi(PERLSI_REQUIRE);
10382             SAVECOPFILE(&PL_compiling);
10383             SAVECOPLINE(&PL_compiling);
10384             SAVEVPTR(PL_curcop);
10385
10386             DEBUG_x( dump_sub(gv) );
10387             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10388             GvCV_set(gv,0);             /* cv has been hijacked */
10389             call_list(oldscope, PL_beginav);
10390
10391             POPSTACK;
10392             LEAVE;
10393             return !PL_savebegin;
10394         }
10395         else
10396             return FALSE;
10397     } else {
10398         if (*name == 'E') {
10399             if strEQ(name, "END") {
10400                 DEBUG_x( dump_sub(gv) );
10401                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10402             } else
10403                 return FALSE;
10404         } else if (*name == 'U') {
10405             if (strEQ(name, "UNITCHECK")) {
10406                 /* It's never too late to run a unitcheck block */
10407                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10408             }
10409             else
10410                 return FALSE;
10411         } else if (*name == 'C') {
10412             if (strEQ(name, "CHECK")) {
10413                 if (PL_main_start)
10414                     /* diag_listed_as: Too late to run %s block */
10415                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10416                                    "Too late to run CHECK block");
10417                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10418             }
10419             else
10420                 return FALSE;
10421         } else if (*name == 'I') {
10422             if (strEQ(name, "INIT")) {
10423                 if (PL_main_start)
10424                     /* diag_listed_as: Too late to run %s block */
10425                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10426                                    "Too late to run INIT block");
10427                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10428             }
10429             else
10430                 return FALSE;
10431         } else
10432             return FALSE;
10433         DEBUG_x( dump_sub(gv) );
10434         (void)CvGV(cv);
10435         GvCV_set(gv,0);         /* cv has been hijacked */
10436         return FALSE;
10437     }
10438 }
10439
10440 /*
10441 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10442
10443 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10444 rather than of counted length, and no flags are set.  (This means that
10445 C<name> is always interpreted as Latin-1.)
10446
10447 =cut
10448 */
10449
10450 CV *
10451 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10452 {
10453     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10454 }
10455
10456 /*
10457 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10458
10459 Construct a constant subroutine, also performing some surrounding
10460 jobs.  A scalar constant-valued subroutine is eligible for inlining
10461 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10462 123 }>>.  Other kinds of constant subroutine have other treatment.
10463
10464 The subroutine will have an empty prototype and will ignore any arguments
10465 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10466 is null, the subroutine will yield an empty list.  If C<sv> points to a
10467 scalar, the subroutine will always yield that scalar.  If C<sv> points
10468 to an array, the subroutine will always yield a list of the elements of
10469 that array in list context, or the number of elements in the array in
10470 scalar context.  This function takes ownership of one counted reference
10471 to the scalar or array, and will arrange for the object to live as long
10472 as the subroutine does.  If C<sv> points to a scalar then the inlining
10473 assumes that the value of the scalar will never change, so the caller
10474 must ensure that the scalar is not subsequently written to.  If C<sv>
10475 points to an array then no such assumption is made, so it is ostensibly
10476 safe to mutate the array or its elements, but whether this is really
10477 supported has not been determined.
10478
10479 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10480 Other aspects of the subroutine will be left in their default state.
10481 The caller is free to mutate the subroutine beyond its initial state
10482 after this function has returned.
10483
10484 If C<name> is null then the subroutine will be anonymous, with its
10485 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10486 subroutine will be named accordingly, referenced by the appropriate glob.
10487 C<name> is a string of length C<len> bytes giving a sigilless symbol
10488 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10489 otherwise.  The name may be either qualified or unqualified.  If the
10490 name is unqualified then it defaults to being in the stash specified by
10491 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10492 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10493 semantics.
10494
10495 C<flags> should not have bits set other than C<SVf_UTF8>.
10496
10497 If there is already a subroutine of the specified name, then the new sub
10498 will replace the existing one in the glob.  A warning may be generated
10499 about the redefinition.
10500
10501 If the subroutine has one of a few special names, such as C<BEGIN> or
10502 C<END>, then it will be claimed by the appropriate queue for automatic
10503 running of phase-related subroutines.  In this case the relevant glob will
10504 be left not containing any subroutine, even if it did contain one before.
10505 Execution of the subroutine will likely be a no-op, unless C<sv> was
10506 a tied array or the caller modified the subroutine in some interesting
10507 way before it was executed.  In the case of C<BEGIN>, the treatment is
10508 buggy: the sub will be executed when only half built, and may be deleted
10509 prematurely, possibly causing a crash.
10510
10511 The function returns a pointer to the constructed subroutine.  If the sub
10512 is anonymous then ownership of one counted reference to the subroutine
10513 is transferred to the caller.  If the sub is named then the caller does
10514 not get ownership of a reference.  In most such cases, where the sub
10515 has a non-phase name, the sub will be alive at the point it is returned
10516 by virtue of being contained in the glob that names it.  A phase-named
10517 subroutine will usually be alive by virtue of the reference owned by
10518 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10519 destroyed already by the time this function returns, but currently bugs
10520 occur in that case before the caller gets control.  It is the caller's
10521 responsibility to ensure that it knows which of these situations applies.
10522
10523 =cut
10524 */
10525
10526 CV *
10527 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10528                              U32 flags, SV *sv)
10529 {
10530     CV* cv;
10531     const char *const file = CopFILE(PL_curcop);
10532
10533     ENTER;
10534
10535     if (IN_PERL_RUNTIME) {
10536         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10537          * an op shared between threads. Use a non-shared COP for our
10538          * dirty work */
10539          SAVEVPTR(PL_curcop);
10540          SAVECOMPILEWARNINGS();
10541          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10542          PL_curcop = &PL_compiling;
10543     }
10544     SAVECOPLINE(PL_curcop);
10545     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10546
10547     SAVEHINTS();
10548     PL_hints &= ~HINT_BLOCK_SCOPE;
10549
10550     if (stash) {
10551         SAVEGENERICSV(PL_curstash);
10552         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10553     }
10554
10555     /* Protect sv against leakage caused by fatal warnings. */
10556     if (sv) SAVEFREESV(sv);
10557
10558     /* file becomes the CvFILE. For an XS, it's usually static storage,
10559        and so doesn't get free()d.  (It's expected to be from the C pre-
10560        processor __FILE__ directive). But we need a dynamically allocated one,
10561        and we need it to get freed.  */
10562     cv = newXS_len_flags(name, len,
10563                          sv && SvTYPE(sv) == SVt_PVAV
10564                              ? const_av_xsub
10565                              : const_sv_xsub,
10566                          file ? file : "", "",
10567                          &sv, XS_DYNAMIC_FILENAME | flags);
10568     assert(cv);
10569     assert(SvREFCNT((SV*)cv) != 0);
10570     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10571     CvCONST_on(cv);
10572
10573     LEAVE;
10574
10575     return cv;
10576 }
10577
10578 /*
10579 =for apidoc U||newXS
10580
10581 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10582 static storage, as it is used directly as CvFILE(), without a copy being made.
10583
10584 =cut
10585 */
10586
10587 CV *
10588 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10589 {
10590     PERL_ARGS_ASSERT_NEWXS;
10591     return newXS_len_flags(
10592         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10593     );
10594 }
10595
10596 CV *
10597 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10598                  const char *const filename, const char *const proto,
10599                  U32 flags)
10600 {
10601     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10602     return newXS_len_flags(
10603        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10604     );
10605 }
10606
10607 CV *
10608 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10609 {
10610     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10611     return newXS_len_flags(
10612         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10613     );
10614 }
10615
10616 /*
10617 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10618
10619 Construct an XS subroutine, also performing some surrounding jobs.
10620
10621 The subroutine will have the entry point C<subaddr>.  It will have
10622 the prototype specified by the nul-terminated string C<proto>, or
10623 no prototype if C<proto> is null.  The prototype string is copied;
10624 the caller can mutate the supplied string afterwards.  If C<filename>
10625 is non-null, it must be a nul-terminated filename, and the subroutine
10626 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10627 point directly to the supplied string, which must be static.  If C<flags>
10628 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10629 be taken instead.
10630
10631 Other aspects of the subroutine will be left in their default state.
10632 If anything else needs to be done to the subroutine for it to function
10633 correctly, it is the caller's responsibility to do that after this
10634 function has constructed it.  However, beware of the subroutine
10635 potentially being destroyed before this function returns, as described
10636 below.
10637
10638 If C<name> is null then the subroutine will be anonymous, with its
10639 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10640 subroutine will be named accordingly, referenced by the appropriate glob.
10641 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10642 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10643 The name may be either qualified or unqualified, with the stash defaulting
10644 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10645 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10646 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10647 the stash if necessary, with C<GV_ADDMULTI> semantics.
10648
10649 If there is already a subroutine of the specified name, then the new sub
10650 will replace the existing one in the glob.  A warning may be generated
10651 about the redefinition.  If the old subroutine was C<CvCONST> then the
10652 decision about whether to warn is influenced by an expectation about
10653 whether the new subroutine will become a constant of similar value.
10654 That expectation is determined by C<const_svp>.  (Note that the call to
10655 this function doesn't make the new subroutine C<CvCONST> in any case;
10656 that is left to the caller.)  If C<const_svp> is null then it indicates
10657 that the new subroutine will not become a constant.  If C<const_svp>
10658 is non-null then it indicates that the new subroutine will become a
10659 constant, and it points to an C<SV*> that provides the constant value
10660 that the subroutine will have.
10661
10662 If the subroutine has one of a few special names, such as C<BEGIN> or
10663 C<END>, then it will be claimed by the appropriate queue for automatic
10664 running of phase-related subroutines.  In this case the relevant glob will
10665 be left not containing any subroutine, even if it did contain one before.
10666 In the case of C<BEGIN>, the subroutine will be executed and the reference
10667 to it disposed of before this function returns, and also before its
10668 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10669 constructed by this function to be ready for execution then the caller
10670 must prevent this happening by giving the subroutine a different name.
10671
10672 The function returns a pointer to the constructed subroutine.  If the sub
10673 is anonymous then ownership of one counted reference to the subroutine
10674 is transferred to the caller.  If the sub is named then the caller does
10675 not get ownership of a reference.  In most such cases, where the sub
10676 has a non-phase name, the sub will be alive at the point it is returned
10677 by virtue of being contained in the glob that names it.  A phase-named
10678 subroutine will usually be alive by virtue of the reference owned by the
10679 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10680 been executed, will quite likely have been destroyed already by the
10681 time this function returns, making it erroneous for the caller to make
10682 any use of the returned pointer.  It is the caller's responsibility to
10683 ensure that it knows which of these situations applies.
10684
10685 =cut
10686 */
10687
10688 CV *
10689 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10690                            XSUBADDR_t subaddr, const char *const filename,
10691                            const char *const proto, SV **const_svp,
10692                            U32 flags)
10693 {
10694     CV *cv;
10695     bool interleave = FALSE;
10696     bool evanescent = FALSE;
10697
10698     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10699
10700     {
10701         GV * const gv = gv_fetchpvn(
10702                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10703                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10704                                 sizeof("__ANON__::__ANON__") - 1,
10705                             GV_ADDMULTI | flags, SVt_PVCV);
10706
10707         if ((cv = (name ? GvCV(gv) : NULL))) {
10708             if (GvCVGEN(gv)) {
10709                 /* just a cached method */
10710                 SvREFCNT_dec(cv);
10711                 cv = NULL;
10712             }
10713             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10714                 /* already defined (or promised) */
10715                 /* Redundant check that allows us to avoid creating an SV
10716                    most of the time: */
10717                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10718                     report_redefined_cv(newSVpvn_flags(
10719                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10720                                         ),
10721                                         cv, const_svp);
10722                 }
10723                 interleave = TRUE;
10724                 ENTER;
10725                 SAVEFREESV(cv);
10726                 cv = NULL;
10727             }
10728         }
10729
10730         if (cv)                         /* must reuse cv if autoloaded */
10731             cv_undef(cv);
10732         else {
10733             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10734             if (name) {
10735                 GvCV_set(gv,cv);
10736                 GvCVGEN(gv) = 0;
10737                 if (HvENAME_HEK(GvSTASH(gv)))
10738                     gv_method_changed(gv); /* newXS */
10739             }
10740         }
10741         assert(cv);
10742         assert(SvREFCNT((SV*)cv) != 0);
10743
10744         CvGV_set(cv, gv);
10745         if(filename) {
10746             /* XSUBs can't be perl lang/perl5db.pl debugged
10747             if (PERLDB_LINE_OR_SAVESRC)
10748                 (void)gv_fetchfile(filename); */
10749             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10750             if (flags & XS_DYNAMIC_FILENAME) {
10751                 CvDYNFILE_on(cv);
10752                 CvFILE(cv) = savepv(filename);
10753             } else {
10754             /* NOTE: not copied, as it is expected to be an external constant string */
10755                 CvFILE(cv) = (char *)filename;
10756             }
10757         } else {
10758             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10759             CvFILE(cv) = (char*)PL_xsubfilename;
10760         }
10761         CvISXSUB_on(cv);
10762         CvXSUB(cv) = subaddr;
10763 #ifndef PERL_IMPLICIT_CONTEXT
10764         CvHSCXT(cv) = &PL_stack_sp;
10765 #else
10766         PoisonPADLIST(cv);
10767 #endif
10768
10769         if (name)
10770             evanescent = process_special_blocks(0, name, gv, cv);
10771         else
10772             CvANON_on(cv);
10773     } /* <- not a conditional branch */
10774
10775     assert(cv);
10776     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10777
10778     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10779     if (interleave) LEAVE;
10780     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10781     return cv;
10782 }
10783
10784 CV *
10785 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10786 {
10787     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10788     GV *cvgv;
10789     PERL_ARGS_ASSERT_NEWSTUB;
10790     assert(!GvCVu(gv));
10791     GvCV_set(gv, cv);
10792     GvCVGEN(gv) = 0;
10793     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10794         gv_method_changed(gv);
10795     if (SvFAKE(gv)) {
10796         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10797         SvFAKE_off(cvgv);
10798     }
10799     else cvgv = gv;
10800     CvGV_set(cv, cvgv);
10801     CvFILE_set_from_cop(cv, PL_curcop);
10802     CvSTASH_set(cv, PL_curstash);
10803     GvMULTI_on(gv);
10804     return cv;
10805 }
10806
10807 void
10808 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10809 {
10810     CV *cv;
10811     GV *gv;
10812     OP *root;
10813     OP *start;
10814
10815     if (PL_parser && PL_parser->error_count) {
10816         op_free(block);
10817         goto finish;
10818     }
10819
10820     gv = o
10821         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10822         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10823
10824     GvMULTI_on(gv);
10825     if ((cv = GvFORM(gv))) {
10826         if (ckWARN(WARN_REDEFINE)) {
10827             const line_t oldline = CopLINE(PL_curcop);
10828             if (PL_parser && PL_parser->copline != NOLINE)
10829                 CopLINE_set(PL_curcop, PL_parser->copline);
10830             if (o) {
10831                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10832                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10833             } else {
10834                 /* diag_listed_as: Format %s redefined */
10835                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10836                             "Format STDOUT redefined");
10837             }
10838             CopLINE_set(PL_curcop, oldline);
10839         }
10840         SvREFCNT_dec(cv);
10841     }
10842     cv = PL_compcv;
10843     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10844     CvGV_set(cv, gv);
10845     CvFILE_set_from_cop(cv, PL_curcop);
10846
10847
10848     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10849     CvROOT(cv) = root;
10850     start = LINKLIST(root);
10851     root->op_next = 0;
10852     S_process_optree(aTHX_ cv, root, start);
10853     cv_forget_slab(cv);
10854
10855   finish:
10856     op_free(o);
10857     if (PL_parser)
10858         PL_parser->copline = NOLINE;
10859     LEAVE_SCOPE(floor);
10860     PL_compiling.cop_seq = 0;
10861 }
10862
10863 OP *
10864 Perl_newANONLIST(pTHX_ OP *o)
10865 {
10866     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10867 }
10868
10869 OP *
10870 Perl_newANONHASH(pTHX_ OP *o)
10871 {
10872     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10873 }
10874
10875 OP *
10876 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10877 {
10878     return newANONATTRSUB(floor, proto, NULL, block);
10879 }
10880
10881 OP *
10882 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10883 {
10884     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10885     OP * anoncode =
10886         newSVOP(OP_ANONCODE, 0,
10887                 cv);
10888     if (CvANONCONST(cv))
10889         anoncode = newUNOP(OP_ANONCONST, 0,
10890                            op_convert_list(OP_ENTERSUB,
10891                                            OPf_STACKED|OPf_WANT_SCALAR,
10892                                            anoncode));
10893     return newUNOP(OP_REFGEN, 0, anoncode);
10894 }
10895
10896 OP *
10897 Perl_oopsAV(pTHX_ OP *o)
10898 {
10899     dVAR;
10900
10901     PERL_ARGS_ASSERT_OOPSAV;
10902
10903     switch (o->op_type) {
10904     case OP_PADSV:
10905     case OP_PADHV:
10906         OpTYPE_set(o, OP_PADAV);
10907         return ref(o, OP_RV2AV);
10908
10909     case OP_RV2SV:
10910     case OP_RV2HV:
10911         OpTYPE_set(o, OP_RV2AV);
10912         ref(o, OP_RV2AV);
10913         break;
10914
10915     default:
10916         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10917         break;
10918     }
10919     return o;
10920 }
10921
10922 OP *
10923 Perl_oopsHV(pTHX_ OP *o)
10924 {
10925     dVAR;
10926
10927     PERL_ARGS_ASSERT_OOPSHV;
10928
10929     switch (o->op_type) {
10930     case OP_PADSV:
10931     case OP_PADAV:
10932         OpTYPE_set(o, OP_PADHV);
10933         return ref(o, OP_RV2HV);
10934
10935     case OP_RV2SV:
10936     case OP_RV2AV:
10937         OpTYPE_set(o, OP_RV2HV);
10938         /* rv2hv steals the bottom bit for its own uses */
10939         o->op_private &= ~OPpARG1_MASK;
10940         ref(o, OP_RV2HV);
10941         break;
10942
10943     default:
10944         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10945         break;
10946     }
10947     return o;
10948 }
10949
10950 OP *
10951 Perl_newAVREF(pTHX_ OP *o)
10952 {
10953     dVAR;
10954
10955     PERL_ARGS_ASSERT_NEWAVREF;
10956
10957     if (o->op_type == OP_PADANY) {
10958         OpTYPE_set(o, OP_PADAV);
10959         return o;
10960     }
10961     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10962         Perl_croak(aTHX_ "Can't use an array as a reference");
10963     }
10964     return newUNOP(OP_RV2AV, 0, scalar(o));
10965 }
10966
10967 OP *
10968 Perl_newGVREF(pTHX_ I32 type, OP *o)
10969 {
10970     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10971         return newUNOP(OP_NULL, 0, o);
10972     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10973 }
10974
10975 OP *
10976 Perl_newHVREF(pTHX_ OP *o)
10977 {
10978     dVAR;
10979
10980     PERL_ARGS_ASSERT_NEWHVREF;
10981
10982     if (o->op_type == OP_PADANY) {
10983         OpTYPE_set(o, OP_PADHV);
10984         return o;
10985     }
10986     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10987         Perl_croak(aTHX_ "Can't use a hash as a reference");
10988     }
10989     return newUNOP(OP_RV2HV, 0, scalar(o));
10990 }
10991
10992 OP *
10993 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10994 {
10995     if (o->op_type == OP_PADANY) {
10996         dVAR;
10997         OpTYPE_set(o, OP_PADCV);
10998     }
10999     return newUNOP(OP_RV2CV, flags, scalar(o));
11000 }
11001
11002 OP *
11003 Perl_newSVREF(pTHX_ OP *o)
11004 {
11005     dVAR;
11006
11007     PERL_ARGS_ASSERT_NEWSVREF;
11008
11009     if (o->op_type == OP_PADANY) {
11010         OpTYPE_set(o, OP_PADSV);
11011         scalar(o);
11012         return o;
11013     }
11014     return newUNOP(OP_RV2SV, 0, scalar(o));
11015 }
11016
11017 /* Check routines. See the comments at the top of this file for details
11018  * on when these are called */
11019
11020 OP *
11021 Perl_ck_anoncode(pTHX_ OP *o)
11022 {
11023     PERL_ARGS_ASSERT_CK_ANONCODE;
11024
11025     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11026     cSVOPo->op_sv = NULL;
11027     return o;
11028 }
11029
11030 static void
11031 S_io_hints(pTHX_ OP *o)
11032 {
11033 #if O_BINARY != 0 || O_TEXT != 0
11034     HV * const table =
11035         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11036     if (table) {
11037         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11038         if (svp && *svp) {
11039             STRLEN len = 0;
11040             const char *d = SvPV_const(*svp, len);
11041             const I32 mode = mode_from_discipline(d, len);
11042             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11043 #  if O_BINARY != 0
11044             if (mode & O_BINARY)
11045                 o->op_private |= OPpOPEN_IN_RAW;
11046 #  endif
11047 #  if O_TEXT != 0
11048             if (mode & O_TEXT)
11049                 o->op_private |= OPpOPEN_IN_CRLF;
11050 #  endif
11051         }
11052
11053         svp = hv_fetchs(table, "open_OUT", FALSE);
11054         if (svp && *svp) {
11055             STRLEN len = 0;
11056             const char *d = SvPV_const(*svp, len);
11057             const I32 mode = mode_from_discipline(d, len);
11058             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11059 #  if O_BINARY != 0
11060             if (mode & O_BINARY)
11061                 o->op_private |= OPpOPEN_OUT_RAW;
11062 #  endif
11063 #  if O_TEXT != 0
11064             if (mode & O_TEXT)
11065                 o->op_private |= OPpOPEN_OUT_CRLF;
11066 #  endif
11067         }
11068     }
11069 #else
11070     PERL_UNUSED_CONTEXT;
11071     PERL_UNUSED_ARG(o);
11072 #endif
11073 }
11074
11075 OP *
11076 Perl_ck_backtick(pTHX_ OP *o)
11077 {
11078     GV *gv;
11079     OP *newop = NULL;
11080     OP *sibl;
11081     PERL_ARGS_ASSERT_CK_BACKTICK;
11082     o = ck_fun(o);
11083     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11084     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11085      && (gv = gv_override("readpipe",8)))
11086     {
11087         /* detach rest of siblings from o and its first child */
11088         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11089         newop = S_new_entersubop(aTHX_ gv, sibl);
11090     }
11091     else if (!(o->op_flags & OPf_KIDS))
11092         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11093     if (newop) {
11094         op_free(o);
11095         return newop;
11096     }
11097     S_io_hints(aTHX_ o);
11098     return o;
11099 }
11100
11101 OP *
11102 Perl_ck_bitop(pTHX_ OP *o)
11103 {
11104     PERL_ARGS_ASSERT_CK_BITOP;
11105
11106     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11107
11108     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11109             && OP_IS_INFIX_BIT(o->op_type))
11110     {
11111         const OP * const left = cBINOPo->op_first;
11112         const OP * const right = OpSIBLING(left);
11113         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11114                 (left->op_flags & OPf_PARENS) == 0) ||
11115             (OP_IS_NUMCOMPARE(right->op_type) &&
11116                 (right->op_flags & OPf_PARENS) == 0))
11117             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11118                           "Possible precedence problem on bitwise %s operator",
11119                            o->op_type ==  OP_BIT_OR
11120                          ||o->op_type == OP_NBIT_OR  ? "|"
11121                         :  o->op_type ==  OP_BIT_AND
11122                          ||o->op_type == OP_NBIT_AND ? "&"
11123                         :  o->op_type ==  OP_BIT_XOR
11124                          ||o->op_type == OP_NBIT_XOR ? "^"
11125                         :  o->op_type == OP_SBIT_OR  ? "|."
11126                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11127                            );
11128     }
11129     return o;
11130 }
11131
11132 PERL_STATIC_INLINE bool
11133 is_dollar_bracket(pTHX_ const OP * const o)
11134 {
11135     const OP *kid;
11136     PERL_UNUSED_CONTEXT;
11137     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11138         && (kid = cUNOPx(o)->op_first)
11139         && kid->op_type == OP_GV
11140         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11141 }
11142
11143 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11144
11145 OP *
11146 Perl_ck_cmp(pTHX_ OP *o)
11147 {
11148     bool is_eq;
11149     bool neg;
11150     bool reverse;
11151     bool iv0;
11152     OP *indexop, *constop, *start;
11153     SV *sv;
11154     IV iv;
11155
11156     PERL_ARGS_ASSERT_CK_CMP;
11157
11158     is_eq = (   o->op_type == OP_EQ
11159              || o->op_type == OP_NE
11160              || o->op_type == OP_I_EQ
11161              || o->op_type == OP_I_NE);
11162
11163     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11164         const OP *kid = cUNOPo->op_first;
11165         if (kid &&
11166             (
11167                 (   is_dollar_bracket(aTHX_ kid)
11168                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11169                 )
11170              || (   kid->op_type == OP_CONST
11171                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11172                 )
11173            )
11174         )
11175             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11176                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11177     }
11178
11179     /* convert (index(...) == -1) and variations into
11180      *   (r)index/BOOL(,NEG)
11181      */
11182
11183     reverse = FALSE;
11184
11185     indexop = cUNOPo->op_first;
11186     constop = OpSIBLING(indexop);
11187     start = NULL;
11188     if (indexop->op_type == OP_CONST) {
11189         constop = indexop;
11190         indexop = OpSIBLING(constop);
11191         start = constop;
11192         reverse = TRUE;
11193     }
11194
11195     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11196         return o;
11197
11198     /* ($lex = index(....)) == -1 */
11199     if (indexop->op_private & OPpTARGET_MY)
11200         return o;
11201
11202     if (constop->op_type != OP_CONST)
11203         return o;
11204
11205     sv = cSVOPx_sv(constop);
11206     if (!(sv && SvIOK_notUV(sv)))
11207         return o;
11208
11209     iv = SvIVX(sv);
11210     if (iv != -1 && iv != 0)
11211         return o;
11212     iv0 = (iv == 0);
11213
11214     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11215         if (!(iv0 ^ reverse))
11216             return o;
11217         neg = iv0;
11218     }
11219     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11220         if (iv0 ^ reverse)
11221             return o;
11222         neg = !iv0;
11223     }
11224     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11225         if (!(iv0 ^ reverse))
11226             return o;
11227         neg = !iv0;
11228     }
11229     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11230         if (iv0 ^ reverse)
11231             return o;
11232         neg = iv0;
11233     }
11234     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11235         if (iv0)
11236             return o;
11237         neg = TRUE;
11238     }
11239     else {
11240         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11241         if (iv0)
11242             return o;
11243         neg = FALSE;
11244     }
11245
11246     indexop->op_flags &= ~OPf_PARENS;
11247     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11248     indexop->op_private |= OPpTRUEBOOL;
11249     if (neg)
11250         indexop->op_private |= OPpINDEX_BOOLNEG;
11251     /* cut out the index op and free the eq,const ops */
11252     (void)op_sibling_splice(o, start, 1, NULL);
11253     op_free(o);
11254
11255     return indexop;
11256 }
11257
11258
11259 OP *
11260 Perl_ck_concat(pTHX_ OP *o)
11261 {
11262     const OP * const kid = cUNOPo->op_first;
11263
11264     PERL_ARGS_ASSERT_CK_CONCAT;
11265     PERL_UNUSED_CONTEXT;
11266
11267     /* reuse the padtmp returned by the concat child */
11268     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11269             !(kUNOP->op_first->op_flags & OPf_MOD))
11270     {
11271         o->op_flags |= OPf_STACKED;
11272         o->op_private |= OPpCONCAT_NESTED;
11273     }
11274     return o;
11275 }
11276
11277 OP *
11278 Perl_ck_spair(pTHX_ OP *o)
11279 {
11280     dVAR;
11281
11282     PERL_ARGS_ASSERT_CK_SPAIR;
11283
11284     if (o->op_flags & OPf_KIDS) {
11285         OP* newop;
11286         OP* kid;
11287         OP* kidkid;
11288         const OPCODE type = o->op_type;
11289         o = modkids(ck_fun(o), type);
11290         kid    = cUNOPo->op_first;
11291         kidkid = kUNOP->op_first;
11292         newop = OpSIBLING(kidkid);
11293         if (newop) {
11294             const OPCODE type = newop->op_type;
11295             if (OpHAS_SIBLING(newop))
11296                 return o;
11297             if (o->op_type == OP_REFGEN
11298              && (  type == OP_RV2CV
11299                 || (  !(newop->op_flags & OPf_PARENS)
11300                    && (  type == OP_RV2AV || type == OP_PADAV
11301                       || type == OP_RV2HV || type == OP_PADHV))))
11302                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11303             else if (OP_GIMME(newop,0) != G_SCALAR)
11304                 return o;
11305         }
11306         /* excise first sibling */
11307         op_sibling_splice(kid, NULL, 1, NULL);
11308         op_free(kidkid);
11309     }
11310     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11311      * and OP_CHOMP into OP_SCHOMP */
11312     o->op_ppaddr = PL_ppaddr[++o->op_type];
11313     return ck_fun(o);
11314 }
11315
11316 OP *
11317 Perl_ck_delete(pTHX_ OP *o)
11318 {
11319     PERL_ARGS_ASSERT_CK_DELETE;
11320
11321     o = ck_fun(o);
11322     o->op_private = 0;
11323     if (o->op_flags & OPf_KIDS) {
11324         OP * const kid = cUNOPo->op_first;
11325         switch (kid->op_type) {
11326         case OP_ASLICE:
11327             o->op_flags |= OPf_SPECIAL;
11328             /* FALLTHROUGH */
11329         case OP_HSLICE:
11330             o->op_private |= OPpSLICE;
11331             break;
11332         case OP_AELEM:
11333             o->op_flags |= OPf_SPECIAL;
11334             /* FALLTHROUGH */
11335         case OP_HELEM:
11336             break;
11337         case OP_KVASLICE:
11338             o->op_flags |= OPf_SPECIAL;
11339             /* FALLTHROUGH */
11340         case OP_KVHSLICE:
11341             o->op_private |= OPpKVSLICE;
11342             break;
11343         default:
11344             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11345                              "element or slice");
11346         }
11347         if (kid->op_private & OPpLVAL_INTRO)
11348             o->op_private |= OPpLVAL_INTRO;
11349         op_null(kid);
11350     }
11351     return o;
11352 }
11353
11354 OP *
11355 Perl_ck_eof(pTHX_ OP *o)
11356 {
11357     PERL_ARGS_ASSERT_CK_EOF;
11358
11359     if (o->op_flags & OPf_KIDS) {
11360         OP *kid;
11361         if (cLISTOPo->op_first->op_type == OP_STUB) {
11362             OP * const newop
11363                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11364             op_free(o);
11365             o = newop;
11366         }
11367         o = ck_fun(o);
11368         kid = cLISTOPo->op_first;
11369         if (kid->op_type == OP_RV2GV)
11370             kid->op_private |= OPpALLOW_FAKE;
11371     }
11372     return o;
11373 }
11374
11375
11376 OP *
11377 Perl_ck_eval(pTHX_ OP *o)
11378 {
11379     dVAR;
11380
11381     PERL_ARGS_ASSERT_CK_EVAL;
11382
11383     PL_hints |= HINT_BLOCK_SCOPE;
11384     if (o->op_flags & OPf_KIDS) {
11385         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11386         assert(kid);
11387
11388         if (o->op_type == OP_ENTERTRY) {
11389             LOGOP *enter;
11390
11391             /* cut whole sibling chain free from o */
11392             op_sibling_splice(o, NULL, -1, NULL);
11393             op_free(o);
11394
11395             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11396
11397             /* establish postfix order */
11398             enter->op_next = (OP*)enter;
11399
11400             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11401             OpTYPE_set(o, OP_LEAVETRY);
11402             enter->op_other = o;
11403             return o;
11404         }
11405         else {
11406             scalar((OP*)kid);
11407             S_set_haseval(aTHX);
11408         }
11409     }
11410     else {
11411         const U8 priv = o->op_private;
11412         op_free(o);
11413         /* the newUNOP will recursively call ck_eval(), which will handle
11414          * all the stuff at the end of this function, like adding
11415          * OP_HINTSEVAL
11416          */
11417         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11418     }
11419     o->op_targ = (PADOFFSET)PL_hints;
11420     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11421     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11422      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11423         /* Store a copy of %^H that pp_entereval can pick up. */
11424         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11425                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11426         /* append hhop to only child  */
11427         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11428
11429         o->op_private |= OPpEVAL_HAS_HH;
11430     }
11431     if (!(o->op_private & OPpEVAL_BYTES)
11432          && FEATURE_UNIEVAL_IS_ENABLED)
11433             o->op_private |= OPpEVAL_UNICODE;
11434     return o;
11435 }
11436
11437 OP *
11438 Perl_ck_exec(pTHX_ OP *o)
11439 {
11440     PERL_ARGS_ASSERT_CK_EXEC;
11441
11442     if (o->op_flags & OPf_STACKED) {
11443         OP *kid;
11444         o = ck_fun(o);
11445         kid = OpSIBLING(cUNOPo->op_first);
11446         if (kid->op_type == OP_RV2GV)
11447             op_null(kid);
11448     }
11449     else
11450         o = listkids(o);
11451     return o;
11452 }
11453
11454 OP *
11455 Perl_ck_exists(pTHX_ OP *o)
11456 {
11457     PERL_ARGS_ASSERT_CK_EXISTS;
11458
11459     o = ck_fun(o);
11460     if (o->op_flags & OPf_KIDS) {
11461         OP * const kid = cUNOPo->op_first;
11462         if (kid->op_type == OP_ENTERSUB) {
11463             (void) ref(kid, o->op_type);
11464             if (kid->op_type != OP_RV2CV
11465                         && !(PL_parser && PL_parser->error_count))
11466                 Perl_croak(aTHX_
11467                           "exists argument is not a subroutine name");
11468             o->op_private |= OPpEXISTS_SUB;
11469         }
11470         else if (kid->op_type == OP_AELEM)
11471             o->op_flags |= OPf_SPECIAL;
11472         else if (kid->op_type != OP_HELEM)
11473             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11474                              "element or a subroutine");
11475         op_null(kid);
11476     }
11477     return o;
11478 }
11479
11480 OP *
11481 Perl_ck_rvconst(pTHX_ OP *o)
11482 {
11483     dVAR;
11484     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11485
11486     PERL_ARGS_ASSERT_CK_RVCONST;
11487
11488     if (o->op_type == OP_RV2HV)
11489         /* rv2hv steals the bottom bit for its own uses */
11490         o->op_private &= ~OPpARG1_MASK;
11491
11492     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11493
11494     if (kid->op_type == OP_CONST) {
11495         int iscv;
11496         GV *gv;
11497         SV * const kidsv = kid->op_sv;
11498
11499         /* Is it a constant from cv_const_sv()? */
11500         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11501             return o;
11502         }
11503         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11504         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11505             const char *badthing;
11506             switch (o->op_type) {
11507             case OP_RV2SV:
11508                 badthing = "a SCALAR";
11509                 break;
11510             case OP_RV2AV:
11511                 badthing = "an ARRAY";
11512                 break;
11513             case OP_RV2HV:
11514                 badthing = "a HASH";
11515                 break;
11516             default:
11517                 badthing = NULL;
11518                 break;
11519             }
11520             if (badthing)
11521                 Perl_croak(aTHX_
11522                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11523                            SVfARG(kidsv), badthing);
11524         }
11525         /*
11526          * This is a little tricky.  We only want to add the symbol if we
11527          * didn't add it in the lexer.  Otherwise we get duplicate strict
11528          * warnings.  But if we didn't add it in the lexer, we must at
11529          * least pretend like we wanted to add it even if it existed before,
11530          * or we get possible typo warnings.  OPpCONST_ENTERED says
11531          * whether the lexer already added THIS instance of this symbol.
11532          */
11533         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11534         gv = gv_fetchsv(kidsv,
11535                 o->op_type == OP_RV2CV
11536                         && o->op_private & OPpMAY_RETURN_CONSTANT
11537                     ? GV_NOEXPAND
11538                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11539                 iscv
11540                     ? SVt_PVCV
11541                     : o->op_type == OP_RV2SV
11542                         ? SVt_PV
11543                         : o->op_type == OP_RV2AV
11544                             ? SVt_PVAV
11545                             : o->op_type == OP_RV2HV
11546                                 ? SVt_PVHV
11547                                 : SVt_PVGV);
11548         if (gv) {
11549             if (!isGV(gv)) {
11550                 assert(iscv);
11551                 assert(SvROK(gv));
11552                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11553                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11554                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11555             }
11556             OpTYPE_set(kid, OP_GV);
11557             SvREFCNT_dec(kid->op_sv);
11558 #ifdef USE_ITHREADS
11559             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11560             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11561             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11562             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11563             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11564 #else
11565             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11566 #endif
11567             kid->op_private = 0;
11568             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11569             SvFAKE_off(gv);
11570         }
11571     }
11572     return o;
11573 }
11574
11575 OP *
11576 Perl_ck_ftst(pTHX_ OP *o)
11577 {
11578     dVAR;
11579     const I32 type = o->op_type;
11580
11581     PERL_ARGS_ASSERT_CK_FTST;
11582
11583     if (o->op_flags & OPf_REF) {
11584         NOOP;
11585     }
11586     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11587         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11588         const OPCODE kidtype = kid->op_type;
11589
11590         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11591          && !kid->op_folded) {
11592             OP * const newop = newGVOP(type, OPf_REF,
11593                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11594             op_free(o);
11595             return newop;
11596         }
11597
11598         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11599             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11600             if (name) {
11601                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11602                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11603                             array_passed_to_stat, name);
11604             }
11605             else {
11606                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11607                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11608             }
11609        }
11610         scalar((OP *) kid);
11611         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11612             o->op_private |= OPpFT_ACCESS;
11613         if (type != OP_STAT && type != OP_LSTAT
11614             && PL_check[kidtype] == Perl_ck_ftst
11615             && kidtype != OP_STAT && kidtype != OP_LSTAT
11616         ) {
11617             o->op_private |= OPpFT_STACKED;
11618             kid->op_private |= OPpFT_STACKING;
11619             if (kidtype == OP_FTTTY && (
11620                    !(kid->op_private & OPpFT_STACKED)
11621                 || kid->op_private & OPpFT_AFTER_t
11622                ))
11623                 o->op_private |= OPpFT_AFTER_t;
11624         }
11625     }
11626     else {
11627         op_free(o);
11628         if (type == OP_FTTTY)
11629             o = newGVOP(type, OPf_REF, PL_stdingv);
11630         else
11631             o = newUNOP(type, 0, newDEFSVOP());
11632     }
11633     return o;
11634 }
11635
11636 OP *
11637 Perl_ck_fun(pTHX_ OP *o)
11638 {
11639     const int type = o->op_type;
11640     I32 oa = PL_opargs[type] >> OASHIFT;
11641
11642     PERL_ARGS_ASSERT_CK_FUN;
11643
11644     if (o->op_flags & OPf_STACKED) {
11645         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11646             oa &= ~OA_OPTIONAL;
11647         else
11648             return no_fh_allowed(o);
11649     }
11650
11651     if (o->op_flags & OPf_KIDS) {
11652         OP *prev_kid = NULL;
11653         OP *kid = cLISTOPo->op_first;
11654         I32 numargs = 0;
11655         bool seen_optional = FALSE;
11656
11657         if (kid->op_type == OP_PUSHMARK ||
11658             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11659         {
11660             prev_kid = kid;
11661             kid = OpSIBLING(kid);
11662         }
11663         if (kid && kid->op_type == OP_COREARGS) {
11664             bool optional = FALSE;
11665             while (oa) {
11666                 numargs++;
11667                 if (oa & OA_OPTIONAL) optional = TRUE;
11668                 oa = oa >> 4;
11669             }
11670             if (optional) o->op_private |= numargs;
11671             return o;
11672         }
11673
11674         while (oa) {
11675             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11676                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11677                     kid = newDEFSVOP();
11678                     /* append kid to chain */
11679                     op_sibling_splice(o, prev_kid, 0, kid);
11680                 }
11681                 seen_optional = TRUE;
11682             }
11683             if (!kid) break;
11684
11685             numargs++;
11686             switch (oa & 7) {
11687             case OA_SCALAR:
11688                 /* list seen where single (scalar) arg expected? */
11689                 if (numargs == 1 && !(oa >> 4)
11690                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11691                 {
11692                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11693                 }
11694                 if (type != OP_DELETE) scalar(kid);
11695                 break;
11696             case OA_LIST:
11697                 if (oa < 16) {
11698                     kid = 0;
11699                     continue;
11700                 }
11701                 else
11702                     list(kid);
11703                 break;
11704             case OA_AVREF:
11705                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11706                     && !OpHAS_SIBLING(kid))
11707                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11708                                    "Useless use of %s with no values",
11709                                    PL_op_desc[type]);
11710
11711                 if (kid->op_type == OP_CONST
11712                       && (  !SvROK(cSVOPx_sv(kid))
11713                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11714                         )
11715                     bad_type_pv(numargs, "array", o, kid);
11716                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11717                          || kid->op_type == OP_RV2GV) {
11718                     bad_type_pv(1, "array", o, kid);
11719                 }
11720                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11721                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11722                                          PL_op_desc[type]), 0);
11723                 }
11724                 else {
11725                     op_lvalue(kid, type);
11726                 }
11727                 break;
11728             case OA_HVREF:
11729                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11730                     bad_type_pv(numargs, "hash", o, kid);
11731                 op_lvalue(kid, type);
11732                 break;
11733             case OA_CVREF:
11734                 {
11735                     /* replace kid with newop in chain */
11736                     OP * const newop =
11737                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11738                     newop->op_next = newop;
11739                     kid = newop;
11740                 }
11741                 break;
11742             case OA_FILEREF:
11743                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11744                     if (kid->op_type == OP_CONST &&
11745                         (kid->op_private & OPpCONST_BARE))
11746                     {
11747                         OP * const newop = newGVOP(OP_GV, 0,
11748                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11749                         /* replace kid with newop in chain */
11750                         op_sibling_splice(o, prev_kid, 1, newop);
11751                         op_free(kid);
11752                         kid = newop;
11753                     }
11754                     else if (kid->op_type == OP_READLINE) {
11755                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11756                         bad_type_pv(numargs, "HANDLE", o, kid);
11757                     }
11758                     else {
11759                         I32 flags = OPf_SPECIAL;
11760                         I32 priv = 0;
11761                         PADOFFSET targ = 0;
11762
11763                         /* is this op a FH constructor? */
11764                         if (is_handle_constructor(o,numargs)) {
11765                             const char *name = NULL;
11766                             STRLEN len = 0;
11767                             U32 name_utf8 = 0;
11768                             bool want_dollar = TRUE;
11769
11770                             flags = 0;
11771                             /* Set a flag to tell rv2gv to vivify
11772                              * need to "prove" flag does not mean something
11773                              * else already - NI-S 1999/05/07
11774                              */
11775                             priv = OPpDEREF;
11776                             if (kid->op_type == OP_PADSV) {
11777                                 PADNAME * const pn
11778                                     = PAD_COMPNAME_SV(kid->op_targ);
11779                                 name = PadnamePV (pn);
11780                                 len  = PadnameLEN(pn);
11781                                 name_utf8 = PadnameUTF8(pn);
11782                             }
11783                             else if (kid->op_type == OP_RV2SV
11784                                      && kUNOP->op_first->op_type == OP_GV)
11785                             {
11786                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11787                                 name = GvNAME(gv);
11788                                 len = GvNAMELEN(gv);
11789                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11790                             }
11791                             else if (kid->op_type == OP_AELEM
11792                                      || kid->op_type == OP_HELEM)
11793                             {
11794                                  OP *firstop;
11795                                  OP *op = ((BINOP*)kid)->op_first;
11796                                  name = NULL;
11797                                  if (op) {
11798                                       SV *tmpstr = NULL;
11799                                       const char * const a =
11800                                            kid->op_type == OP_AELEM ?
11801                                            "[]" : "{}";
11802                                       if (((op->op_type == OP_RV2AV) ||
11803                                            (op->op_type == OP_RV2HV)) &&
11804                                           (firstop = ((UNOP*)op)->op_first) &&
11805                                           (firstop->op_type == OP_GV)) {
11806                                            /* packagevar $a[] or $h{} */
11807                                            GV * const gv = cGVOPx_gv(firstop);
11808                                            if (gv)
11809                                                 tmpstr =
11810                                                      Perl_newSVpvf(aTHX_
11811                                                                    "%s%c...%c",
11812                                                                    GvNAME(gv),
11813                                                                    a[0], a[1]);
11814                                       }
11815                                       else if (op->op_type == OP_PADAV
11816                                                || op->op_type == OP_PADHV) {
11817                                            /* lexicalvar $a[] or $h{} */
11818                                            const char * const padname =
11819                                                 PAD_COMPNAME_PV(op->op_targ);
11820                                            if (padname)
11821                                                 tmpstr =
11822                                                      Perl_newSVpvf(aTHX_
11823                                                                    "%s%c...%c",
11824                                                                    padname + 1,
11825                                                                    a[0], a[1]);
11826                                       }
11827                                       if (tmpstr) {
11828                                            name = SvPV_const(tmpstr, len);
11829                                            name_utf8 = SvUTF8(tmpstr);
11830                                            sv_2mortal(tmpstr);
11831                                       }
11832                                  }
11833                                  if (!name) {
11834                                       name = "__ANONIO__";
11835                                       len = 10;
11836                                       want_dollar = FALSE;
11837                                  }
11838                                  op_lvalue(kid, type);
11839                             }
11840                             if (name) {
11841                                 SV *namesv;
11842                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11843                                 namesv = PAD_SVl(targ);
11844                                 if (want_dollar && *name != '$')
11845                                     sv_setpvs(namesv, "$");
11846                                 else
11847                                     SvPVCLEAR(namesv);
11848                                 sv_catpvn(namesv, name, len);
11849                                 if ( name_utf8 ) SvUTF8_on(namesv);
11850                             }
11851                         }
11852                         scalar(kid);
11853                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11854                                     OP_RV2GV, flags);
11855                         kid->op_targ = targ;
11856                         kid->op_private |= priv;
11857                     }
11858                 }
11859                 scalar(kid);
11860                 break;
11861             case OA_SCALARREF:
11862                 if ((type == OP_UNDEF || type == OP_POS)
11863                     && numargs == 1 && !(oa >> 4)
11864                     && kid->op_type == OP_LIST)
11865                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11866                 op_lvalue(scalar(kid), type);
11867                 break;
11868             }
11869             oa >>= 4;
11870             prev_kid = kid;
11871             kid = OpSIBLING(kid);
11872         }
11873         /* FIXME - should the numargs or-ing move after the too many
11874          * arguments check? */
11875         o->op_private |= numargs;
11876         if (kid)
11877             return too_many_arguments_pv(o,OP_DESC(o), 0);
11878         listkids(o);
11879     }
11880     else if (PL_opargs[type] & OA_DEFGV) {
11881         /* Ordering of these two is important to keep f_map.t passing.  */
11882         op_free(o);
11883         return newUNOP(type, 0, newDEFSVOP());
11884     }
11885
11886     if (oa) {
11887         while (oa & OA_OPTIONAL)
11888             oa >>= 4;
11889         if (oa && oa != OA_LIST)
11890             return too_few_arguments_pv(o,OP_DESC(o), 0);
11891     }
11892     return o;
11893 }
11894
11895 OP *
11896 Perl_ck_glob(pTHX_ OP *o)
11897 {
11898     GV *gv;
11899
11900     PERL_ARGS_ASSERT_CK_GLOB;
11901
11902     o = ck_fun(o);
11903     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11904         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11905
11906     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11907     {
11908         /* convert
11909          *     glob
11910          *       \ null - const(wildcard)
11911          * into
11912          *     null
11913          *       \ enter
11914          *            \ list
11915          *                 \ mark - glob - rv2cv
11916          *                             |        \ gv(CORE::GLOBAL::glob)
11917          *                             |
11918          *                              \ null - const(wildcard)
11919          */
11920         o->op_flags |= OPf_SPECIAL;
11921         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11922         o = S_new_entersubop(aTHX_ gv, o);
11923         o = newUNOP(OP_NULL, 0, o);
11924         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11925         return o;
11926     }
11927     else o->op_flags &= ~OPf_SPECIAL;
11928 #if !defined(PERL_EXTERNAL_GLOB)
11929     if (!PL_globhook) {
11930         ENTER;
11931         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11932                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11933         LEAVE;
11934     }
11935 #endif /* !PERL_EXTERNAL_GLOB */
11936     gv = (GV *)newSV(0);
11937     gv_init(gv, 0, "", 0, 0);
11938     gv_IOadd(gv);
11939     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11940     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11941     scalarkids(o);
11942     return o;
11943 }
11944
11945 OP *
11946 Perl_ck_grep(pTHX_ OP *o)
11947 {
11948     LOGOP *gwop;
11949     OP *kid;
11950     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11951
11952     PERL_ARGS_ASSERT_CK_GREP;
11953
11954     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11955
11956     if (o->op_flags & OPf_STACKED) {
11957         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11958         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11959             return no_fh_allowed(o);
11960         o->op_flags &= ~OPf_STACKED;
11961     }
11962     kid = OpSIBLING(cLISTOPo->op_first);
11963     if (type == OP_MAPWHILE)
11964         list(kid);
11965     else
11966         scalar(kid);
11967     o = ck_fun(o);
11968     if (PL_parser && PL_parser->error_count)
11969         return o;
11970     kid = OpSIBLING(cLISTOPo->op_first);
11971     if (kid->op_type != OP_NULL)
11972         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11973     kid = kUNOP->op_first;
11974
11975     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11976     kid->op_next = (OP*)gwop;
11977     o->op_private = gwop->op_private = 0;
11978     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11979
11980     kid = OpSIBLING(cLISTOPo->op_first);
11981     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11982         op_lvalue(kid, OP_GREPSTART);
11983
11984     return (OP*)gwop;
11985 }
11986
11987 OP *
11988 Perl_ck_index(pTHX_ OP *o)
11989 {
11990     PERL_ARGS_ASSERT_CK_INDEX;
11991
11992     if (o->op_flags & OPf_KIDS) {
11993         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11994         if (kid)
11995             kid = OpSIBLING(kid);                       /* get past "big" */
11996         if (kid && kid->op_type == OP_CONST) {
11997             const bool save_taint = TAINT_get;
11998             SV *sv = kSVOP->op_sv;
11999             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12000                 && SvOK(sv) && !SvROK(sv))
12001             {
12002                 sv = newSV(0);
12003                 sv_copypv(sv, kSVOP->op_sv);
12004                 SvREFCNT_dec_NN(kSVOP->op_sv);
12005                 kSVOP->op_sv = sv;
12006             }
12007             if (SvOK(sv)) fbm_compile(sv, 0);
12008             TAINT_set(save_taint);
12009 #ifdef NO_TAINT_SUPPORT
12010             PERL_UNUSED_VAR(save_taint);
12011 #endif
12012         }
12013     }
12014     return ck_fun(o);
12015 }
12016
12017 OP *
12018 Perl_ck_lfun(pTHX_ OP *o)
12019 {
12020     const OPCODE type = o->op_type;
12021
12022     PERL_ARGS_ASSERT_CK_LFUN;
12023
12024     return modkids(ck_fun(o), type);
12025 }
12026
12027 OP *
12028 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12029 {
12030     PERL_ARGS_ASSERT_CK_DEFINED;
12031
12032     if ((o->op_flags & OPf_KIDS)) {
12033         switch (cUNOPo->op_first->op_type) {
12034         case OP_RV2AV:
12035         case OP_PADAV:
12036             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12037                              " (Maybe you should just omit the defined()?)");
12038             NOT_REACHED; /* NOTREACHED */
12039             break;
12040         case OP_RV2HV:
12041         case OP_PADHV:
12042             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12043                              " (Maybe you should just omit the defined()?)");
12044             NOT_REACHED; /* NOTREACHED */
12045             break;
12046         default:
12047             /* no warning */
12048             break;
12049         }
12050     }
12051     return ck_rfun(o);
12052 }
12053
12054 OP *
12055 Perl_ck_readline(pTHX_ OP *o)
12056 {
12057     PERL_ARGS_ASSERT_CK_READLINE;
12058
12059     if (o->op_flags & OPf_KIDS) {
12060          OP *kid = cLISTOPo->op_first;
12061          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12062     }
12063     else {
12064         OP * const newop
12065             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12066         op_free(o);
12067         return newop;
12068     }
12069     return o;
12070 }
12071
12072 OP *
12073 Perl_ck_rfun(pTHX_ OP *o)
12074 {
12075     const OPCODE type = o->op_type;
12076
12077     PERL_ARGS_ASSERT_CK_RFUN;
12078
12079     return refkids(ck_fun(o), type);
12080 }
12081
12082 OP *
12083 Perl_ck_listiob(pTHX_ OP *o)
12084 {
12085     OP *kid;
12086
12087     PERL_ARGS_ASSERT_CK_LISTIOB;
12088
12089     kid = cLISTOPo->op_first;
12090     if (!kid) {
12091         o = force_list(o, 1);
12092         kid = cLISTOPo->op_first;
12093     }
12094     if (kid->op_type == OP_PUSHMARK)
12095         kid = OpSIBLING(kid);
12096     if (kid && o->op_flags & OPf_STACKED)
12097         kid = OpSIBLING(kid);
12098     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12099         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12100          && !kid->op_folded) {
12101             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12102             scalar(kid);
12103             /* replace old const op with new OP_RV2GV parent */
12104             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12105                                         OP_RV2GV, OPf_REF);
12106             kid = OpSIBLING(kid);
12107         }
12108     }
12109
12110     if (!kid)
12111         op_append_elem(o->op_type, o, newDEFSVOP());
12112
12113     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12114     return listkids(o);
12115 }
12116
12117 OP *
12118 Perl_ck_smartmatch(pTHX_ OP *o)
12119 {
12120     dVAR;
12121     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12122     if (0 == (o->op_flags & OPf_SPECIAL)) {
12123         OP *first  = cBINOPo->op_first;
12124         OP *second = OpSIBLING(first);
12125
12126         /* Implicitly take a reference to an array or hash */
12127
12128         /* remove the original two siblings, then add back the
12129          * (possibly different) first and second sibs.
12130          */
12131         op_sibling_splice(o, NULL, 1, NULL);
12132         op_sibling_splice(o, NULL, 1, NULL);
12133         first  = ref_array_or_hash(first);
12134         second = ref_array_or_hash(second);
12135         op_sibling_splice(o, NULL, 0, second);
12136         op_sibling_splice(o, NULL, 0, first);
12137
12138         /* Implicitly take a reference to a regular expression */
12139         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12140             OpTYPE_set(first, OP_QR);
12141         }
12142         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12143             OpTYPE_set(second, OP_QR);
12144         }
12145     }
12146
12147     return o;
12148 }
12149
12150
12151 static OP *
12152 S_maybe_targlex(pTHX_ OP *o)
12153 {
12154     OP * const kid = cLISTOPo->op_first;
12155     /* has a disposable target? */
12156     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12157         && !(kid->op_flags & OPf_STACKED)
12158         /* Cannot steal the second time! */
12159         && !(kid->op_private & OPpTARGET_MY)
12160         )
12161     {
12162         OP * const kkid = OpSIBLING(kid);
12163
12164         /* Can just relocate the target. */
12165         if (kkid && kkid->op_type == OP_PADSV
12166             && (!(kkid->op_private & OPpLVAL_INTRO)
12167                || kkid->op_private & OPpPAD_STATE))
12168         {
12169             kid->op_targ = kkid->op_targ;
12170             kkid->op_targ = 0;
12171             /* Now we do not need PADSV and SASSIGN.
12172              * Detach kid and free the rest. */
12173             op_sibling_splice(o, NULL, 1, NULL);
12174             op_free(o);
12175             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12176             return kid;
12177         }
12178     }
12179     return o;
12180 }
12181
12182 OP *
12183 Perl_ck_sassign(pTHX_ OP *o)
12184 {
12185     dVAR;
12186     OP * const kid = cBINOPo->op_first;
12187
12188     PERL_ARGS_ASSERT_CK_SASSIGN;
12189
12190     if (OpHAS_SIBLING(kid)) {
12191         OP *kkid = OpSIBLING(kid);
12192         /* For state variable assignment with attributes, kkid is a list op
12193            whose op_last is a padsv. */
12194         if ((kkid->op_type == OP_PADSV ||
12195              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12196               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12197              )
12198             )
12199                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12200                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12201             return S_newONCEOP(aTHX_ o, kkid);
12202         }
12203     }
12204     return S_maybe_targlex(aTHX_ o);
12205 }
12206
12207
12208 OP *
12209 Perl_ck_match(pTHX_ OP *o)
12210 {
12211     PERL_UNUSED_CONTEXT;
12212     PERL_ARGS_ASSERT_CK_MATCH;
12213
12214     return o;
12215 }
12216
12217 OP *
12218 Perl_ck_method(pTHX_ OP *o)
12219 {
12220     SV *sv, *methsv, *rclass;
12221     const char* method;
12222     char* compatptr;
12223     int utf8;
12224     STRLEN len, nsplit = 0, i;
12225     OP* new_op;
12226     OP * const kid = cUNOPo->op_first;
12227
12228     PERL_ARGS_ASSERT_CK_METHOD;
12229     if (kid->op_type != OP_CONST) return o;
12230
12231     sv = kSVOP->op_sv;
12232
12233     /* replace ' with :: */
12234     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12235                                         SvEND(sv) - SvPVX(sv) )))
12236     {
12237         *compatptr = ':';
12238         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12239     }
12240
12241     method = SvPVX_const(sv);
12242     len = SvCUR(sv);
12243     utf8 = SvUTF8(sv) ? -1 : 1;
12244
12245     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12246         nsplit = i+1;
12247         break;
12248     }
12249
12250     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12251
12252     if (!nsplit) { /* $proto->method() */
12253         op_free(o);
12254         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12255     }
12256
12257     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12258         op_free(o);
12259         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12260     }
12261
12262     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12263     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12264         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12265         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12266     } else {
12267         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12268         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12269     }
12270 #ifdef USE_ITHREADS
12271     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12272 #else
12273     cMETHOPx(new_op)->op_rclass_sv = rclass;
12274 #endif
12275     op_free(o);
12276     return new_op;
12277 }
12278
12279 OP *
12280 Perl_ck_null(pTHX_ OP *o)
12281 {
12282     PERL_ARGS_ASSERT_CK_NULL;
12283     PERL_UNUSED_CONTEXT;
12284     return o;
12285 }
12286
12287 OP *
12288 Perl_ck_open(pTHX_ OP *o)
12289 {
12290     PERL_ARGS_ASSERT_CK_OPEN;
12291
12292     S_io_hints(aTHX_ o);
12293     {
12294          /* In case of three-arg dup open remove strictness
12295           * from the last arg if it is a bareword. */
12296          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12297          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12298          OP *oa;
12299          const char *mode;
12300
12301          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12302              (last->op_private & OPpCONST_BARE) &&
12303              (last->op_private & OPpCONST_STRICT) &&
12304              (oa = OpSIBLING(first)) &&         /* The fh. */
12305              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12306              (oa->op_type == OP_CONST) &&
12307              SvPOK(((SVOP*)oa)->op_sv) &&
12308              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12309              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12310              (last == OpSIBLING(oa)))                   /* The bareword. */
12311               last->op_private &= ~OPpCONST_STRICT;
12312     }
12313     return ck_fun(o);
12314 }
12315
12316 OP *
12317 Perl_ck_prototype(pTHX_ OP *o)
12318 {
12319     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12320     if (!(o->op_flags & OPf_KIDS)) {
12321         op_free(o);
12322         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12323     }
12324     return o;
12325 }
12326
12327 OP *
12328 Perl_ck_refassign(pTHX_ OP *o)
12329 {
12330     OP * const right = cLISTOPo->op_first;
12331     OP * const left = OpSIBLING(right);
12332     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12333     bool stacked = 0;
12334
12335     PERL_ARGS_ASSERT_CK_REFASSIGN;
12336     assert (left);
12337     assert (left->op_type == OP_SREFGEN);
12338
12339     o->op_private = 0;
12340     /* we use OPpPAD_STATE in refassign to mean either of those things,
12341      * and the code assumes the two flags occupy the same bit position
12342      * in the various ops below */
12343     assert(OPpPAD_STATE == OPpOUR_INTRO);
12344
12345     switch (varop->op_type) {
12346     case OP_PADAV:
12347         o->op_private |= OPpLVREF_AV;
12348         goto settarg;
12349     case OP_PADHV:
12350         o->op_private |= OPpLVREF_HV;
12351         /* FALLTHROUGH */
12352     case OP_PADSV:
12353       settarg:
12354         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12355         o->op_targ = varop->op_targ;
12356         varop->op_targ = 0;
12357         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12358         break;
12359
12360     case OP_RV2AV:
12361         o->op_private |= OPpLVREF_AV;
12362         goto checkgv;
12363         NOT_REACHED; /* NOTREACHED */
12364     case OP_RV2HV:
12365         o->op_private |= OPpLVREF_HV;
12366         /* FALLTHROUGH */
12367     case OP_RV2SV:
12368       checkgv:
12369         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12370         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12371       detach_and_stack:
12372         /* Point varop to its GV kid, detached.  */
12373         varop = op_sibling_splice(varop, NULL, -1, NULL);
12374         stacked = TRUE;
12375         break;
12376     case OP_RV2CV: {
12377         OP * const kidparent =
12378             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12379         OP * const kid = cUNOPx(kidparent)->op_first;
12380         o->op_private |= OPpLVREF_CV;
12381         if (kid->op_type == OP_GV) {
12382             varop = kidparent;
12383             goto detach_and_stack;
12384         }
12385         if (kid->op_type != OP_PADCV)   goto bad;
12386         o->op_targ = kid->op_targ;
12387         kid->op_targ = 0;
12388         break;
12389     }
12390     case OP_AELEM:
12391     case OP_HELEM:
12392         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12393         o->op_private |= OPpLVREF_ELEM;
12394         op_null(varop);
12395         stacked = TRUE;
12396         /* Detach varop.  */
12397         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12398         break;
12399     default:
12400       bad:
12401         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12402         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12403                                 "assignment",
12404                                  OP_DESC(varop)));
12405         return o;
12406     }
12407     if (!FEATURE_REFALIASING_IS_ENABLED)
12408         Perl_croak(aTHX_
12409                   "Experimental aliasing via reference not enabled");
12410     Perl_ck_warner_d(aTHX_
12411                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12412                     "Aliasing via reference is experimental");
12413     if (stacked) {
12414         o->op_flags |= OPf_STACKED;
12415         op_sibling_splice(o, right, 1, varop);
12416     }
12417     else {
12418         o->op_flags &=~ OPf_STACKED;
12419         op_sibling_splice(o, right, 1, NULL);
12420     }
12421     op_free(left);
12422     return o;
12423 }
12424
12425 OP *
12426 Perl_ck_repeat(pTHX_ OP *o)
12427 {
12428     PERL_ARGS_ASSERT_CK_REPEAT;
12429
12430     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12431         OP* kids;
12432         o->op_private |= OPpREPEAT_DOLIST;
12433         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12434         kids = force_list(kids, 1); /* promote it to a list */
12435         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12436     }
12437     else
12438         scalar(o);
12439     return o;
12440 }
12441
12442 OP *
12443 Perl_ck_require(pTHX_ OP *o)
12444 {
12445     GV* gv;
12446
12447     PERL_ARGS_ASSERT_CK_REQUIRE;
12448
12449     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12450         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12451         U32 hash;
12452         char *s;
12453         STRLEN len;
12454         if (kid->op_type == OP_CONST) {
12455           SV * const sv = kid->op_sv;
12456           U32 const was_readonly = SvREADONLY(sv);
12457           if (kid->op_private & OPpCONST_BARE) {
12458             dVAR;
12459             const char *end;
12460             HEK *hek;
12461
12462             if (was_readonly) {
12463                     SvREADONLY_off(sv);
12464             }
12465             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12466
12467             s = SvPVX(sv);
12468             len = SvCUR(sv);
12469             end = s + len;
12470             /* treat ::foo::bar as foo::bar */
12471             if (len >= 2 && s[0] == ':' && s[1] == ':')
12472                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12473             if (s == end)
12474                 DIE(aTHX_ "Bareword in require maps to empty filename");
12475
12476             for (; s < end; s++) {
12477                 if (*s == ':' && s[1] == ':') {
12478                     *s = '/';
12479                     Move(s+2, s+1, end - s - 1, char);
12480                     --end;
12481                 }
12482             }
12483             SvEND_set(sv, end);
12484             sv_catpvs(sv, ".pm");
12485             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12486             hek = share_hek(SvPVX(sv),
12487                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12488                             hash);
12489             sv_sethek(sv, hek);
12490             unshare_hek(hek);
12491             SvFLAGS(sv) |= was_readonly;
12492           }
12493           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12494                 && !SvVOK(sv)) {
12495             s = SvPV(sv, len);
12496             if (SvREFCNT(sv) > 1) {
12497                 kid->op_sv = newSVpvn_share(
12498                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12499                 SvREFCNT_dec_NN(sv);
12500             }
12501             else {
12502                 dVAR;
12503                 HEK *hek;
12504                 if (was_readonly) SvREADONLY_off(sv);
12505                 PERL_HASH(hash, s, len);
12506                 hek = share_hek(s,
12507                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12508                                 hash);
12509                 sv_sethek(sv, hek);
12510                 unshare_hek(hek);
12511                 SvFLAGS(sv) |= was_readonly;
12512             }
12513           }
12514         }
12515     }
12516
12517     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12518         /* handle override, if any */
12519      && (gv = gv_override("require", 7))) {
12520         OP *kid, *newop;
12521         if (o->op_flags & OPf_KIDS) {
12522             kid = cUNOPo->op_first;
12523             op_sibling_splice(o, NULL, -1, NULL);
12524         }
12525         else {
12526             kid = newDEFSVOP();
12527         }
12528         op_free(o);
12529         newop = S_new_entersubop(aTHX_ gv, kid);
12530         return newop;
12531     }
12532
12533     return ck_fun(o);
12534 }
12535
12536 OP *
12537 Perl_ck_return(pTHX_ OP *o)
12538 {
12539     OP *kid;
12540
12541     PERL_ARGS_ASSERT_CK_RETURN;
12542
12543     kid = OpSIBLING(cLISTOPo->op_first);
12544     if (PL_compcv && CvLVALUE(PL_compcv)) {
12545         for (; kid; kid = OpSIBLING(kid))
12546             op_lvalue(kid, OP_LEAVESUBLV);
12547     }
12548
12549     return o;
12550 }
12551
12552 OP *
12553 Perl_ck_select(pTHX_ OP *o)
12554 {
12555     dVAR;
12556     OP* kid;
12557
12558     PERL_ARGS_ASSERT_CK_SELECT;
12559
12560     if (o->op_flags & OPf_KIDS) {
12561         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12562         if (kid && OpHAS_SIBLING(kid)) {
12563             OpTYPE_set(o, OP_SSELECT);
12564             o = ck_fun(o);
12565             return fold_constants(op_integerize(op_std_init(o)));
12566         }
12567     }
12568     o = ck_fun(o);
12569     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12570     if (kid && kid->op_type == OP_RV2GV)
12571         kid->op_private &= ~HINT_STRICT_REFS;
12572     return o;
12573 }
12574
12575 OP *
12576 Perl_ck_shift(pTHX_ OP *o)
12577 {
12578     const I32 type = o->op_type;
12579
12580     PERL_ARGS_ASSERT_CK_SHIFT;
12581
12582     if (!(o->op_flags & OPf_KIDS)) {
12583         OP *argop;
12584
12585         if (!CvUNIQUE(PL_compcv)) {
12586             o->op_flags |= OPf_SPECIAL;
12587             return o;
12588         }
12589
12590         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12591         op_free(o);
12592         return newUNOP(type, 0, scalar(argop));
12593     }
12594     return scalar(ck_fun(o));
12595 }
12596
12597 OP *
12598 Perl_ck_sort(pTHX_ OP *o)
12599 {
12600     OP *firstkid;
12601     OP *kid;
12602     HV * const hinthv =
12603         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12604     U8 stacked;
12605
12606     PERL_ARGS_ASSERT_CK_SORT;
12607
12608     if (hinthv) {
12609             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12610             if (svp) {
12611                 const I32 sorthints = (I32)SvIV(*svp);
12612                 if ((sorthints & HINT_SORT_STABLE) != 0)
12613                     o->op_private |= OPpSORT_STABLE;
12614                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12615                     o->op_private |= OPpSORT_UNSTABLE;
12616             }
12617     }
12618
12619     if (o->op_flags & OPf_STACKED)
12620         simplify_sort(o);
12621     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12622
12623     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12624         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12625
12626         /* if the first arg is a code block, process it and mark sort as
12627          * OPf_SPECIAL */
12628         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12629             LINKLIST(kid);
12630             if (kid->op_type == OP_LEAVE)
12631                     op_null(kid);                       /* wipe out leave */
12632             /* Prevent execution from escaping out of the sort block. */
12633             kid->op_next = 0;
12634
12635             /* provide scalar context for comparison function/block */
12636             kid = scalar(firstkid);
12637             kid->op_next = kid;
12638             o->op_flags |= OPf_SPECIAL;
12639         }
12640         else if (kid->op_type == OP_CONST
12641               && kid->op_private & OPpCONST_BARE) {
12642             char tmpbuf[256];
12643             STRLEN len;
12644             PADOFFSET off;
12645             const char * const name = SvPV(kSVOP_sv, len);
12646             *tmpbuf = '&';
12647             assert (len < 256);
12648             Copy(name, tmpbuf+1, len, char);
12649             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12650             if (off != NOT_IN_PAD) {
12651                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12652                     SV * const fq =
12653                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12654                     sv_catpvs(fq, "::");
12655                     sv_catsv(fq, kSVOP_sv);
12656                     SvREFCNT_dec_NN(kSVOP_sv);
12657                     kSVOP->op_sv = fq;
12658                 }
12659                 else {
12660                     OP * const padop = newOP(OP_PADCV, 0);
12661                     padop->op_targ = off;
12662                     /* replace the const op with the pad op */
12663                     op_sibling_splice(firstkid, NULL, 1, padop);
12664                     op_free(kid);
12665                 }
12666             }
12667         }
12668
12669         firstkid = OpSIBLING(firstkid);
12670     }
12671
12672     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12673         /* provide list context for arguments */
12674         list(kid);
12675         if (stacked)
12676             op_lvalue(kid, OP_GREPSTART);
12677     }
12678
12679     return o;
12680 }
12681
12682 /* for sort { X } ..., where X is one of
12683  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12684  * elide the second child of the sort (the one containing X),
12685  * and set these flags as appropriate
12686         OPpSORT_NUMERIC;
12687         OPpSORT_INTEGER;
12688         OPpSORT_DESCEND;
12689  * Also, check and warn on lexical $a, $b.
12690  */
12691
12692 STATIC void
12693 S_simplify_sort(pTHX_ OP *o)
12694 {
12695     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12696     OP *k;
12697     int descending;
12698     GV *gv;
12699     const char *gvname;
12700     bool have_scopeop;
12701
12702     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12703
12704     kid = kUNOP->op_first;                              /* get past null */
12705     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12706      && kid->op_type != OP_LEAVE)
12707         return;
12708     kid = kLISTOP->op_last;                             /* get past scope */
12709     switch(kid->op_type) {
12710         case OP_NCMP:
12711         case OP_I_NCMP:
12712         case OP_SCMP:
12713             if (!have_scopeop) goto padkids;
12714             break;
12715         default:
12716             return;
12717     }
12718     k = kid;                                            /* remember this node*/
12719     if (kBINOP->op_first->op_type != OP_RV2SV
12720      || kBINOP->op_last ->op_type != OP_RV2SV)
12721     {
12722         /*
12723            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12724            then used in a comparison.  This catches most, but not
12725            all cases.  For instance, it catches
12726                sort { my($a); $a <=> $b }
12727            but not
12728                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12729            (although why you'd do that is anyone's guess).
12730         */
12731
12732        padkids:
12733         if (!ckWARN(WARN_SYNTAX)) return;
12734         kid = kBINOP->op_first;
12735         do {
12736             if (kid->op_type == OP_PADSV) {
12737                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12738                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12739                  && (  PadnamePV(name)[1] == 'a'
12740                     || PadnamePV(name)[1] == 'b'  ))
12741                     /* diag_listed_as: "my %s" used in sort comparison */
12742                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12743                                      "\"%s %s\" used in sort comparison",
12744                                       PadnameIsSTATE(name)
12745                                         ? "state"
12746                                         : "my",
12747                                       PadnamePV(name));
12748             }
12749         } while ((kid = OpSIBLING(kid)));
12750         return;
12751     }
12752     kid = kBINOP->op_first;                             /* get past cmp */
12753     if (kUNOP->op_first->op_type != OP_GV)
12754         return;
12755     kid = kUNOP->op_first;                              /* get past rv2sv */
12756     gv = kGVOP_gv;
12757     if (GvSTASH(gv) != PL_curstash)
12758         return;
12759     gvname = GvNAME(gv);
12760     if (*gvname == 'a' && gvname[1] == '\0')
12761         descending = 0;
12762     else if (*gvname == 'b' && gvname[1] == '\0')
12763         descending = 1;
12764     else
12765         return;
12766
12767     kid = k;                                            /* back to cmp */
12768     /* already checked above that it is rv2sv */
12769     kid = kBINOP->op_last;                              /* down to 2nd arg */
12770     if (kUNOP->op_first->op_type != OP_GV)
12771         return;
12772     kid = kUNOP->op_first;                              /* get past rv2sv */
12773     gv = kGVOP_gv;
12774     if (GvSTASH(gv) != PL_curstash)
12775         return;
12776     gvname = GvNAME(gv);
12777     if ( descending
12778          ? !(*gvname == 'a' && gvname[1] == '\0')
12779          : !(*gvname == 'b' && gvname[1] == '\0'))
12780         return;
12781     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12782     if (descending)
12783         o->op_private |= OPpSORT_DESCEND;
12784     if (k->op_type == OP_NCMP)
12785         o->op_private |= OPpSORT_NUMERIC;
12786     if (k->op_type == OP_I_NCMP)
12787         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12788     kid = OpSIBLING(cLISTOPo->op_first);
12789     /* cut out and delete old block (second sibling) */
12790     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12791     op_free(kid);
12792 }
12793
12794 OP *
12795 Perl_ck_split(pTHX_ OP *o)
12796 {
12797     dVAR;
12798     OP *kid;
12799     OP *sibs;
12800
12801     PERL_ARGS_ASSERT_CK_SPLIT;
12802
12803     assert(o->op_type == OP_LIST);
12804
12805     if (o->op_flags & OPf_STACKED)
12806         return no_fh_allowed(o);
12807
12808     kid = cLISTOPo->op_first;
12809     /* delete leading NULL node, then add a CONST if no other nodes */
12810     assert(kid->op_type == OP_NULL);
12811     op_sibling_splice(o, NULL, 1,
12812         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12813     op_free(kid);
12814     kid = cLISTOPo->op_first;
12815
12816     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12817         /* remove match expression, and replace with new optree with
12818          * a match op at its head */
12819         op_sibling_splice(o, NULL, 1, NULL);
12820         /* pmruntime will handle split " " behavior with flag==2 */
12821         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12822         op_sibling_splice(o, NULL, 0, kid);
12823     }
12824
12825     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12826
12827     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12828       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12829                      "Use of /g modifier is meaningless in split");
12830     }
12831
12832     /* eliminate the split op, and move the match op (plus any children)
12833      * into its place, then convert the match op into a split op. i.e.
12834      *
12835      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12836      *    |                        |                     |
12837      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12838      *    |                        |                     |
12839      *    R                        X - Y                 X - Y
12840      *    |
12841      *    X - Y
12842      *
12843      * (R, if it exists, will be a regcomp op)
12844      */
12845
12846     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12847     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12848     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12849     OpTYPE_set(kid, OP_SPLIT);
12850     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12851     kid->op_private = o->op_private;
12852     op_free(o);
12853     o = kid;
12854     kid = sibs; /* kid is now the string arg of the split */
12855
12856     if (!kid) {
12857         kid = newDEFSVOP();
12858         op_append_elem(OP_SPLIT, o, kid);
12859     }
12860     scalar(kid);
12861
12862     kid = OpSIBLING(kid);
12863     if (!kid) {
12864         kid = newSVOP(OP_CONST, 0, newSViv(0));
12865         op_append_elem(OP_SPLIT, o, kid);
12866         o->op_private |= OPpSPLIT_IMPLIM;
12867     }
12868     scalar(kid);
12869
12870     if (OpHAS_SIBLING(kid))
12871         return too_many_arguments_pv(o,OP_DESC(o), 0);
12872
12873     return o;
12874 }
12875
12876 OP *
12877 Perl_ck_stringify(pTHX_ OP *o)
12878 {
12879     OP * const kid = OpSIBLING(cUNOPo->op_first);
12880     PERL_ARGS_ASSERT_CK_STRINGIFY;
12881     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12882          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12883          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12884         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12885     {
12886         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12887         op_free(o);
12888         return kid;
12889     }
12890     return ck_fun(o);
12891 }
12892
12893 OP *
12894 Perl_ck_join(pTHX_ OP *o)
12895 {
12896     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12897
12898     PERL_ARGS_ASSERT_CK_JOIN;
12899
12900     if (kid && kid->op_type == OP_MATCH) {
12901         if (ckWARN(WARN_SYNTAX)) {
12902             const REGEXP *re = PM_GETRE(kPMOP);
12903             const SV *msg = re
12904                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12905                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12906                     : newSVpvs_flags( "STRING", SVs_TEMP );
12907             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12908                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12909                         SVfARG(msg), SVfARG(msg));
12910         }
12911     }
12912     if (kid
12913      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12914         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12915         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12916            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12917     {
12918         const OP * const bairn = OpSIBLING(kid); /* the list */
12919         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12920          && OP_GIMME(bairn,0) == G_SCALAR)
12921         {
12922             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12923                                      op_sibling_splice(o, kid, 1, NULL));
12924             op_free(o);
12925             return ret;
12926         }
12927     }
12928
12929     return ck_fun(o);
12930 }
12931
12932 /*
12933 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12934
12935 Examines an op, which is expected to identify a subroutine at runtime,
12936 and attempts to determine at compile time which subroutine it identifies.
12937 This is normally used during Perl compilation to determine whether
12938 a prototype can be applied to a function call.  C<cvop> is the op
12939 being considered, normally an C<rv2cv> op.  A pointer to the identified
12940 subroutine is returned, if it could be determined statically, and a null
12941 pointer is returned if it was not possible to determine statically.
12942
12943 Currently, the subroutine can be identified statically if the RV that the
12944 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12945 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12946 suitable if the constant value must be an RV pointing to a CV.  Details of
12947 this process may change in future versions of Perl.  If the C<rv2cv> op
12948 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12949 the subroutine statically: this flag is used to suppress compile-time
12950 magic on a subroutine call, forcing it to use default runtime behaviour.
12951
12952 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12953 of a GV reference is modified.  If a GV was examined and its CV slot was
12954 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12955 If the op is not optimised away, and the CV slot is later populated with
12956 a subroutine having a prototype, that flag eventually triggers the warning
12957 "called too early to check prototype".
12958
12959 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12960 of returning a pointer to the subroutine it returns a pointer to the
12961 GV giving the most appropriate name for the subroutine in this context.
12962 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12963 (C<CvANON>) subroutine that is referenced through a GV it will be the
12964 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12965 A null pointer is returned as usual if there is no statically-determinable
12966 subroutine.
12967
12968 =cut
12969 */
12970
12971 /* shared by toke.c:yylex */
12972 CV *
12973 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12974 {
12975     PADNAME *name = PAD_COMPNAME(off);
12976     CV *compcv = PL_compcv;
12977     while (PadnameOUTER(name)) {
12978         assert(PARENT_PAD_INDEX(name));
12979         compcv = CvOUTSIDE(compcv);
12980         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12981                 [off = PARENT_PAD_INDEX(name)];
12982     }
12983     assert(!PadnameIsOUR(name));
12984     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12985         return PadnamePROTOCV(name);
12986     }
12987     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12988 }
12989
12990 CV *
12991 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12992 {
12993     OP *rvop;
12994     CV *cv;
12995     GV *gv;
12996     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12997     if (flags & ~RV2CVOPCV_FLAG_MASK)
12998         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12999     if (cvop->op_type != OP_RV2CV)
13000         return NULL;
13001     if (cvop->op_private & OPpENTERSUB_AMPER)
13002         return NULL;
13003     if (!(cvop->op_flags & OPf_KIDS))
13004         return NULL;
13005     rvop = cUNOPx(cvop)->op_first;
13006     switch (rvop->op_type) {
13007         case OP_GV: {
13008             gv = cGVOPx_gv(rvop);
13009             if (!isGV(gv)) {
13010                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13011                     cv = MUTABLE_CV(SvRV(gv));
13012                     gv = NULL;
13013                     break;
13014                 }
13015                 if (flags & RV2CVOPCV_RETURN_STUB)
13016                     return (CV *)gv;
13017                 else return NULL;
13018             }
13019             cv = GvCVu(gv);
13020             if (!cv) {
13021                 if (flags & RV2CVOPCV_MARK_EARLY)
13022                     rvop->op_private |= OPpEARLY_CV;
13023                 return NULL;
13024             }
13025         } break;
13026         case OP_CONST: {
13027             SV *rv = cSVOPx_sv(rvop);
13028             if (!SvROK(rv))
13029                 return NULL;
13030             cv = (CV*)SvRV(rv);
13031             gv = NULL;
13032         } break;
13033         case OP_PADCV: {
13034             cv = find_lexical_cv(rvop->op_targ);
13035             gv = NULL;
13036         } break;
13037         default: {
13038             return NULL;
13039         } NOT_REACHED; /* NOTREACHED */
13040     }
13041     if (SvTYPE((SV*)cv) != SVt_PVCV)
13042         return NULL;
13043     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13044         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13045             gv = CvGV(cv);
13046         return (CV*)gv;
13047     }
13048     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13049         if (CvLEXICAL(cv) || CvNAMED(cv))
13050             return NULL;
13051         if (!CvANON(cv) || !gv)
13052             gv = CvGV(cv);
13053         return (CV*)gv;
13054
13055     } else {
13056         return cv;
13057     }
13058 }
13059
13060 /*
13061 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13062
13063 Performs the default fixup of the arguments part of an C<entersub>
13064 op tree.  This consists of applying list context to each of the
13065 argument ops.  This is the standard treatment used on a call marked
13066 with C<&>, or a method call, or a call through a subroutine reference,
13067 or any other call where the callee can't be identified at compile time,
13068 or a call where the callee has no prototype.
13069
13070 =cut
13071 */
13072
13073 OP *
13074 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13075 {
13076     OP *aop;
13077
13078     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13079
13080     aop = cUNOPx(entersubop)->op_first;
13081     if (!OpHAS_SIBLING(aop))
13082         aop = cUNOPx(aop)->op_first;
13083     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13084         /* skip the extra attributes->import() call implicitly added in
13085          * something like foo(my $x : bar)
13086          */
13087         if (   aop->op_type == OP_ENTERSUB
13088             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13089         )
13090             continue;
13091         list(aop);
13092         op_lvalue(aop, OP_ENTERSUB);
13093     }
13094     return entersubop;
13095 }
13096
13097 /*
13098 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13099
13100 Performs the fixup of the arguments part of an C<entersub> op tree
13101 based on a subroutine prototype.  This makes various modifications to
13102 the argument ops, from applying context up to inserting C<refgen> ops,
13103 and checking the number and syntactic types of arguments, as directed by
13104 the prototype.  This is the standard treatment used on a subroutine call,
13105 not marked with C<&>, where the callee can be identified at compile time
13106 and has a prototype.
13107
13108 C<protosv> supplies the subroutine prototype to be applied to the call.
13109 It may be a normal defined scalar, of which the string value will be used.
13110 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13111 that has been cast to C<SV*>) which has a prototype.  The prototype
13112 supplied, in whichever form, does not need to match the actual callee
13113 referenced by the op tree.
13114
13115 If the argument ops disagree with the prototype, for example by having
13116 an unacceptable number of arguments, a valid op tree is returned anyway.
13117 The error is reflected in the parser state, normally resulting in a single
13118 exception at the top level of parsing which covers all the compilation
13119 errors that occurred.  In the error message, the callee is referred to
13120 by the name defined by the C<namegv> parameter.
13121
13122 =cut
13123 */
13124
13125 OP *
13126 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13127 {
13128     STRLEN proto_len;
13129     const char *proto, *proto_end;
13130     OP *aop, *prev, *cvop, *parent;
13131     int optional = 0;
13132     I32 arg = 0;
13133     I32 contextclass = 0;
13134     const char *e = NULL;
13135     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13136     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13137         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13138                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13139     if (SvTYPE(protosv) == SVt_PVCV)
13140          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13141     else proto = SvPV(protosv, proto_len);
13142     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13143     proto_end = proto + proto_len;
13144     parent = entersubop;
13145     aop = cUNOPx(entersubop)->op_first;
13146     if (!OpHAS_SIBLING(aop)) {
13147         parent = aop;
13148         aop = cUNOPx(aop)->op_first;
13149     }
13150     prev = aop;
13151     aop = OpSIBLING(aop);
13152     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13153     while (aop != cvop) {
13154         OP* o3 = aop;
13155
13156         if (proto >= proto_end)
13157         {
13158             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13159             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13160                                         SVfARG(namesv)), SvUTF8(namesv));
13161             return entersubop;
13162         }
13163
13164         switch (*proto) {
13165             case ';':
13166                 optional = 1;
13167                 proto++;
13168                 continue;
13169             case '_':
13170                 /* _ must be at the end */
13171                 if (proto[1] && !strchr(";@%", proto[1]))
13172                     goto oops;
13173                 /* FALLTHROUGH */
13174             case '$':
13175                 proto++;
13176                 arg++;
13177                 scalar(aop);
13178                 break;
13179             case '%':
13180             case '@':
13181                 list(aop);
13182                 arg++;
13183                 break;
13184             case '&':
13185                 proto++;
13186                 arg++;
13187                 if (    o3->op_type != OP_UNDEF
13188                     && (o3->op_type != OP_SREFGEN
13189                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13190                                 != OP_ANONCODE
13191                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13192                                 != OP_RV2CV)))
13193                     bad_type_gv(arg, namegv, o3,
13194                             arg == 1 ? "block or sub {}" : "sub {}");
13195                 break;
13196             case '*':
13197                 /* '*' allows any scalar type, including bareword */
13198                 proto++;
13199                 arg++;
13200                 if (o3->op_type == OP_RV2GV)
13201                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13202                 else if (o3->op_type == OP_CONST)
13203                     o3->op_private &= ~OPpCONST_STRICT;
13204                 scalar(aop);
13205                 break;
13206             case '+':
13207                 proto++;
13208                 arg++;
13209                 if (o3->op_type == OP_RV2AV ||
13210                     o3->op_type == OP_PADAV ||
13211                     o3->op_type == OP_RV2HV ||
13212                     o3->op_type == OP_PADHV
13213                 ) {
13214                     goto wrapref;
13215                 }
13216                 scalar(aop);
13217                 break;
13218             case '[': case ']':
13219                 goto oops;
13220
13221             case '\\':
13222                 proto++;
13223                 arg++;
13224             again:
13225                 switch (*proto++) {
13226                     case '[':
13227                         if (contextclass++ == 0) {
13228                             e = (char *) memchr(proto, ']', proto_end - proto);
13229                             if (!e || e == proto)
13230                                 goto oops;
13231                         }
13232                         else
13233                             goto oops;
13234                         goto again;
13235
13236                     case ']':
13237                         if (contextclass) {
13238                             const char *p = proto;
13239                             const char *const end = proto;
13240                             contextclass = 0;
13241                             while (*--p != '[')
13242                                 /* \[$] accepts any scalar lvalue */
13243                                 if (*p == '$'
13244                                  && Perl_op_lvalue_flags(aTHX_
13245                                      scalar(o3),
13246                                      OP_READ, /* not entersub */
13247                                      OP_LVALUE_NO_CROAK
13248                                     )) goto wrapref;
13249                             bad_type_gv(arg, namegv, o3,
13250                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13251                         } else
13252                             goto oops;
13253                         break;
13254                     case '*':
13255                         if (o3->op_type == OP_RV2GV)
13256                             goto wrapref;
13257                         if (!contextclass)
13258                             bad_type_gv(arg, namegv, o3, "symbol");
13259                         break;
13260                     case '&':
13261                         if (o3->op_type == OP_ENTERSUB
13262                          && !(o3->op_flags & OPf_STACKED))
13263                             goto wrapref;
13264                         if (!contextclass)
13265                             bad_type_gv(arg, namegv, o3, "subroutine");
13266                         break;
13267                     case '$':
13268                         if (o3->op_type == OP_RV2SV ||
13269                                 o3->op_type == OP_PADSV ||
13270                                 o3->op_type == OP_HELEM ||
13271                                 o3->op_type == OP_AELEM)
13272                             goto wrapref;
13273                         if (!contextclass) {
13274                             /* \$ accepts any scalar lvalue */
13275                             if (Perl_op_lvalue_flags(aTHX_
13276                                     scalar(o3),
13277                                     OP_READ,  /* not entersub */
13278                                     OP_LVALUE_NO_CROAK
13279                                )) goto wrapref;
13280                             bad_type_gv(arg, namegv, o3, "scalar");
13281                         }
13282                         break;
13283                     case '@':
13284                         if (o3->op_type == OP_RV2AV ||
13285                                 o3->op_type == OP_PADAV)
13286                         {
13287                             o3->op_flags &=~ OPf_PARENS;
13288                             goto wrapref;
13289                         }
13290                         if (!contextclass)
13291                             bad_type_gv(arg, namegv, o3, "array");
13292                         break;
13293                     case '%':
13294                         if (o3->op_type == OP_RV2HV ||
13295                                 o3->op_type == OP_PADHV)
13296                         {
13297                             o3->op_flags &=~ OPf_PARENS;
13298                             goto wrapref;
13299                         }
13300                         if (!contextclass)
13301                             bad_type_gv(arg, namegv, o3, "hash");
13302                         break;
13303                     wrapref:
13304                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13305                                                 OP_REFGEN, 0);
13306                         if (contextclass && e) {
13307                             proto = e + 1;
13308                             contextclass = 0;
13309                         }
13310                         break;
13311                     default: goto oops;
13312                 }
13313                 if (contextclass)
13314                     goto again;
13315                 break;
13316             case ' ':
13317                 proto++;
13318                 continue;
13319             default:
13320             oops: {
13321                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13322                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13323                                   SVfARG(protosv));
13324             }
13325         }
13326
13327         op_lvalue(aop, OP_ENTERSUB);
13328         prev = aop;
13329         aop = OpSIBLING(aop);
13330     }
13331     if (aop == cvop && *proto == '_') {
13332         /* generate an access to $_ */
13333         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13334     }
13335     if (!optional && proto_end > proto &&
13336         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13337     {
13338         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13339         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13340                                     SVfARG(namesv)), SvUTF8(namesv));
13341     }
13342     return entersubop;
13343 }
13344
13345 /*
13346 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13347
13348 Performs the fixup of the arguments part of an C<entersub> op tree either
13349 based on a subroutine prototype or using default list-context processing.
13350 This is the standard treatment used on a subroutine call, not marked
13351 with C<&>, where the callee can be identified at compile time.
13352
13353 C<protosv> supplies the subroutine prototype to be applied to the call,
13354 or indicates that there is no prototype.  It may be a normal scalar,
13355 in which case if it is defined then the string value will be used
13356 as a prototype, and if it is undefined then there is no prototype.
13357 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13358 that has been cast to C<SV*>), of which the prototype will be used if it
13359 has one.  The prototype (or lack thereof) supplied, in whichever form,
13360 does not need to match the actual callee referenced by the op tree.
13361
13362 If the argument ops disagree with the prototype, for example by having
13363 an unacceptable number of arguments, a valid op tree is returned anyway.
13364 The error is reflected in the parser state, normally resulting in a single
13365 exception at the top level of parsing which covers all the compilation
13366 errors that occurred.  In the error message, the callee is referred to
13367 by the name defined by the C<namegv> parameter.
13368
13369 =cut
13370 */
13371
13372 OP *
13373 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13374         GV *namegv, SV *protosv)
13375 {
13376     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13377     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13378         return ck_entersub_args_proto(entersubop, namegv, protosv);
13379     else
13380         return ck_entersub_args_list(entersubop);
13381 }
13382
13383 OP *
13384 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13385 {
13386     IV cvflags = SvIVX(protosv);
13387     int opnum = cvflags & 0xffff;
13388     OP *aop = cUNOPx(entersubop)->op_first;
13389
13390     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13391
13392     if (!opnum) {
13393         OP *cvop;
13394         if (!OpHAS_SIBLING(aop))
13395             aop = cUNOPx(aop)->op_first;
13396         aop = OpSIBLING(aop);
13397         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13398         if (aop != cvop) {
13399             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13400             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13401                 SVfARG(namesv)), SvUTF8(namesv));
13402         }
13403
13404         op_free(entersubop);
13405         switch(cvflags >> 16) {
13406         case 'F': return newSVOP(OP_CONST, 0,
13407                                         newSVpv(CopFILE(PL_curcop),0));
13408         case 'L': return newSVOP(
13409                            OP_CONST, 0,
13410                            Perl_newSVpvf(aTHX_
13411                              "%" IVdf, (IV)CopLINE(PL_curcop)
13412                            )
13413                          );
13414         case 'P': return newSVOP(OP_CONST, 0,
13415                                    (PL_curstash
13416                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13417                                      : &PL_sv_undef
13418                                    )
13419                                 );
13420         }
13421         NOT_REACHED; /* NOTREACHED */
13422     }
13423     else {
13424         OP *prev, *cvop, *first, *parent;
13425         U32 flags = 0;
13426
13427         parent = entersubop;
13428         if (!OpHAS_SIBLING(aop)) {
13429             parent = aop;
13430             aop = cUNOPx(aop)->op_first;
13431         }
13432
13433         first = prev = aop;
13434         aop = OpSIBLING(aop);
13435         /* find last sibling */
13436         for (cvop = aop;
13437              OpHAS_SIBLING(cvop);
13438              prev = cvop, cvop = OpSIBLING(cvop))
13439             ;
13440         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13441             /* Usually, OPf_SPECIAL on an op with no args means that it had
13442              * parens, but these have their own meaning for that flag: */
13443             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13444             && opnum != OP_DELETE && opnum != OP_EXISTS)
13445                 flags |= OPf_SPECIAL;
13446         /* excise cvop from end of sibling chain */
13447         op_sibling_splice(parent, prev, 1, NULL);
13448         op_free(cvop);
13449         if (aop == cvop) aop = NULL;
13450
13451         /* detach remaining siblings from the first sibling, then
13452          * dispose of original optree */
13453
13454         if (aop)
13455             op_sibling_splice(parent, first, -1, NULL);
13456         op_free(entersubop);
13457
13458         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13459             flags |= OPpEVAL_BYTES <<8;
13460
13461         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13462         case OA_UNOP:
13463         case OA_BASEOP_OR_UNOP:
13464         case OA_FILESTATOP:
13465             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13466         case OA_BASEOP:
13467             if (aop) {
13468                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13469                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13470                     SVfARG(namesv)), SvUTF8(namesv));
13471                 op_free(aop);
13472             }
13473             return opnum == OP_RUNCV
13474                 ? newPVOP(OP_RUNCV,0,NULL)
13475                 : newOP(opnum,0);
13476         default:
13477             return op_convert_list(opnum,0,aop);
13478         }
13479     }
13480     NOT_REACHED; /* NOTREACHED */
13481     return entersubop;
13482 }
13483
13484 /*
13485 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13486
13487 Retrieves the function that will be used to fix up a call to C<cv>.
13488 Specifically, the function is applied to an C<entersub> op tree for a
13489 subroutine call, not marked with C<&>, where the callee can be identified
13490 at compile time as C<cv>.
13491
13492 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13493 for it is returned in C<*ckobj_p>, and control flags are returned in
13494 C<*ckflags_p>.  The function is intended to be called in this manner:
13495
13496  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13497
13498 In this call, C<entersubop> is a pointer to the C<entersub> op,
13499 which may be replaced by the check function, and C<namegv> supplies
13500 the name that should be used by the check function to refer
13501 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13502 It is permitted to apply the check function in non-standard situations,
13503 such as to a call to a different subroutine or to a method call.
13504
13505 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13506 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13507 instead, anything that can be used as the first argument to L</cv_name>.
13508 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13509 check function requires C<namegv> to be a genuine GV.
13510
13511 By default, the check function is
13512 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13513 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13514 flag is clear.  This implements standard prototype processing.  It can
13515 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13516
13517 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13518 indicates that the caller only knows about the genuine GV version of
13519 C<namegv>, and accordingly the corresponding bit will always be set in
13520 C<*ckflags_p>, regardless of the check function's recorded requirements.
13521 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13522 indicates the caller knows about the possibility of passing something
13523 other than a GV as C<namegv>, and accordingly the corresponding bit may
13524 be either set or clear in C<*ckflags_p>, indicating the check function's
13525 recorded requirements.
13526
13527 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13528 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13529 (for which see above).  All other bits should be clear.
13530
13531 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13532
13533 The original form of L</cv_get_call_checker_flags>, which does not return
13534 checker flags.  When using a checker function returned by this function,
13535 it is only safe to call it with a genuine GV as its C<namegv> argument.
13536
13537 =cut
13538 */
13539
13540 void
13541 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13542         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13543 {
13544     MAGIC *callmg;
13545     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13546     PERL_UNUSED_CONTEXT;
13547     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13548     if (callmg) {
13549         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13550         *ckobj_p = callmg->mg_obj;
13551         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13552     } else {
13553         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13554         *ckobj_p = (SV*)cv;
13555         *ckflags_p = gflags & MGf_REQUIRE_GV;
13556     }
13557 }
13558
13559 void
13560 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13561 {
13562     U32 ckflags;
13563     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13564     PERL_UNUSED_CONTEXT;
13565     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13566         &ckflags);
13567 }
13568
13569 /*
13570 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13571
13572 Sets the function that will be used to fix up a call to C<cv>.
13573 Specifically, the function is applied to an C<entersub> op tree for a
13574 subroutine call, not marked with C<&>, where the callee can be identified
13575 at compile time as C<cv>.
13576
13577 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13578 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13579 The function should be defined like this:
13580
13581     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13582
13583 It is intended to be called in this manner:
13584
13585     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13586
13587 In this call, C<entersubop> is a pointer to the C<entersub> op,
13588 which may be replaced by the check function, and C<namegv> supplies
13589 the name that should be used by the check function to refer
13590 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13591 It is permitted to apply the check function in non-standard situations,
13592 such as to a call to a different subroutine or to a method call.
13593
13594 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13595 CV or other SV instead.  Whatever is passed can be used as the first
13596 argument to L</cv_name>.  You can force perl to pass a GV by including
13597 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13598
13599 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13600 bit currently has a defined meaning (for which see above).  All other
13601 bits should be clear.
13602
13603 The current setting for a particular CV can be retrieved by
13604 L</cv_get_call_checker_flags>.
13605
13606 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13607
13608 The original form of L</cv_set_call_checker_flags>, which passes it the
13609 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13610 of that flag setting is that the check function is guaranteed to get a
13611 genuine GV as its C<namegv> argument.
13612
13613 =cut
13614 */
13615
13616 void
13617 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13618 {
13619     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13620     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13621 }
13622
13623 void
13624 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13625                                      SV *ckobj, U32 ckflags)
13626 {
13627     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13628     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13629         if (SvMAGICAL((SV*)cv))
13630             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13631     } else {
13632         MAGIC *callmg;
13633         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13634         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13635         assert(callmg);
13636         if (callmg->mg_flags & MGf_REFCOUNTED) {
13637             SvREFCNT_dec(callmg->mg_obj);
13638             callmg->mg_flags &= ~MGf_REFCOUNTED;
13639         }
13640         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13641         callmg->mg_obj = ckobj;
13642         if (ckobj != (SV*)cv) {
13643             SvREFCNT_inc_simple_void_NN(ckobj);
13644             callmg->mg_flags |= MGf_REFCOUNTED;
13645         }
13646         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13647                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13648     }
13649 }
13650
13651 static void
13652 S_entersub_alloc_targ(pTHX_ OP * const o)
13653 {
13654     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13655     o->op_private |= OPpENTERSUB_HASTARG;
13656 }
13657
13658 OP *
13659 Perl_ck_subr(pTHX_ OP *o)
13660 {
13661     OP *aop, *cvop;
13662     CV *cv;
13663     GV *namegv;
13664     SV **const_class = NULL;
13665
13666     PERL_ARGS_ASSERT_CK_SUBR;
13667
13668     aop = cUNOPx(o)->op_first;
13669     if (!OpHAS_SIBLING(aop))
13670         aop = cUNOPx(aop)->op_first;
13671     aop = OpSIBLING(aop);
13672     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13673     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13674     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13675
13676     o->op_private &= ~1;
13677     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13678     if (PERLDB_SUB && PL_curstash != PL_debstash)
13679         o->op_private |= OPpENTERSUB_DB;
13680     switch (cvop->op_type) {
13681         case OP_RV2CV:
13682             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13683             op_null(cvop);
13684             break;
13685         case OP_METHOD:
13686         case OP_METHOD_NAMED:
13687         case OP_METHOD_SUPER:
13688         case OP_METHOD_REDIR:
13689         case OP_METHOD_REDIR_SUPER:
13690             o->op_flags |= OPf_REF;
13691             if (aop->op_type == OP_CONST) {
13692                 aop->op_private &= ~OPpCONST_STRICT;
13693                 const_class = &cSVOPx(aop)->op_sv;
13694             }
13695             else if (aop->op_type == OP_LIST) {
13696                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13697                 if (sib && sib->op_type == OP_CONST) {
13698                     sib->op_private &= ~OPpCONST_STRICT;
13699                     const_class = &cSVOPx(sib)->op_sv;
13700                 }
13701             }
13702             /* make class name a shared cow string to speedup method calls */
13703             /* constant string might be replaced with object, f.e. bigint */
13704             if (const_class && SvPOK(*const_class)) {
13705                 STRLEN len;
13706                 const char* str = SvPV(*const_class, len);
13707                 if (len) {
13708                     SV* const shared = newSVpvn_share(
13709                         str, SvUTF8(*const_class)
13710                                     ? -(SSize_t)len : (SSize_t)len,
13711                         0
13712                     );
13713                     if (SvREADONLY(*const_class))
13714                         SvREADONLY_on(shared);
13715                     SvREFCNT_dec(*const_class);
13716                     *const_class = shared;
13717                 }
13718             }
13719             break;
13720     }
13721
13722     if (!cv) {
13723         S_entersub_alloc_targ(aTHX_ o);
13724         return ck_entersub_args_list(o);
13725     } else {
13726         Perl_call_checker ckfun;
13727         SV *ckobj;
13728         U32 ckflags;
13729         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13730         if (CvISXSUB(cv) || !CvROOT(cv))
13731             S_entersub_alloc_targ(aTHX_ o);
13732         if (!namegv) {
13733             /* The original call checker API guarantees that a GV will be
13734                be provided with the right name.  So, if the old API was
13735                used (or the REQUIRE_GV flag was passed), we have to reify
13736                the CV’s GV, unless this is an anonymous sub.  This is not
13737                ideal for lexical subs, as its stringification will include
13738                the package.  But it is the best we can do.  */
13739             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13740                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13741                     namegv = CvGV(cv);
13742             }
13743             else namegv = MUTABLE_GV(cv);
13744             /* After a syntax error in a lexical sub, the cv that
13745                rv2cv_op_cv returns may be a nameless stub. */
13746             if (!namegv) return ck_entersub_args_list(o);
13747
13748         }
13749         return ckfun(aTHX_ o, namegv, ckobj);
13750     }
13751 }
13752
13753 OP *
13754 Perl_ck_svconst(pTHX_ OP *o)
13755 {
13756     SV * const sv = cSVOPo->op_sv;
13757     PERL_ARGS_ASSERT_CK_SVCONST;
13758     PERL_UNUSED_CONTEXT;
13759 #ifdef PERL_COPY_ON_WRITE
13760     /* Since the read-only flag may be used to protect a string buffer, we
13761        cannot do copy-on-write with existing read-only scalars that are not
13762        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13763        that constant, mark the constant as COWable here, if it is not
13764        already read-only. */
13765     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13766         SvIsCOW_on(sv);
13767         CowREFCNT(sv) = 0;
13768 # ifdef PERL_DEBUG_READONLY_COW
13769         sv_buf_to_ro(sv);
13770 # endif
13771     }
13772 #endif
13773     SvREADONLY_on(sv);
13774     return o;
13775 }
13776
13777 OP *
13778 Perl_ck_trunc(pTHX_ OP *o)
13779 {
13780     PERL_ARGS_ASSERT_CK_TRUNC;
13781
13782     if (o->op_flags & OPf_KIDS) {
13783         SVOP *kid = (SVOP*)cUNOPo->op_first;
13784
13785         if (kid->op_type == OP_NULL)
13786             kid = (SVOP*)OpSIBLING(kid);
13787         if (kid && kid->op_type == OP_CONST &&
13788             (kid->op_private & OPpCONST_BARE) &&
13789             !kid->op_folded)
13790         {
13791             o->op_flags |= OPf_SPECIAL;
13792             kid->op_private &= ~OPpCONST_STRICT;
13793         }
13794     }
13795     return ck_fun(o);
13796 }
13797
13798 OP *
13799 Perl_ck_substr(pTHX_ OP *o)
13800 {
13801     PERL_ARGS_ASSERT_CK_SUBSTR;
13802
13803     o = ck_fun(o);
13804     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13805         OP *kid = cLISTOPo->op_first;
13806
13807         if (kid->op_type == OP_NULL)
13808             kid = OpSIBLING(kid);
13809         if (kid)
13810             /* Historically, substr(delete $foo{bar},...) has been allowed
13811                with 4-arg substr.  Keep it working by applying entersub
13812                lvalue context.  */
13813             op_lvalue(kid, OP_ENTERSUB);
13814
13815     }
13816     return o;
13817 }
13818
13819 OP *
13820 Perl_ck_tell(pTHX_ OP *o)
13821 {
13822     PERL_ARGS_ASSERT_CK_TELL;
13823     o = ck_fun(o);
13824     if (o->op_flags & OPf_KIDS) {
13825      OP *kid = cLISTOPo->op_first;
13826      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13827      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13828     }
13829     return o;
13830 }
13831
13832 OP *
13833 Perl_ck_each(pTHX_ OP *o)
13834 {
13835     dVAR;
13836     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13837     const unsigned orig_type  = o->op_type;
13838
13839     PERL_ARGS_ASSERT_CK_EACH;
13840
13841     if (kid) {
13842         switch (kid->op_type) {
13843             case OP_PADHV:
13844             case OP_RV2HV:
13845                 break;
13846             case OP_PADAV:
13847             case OP_RV2AV:
13848                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13849                             : orig_type == OP_KEYS ? OP_AKEYS
13850                             :                        OP_AVALUES);
13851                 break;
13852             case OP_CONST:
13853                 if (kid->op_private == OPpCONST_BARE
13854                  || !SvROK(cSVOPx_sv(kid))
13855                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13856                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13857                    )
13858                     goto bad;
13859                 /* FALLTHROUGH */
13860             default:
13861                 qerror(Perl_mess(aTHX_
13862                     "Experimental %s on scalar is now forbidden",
13863                      PL_op_desc[orig_type]));
13864                bad:
13865                 bad_type_pv(1, "hash or array", o, kid);
13866                 return o;
13867         }
13868     }
13869     return ck_fun(o);
13870 }
13871
13872 OP *
13873 Perl_ck_length(pTHX_ OP *o)
13874 {
13875     PERL_ARGS_ASSERT_CK_LENGTH;
13876
13877     o = ck_fun(o);
13878
13879     if (ckWARN(WARN_SYNTAX)) {
13880         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13881
13882         if (kid) {
13883             SV *name = NULL;
13884             const bool hash = kid->op_type == OP_PADHV
13885                            || kid->op_type == OP_RV2HV;
13886             switch (kid->op_type) {
13887                 case OP_PADHV:
13888                 case OP_PADAV:
13889                 case OP_RV2HV:
13890                 case OP_RV2AV:
13891                     name = S_op_varname(aTHX_ kid);
13892                     break;
13893                 default:
13894                     return o;
13895             }
13896             if (name)
13897                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13898                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13899                     ")\"?)",
13900                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13901                 );
13902             else if (hash)
13903      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13904                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13905                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13906             else
13907      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13908                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13909                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13910         }
13911     }
13912
13913     return o;
13914 }
13915
13916
13917
13918 /*
13919    ---------------------------------------------------------
13920
13921    Common vars in list assignment
13922
13923    There now follows some enums and static functions for detecting
13924    common variables in list assignments. Here is a little essay I wrote
13925    for myself when trying to get my head around this. DAPM.
13926
13927    ----
13928
13929    First some random observations:
13930
13931    * If a lexical var is an alias of something else, e.g.
13932        for my $x ($lex, $pkg, $a[0]) {...}
13933      then the act of aliasing will increase the reference count of the SV
13934
13935    * If a package var is an alias of something else, it may still have a
13936      reference count of 1, depending on how the alias was created, e.g.
13937      in *a = *b, $a may have a refcount of 1 since the GP is shared
13938      with a single GvSV pointer to the SV. So If it's an alias of another
13939      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13940      a lexical var or an array element, then it will have RC > 1.
13941
13942    * There are many ways to create a package alias; ultimately, XS code
13943      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13944      run-time tracing mechanisms are unlikely to be able to catch all cases.
13945
13946    * When the LHS is all my declarations, the same vars can't appear directly
13947      on the RHS, but they can indirectly via closures, aliasing and lvalue
13948      subs. But those techniques all involve an increase in the lexical
13949      scalar's ref count.
13950
13951    * When the LHS is all lexical vars (but not necessarily my declarations),
13952      it is possible for the same lexicals to appear directly on the RHS, and
13953      without an increased ref count, since the stack isn't refcounted.
13954      This case can be detected at compile time by scanning for common lex
13955      vars with PL_generation.
13956
13957    * lvalue subs defeat common var detection, but they do at least
13958      return vars with a temporary ref count increment. Also, you can't
13959      tell at compile time whether a sub call is lvalue.
13960
13961
13962    So...
13963
13964    A: There are a few circumstances where there definitely can't be any
13965      commonality:
13966
13967        LHS empty:  () = (...);
13968        RHS empty:  (....) = ();
13969        RHS contains only constants or other 'can't possibly be shared'
13970            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13971            i.e. they only contain ops not marked as dangerous, whose children
13972            are also not dangerous;
13973        LHS ditto;
13974        LHS contains a single scalar element: e.g. ($x) = (....); because
13975            after $x has been modified, it won't be used again on the RHS;
13976        RHS contains a single element with no aggregate on LHS: e.g.
13977            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13978            won't be used again.
13979
13980    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13981      we can ignore):
13982
13983        my ($a, $b, @c) = ...;
13984
13985        Due to closure and goto tricks, these vars may already have content.
13986        For the same reason, an element on the RHS may be a lexical or package
13987        alias of one of the vars on the left, or share common elements, for
13988        example:
13989
13990            my ($x,$y) = f(); # $x and $y on both sides
13991            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13992
13993        and
13994
13995            my $ra = f();
13996            my @a = @$ra;  # elements of @a on both sides
13997            sub f { @a = 1..4; \@a }
13998
13999
14000        First, just consider scalar vars on LHS:
14001
14002            RHS is safe only if (A), or in addition,
14003                * contains only lexical *scalar* vars, where neither side's
14004                  lexicals have been flagged as aliases
14005
14006            If RHS is not safe, then it's always legal to check LHS vars for
14007            RC==1, since the only RHS aliases will always be associated
14008            with an RC bump.
14009
14010            Note that in particular, RHS is not safe if:
14011
14012                * it contains package scalar vars; e.g.:
14013
14014                    f();
14015                    my ($x, $y) = (2, $x_alias);
14016                    sub f { $x = 1; *x_alias = \$x; }
14017
14018                * It contains other general elements, such as flattened or
14019                * spliced or single array or hash elements, e.g.
14020
14021                    f();
14022                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14023
14024                    sub f {
14025                        ($x, $y) = (1,2);
14026                        use feature 'refaliasing';
14027                        \($a[0], $a[1]) = \($y,$x);
14028                    }
14029
14030                  It doesn't matter if the array/hash is lexical or package.
14031
14032                * it contains a function call that happens to be an lvalue
14033                  sub which returns one or more of the above, e.g.
14034
14035                    f();
14036                    my ($x,$y) = f();
14037
14038                    sub f : lvalue {
14039                        ($x, $y) = (1,2);
14040                        *x1 = \$x;
14041                        $y, $x1;
14042                    }
14043
14044                    (so a sub call on the RHS should be treated the same
14045                    as having a package var on the RHS).
14046
14047                * any other "dangerous" thing, such an op or built-in that
14048                  returns one of the above, e.g. pp_preinc
14049
14050
14051            If RHS is not safe, what we can do however is at compile time flag
14052            that the LHS are all my declarations, and at run time check whether
14053            all the LHS have RC == 1, and if so skip the full scan.
14054
14055        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14056
14057            Here the issue is whether there can be elements of @a on the RHS
14058            which will get prematurely freed when @a is cleared prior to
14059            assignment. This is only a problem if the aliasing mechanism
14060            is one which doesn't increase the refcount - only if RC == 1
14061            will the RHS element be prematurely freed.
14062
14063            Because the array/hash is being INTROed, it or its elements
14064            can't directly appear on the RHS:
14065
14066                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14067
14068            but can indirectly, e.g.:
14069
14070                my $r = f();
14071                my (@a) = @$r;
14072                sub f { @a = 1..3; \@a }
14073
14074            So if the RHS isn't safe as defined by (A), we must always
14075            mortalise and bump the ref count of any remaining RHS elements
14076            when assigning to a non-empty LHS aggregate.
14077
14078            Lexical scalars on the RHS aren't safe if they've been involved in
14079            aliasing, e.g.
14080
14081                use feature 'refaliasing';
14082
14083                f();
14084                \(my $lex) = \$pkg;
14085                my @a = ($lex,3); # equivalent to ($a[0],3)
14086
14087                sub f {
14088                    @a = (1,2);
14089                    \$pkg = \$a[0];
14090                }
14091
14092            Similarly with lexical arrays and hashes on the RHS:
14093
14094                f();
14095                my @b;
14096                my @a = (@b);
14097
14098                sub f {
14099                    @a = (1,2);
14100                    \$b[0] = \$a[1];
14101                    \$b[1] = \$a[0];
14102                }
14103
14104
14105
14106    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14107        my $a; ($a, my $b) = (....);
14108
14109        The difference between (B) and (C) is that it is now physically
14110        possible for the LHS vars to appear on the RHS too, where they
14111        are not reference counted; but in this case, the compile-time
14112        PL_generation sweep will detect such common vars.
14113
14114        So the rules for (C) differ from (B) in that if common vars are
14115        detected, the runtime "test RC==1" optimisation can no longer be used,
14116        and a full mark and sweep is required
14117
14118    D: As (C), but in addition the LHS may contain package vars.
14119
14120        Since package vars can be aliased without a corresponding refcount
14121        increase, all bets are off. It's only safe if (A). E.g.
14122
14123            my ($x, $y) = (1,2);
14124
14125            for $x_alias ($x) {
14126                ($x_alias, $y) = (3, $x); # whoops
14127            }
14128
14129        Ditto for LHS aggregate package vars.
14130
14131    E: Any other dangerous ops on LHS, e.g.
14132            (f(), $a[0], @$r) = (...);
14133
14134        this is similar to (E) in that all bets are off. In addition, it's
14135        impossible to determine at compile time whether the LHS
14136        contains a scalar or an aggregate, e.g.
14137
14138            sub f : lvalue { @a }
14139            (f()) = 1..3;
14140
14141 * ---------------------------------------------------------
14142 */
14143
14144
14145 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14146  * that at least one of the things flagged was seen.
14147  */
14148
14149 enum {
14150     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14151     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14152     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14153     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14154     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14155     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14156     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14157     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14158                                          that's flagged OA_DANGEROUS */
14159     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14160                                         not in any of the categories above */
14161     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14162 };
14163
14164
14165
14166 /* helper function for S_aassign_scan().
14167  * check a PAD-related op for commonality and/or set its generation number.
14168  * Returns a boolean indicating whether its shared */
14169
14170 static bool
14171 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14172 {
14173     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14174         /* lexical used in aliasing */
14175         return TRUE;
14176
14177     if (rhs)
14178         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14179     else
14180         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14181
14182     return FALSE;
14183 }
14184
14185
14186 /*
14187   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14188   It scans the left or right hand subtree of the aassign op, and returns a
14189   set of flags indicating what sorts of things it found there.
14190   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14191   set PL_generation on lexical vars; if the latter, we see if
14192   PL_generation matches.
14193   'top' indicates whether we're recursing or at the top level.
14194   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14195   This fn will increment it by the number seen. It's not intended to
14196   be an accurate count (especially as many ops can push a variable
14197   number of SVs onto the stack); rather it's used as to test whether there
14198   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14199 */
14200
14201 static int
14202 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14203 {
14204     int flags = 0;
14205     bool kid_top = FALSE;
14206
14207     /* first, look for a solitary @_ on the RHS */
14208     if (   rhs
14209         && top
14210         && (o->op_flags & OPf_KIDS)
14211         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14212     ) {
14213         OP *kid = cUNOPo->op_first;
14214         if (   (   kid->op_type == OP_PUSHMARK
14215                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14216             && ((kid = OpSIBLING(kid)))
14217             && !OpHAS_SIBLING(kid)
14218             && kid->op_type == OP_RV2AV
14219             && !(kid->op_flags & OPf_REF)
14220             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14221             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14222             && ((kid = cUNOPx(kid)->op_first))
14223             && kid->op_type == OP_GV
14224             && cGVOPx_gv(kid) == PL_defgv
14225         )
14226             flags |= AAS_DEFAV;
14227     }
14228
14229     switch (o->op_type) {
14230     case OP_GVSV:
14231         (*scalars_p)++;
14232         return AAS_PKG_SCALAR;
14233
14234     case OP_PADAV:
14235     case OP_PADHV:
14236         (*scalars_p) += 2;
14237         /* if !top, could be e.g. @a[0,1] */
14238         if (top && (o->op_flags & OPf_REF))
14239             return (o->op_private & OPpLVAL_INTRO)
14240                 ? AAS_MY_AGG : AAS_LEX_AGG;
14241         return AAS_DANGEROUS;
14242
14243     case OP_PADSV:
14244         {
14245             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14246                         ?  AAS_LEX_SCALAR_COMM : 0;
14247             (*scalars_p)++;
14248             return (o->op_private & OPpLVAL_INTRO)
14249                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14250         }
14251
14252     case OP_RV2AV:
14253     case OP_RV2HV:
14254         (*scalars_p) += 2;
14255         if (cUNOPx(o)->op_first->op_type != OP_GV)
14256             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14257         /* @pkg, %pkg */
14258         /* if !top, could be e.g. @a[0,1] */
14259         if (top && (o->op_flags & OPf_REF))
14260             return AAS_PKG_AGG;
14261         return AAS_DANGEROUS;
14262
14263     case OP_RV2SV:
14264         (*scalars_p)++;
14265         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14266             (*scalars_p) += 2;
14267             return AAS_DANGEROUS; /* ${expr} */
14268         }
14269         return AAS_PKG_SCALAR; /* $pkg */
14270
14271     case OP_SPLIT:
14272         if (o->op_private & OPpSPLIT_ASSIGN) {
14273             /* the assign in @a = split() has been optimised away
14274              * and the @a attached directly to the split op
14275              * Treat the array as appearing on the RHS, i.e.
14276              *    ... = (@a = split)
14277              * is treated like
14278              *    ... = @a;
14279              */
14280
14281             if (o->op_flags & OPf_STACKED)
14282                 /* @{expr} = split() - the array expression is tacked
14283                  * on as an extra child to split - process kid */
14284                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14285                                         top, scalars_p);
14286
14287             /* ... else array is directly attached to split op */
14288             (*scalars_p) += 2;
14289             if (PL_op->op_private & OPpSPLIT_LEX)
14290                 return (o->op_private & OPpLVAL_INTRO)
14291                     ? AAS_MY_AGG : AAS_LEX_AGG;
14292             else
14293                 return AAS_PKG_AGG;
14294         }
14295         (*scalars_p)++;
14296         /* other args of split can't be returned */
14297         return AAS_SAFE_SCALAR;
14298
14299     case OP_UNDEF:
14300         /* undef counts as a scalar on the RHS:
14301          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14302          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14303          */
14304         if (rhs)
14305             (*scalars_p)++;
14306         flags = AAS_SAFE_SCALAR;
14307         break;
14308
14309     case OP_PUSHMARK:
14310     case OP_STUB:
14311         /* these are all no-ops; they don't push a potentially common SV
14312          * onto the stack, so they are neither AAS_DANGEROUS nor
14313          * AAS_SAFE_SCALAR */
14314         return 0;
14315
14316     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14317         break;
14318
14319     case OP_NULL:
14320     case OP_LIST:
14321         /* these do nothing but may have children; but their children
14322          * should also be treated as top-level */
14323         kid_top = top;
14324         break;
14325
14326     default:
14327         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14328             (*scalars_p) += 2;
14329             flags = AAS_DANGEROUS;
14330             break;
14331         }
14332
14333         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14334             && (o->op_private & OPpTARGET_MY))
14335         {
14336             (*scalars_p)++;
14337             return S_aassign_padcheck(aTHX_ o, rhs)
14338                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14339         }
14340
14341         /* if its an unrecognised, non-dangerous op, assume that it
14342          * it the cause of at least one safe scalar */
14343         (*scalars_p)++;
14344         flags = AAS_SAFE_SCALAR;
14345         break;
14346     }
14347
14348     /* XXX this assumes that all other ops are "transparent" - i.e. that
14349      * they can return some of their children. While this true for e.g.
14350      * sort and grep, it's not true for e.g. map. We really need a
14351      * 'transparent' flag added to regen/opcodes
14352      */
14353     if (o->op_flags & OPf_KIDS) {
14354         OP *kid;
14355         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14356             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14357     }
14358     return flags;
14359 }
14360
14361
14362 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14363    and modify the optree to make them work inplace */
14364
14365 STATIC void
14366 S_inplace_aassign(pTHX_ OP *o) {
14367
14368     OP *modop, *modop_pushmark;
14369     OP *oright;
14370     OP *oleft, *oleft_pushmark;
14371
14372     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14373
14374     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14375
14376     assert(cUNOPo->op_first->op_type == OP_NULL);
14377     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14378     assert(modop_pushmark->op_type == OP_PUSHMARK);
14379     modop = OpSIBLING(modop_pushmark);
14380
14381     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14382         return;
14383
14384     /* no other operation except sort/reverse */
14385     if (OpHAS_SIBLING(modop))
14386         return;
14387
14388     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14389     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14390
14391     if (modop->op_flags & OPf_STACKED) {
14392         /* skip sort subroutine/block */
14393         assert(oright->op_type == OP_NULL);
14394         oright = OpSIBLING(oright);
14395     }
14396
14397     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14398     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14399     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14400     oleft = OpSIBLING(oleft_pushmark);
14401
14402     /* Check the lhs is an array */
14403     if (!oleft ||
14404         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14405         || OpHAS_SIBLING(oleft)
14406         || (oleft->op_private & OPpLVAL_INTRO)
14407     )
14408         return;
14409
14410     /* Only one thing on the rhs */
14411     if (OpHAS_SIBLING(oright))
14412         return;
14413
14414     /* check the array is the same on both sides */
14415     if (oleft->op_type == OP_RV2AV) {
14416         if (oright->op_type != OP_RV2AV
14417             || !cUNOPx(oright)->op_first
14418             || cUNOPx(oright)->op_first->op_type != OP_GV
14419             || cUNOPx(oleft )->op_first->op_type != OP_GV
14420             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14421                cGVOPx_gv(cUNOPx(oright)->op_first)
14422         )
14423             return;
14424     }
14425     else if (oright->op_type != OP_PADAV
14426         || oright->op_targ != oleft->op_targ
14427     )
14428         return;
14429
14430     /* This actually is an inplace assignment */
14431
14432     modop->op_private |= OPpSORT_INPLACE;
14433
14434     /* transfer MODishness etc from LHS arg to RHS arg */
14435     oright->op_flags = oleft->op_flags;
14436
14437     /* remove the aassign op and the lhs */
14438     op_null(o);
14439     op_null(oleft_pushmark);
14440     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14441         op_null(cUNOPx(oleft)->op_first);
14442     op_null(oleft);
14443 }
14444
14445
14446
14447 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14448  * that potentially represent a series of one or more aggregate derefs
14449  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14450  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14451  * additional ops left in too).
14452  *
14453  * The caller will have already verified that the first few ops in the
14454  * chain following 'start' indicate a multideref candidate, and will have
14455  * set 'orig_o' to the point further on in the chain where the first index
14456  * expression (if any) begins.  'orig_action' specifies what type of
14457  * beginning has already been determined by the ops between start..orig_o
14458  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14459  *
14460  * 'hints' contains any hints flags that need adding (currently just
14461  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14462  */
14463
14464 STATIC void
14465 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14466 {
14467     dVAR;
14468     int pass;
14469     UNOP_AUX_item *arg_buf = NULL;
14470     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14471     int index_skip         = -1;    /* don't output index arg on this action */
14472
14473     /* similar to regex compiling, do two passes; the first pass
14474      * determines whether the op chain is convertible and calculates the
14475      * buffer size; the second pass populates the buffer and makes any
14476      * changes necessary to ops (such as moving consts to the pad on
14477      * threaded builds).
14478      *
14479      * NB: for things like Coverity, note that both passes take the same
14480      * path through the logic tree (except for 'if (pass)' bits), since
14481      * both passes are following the same op_next chain; and in
14482      * particular, if it would return early on the second pass, it would
14483      * already have returned early on the first pass.
14484      */
14485     for (pass = 0; pass < 2; pass++) {
14486         OP *o                = orig_o;
14487         UV action            = orig_action;
14488         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14489         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14490         int action_count     = 0;     /* number of actions seen so far */
14491         int action_ix        = 0;     /* action_count % (actions per IV) */
14492         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14493         bool is_last         = FALSE; /* no more derefs to follow */
14494         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14495         UNOP_AUX_item *arg     = arg_buf;
14496         UNOP_AUX_item *action_ptr = arg_buf;
14497
14498         if (pass)
14499             action_ptr->uv = 0;
14500         arg++;
14501
14502         switch (action) {
14503         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14504         case MDEREF_HV_gvhv_helem:
14505             next_is_hash = TRUE;
14506             /* FALLTHROUGH */
14507         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14508         case MDEREF_AV_gvav_aelem:
14509             if (pass) {
14510 #ifdef USE_ITHREADS
14511                 arg->pad_offset = cPADOPx(start)->op_padix;
14512                 /* stop it being swiped when nulled */
14513                 cPADOPx(start)->op_padix = 0;
14514 #else
14515                 arg->sv = cSVOPx(start)->op_sv;
14516                 cSVOPx(start)->op_sv = NULL;
14517 #endif
14518             }
14519             arg++;
14520             break;
14521
14522         case MDEREF_HV_padhv_helem:
14523         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14524             next_is_hash = TRUE;
14525             /* FALLTHROUGH */
14526         case MDEREF_AV_padav_aelem:
14527         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14528             if (pass) {
14529                 arg->pad_offset = start->op_targ;
14530                 /* we skip setting op_targ = 0 for now, since the intact
14531                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14532                 reset_start_targ = TRUE;
14533             }
14534             arg++;
14535             break;
14536
14537         case MDEREF_HV_pop_rv2hv_helem:
14538             next_is_hash = TRUE;
14539             /* FALLTHROUGH */
14540         case MDEREF_AV_pop_rv2av_aelem:
14541             break;
14542
14543         default:
14544             NOT_REACHED; /* NOTREACHED */
14545             return;
14546         }
14547
14548         while (!is_last) {
14549             /* look for another (rv2av/hv; get index;
14550              * aelem/helem/exists/delele) sequence */
14551
14552             OP *kid;
14553             bool is_deref;
14554             bool ok;
14555             UV index_type = MDEREF_INDEX_none;
14556
14557             if (action_count) {
14558                 /* if this is not the first lookup, consume the rv2av/hv  */
14559
14560                 /* for N levels of aggregate lookup, we normally expect
14561                  * that the first N-1 [ah]elem ops will be flagged as
14562                  * /DEREF (so they autovivifiy if necessary), and the last
14563                  * lookup op not to be.
14564                  * For other things (like @{$h{k1}{k2}}) extra scope or
14565                  * leave ops can appear, so abandon the effort in that
14566                  * case */
14567                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14568                     return;
14569
14570                 /* rv2av or rv2hv sKR/1 */
14571
14572                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14573                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14574                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14575                     return;
14576
14577                 /* at this point, we wouldn't expect any of these
14578                  * possible private flags:
14579                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14580                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14581                  */
14582                 ASSUME(!(o->op_private &
14583                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14584
14585                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14586
14587                 /* make sure the type of the previous /DEREF matches the
14588                  * type of the next lookup */
14589                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14590                 top_op = o;
14591
14592                 action = next_is_hash
14593                             ? MDEREF_HV_vivify_rv2hv_helem
14594                             : MDEREF_AV_vivify_rv2av_aelem;
14595                 o = o->op_next;
14596             }
14597
14598             /* if this is the second pass, and we're at the depth where
14599              * previously we encountered a non-simple index expression,
14600              * stop processing the index at this point */
14601             if (action_count != index_skip) {
14602
14603                 /* look for one or more simple ops that return an array
14604                  * index or hash key */
14605
14606                 switch (o->op_type) {
14607                 case OP_PADSV:
14608                     /* it may be a lexical var index */
14609                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14610                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14611                     ASSUME(!(o->op_private &
14612                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14613
14614                     if (   OP_GIMME(o,0) == G_SCALAR
14615                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14616                         && o->op_private == 0)
14617                     {
14618                         if (pass)
14619                             arg->pad_offset = o->op_targ;
14620                         arg++;
14621                         index_type = MDEREF_INDEX_padsv;
14622                         o = o->op_next;
14623                     }
14624                     break;
14625
14626                 case OP_CONST:
14627                     if (next_is_hash) {
14628                         /* it's a constant hash index */
14629                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14630                             /* "use constant foo => FOO; $h{+foo}" for
14631                              * some weird FOO, can leave you with constants
14632                              * that aren't simple strings. It's not worth
14633                              * the extra hassle for those edge cases */
14634                             break;
14635
14636                         if (pass) {
14637                             UNOP *rop = NULL;
14638                             OP * helem_op = o->op_next;
14639
14640                             ASSUME(   helem_op->op_type == OP_HELEM
14641                                    || helem_op->op_type == OP_NULL);
14642                             if (helem_op->op_type == OP_HELEM) {
14643                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14644                                 if (   helem_op->op_private & OPpLVAL_INTRO
14645                                     || rop->op_type != OP_RV2HV
14646                                 )
14647                                     rop = NULL;
14648                             }
14649                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14650
14651 #ifdef USE_ITHREADS
14652                             /* Relocate sv to the pad for thread safety */
14653                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14654                             arg->pad_offset = o->op_targ;
14655                             o->op_targ = 0;
14656 #else
14657                             arg->sv = cSVOPx_sv(o);
14658 #endif
14659                         }
14660                     }
14661                     else {
14662                         /* it's a constant array index */
14663                         IV iv;
14664                         SV *ix_sv = cSVOPo->op_sv;
14665                         if (!SvIOK(ix_sv))
14666                             break;
14667                         iv = SvIV(ix_sv);
14668
14669                         if (   action_count == 0
14670                             && iv >= -128
14671                             && iv <= 127
14672                             && (   action == MDEREF_AV_padav_aelem
14673                                 || action == MDEREF_AV_gvav_aelem)
14674                         )
14675                             maybe_aelemfast = TRUE;
14676
14677                         if (pass) {
14678                             arg->iv = iv;
14679                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14680                         }
14681                     }
14682                     if (pass)
14683                         /* we've taken ownership of the SV */
14684                         cSVOPo->op_sv = NULL;
14685                     arg++;
14686                     index_type = MDEREF_INDEX_const;
14687                     o = o->op_next;
14688                     break;
14689
14690                 case OP_GV:
14691                     /* it may be a package var index */
14692
14693                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14694                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14695                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14696                         || o->op_private != 0
14697                     )
14698                         break;
14699
14700                     kid = o->op_next;
14701                     if (kid->op_type != OP_RV2SV)
14702                         break;
14703
14704                     ASSUME(!(kid->op_flags &
14705                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14706                              |OPf_SPECIAL|OPf_PARENS)));
14707                     ASSUME(!(kid->op_private &
14708                                     ~(OPpARG1_MASK
14709                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14710                                      |OPpDEREF|OPpLVAL_INTRO)));
14711                     if(   (kid->op_flags &~ OPf_PARENS)
14712                             != (OPf_WANT_SCALAR|OPf_KIDS)
14713                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14714                     )
14715                         break;
14716
14717                     if (pass) {
14718 #ifdef USE_ITHREADS
14719                         arg->pad_offset = cPADOPx(o)->op_padix;
14720                         /* stop it being swiped when nulled */
14721                         cPADOPx(o)->op_padix = 0;
14722 #else
14723                         arg->sv = cSVOPx(o)->op_sv;
14724                         cSVOPo->op_sv = NULL;
14725 #endif
14726                     }
14727                     arg++;
14728                     index_type = MDEREF_INDEX_gvsv;
14729                     o = kid->op_next;
14730                     break;
14731
14732                 } /* switch */
14733             } /* action_count != index_skip */
14734
14735             action |= index_type;
14736
14737
14738             /* at this point we have either:
14739              *   * detected what looks like a simple index expression,
14740              *     and expect the next op to be an [ah]elem, or
14741              *     an nulled  [ah]elem followed by a delete or exists;
14742              *  * found a more complex expression, so something other
14743              *    than the above follows.
14744              */
14745
14746             /* possibly an optimised away [ah]elem (where op_next is
14747              * exists or delete) */
14748             if (o->op_type == OP_NULL)
14749                 o = o->op_next;
14750
14751             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14752              * OP_EXISTS or OP_DELETE */
14753
14754             /* if a custom array/hash access checker is in scope,
14755              * abandon optimisation attempt */
14756             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14757                && PL_check[o->op_type] != Perl_ck_null)
14758                 return;
14759             /* similarly for customised exists and delete */
14760             if (  (o->op_type == OP_EXISTS)
14761                && PL_check[o->op_type] != Perl_ck_exists)
14762                 return;
14763             if (  (o->op_type == OP_DELETE)
14764                && PL_check[o->op_type] != Perl_ck_delete)
14765                 return;
14766
14767             if (   o->op_type != OP_AELEM
14768                 || (o->op_private &
14769                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14770                 )
14771                 maybe_aelemfast = FALSE;
14772
14773             /* look for aelem/helem/exists/delete. If it's not the last elem
14774              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14775              * flags; if it's the last, then it mustn't have
14776              * OPpDEREF_AV/HV, but may have lots of other flags, like
14777              * OPpLVAL_INTRO etc
14778              */
14779
14780             if (   index_type == MDEREF_INDEX_none
14781                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14782                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14783             )
14784                 ok = FALSE;
14785             else {
14786                 /* we have aelem/helem/exists/delete with valid simple index */
14787
14788                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14789                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14790                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14791
14792                 /* This doesn't make much sense but is legal:
14793                  *    @{ local $x[0][0] } = 1
14794                  * Since scope exit will undo the autovivification,
14795                  * don't bother in the first place. The OP_LEAVE
14796                  * assertion is in case there are other cases of both
14797                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14798                  * exit that would undo the local - in which case this
14799                  * block of code would need rethinking.
14800                  */
14801                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14802 #ifdef DEBUGGING
14803                     OP *n = o->op_next;
14804                     while (n && (  n->op_type == OP_NULL
14805                                 || n->op_type == OP_LIST))
14806                         n = n->op_next;
14807                     assert(n && n->op_type == OP_LEAVE);
14808 #endif
14809                     o->op_private &= ~OPpDEREF;
14810                     is_deref = FALSE;
14811                 }
14812
14813                 if (is_deref) {
14814                     ASSUME(!(o->op_flags &
14815                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14816                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14817
14818                     ok =    (o->op_flags &~ OPf_PARENS)
14819                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14820                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14821                 }
14822                 else if (o->op_type == OP_EXISTS) {
14823                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14824                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14825                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14826                     ok =  !(o->op_private & ~OPpARG1_MASK);
14827                 }
14828                 else if (o->op_type == OP_DELETE) {
14829                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14830                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14831                     ASSUME(!(o->op_private &
14832                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14833                     /* don't handle slices or 'local delete'; the latter
14834                      * is fairly rare, and has a complex runtime */
14835                     ok =  !(o->op_private & ~OPpARG1_MASK);
14836                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14837                         /* skip handling run-tome error */
14838                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14839                 }
14840                 else {
14841                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14842                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14843                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14844                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14845                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14846                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14847                 }
14848             }
14849
14850             if (ok) {
14851                 if (!first_elem_op)
14852                     first_elem_op = o;
14853                 top_op = o;
14854                 if (is_deref) {
14855                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14856                     o = o->op_next;
14857                 }
14858                 else {
14859                     is_last = TRUE;
14860                     action |= MDEREF_FLAG_last;
14861                 }
14862             }
14863             else {
14864                 /* at this point we have something that started
14865                  * promisingly enough (with rv2av or whatever), but failed
14866                  * to find a simple index followed by an
14867                  * aelem/helem/exists/delete. If this is the first action,
14868                  * give up; but if we've already seen at least one
14869                  * aelem/helem, then keep them and add a new action with
14870                  * MDEREF_INDEX_none, which causes it to do the vivify
14871                  * from the end of the previous lookup, and do the deref,
14872                  * but stop at that point. So $a[0][expr] will do one
14873                  * av_fetch, vivify and deref, then continue executing at
14874                  * expr */
14875                 if (!action_count)
14876                     return;
14877                 is_last = TRUE;
14878                 index_skip = action_count;
14879                 action |= MDEREF_FLAG_last;
14880                 if (index_type != MDEREF_INDEX_none)
14881                     arg--;
14882             }
14883
14884             if (pass)
14885                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14886             action_ix++;
14887             action_count++;
14888             /* if there's no space for the next action, create a new slot
14889              * for it *before* we start adding args for that action */
14890             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14891                 action_ptr = arg;
14892                 if (pass)
14893                     arg->uv = 0;
14894                 arg++;
14895                 action_ix = 0;
14896             }
14897         } /* while !is_last */
14898
14899         /* success! */
14900
14901         if (pass) {
14902             OP *mderef;
14903             OP *p, *q;
14904
14905             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14906             if (index_skip == -1) {
14907                 mderef->op_flags = o->op_flags
14908                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14909                 if (o->op_type == OP_EXISTS)
14910                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14911                 else if (o->op_type == OP_DELETE)
14912                     mderef->op_private = OPpMULTIDEREF_DELETE;
14913                 else
14914                     mderef->op_private = o->op_private
14915                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14916             }
14917             /* accumulate strictness from every level (although I don't think
14918              * they can actually vary) */
14919             mderef->op_private |= hints;
14920
14921             /* integrate the new multideref op into the optree and the
14922              * op_next chain.
14923              *
14924              * In general an op like aelem or helem has two child
14925              * sub-trees: the aggregate expression (a_expr) and the
14926              * index expression (i_expr):
14927              *
14928              *     aelem
14929              *       |
14930              *     a_expr - i_expr
14931              *
14932              * The a_expr returns an AV or HV, while the i-expr returns an
14933              * index. In general a multideref replaces most or all of a
14934              * multi-level tree, e.g.
14935              *
14936              *     exists
14937              *       |
14938              *     ex-aelem
14939              *       |
14940              *     rv2av  - i_expr1
14941              *       |
14942              *     helem
14943              *       |
14944              *     rv2hv  - i_expr2
14945              *       |
14946              *     aelem
14947              *       |
14948              *     a_expr - i_expr3
14949              *
14950              * With multideref, all the i_exprs will be simple vars or
14951              * constants, except that i_expr1 may be arbitrary in the case
14952              * of MDEREF_INDEX_none.
14953              *
14954              * The bottom-most a_expr will be either:
14955              *   1) a simple var (so padXv or gv+rv2Xv);
14956              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14957              *      so a simple var with an extra rv2Xv;
14958              *   3) or an arbitrary expression.
14959              *
14960              * 'start', the first op in the execution chain, will point to
14961              *   1),2): the padXv or gv op;
14962              *   3):    the rv2Xv which forms the last op in the a_expr
14963              *          execution chain, and the top-most op in the a_expr
14964              *          subtree.
14965              *
14966              * For all cases, the 'start' node is no longer required,
14967              * but we can't free it since one or more external nodes
14968              * may point to it. E.g. consider
14969              *     $h{foo} = $a ? $b : $c
14970              * Here, both the op_next and op_other branches of the
14971              * cond_expr point to the gv[*h] of the hash expression, so
14972              * we can't free the 'start' op.
14973              *
14974              * For expr->[...], we need to save the subtree containing the
14975              * expression; for the other cases, we just need to save the
14976              * start node.
14977              * So in all cases, we null the start op and keep it around by
14978              * making it the child of the multideref op; for the expr->
14979              * case, the expr will be a subtree of the start node.
14980              *
14981              * So in the simple 1,2 case the  optree above changes to
14982              *
14983              *     ex-exists
14984              *       |
14985              *     multideref
14986              *       |
14987              *     ex-gv (or ex-padxv)
14988              *
14989              *  with the op_next chain being
14990              *
14991              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14992              *
14993              *  In the 3 case, we have
14994              *
14995              *     ex-exists
14996              *       |
14997              *     multideref
14998              *       |
14999              *     ex-rv2xv
15000              *       |
15001              *    rest-of-a_expr
15002              *      subtree
15003              *
15004              *  and
15005              *
15006              *  -> rest-of-a_expr subtree ->
15007              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15008              *
15009              *
15010              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15011              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15012              * multideref attached as the child, e.g.
15013              *
15014              *     exists
15015              *       |
15016              *     ex-aelem
15017              *       |
15018              *     ex-rv2av  - i_expr1
15019              *       |
15020              *     multideref
15021              *       |
15022              *     ex-whatever
15023              *
15024              */
15025
15026             /* if we free this op, don't free the pad entry */
15027             if (reset_start_targ)
15028                 start->op_targ = 0;
15029
15030
15031             /* Cut the bit we need to save out of the tree and attach to
15032              * the multideref op, then free the rest of the tree */
15033
15034             /* find parent of node to be detached (for use by splice) */
15035             p = first_elem_op;
15036             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15037                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15038             {
15039                 /* there is an arbitrary expression preceding us, e.g.
15040                  * expr->[..]? so we need to save the 'expr' subtree */
15041                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15042                     p = cUNOPx(p)->op_first;
15043                 ASSUME(   start->op_type == OP_RV2AV
15044                        || start->op_type == OP_RV2HV);
15045             }
15046             else {
15047                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15048                  * above for exists/delete. */
15049                 while (   (p->op_flags & OPf_KIDS)
15050                        && cUNOPx(p)->op_first != start
15051                 )
15052                     p = cUNOPx(p)->op_first;
15053             }
15054             ASSUME(cUNOPx(p)->op_first == start);
15055
15056             /* detach from main tree, and re-attach under the multideref */
15057             op_sibling_splice(mderef, NULL, 0,
15058                     op_sibling_splice(p, NULL, 1, NULL));
15059             op_null(start);
15060
15061             start->op_next = mderef;
15062
15063             mderef->op_next = index_skip == -1 ? o->op_next : o;
15064
15065             /* excise and free the original tree, and replace with
15066              * the multideref op */
15067             p = op_sibling_splice(top_op, NULL, -1, mderef);
15068             while (p) {
15069                 q = OpSIBLING(p);
15070                 op_free(p);
15071                 p = q;
15072             }
15073             op_null(top_op);
15074         }
15075         else {
15076             Size_t size = arg - arg_buf;
15077
15078             if (maybe_aelemfast && action_count == 1)
15079                 return;
15080
15081             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15082                                 sizeof(UNOP_AUX_item) * (size + 1));
15083             /* for dumping etc: store the length in a hidden first slot;
15084              * we set the op_aux pointer to the second slot */
15085             arg_buf->uv = size;
15086             arg_buf++;
15087         }
15088     } /* for (pass = ...) */
15089 }
15090
15091 /* See if the ops following o are such that o will always be executed in
15092  * boolean context: that is, the SV which o pushes onto the stack will
15093  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15094  * If so, set a suitable private flag on o. Normally this will be
15095  * bool_flag; but see below why maybe_flag is needed too.
15096  *
15097  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15098  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15099  * already be taken, so you'll have to give that op two different flags.
15100  *
15101  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15102  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15103  * those underlying ops) short-circuit, which means that rather than
15104  * necessarily returning a truth value, they may return the LH argument,
15105  * which may not be boolean. For example in $x = (keys %h || -1), keys
15106  * should return a key count rather than a boolean, even though its
15107  * sort-of being used in boolean context.
15108  *
15109  * So we only consider such logical ops to provide boolean context to
15110  * their LH argument if they themselves are in void or boolean context.
15111  * However, sometimes the context isn't known until run-time. In this
15112  * case the op is marked with the maybe_flag flag it.
15113  *
15114  * Consider the following.
15115  *
15116  *     sub f { ....;  if (%h) { .... } }
15117  *
15118  * This is actually compiled as
15119  *
15120  *     sub f { ....;  %h && do { .... } }
15121  *
15122  * Here we won't know until runtime whether the final statement (and hence
15123  * the &&) is in void context and so is safe to return a boolean value.
15124  * So mark o with maybe_flag rather than the bool_flag.
15125  * Note that there is cost associated with determining context at runtime
15126  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15127  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15128  * boolean costs savings are marginal.
15129  *
15130  * However, we can do slightly better with && (compared to || and //):
15131  * this op only returns its LH argument when that argument is false. In
15132  * this case, as long as the op promises to return a false value which is
15133  * valid in both boolean and scalar contexts, we can mark an op consumed
15134  * by && with bool_flag rather than maybe_flag.
15135  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15136  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15137  * op which promises to handle this case is indicated by setting safe_and
15138  * to true.
15139  */
15140
15141 static void
15142 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15143 {
15144     OP *lop;
15145     U8 flag = 0;
15146
15147     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15148
15149     /* OPpTARGET_MY and boolean context probably don't mix well.
15150      * If someone finds a valid use case, maybe add an extra flag to this
15151      * function which indicates its safe to do so for this op? */
15152     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15153              && (o->op_private & OPpTARGET_MY)));
15154
15155     lop = o->op_next;
15156
15157     while (lop) {
15158         switch (lop->op_type) {
15159         case OP_NULL:
15160         case OP_SCALAR:
15161             break;
15162
15163         /* these two consume the stack argument in the scalar case,
15164          * and treat it as a boolean in the non linenumber case */
15165         case OP_FLIP:
15166         case OP_FLOP:
15167             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15168                 || (lop->op_private & OPpFLIP_LINENUM))
15169             {
15170                 lop = NULL;
15171                 break;
15172             }
15173             /* FALLTHROUGH */
15174         /* these never leave the original value on the stack */
15175         case OP_NOT:
15176         case OP_XOR:
15177         case OP_COND_EXPR:
15178         case OP_GREPWHILE:
15179             flag = bool_flag;
15180             lop = NULL;
15181             break;
15182
15183         /* OR DOR and AND evaluate their arg as a boolean, but then may
15184          * leave the original scalar value on the stack when following the
15185          * op_next route. If not in void context, we need to ensure
15186          * that whatever follows consumes the arg only in boolean context
15187          * too.
15188          */
15189         case OP_AND:
15190             if (safe_and) {
15191                 flag = bool_flag;
15192                 lop = NULL;
15193                 break;
15194             }
15195             /* FALLTHROUGH */
15196         case OP_OR:
15197         case OP_DOR:
15198             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15199                 flag = bool_flag;
15200                 lop = NULL;
15201             }
15202             else if (!(lop->op_flags & OPf_WANT)) {
15203                 /* unknown context - decide at runtime */
15204                 flag = maybe_flag;
15205                 lop = NULL;
15206             }
15207             break;
15208
15209         default:
15210             lop = NULL;
15211             break;
15212         }
15213
15214         if (lop)
15215             lop = lop->op_next;
15216     }
15217
15218     o->op_private |= flag;
15219 }
15220
15221
15222
15223 /* mechanism for deferring recursion in rpeep() */
15224
15225 #define MAX_DEFERRED 4
15226
15227 #define DEFER(o) \
15228   STMT_START { \
15229     if (defer_ix == (MAX_DEFERRED-1)) { \
15230         OP **defer = defer_queue[defer_base]; \
15231         CALL_RPEEP(*defer); \
15232         S_prune_chain_head(defer); \
15233         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15234         defer_ix--; \
15235     } \
15236     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15237   } STMT_END
15238
15239 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15240 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15241
15242
15243 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15244  * See the comments at the top of this file for more details about when
15245  * peep() is called */
15246
15247 void
15248 Perl_rpeep(pTHX_ OP *o)
15249 {
15250     dVAR;
15251     OP* oldop = NULL;
15252     OP* oldoldop = NULL;
15253     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15254     int defer_base = 0;
15255     int defer_ix = -1;
15256
15257     if (!o || o->op_opt)
15258         return;
15259
15260     assert(o->op_type != OP_FREED);
15261
15262     ENTER;
15263     SAVEOP();
15264     SAVEVPTR(PL_curcop);
15265     for (;; o = o->op_next) {
15266         if (o && o->op_opt)
15267             o = NULL;
15268         if (!o) {
15269             while (defer_ix >= 0) {
15270                 OP **defer =
15271                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15272                 CALL_RPEEP(*defer);
15273                 S_prune_chain_head(defer);
15274             }
15275             break;
15276         }
15277
15278       redo:
15279
15280         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15281         assert(!oldoldop || oldoldop->op_next == oldop);
15282         assert(!oldop    || oldop->op_next    == o);
15283
15284         /* By default, this op has now been optimised. A couple of cases below
15285            clear this again.  */
15286         o->op_opt = 1;
15287         PL_op = o;
15288
15289         /* look for a series of 1 or more aggregate derefs, e.g.
15290          *   $a[1]{foo}[$i]{$k}
15291          * and replace with a single OP_MULTIDEREF op.
15292          * Each index must be either a const, or a simple variable,
15293          *
15294          * First, look for likely combinations of starting ops,
15295          * corresponding to (global and lexical variants of)
15296          *     $a[...]   $h{...}
15297          *     $r->[...] $r->{...}
15298          *     (preceding expression)->[...]
15299          *     (preceding expression)->{...}
15300          * and if so, call maybe_multideref() to do a full inspection
15301          * of the op chain and if appropriate, replace with an
15302          * OP_MULTIDEREF
15303          */
15304         {
15305             UV action;
15306             OP *o2 = o;
15307             U8 hints = 0;
15308
15309             switch (o2->op_type) {
15310             case OP_GV:
15311                 /* $pkg[..]   :   gv[*pkg]
15312                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15313
15314                 /* Fail if there are new op flag combinations that we're
15315                  * not aware of, rather than:
15316                  *  * silently failing to optimise, or
15317                  *  * silently optimising the flag away.
15318                  * If this ASSUME starts failing, examine what new flag
15319                  * has been added to the op, and decide whether the
15320                  * optimisation should still occur with that flag, then
15321                  * update the code accordingly. This applies to all the
15322                  * other ASSUMEs in the block of code too.
15323                  */
15324                 ASSUME(!(o2->op_flags &
15325                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15326                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15327
15328                 o2 = o2->op_next;
15329
15330                 if (o2->op_type == OP_RV2AV) {
15331                     action = MDEREF_AV_gvav_aelem;
15332                     goto do_deref;
15333                 }
15334
15335                 if (o2->op_type == OP_RV2HV) {
15336                     action = MDEREF_HV_gvhv_helem;
15337                     goto do_deref;
15338                 }
15339
15340                 if (o2->op_type != OP_RV2SV)
15341                     break;
15342
15343                 /* at this point we've seen gv,rv2sv, so the only valid
15344                  * construct left is $pkg->[] or $pkg->{} */
15345
15346                 ASSUME(!(o2->op_flags & OPf_STACKED));
15347                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15348                             != (OPf_WANT_SCALAR|OPf_MOD))
15349                     break;
15350
15351                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15352                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15353                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15354                     break;
15355                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15356                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15357                     break;
15358
15359                 o2 = o2->op_next;
15360                 if (o2->op_type == OP_RV2AV) {
15361                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15362                     goto do_deref;
15363                 }
15364                 if (o2->op_type == OP_RV2HV) {
15365                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15366                     goto do_deref;
15367                 }
15368                 break;
15369
15370             case OP_PADSV:
15371                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15372
15373                 ASSUME(!(o2->op_flags &
15374                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15375                 if ((o2->op_flags &
15376                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15377                      != (OPf_WANT_SCALAR|OPf_MOD))
15378                     break;
15379
15380                 ASSUME(!(o2->op_private &
15381                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15382                 /* skip if state or intro, or not a deref */
15383                 if (      o2->op_private != OPpDEREF_AV
15384                        && o2->op_private != OPpDEREF_HV)
15385                     break;
15386
15387                 o2 = o2->op_next;
15388                 if (o2->op_type == OP_RV2AV) {
15389                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15390                     goto do_deref;
15391                 }
15392                 if (o2->op_type == OP_RV2HV) {
15393                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15394                     goto do_deref;
15395                 }
15396                 break;
15397
15398             case OP_PADAV:
15399             case OP_PADHV:
15400                 /*    $lex[..]:  padav[@lex:1,2] sR *
15401                  * or $lex{..}:  padhv[%lex:1,2] sR */
15402                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15403                                             OPf_REF|OPf_SPECIAL)));
15404                 if ((o2->op_flags &
15405                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15406                      != (OPf_WANT_SCALAR|OPf_REF))
15407                     break;
15408                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15409                     break;
15410                 /* OPf_PARENS isn't currently used in this case;
15411                  * if that changes, let us know! */
15412                 ASSUME(!(o2->op_flags & OPf_PARENS));
15413
15414                 /* at this point, we wouldn't expect any of the remaining
15415                  * possible private flags:
15416                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15417                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15418                  *
15419                  * OPpSLICEWARNING shouldn't affect runtime
15420                  */
15421                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15422
15423                 action = o2->op_type == OP_PADAV
15424                             ? MDEREF_AV_padav_aelem
15425                             : MDEREF_HV_padhv_helem;
15426                 o2 = o2->op_next;
15427                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15428                 break;
15429
15430
15431             case OP_RV2AV:
15432             case OP_RV2HV:
15433                 action = o2->op_type == OP_RV2AV
15434                             ? MDEREF_AV_pop_rv2av_aelem
15435                             : MDEREF_HV_pop_rv2hv_helem;
15436                 /* FALLTHROUGH */
15437             do_deref:
15438                 /* (expr)->[...]:  rv2av sKR/1;
15439                  * (expr)->{...}:  rv2hv sKR/1; */
15440
15441                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15442
15443                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15444                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15445                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15446                     break;
15447
15448                 /* at this point, we wouldn't expect any of these
15449                  * possible private flags:
15450                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15451                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15452                  */
15453                 ASSUME(!(o2->op_private &
15454                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15455                      |OPpOUR_INTRO)));
15456                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15457
15458                 o2 = o2->op_next;
15459
15460                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15461                 break;
15462
15463             default:
15464                 break;
15465             }
15466         }
15467
15468
15469         switch (o->op_type) {
15470         case OP_DBSTATE:
15471             PL_curcop = ((COP*)o);              /* for warnings */
15472             break;
15473         case OP_NEXTSTATE:
15474             PL_curcop = ((COP*)o);              /* for warnings */
15475
15476             /* Optimise a "return ..." at the end of a sub to just be "...".
15477              * This saves 2 ops. Before:
15478              * 1  <;> nextstate(main 1 -e:1) v ->2
15479              * 4  <@> return K ->5
15480              * 2    <0> pushmark s ->3
15481              * -    <1> ex-rv2sv sK/1 ->4
15482              * 3      <#> gvsv[*cat] s ->4
15483              *
15484              * After:
15485              * -  <@> return K ->-
15486              * -    <0> pushmark s ->2
15487              * -    <1> ex-rv2sv sK/1 ->-
15488              * 2      <$> gvsv(*cat) s ->3
15489              */
15490             {
15491                 OP *next = o->op_next;
15492                 OP *sibling = OpSIBLING(o);
15493                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15494                     && OP_TYPE_IS(sibling, OP_RETURN)
15495                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15496                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15497                        ||OP_TYPE_IS(sibling->op_next->op_next,
15498                                     OP_LEAVESUBLV))
15499                     && cUNOPx(sibling)->op_first == next
15500                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15501                     && next->op_next
15502                 ) {
15503                     /* Look through the PUSHMARK's siblings for one that
15504                      * points to the RETURN */
15505                     OP *top = OpSIBLING(next);
15506                     while (top && top->op_next) {
15507                         if (top->op_next == sibling) {
15508                             top->op_next = sibling->op_next;
15509                             o->op_next = next->op_next;
15510                             break;
15511                         }
15512                         top = OpSIBLING(top);
15513                     }
15514                 }
15515             }
15516
15517             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15518              *
15519              * This latter form is then suitable for conversion into padrange
15520              * later on. Convert:
15521              *
15522              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15523              *
15524              * into:
15525              *
15526              *   nextstate1 ->     listop     -> nextstate3
15527              *                 /            \
15528              *         pushmark -> padop1 -> padop2
15529              */
15530             if (o->op_next && (
15531                     o->op_next->op_type == OP_PADSV
15532                  || o->op_next->op_type == OP_PADAV
15533                  || o->op_next->op_type == OP_PADHV
15534                 )
15535                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15536                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15537                 && o->op_next->op_next->op_next && (
15538                     o->op_next->op_next->op_next->op_type == OP_PADSV
15539                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15540                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15541                 )
15542                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15543                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15544                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15545                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15546             ) {
15547                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15548
15549                 pad1 =    o->op_next;
15550                 ns2  = pad1->op_next;
15551                 pad2 =  ns2->op_next;
15552                 ns3  = pad2->op_next;
15553
15554                 /* we assume here that the op_next chain is the same as
15555                  * the op_sibling chain */
15556                 assert(OpSIBLING(o)    == pad1);
15557                 assert(OpSIBLING(pad1) == ns2);
15558                 assert(OpSIBLING(ns2)  == pad2);
15559                 assert(OpSIBLING(pad2) == ns3);
15560
15561                 /* excise and delete ns2 */
15562                 op_sibling_splice(NULL, pad1, 1, NULL);
15563                 op_free(ns2);
15564
15565                 /* excise pad1 and pad2 */
15566                 op_sibling_splice(NULL, o, 2, NULL);
15567
15568                 /* create new listop, with children consisting of:
15569                  * a new pushmark, pad1, pad2. */
15570                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15571                 newop->op_flags |= OPf_PARENS;
15572                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15573
15574                 /* insert newop between o and ns3 */
15575                 op_sibling_splice(NULL, o, 0, newop);
15576
15577                 /*fixup op_next chain */
15578                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15579                 o    ->op_next = newpm;
15580                 newpm->op_next = pad1;
15581                 pad1 ->op_next = pad2;
15582                 pad2 ->op_next = newop; /* listop */
15583                 newop->op_next = ns3;
15584
15585                 /* Ensure pushmark has this flag if padops do */
15586                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15587                     newpm->op_flags |= OPf_MOD;
15588                 }
15589
15590                 break;
15591             }
15592
15593             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15594                to carry two labels. For now, take the easier option, and skip
15595                this optimisation if the first NEXTSTATE has a label.  */
15596             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15597                 OP *nextop = o->op_next;
15598                 while (nextop && nextop->op_type == OP_NULL)
15599                     nextop = nextop->op_next;
15600
15601                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15602                     op_null(o);
15603                     if (oldop)
15604                         oldop->op_next = nextop;
15605                     o = nextop;
15606                     /* Skip (old)oldop assignment since the current oldop's
15607                        op_next already points to the next op.  */
15608                     goto redo;
15609                 }
15610             }
15611             break;
15612
15613         case OP_CONCAT:
15614             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15615                 if (o->op_next->op_private & OPpTARGET_MY) {
15616                     if (o->op_flags & OPf_STACKED) /* chained concats */
15617                         break; /* ignore_optimization */
15618                     else {
15619                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15620                         o->op_targ = o->op_next->op_targ;
15621                         o->op_next->op_targ = 0;
15622                         o->op_private |= OPpTARGET_MY;
15623                     }
15624                 }
15625                 op_null(o->op_next);
15626             }
15627             break;
15628         case OP_STUB:
15629             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15630                 break; /* Scalar stub must produce undef.  List stub is noop */
15631             }
15632             goto nothin;
15633         case OP_NULL:
15634             if (o->op_targ == OP_NEXTSTATE
15635                 || o->op_targ == OP_DBSTATE)
15636             {
15637                 PL_curcop = ((COP*)o);
15638             }
15639             /* XXX: We avoid setting op_seq here to prevent later calls
15640                to rpeep() from mistakenly concluding that optimisation
15641                has already occurred. This doesn't fix the real problem,
15642                though (See 20010220.007 (#5874)). AMS 20010719 */
15643             /* op_seq functionality is now replaced by op_opt */
15644             o->op_opt = 0;
15645             /* FALLTHROUGH */
15646         case OP_SCALAR:
15647         case OP_LINESEQ:
15648         case OP_SCOPE:
15649         nothin:
15650             if (oldop) {
15651                 oldop->op_next = o->op_next;
15652                 o->op_opt = 0;
15653                 continue;
15654             }
15655             break;
15656
15657         case OP_PUSHMARK:
15658
15659             /* Given
15660                  5 repeat/DOLIST
15661                  3   ex-list
15662                  1     pushmark
15663                  2     scalar or const
15664                  4   const[0]
15665                convert repeat into a stub with no kids.
15666              */
15667             if (o->op_next->op_type == OP_CONST
15668              || (  o->op_next->op_type == OP_PADSV
15669                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15670              || (  o->op_next->op_type == OP_GV
15671                 && o->op_next->op_next->op_type == OP_RV2SV
15672                 && !(o->op_next->op_next->op_private
15673                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15674             {
15675                 const OP *kid = o->op_next->op_next;
15676                 if (o->op_next->op_type == OP_GV)
15677                    kid = kid->op_next;
15678                 /* kid is now the ex-list.  */
15679                 if (kid->op_type == OP_NULL
15680                  && (kid = kid->op_next)->op_type == OP_CONST
15681                     /* kid is now the repeat count.  */
15682                  && kid->op_next->op_type == OP_REPEAT
15683                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15684                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15685                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15686                  && oldop)
15687                 {
15688                     o = kid->op_next; /* repeat */
15689                     oldop->op_next = o;
15690                     op_free(cBINOPo->op_first);
15691                     op_free(cBINOPo->op_last );
15692                     o->op_flags &=~ OPf_KIDS;
15693                     /* stub is a baseop; repeat is a binop */
15694                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15695                     OpTYPE_set(o, OP_STUB);
15696                     o->op_private = 0;
15697                     break;
15698                 }
15699             }
15700
15701             /* Convert a series of PAD ops for my vars plus support into a
15702              * single padrange op. Basically
15703              *
15704              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15705              *
15706              * becomes, depending on circumstances, one of
15707              *
15708              *    padrange  ----------------------------------> (list) -> rest
15709              *    padrange  --------------------------------------------> rest
15710              *
15711              * where all the pad indexes are sequential and of the same type
15712              * (INTRO or not).
15713              * We convert the pushmark into a padrange op, then skip
15714              * any other pad ops, and possibly some trailing ops.
15715              * Note that we don't null() the skipped ops, to make it
15716              * easier for Deparse to undo this optimisation (and none of
15717              * the skipped ops are holding any resourses). It also makes
15718              * it easier for find_uninit_var(), as it can just ignore
15719              * padrange, and examine the original pad ops.
15720              */
15721         {
15722             OP *p;
15723             OP *followop = NULL; /* the op that will follow the padrange op */
15724             U8 count = 0;
15725             U8 intro = 0;
15726             PADOFFSET base = 0; /* init only to stop compiler whining */
15727             bool gvoid = 0;     /* init only to stop compiler whining */
15728             bool defav = 0;  /* seen (...) = @_ */
15729             bool reuse = 0;  /* reuse an existing padrange op */
15730
15731             /* look for a pushmark -> gv[_] -> rv2av */
15732
15733             {
15734                 OP *rv2av, *q;
15735                 p = o->op_next;
15736                 if (   p->op_type == OP_GV
15737                     && cGVOPx_gv(p) == PL_defgv
15738                     && (rv2av = p->op_next)
15739                     && rv2av->op_type == OP_RV2AV
15740                     && !(rv2av->op_flags & OPf_REF)
15741                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15742                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15743                 ) {
15744                     q = rv2av->op_next;
15745                     if (q->op_type == OP_NULL)
15746                         q = q->op_next;
15747                     if (q->op_type == OP_PUSHMARK) {
15748                         defav = 1;
15749                         p = q;
15750                     }
15751                 }
15752             }
15753             if (!defav) {
15754                 p = o;
15755             }
15756
15757             /* scan for PAD ops */
15758
15759             for (p = p->op_next; p; p = p->op_next) {
15760                 if (p->op_type == OP_NULL)
15761                     continue;
15762
15763                 if ((     p->op_type != OP_PADSV
15764                        && p->op_type != OP_PADAV
15765                        && p->op_type != OP_PADHV
15766                     )
15767                       /* any private flag other than INTRO? e.g. STATE */
15768                    || (p->op_private & ~OPpLVAL_INTRO)
15769                 )
15770                     break;
15771
15772                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15773                  * instead */
15774                 if (   p->op_type == OP_PADAV
15775                     && p->op_next
15776                     && p->op_next->op_type == OP_CONST
15777                     && p->op_next->op_next
15778                     && p->op_next->op_next->op_type == OP_AELEM
15779                 )
15780                     break;
15781
15782                 /* for 1st padop, note what type it is and the range
15783                  * start; for the others, check that it's the same type
15784                  * and that the targs are contiguous */
15785                 if (count == 0) {
15786                     intro = (p->op_private & OPpLVAL_INTRO);
15787                     base = p->op_targ;
15788                     gvoid = OP_GIMME(p,0) == G_VOID;
15789                 }
15790                 else {
15791                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15792                         break;
15793                     /* Note that you'd normally  expect targs to be
15794                      * contiguous in my($a,$b,$c), but that's not the case
15795                      * when external modules start doing things, e.g.
15796                      * Function::Parameters */
15797                     if (p->op_targ != base + count)
15798                         break;
15799                     assert(p->op_targ == base + count);
15800                     /* Either all the padops or none of the padops should
15801                        be in void context.  Since we only do the optimisa-
15802                        tion for av/hv when the aggregate itself is pushed
15803                        on to the stack (one item), there is no need to dis-
15804                        tinguish list from scalar context.  */
15805                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15806                         break;
15807                 }
15808
15809                 /* for AV, HV, only when we're not flattening */
15810                 if (   p->op_type != OP_PADSV
15811                     && !gvoid
15812                     && !(p->op_flags & OPf_REF)
15813                 )
15814                     break;
15815
15816                 if (count >= OPpPADRANGE_COUNTMASK)
15817                     break;
15818
15819                 /* there's a biggest base we can fit into a
15820                  * SAVEt_CLEARPADRANGE in pp_padrange.
15821                  * (The sizeof() stuff will be constant-folded, and is
15822                  * intended to avoid getting "comparison is always false"
15823                  * compiler warnings. See the comments above
15824                  * MEM_WRAP_CHECK for more explanation on why we do this
15825                  * in a weird way to avoid compiler warnings.)
15826                  */
15827                 if (   intro
15828                     && (8*sizeof(base) >
15829                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15830                         ? (Size_t)base
15831                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15832                         ) >
15833                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15834                 )
15835                     break;
15836
15837                 /* Success! We've got another valid pad op to optimise away */
15838                 count++;
15839                 followop = p->op_next;
15840             }
15841
15842             if (count < 1 || (count == 1 && !defav))
15843                 break;
15844
15845             /* pp_padrange in specifically compile-time void context
15846              * skips pushing a mark and lexicals; in all other contexts
15847              * (including unknown till runtime) it pushes a mark and the
15848              * lexicals. We must be very careful then, that the ops we
15849              * optimise away would have exactly the same effect as the
15850              * padrange.
15851              * In particular in void context, we can only optimise to
15852              * a padrange if we see the complete sequence
15853              *     pushmark, pad*v, ...., list
15854              * which has the net effect of leaving the markstack as it
15855              * was.  Not pushing onto the stack (whereas padsv does touch
15856              * the stack) makes no difference in void context.
15857              */
15858             assert(followop);
15859             if (gvoid) {
15860                 if (followop->op_type == OP_LIST
15861                         && OP_GIMME(followop,0) == G_VOID
15862                    )
15863                 {
15864                     followop = followop->op_next; /* skip OP_LIST */
15865
15866                     /* consolidate two successive my(...);'s */
15867
15868                     if (   oldoldop
15869                         && oldoldop->op_type == OP_PADRANGE
15870                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15871                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15872                         && !(oldoldop->op_flags & OPf_SPECIAL)
15873                     ) {
15874                         U8 old_count;
15875                         assert(oldoldop->op_next == oldop);
15876                         assert(   oldop->op_type == OP_NEXTSTATE
15877                                || oldop->op_type == OP_DBSTATE);
15878                         assert(oldop->op_next == o);
15879
15880                         old_count
15881                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15882
15883                        /* Do not assume pad offsets for $c and $d are con-
15884                           tiguous in
15885                             my ($a,$b,$c);
15886                             my ($d,$e,$f);
15887                         */
15888                         if (  oldoldop->op_targ + old_count == base
15889                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15890                             base = oldoldop->op_targ;
15891                             count += old_count;
15892                             reuse = 1;
15893                         }
15894                     }
15895
15896                     /* if there's any immediately following singleton
15897                      * my var's; then swallow them and the associated
15898                      * nextstates; i.e.
15899                      *    my ($a,$b); my $c; my $d;
15900                      * is treated as
15901                      *    my ($a,$b,$c,$d);
15902                      */
15903
15904                     while (    ((p = followop->op_next))
15905                             && (  p->op_type == OP_PADSV
15906                                || p->op_type == OP_PADAV
15907                                || p->op_type == OP_PADHV)
15908                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15909                             && (p->op_private & OPpLVAL_INTRO) == intro
15910                             && !(p->op_private & ~OPpLVAL_INTRO)
15911                             && p->op_next
15912                             && (   p->op_next->op_type == OP_NEXTSTATE
15913                                 || p->op_next->op_type == OP_DBSTATE)
15914                             && count < OPpPADRANGE_COUNTMASK
15915                             && base + count == p->op_targ
15916                     ) {
15917                         count++;
15918                         followop = p->op_next;
15919                     }
15920                 }
15921                 else
15922                     break;
15923             }
15924
15925             if (reuse) {
15926                 assert(oldoldop->op_type == OP_PADRANGE);
15927                 oldoldop->op_next = followop;
15928                 oldoldop->op_private = (intro | count);
15929                 o = oldoldop;
15930                 oldop = NULL;
15931                 oldoldop = NULL;
15932             }
15933             else {
15934                 /* Convert the pushmark into a padrange.
15935                  * To make Deparse easier, we guarantee that a padrange was
15936                  * *always* formerly a pushmark */
15937                 assert(o->op_type == OP_PUSHMARK);
15938                 o->op_next = followop;
15939                 OpTYPE_set(o, OP_PADRANGE);
15940                 o->op_targ = base;
15941                 /* bit 7: INTRO; bit 6..0: count */
15942                 o->op_private = (intro | count);
15943                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15944                               | gvoid * OPf_WANT_VOID
15945                               | (defav ? OPf_SPECIAL : 0));
15946             }
15947             break;
15948         }
15949
15950         case OP_RV2AV:
15951             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15952                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15953             break;
15954
15955         case OP_RV2HV:
15956         case OP_PADHV:
15957             /*'keys %h' in void or scalar context: skip the OP_KEYS
15958              * and perform the functionality directly in the RV2HV/PADHV
15959              * op
15960              */
15961             if (o->op_flags & OPf_REF) {
15962                 OP *k = o->op_next;
15963                 U8 want = (k->op_flags & OPf_WANT);
15964                 if (   k
15965                     && k->op_type == OP_KEYS
15966                     && (   want == OPf_WANT_VOID
15967                         || want == OPf_WANT_SCALAR)
15968                     && !(k->op_private & OPpMAYBE_LVSUB)
15969                     && !(k->op_flags & OPf_MOD)
15970                 ) {
15971                     o->op_next     = k->op_next;
15972                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15973                     o->op_flags   |= want;
15974                     o->op_private |= (o->op_type == OP_PADHV ?
15975                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15976                     /* for keys(%lex), hold onto the OP_KEYS's targ
15977                      * since padhv doesn't have its own targ to return
15978                      * an int with */
15979                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15980                         op_null(k);
15981                 }
15982             }
15983
15984             /* see if %h is used in boolean context */
15985             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15986                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15987
15988
15989             if (o->op_type != OP_PADHV)
15990                 break;
15991             /* FALLTHROUGH */
15992         case OP_PADAV:
15993             if (   o->op_type == OP_PADAV
15994                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15995             )
15996                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15997             /* FALLTHROUGH */
15998         case OP_PADSV:
15999             /* Skip over state($x) in void context.  */
16000             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16001              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16002             {
16003                 oldop->op_next = o->op_next;
16004                 goto redo_nextstate;
16005             }
16006             if (o->op_type != OP_PADAV)
16007                 break;
16008             /* FALLTHROUGH */
16009         case OP_GV:
16010             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16011                 OP* const pop = (o->op_type == OP_PADAV) ?
16012                             o->op_next : o->op_next->op_next;
16013                 IV i;
16014                 if (pop && pop->op_type == OP_CONST &&
16015                     ((PL_op = pop->op_next)) &&
16016                     pop->op_next->op_type == OP_AELEM &&
16017                     !(pop->op_next->op_private &
16018                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16019                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16020                 {
16021                     GV *gv;
16022                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16023                         no_bareword_allowed(pop);
16024                     if (o->op_type == OP_GV)
16025                         op_null(o->op_next);
16026                     op_null(pop->op_next);
16027                     op_null(pop);
16028                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16029                     o->op_next = pop->op_next->op_next;
16030                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16031                     o->op_private = (U8)i;
16032                     if (o->op_type == OP_GV) {
16033                         gv = cGVOPo_gv;
16034                         GvAVn(gv);
16035                         o->op_type = OP_AELEMFAST;
16036                     }
16037                     else
16038                         o->op_type = OP_AELEMFAST_LEX;
16039                 }
16040                 if (o->op_type != OP_GV)
16041                     break;
16042             }
16043
16044             /* Remove $foo from the op_next chain in void context.  */
16045             if (oldop
16046              && (  o->op_next->op_type == OP_RV2SV
16047                 || o->op_next->op_type == OP_RV2AV
16048                 || o->op_next->op_type == OP_RV2HV  )
16049              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16050              && !(o->op_next->op_private & OPpLVAL_INTRO))
16051             {
16052                 oldop->op_next = o->op_next->op_next;
16053                 /* Reprocess the previous op if it is a nextstate, to
16054                    allow double-nextstate optimisation.  */
16055               redo_nextstate:
16056                 if (oldop->op_type == OP_NEXTSTATE) {
16057                     oldop->op_opt = 0;
16058                     o = oldop;
16059                     oldop = oldoldop;
16060                     oldoldop = NULL;
16061                     goto redo;
16062                 }
16063                 o = oldop->op_next;
16064                 goto redo;
16065             }
16066             else if (o->op_next->op_type == OP_RV2SV) {
16067                 if (!(o->op_next->op_private & OPpDEREF)) {
16068                     op_null(o->op_next);
16069                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16070                                                                | OPpOUR_INTRO);
16071                     o->op_next = o->op_next->op_next;
16072                     OpTYPE_set(o, OP_GVSV);
16073                 }
16074             }
16075             else if (o->op_next->op_type == OP_READLINE
16076                     && o->op_next->op_next->op_type == OP_CONCAT
16077                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16078             {
16079                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16080                 OpTYPE_set(o, OP_RCATLINE);
16081                 o->op_flags |= OPf_STACKED;
16082                 op_null(o->op_next->op_next);
16083                 op_null(o->op_next);
16084             }
16085
16086             break;
16087
16088         case OP_NOT:
16089             break;
16090
16091         case OP_AND:
16092         case OP_OR:
16093         case OP_DOR:
16094             while (cLOGOP->op_other->op_type == OP_NULL)
16095                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16096             while (o->op_next && (   o->op_type == o->op_next->op_type
16097                                   || o->op_next->op_type == OP_NULL))
16098                 o->op_next = o->op_next->op_next;
16099
16100             /* If we're an OR and our next is an AND in void context, we'll
16101                follow its op_other on short circuit, same for reverse.
16102                We can't do this with OP_DOR since if it's true, its return
16103                value is the underlying value which must be evaluated
16104                by the next op. */
16105             if (o->op_next &&
16106                 (
16107                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16108                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16109                 )
16110                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16111             ) {
16112                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16113             }
16114             DEFER(cLOGOP->op_other);
16115             o->op_opt = 1;
16116             break;
16117
16118         case OP_GREPWHILE:
16119             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16120                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16121             /* FALLTHROUGH */
16122         case OP_COND_EXPR:
16123         case OP_MAPWHILE:
16124         case OP_ANDASSIGN:
16125         case OP_ORASSIGN:
16126         case OP_DORASSIGN:
16127         case OP_RANGE:
16128         case OP_ONCE:
16129         case OP_ARGDEFELEM:
16130             while (cLOGOP->op_other->op_type == OP_NULL)
16131                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16132             DEFER(cLOGOP->op_other);
16133             break;
16134
16135         case OP_ENTERLOOP:
16136         case OP_ENTERITER:
16137             while (cLOOP->op_redoop->op_type == OP_NULL)
16138                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16139             while (cLOOP->op_nextop->op_type == OP_NULL)
16140                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16141             while (cLOOP->op_lastop->op_type == OP_NULL)
16142                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16143             /* a while(1) loop doesn't have an op_next that escapes the
16144              * loop, so we have to explicitly follow the op_lastop to
16145              * process the rest of the code */
16146             DEFER(cLOOP->op_lastop);
16147             break;
16148
16149         case OP_ENTERTRY:
16150             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16151             DEFER(cLOGOPo->op_other);
16152             break;
16153
16154         case OP_SUBST:
16155             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16156                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16157             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16158             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16159                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16160                 cPMOP->op_pmstashstartu.op_pmreplstart
16161                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16162             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16163             break;
16164
16165         case OP_SORT: {
16166             OP *oright;
16167
16168             if (o->op_flags & OPf_SPECIAL) {
16169                 /* first arg is a code block */
16170                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16171                 OP * kid          = cUNOPx(nullop)->op_first;
16172
16173                 assert(nullop->op_type == OP_NULL);
16174                 assert(kid->op_type == OP_SCOPE
16175                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16176                 /* since OP_SORT doesn't have a handy op_other-style
16177                  * field that can point directly to the start of the code
16178                  * block, store it in the otherwise-unused op_next field
16179                  * of the top-level OP_NULL. This will be quicker at
16180                  * run-time, and it will also allow us to remove leading
16181                  * OP_NULLs by just messing with op_nexts without
16182                  * altering the basic op_first/op_sibling layout. */
16183                 kid = kLISTOP->op_first;
16184                 assert(
16185                       (kid->op_type == OP_NULL
16186                       && (  kid->op_targ == OP_NEXTSTATE
16187                          || kid->op_targ == OP_DBSTATE  ))
16188                     || kid->op_type == OP_STUB
16189                     || kid->op_type == OP_ENTER
16190                     || (PL_parser && PL_parser->error_count));
16191                 nullop->op_next = kid->op_next;
16192                 DEFER(nullop->op_next);
16193             }
16194
16195             /* check that RHS of sort is a single plain array */
16196             oright = cUNOPo->op_first;
16197             if (!oright || oright->op_type != OP_PUSHMARK)
16198                 break;
16199
16200             if (o->op_private & OPpSORT_INPLACE)
16201                 break;
16202
16203             /* reverse sort ... can be optimised.  */
16204             if (!OpHAS_SIBLING(cUNOPo)) {
16205                 /* Nothing follows us on the list. */
16206                 OP * const reverse = o->op_next;
16207
16208                 if (reverse->op_type == OP_REVERSE &&
16209                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16210                     OP * const pushmark = cUNOPx(reverse)->op_first;
16211                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16212                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16213                         /* reverse -> pushmark -> sort */
16214                         o->op_private |= OPpSORT_REVERSE;
16215                         op_null(reverse);
16216                         pushmark->op_next = oright->op_next;
16217                         op_null(oright);
16218                     }
16219                 }
16220             }
16221
16222             break;
16223         }
16224
16225         case OP_REVERSE: {
16226             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16227             OP *gvop = NULL;
16228             LISTOP *enter, *exlist;
16229
16230             if (o->op_private & OPpSORT_INPLACE)
16231                 break;
16232
16233             enter = (LISTOP *) o->op_next;
16234             if (!enter)
16235                 break;
16236             if (enter->op_type == OP_NULL) {
16237                 enter = (LISTOP *) enter->op_next;
16238                 if (!enter)
16239                     break;
16240             }
16241             /* for $a (...) will have OP_GV then OP_RV2GV here.
16242                for (...) just has an OP_GV.  */
16243             if (enter->op_type == OP_GV) {
16244                 gvop = (OP *) enter;
16245                 enter = (LISTOP *) enter->op_next;
16246                 if (!enter)
16247                     break;
16248                 if (enter->op_type == OP_RV2GV) {
16249                   enter = (LISTOP *) enter->op_next;
16250                   if (!enter)
16251                     break;
16252                 }
16253             }
16254
16255             if (enter->op_type != OP_ENTERITER)
16256                 break;
16257
16258             iter = enter->op_next;
16259             if (!iter || iter->op_type != OP_ITER)
16260                 break;
16261
16262             expushmark = enter->op_first;
16263             if (!expushmark || expushmark->op_type != OP_NULL
16264                 || expushmark->op_targ != OP_PUSHMARK)
16265                 break;
16266
16267             exlist = (LISTOP *) OpSIBLING(expushmark);
16268             if (!exlist || exlist->op_type != OP_NULL
16269                 || exlist->op_targ != OP_LIST)
16270                 break;
16271
16272             if (exlist->op_last != o) {
16273                 /* Mmm. Was expecting to point back to this op.  */
16274                 break;
16275             }
16276             theirmark = exlist->op_first;
16277             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16278                 break;
16279
16280             if (OpSIBLING(theirmark) != o) {
16281                 /* There's something between the mark and the reverse, eg
16282                    for (1, reverse (...))
16283                    so no go.  */
16284                 break;
16285             }
16286
16287             ourmark = ((LISTOP *)o)->op_first;
16288             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16289                 break;
16290
16291             ourlast = ((LISTOP *)o)->op_last;
16292             if (!ourlast || ourlast->op_next != o)
16293                 break;
16294
16295             rv2av = OpSIBLING(ourmark);
16296             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16297                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16298                 /* We're just reversing a single array.  */
16299                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16300                 enter->op_flags |= OPf_STACKED;
16301             }
16302
16303             /* We don't have control over who points to theirmark, so sacrifice
16304                ours.  */
16305             theirmark->op_next = ourmark->op_next;
16306             theirmark->op_flags = ourmark->op_flags;
16307             ourlast->op_next = gvop ? gvop : (OP *) enter;
16308             op_null(ourmark);
16309             op_null(o);
16310             enter->op_private |= OPpITER_REVERSED;
16311             iter->op_private |= OPpITER_REVERSED;
16312
16313             oldoldop = NULL;
16314             oldop    = ourlast;
16315             o        = oldop->op_next;
16316             goto redo;
16317             NOT_REACHED; /* NOTREACHED */
16318             break;
16319         }
16320
16321         case OP_QR:
16322         case OP_MATCH:
16323             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16324                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16325             }
16326             break;
16327
16328         case OP_RUNCV:
16329             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16330              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16331             {
16332                 SV *sv;
16333                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16334                 else {
16335                     sv = newRV((SV *)PL_compcv);
16336                     sv_rvweaken(sv);
16337                     SvREADONLY_on(sv);
16338                 }
16339                 OpTYPE_set(o, OP_CONST);
16340                 o->op_flags |= OPf_SPECIAL;
16341                 cSVOPo->op_sv = sv;
16342             }
16343             break;
16344
16345         case OP_SASSIGN:
16346             if (OP_GIMME(o,0) == G_VOID
16347              || (  o->op_next->op_type == OP_LINESEQ
16348                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16349                    || (  o->op_next->op_next->op_type == OP_RETURN
16350                       && !CvLVALUE(PL_compcv)))))
16351             {
16352                 OP *right = cBINOP->op_first;
16353                 if (right) {
16354                     /*   sassign
16355                     *      RIGHT
16356                     *      substr
16357                     *         pushmark
16358                     *         arg1
16359                     *         arg2
16360                     *         ...
16361                     * becomes
16362                     *
16363                     *  ex-sassign
16364                     *     substr
16365                     *        pushmark
16366                     *        RIGHT
16367                     *        arg1
16368                     *        arg2
16369                     *        ...
16370                     */
16371                     OP *left = OpSIBLING(right);
16372                     if (left->op_type == OP_SUBSTR
16373                          && (left->op_private & 7) < 4) {
16374                         op_null(o);
16375                         /* cut out right */
16376                         op_sibling_splice(o, NULL, 1, NULL);
16377                         /* and insert it as second child of OP_SUBSTR */
16378                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16379                                     right);
16380                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16381                         left->op_flags =
16382                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16383                     }
16384                 }
16385             }
16386             break;
16387
16388         case OP_AASSIGN: {
16389             int l, r, lr, lscalars, rscalars;
16390
16391             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16392                Note that we do this now rather than in newASSIGNOP(),
16393                since only by now are aliased lexicals flagged as such
16394
16395                See the essay "Common vars in list assignment" above for
16396                the full details of the rationale behind all the conditions
16397                below.
16398
16399                PL_generation sorcery:
16400                To detect whether there are common vars, the global var
16401                PL_generation is incremented for each assign op we scan.
16402                Then we run through all the lexical variables on the LHS,
16403                of the assignment, setting a spare slot in each of them to
16404                PL_generation.  Then we scan the RHS, and if any lexicals
16405                already have that value, we know we've got commonality.
16406                Also, if the generation number is already set to
16407                PERL_INT_MAX, then the variable is involved in aliasing, so
16408                we also have potential commonality in that case.
16409              */
16410
16411             PL_generation++;
16412             /* scan LHS */
16413             lscalars = 0;
16414             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16415             /* scan RHS */
16416             rscalars = 0;
16417             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16418             lr = (l|r);
16419
16420
16421             /* After looking for things which are *always* safe, this main
16422              * if/else chain selects primarily based on the type of the
16423              * LHS, gradually working its way down from the more dangerous
16424              * to the more restrictive and thus safer cases */
16425
16426             if (   !l                      /* () = ....; */
16427                 || !r                      /* .... = (); */
16428                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16429                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16430                 || (lscalars < 2)          /* ($x, undef) = ... */
16431             ) {
16432                 NOOP; /* always safe */
16433             }
16434             else if (l & AAS_DANGEROUS) {
16435                 /* always dangerous */
16436                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16437                 o->op_private |= OPpASSIGN_COMMON_AGG;
16438             }
16439             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16440                 /* package vars are always dangerous - too many
16441                  * aliasing possibilities */
16442                 if (l & AAS_PKG_SCALAR)
16443                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16444                 if (l & AAS_PKG_AGG)
16445                     o->op_private |= OPpASSIGN_COMMON_AGG;
16446             }
16447             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16448                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16449             {
16450                 /* LHS contains only lexicals and safe ops */
16451
16452                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16453                     o->op_private |= OPpASSIGN_COMMON_AGG;
16454
16455                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16456                     if (lr & AAS_LEX_SCALAR_COMM)
16457                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16458                     else if (   !(l & AAS_LEX_SCALAR)
16459                              && (r & AAS_DEFAV))
16460                     {
16461                         /* falsely mark
16462                          *    my (...) = @_
16463                          * as scalar-safe for performance reasons.
16464                          * (it will still have been marked _AGG if necessary */
16465                         NOOP;
16466                     }
16467                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16468                         /* if there are only lexicals on the LHS and no
16469                          * common ones on the RHS, then we assume that the
16470                          * only way those lexicals could also get
16471                          * on the RHS is via some sort of dereffing or
16472                          * closure, e.g.
16473                          *    $r = \$lex;
16474                          *    ($lex, $x) = (1, $$r)
16475                          * and in this case we assume the var must have
16476                          *  a bumped ref count. So if its ref count is 1,
16477                          *  it must only be on the LHS.
16478                          */
16479                         o->op_private |= OPpASSIGN_COMMON_RC1;
16480                 }
16481             }
16482
16483             /* ... = ($x)
16484              * may have to handle aggregate on LHS, but we can't
16485              * have common scalars. */
16486             if (rscalars < 2)
16487                 o->op_private &=
16488                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16489
16490             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16491                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16492             break;
16493         }
16494
16495         case OP_REF:
16496             /* see if ref() is used in boolean context */
16497             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16498                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16499             break;
16500
16501         case OP_LENGTH:
16502             /* see if the op is used in known boolean context,
16503              * but not if OA_TARGLEX optimisation is enabled */
16504             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16505                 && !(o->op_private & OPpTARGET_MY)
16506             )
16507                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16508             break;
16509
16510         case OP_POS:
16511             /* see if the op is used in known boolean context */
16512             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16513                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16514             break;
16515
16516         case OP_CUSTOM: {
16517             Perl_cpeep_t cpeep =
16518                 XopENTRYCUSTOM(o, xop_peep);
16519             if (cpeep)
16520                 cpeep(aTHX_ o, oldop);
16521             break;
16522         }
16523
16524         }
16525         /* did we just null the current op? If so, re-process it to handle
16526          * eliding "empty" ops from the chain */
16527         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16528             o->op_opt = 0;
16529             o = oldop;
16530         }
16531         else {
16532             oldoldop = oldop;
16533             oldop = o;
16534         }
16535     }
16536     LEAVE;
16537 }
16538
16539 void
16540 Perl_peep(pTHX_ OP *o)
16541 {
16542     CALL_RPEEP(o);
16543 }
16544
16545 /*
16546 =head1 Custom Operators
16547
16548 =for apidoc Ao||custom_op_xop
16549 Return the XOP structure for a given custom op.  This macro should be
16550 considered internal to C<OP_NAME> and the other access macros: use them instead.
16551 This macro does call a function.  Prior
16552 to 5.19.6, this was implemented as a
16553 function.
16554
16555 =cut
16556 */
16557
16558 XOPRETANY
16559 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16560 {
16561     SV *keysv;
16562     HE *he = NULL;
16563     XOP *xop;
16564
16565     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16566
16567     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16568     assert(o->op_type == OP_CUSTOM);
16569
16570     /* This is wrong. It assumes a function pointer can be cast to IV,
16571      * which isn't guaranteed, but this is what the old custom OP code
16572      * did. In principle it should be safer to Copy the bytes of the
16573      * pointer into a PV: since the new interface is hidden behind
16574      * functions, this can be changed later if necessary.  */
16575     /* Change custom_op_xop if this ever happens */
16576     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16577
16578     if (PL_custom_ops)
16579         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16580
16581     /* assume noone will have just registered a desc */
16582     if (!he && PL_custom_op_names &&
16583         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16584     ) {
16585         const char *pv;
16586         STRLEN l;
16587
16588         /* XXX does all this need to be shared mem? */
16589         Newxz(xop, 1, XOP);
16590         pv = SvPV(HeVAL(he), l);
16591         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16592         if (PL_custom_op_descs &&
16593             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16594         ) {
16595             pv = SvPV(HeVAL(he), l);
16596             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16597         }
16598         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16599     }
16600     else {
16601         if (!he)
16602             xop = (XOP *)&xop_null;
16603         else
16604             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16605     }
16606     {
16607         XOPRETANY any;
16608         if(field == XOPe_xop_ptr) {
16609             any.xop_ptr = xop;
16610         } else {
16611             const U32 flags = XopFLAGS(xop);
16612             if(flags & field) {
16613                 switch(field) {
16614                 case XOPe_xop_name:
16615                     any.xop_name = xop->xop_name;
16616                     break;
16617                 case XOPe_xop_desc:
16618                     any.xop_desc = xop->xop_desc;
16619                     break;
16620                 case XOPe_xop_class:
16621                     any.xop_class = xop->xop_class;
16622                     break;
16623                 case XOPe_xop_peep:
16624                     any.xop_peep = xop->xop_peep;
16625                     break;
16626                 default:
16627                     NOT_REACHED; /* NOTREACHED */
16628                     break;
16629                 }
16630             } else {
16631                 switch(field) {
16632                 case XOPe_xop_name:
16633                     any.xop_name = XOPd_xop_name;
16634                     break;
16635                 case XOPe_xop_desc:
16636                     any.xop_desc = XOPd_xop_desc;
16637                     break;
16638                 case XOPe_xop_class:
16639                     any.xop_class = XOPd_xop_class;
16640                     break;
16641                 case XOPe_xop_peep:
16642                     any.xop_peep = XOPd_xop_peep;
16643                     break;
16644                 default:
16645                     NOT_REACHED; /* NOTREACHED */
16646                     break;
16647                 }
16648             }
16649         }
16650         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16651          * op.c: In function 'Perl_custom_op_get_field':
16652          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16653          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16654          * expands to assert(0), which expands to ((0) ? (void)0 :
16655          * __assert(...)), and gcc doesn't know that __assert can never return. */
16656         return any;
16657     }
16658 }
16659
16660 /*
16661 =for apidoc Ao||custom_op_register
16662 Register a custom op.  See L<perlguts/"Custom Operators">.
16663
16664 =cut
16665 */
16666
16667 void
16668 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16669 {
16670     SV *keysv;
16671
16672     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16673
16674     /* see the comment in custom_op_xop */
16675     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16676
16677     if (!PL_custom_ops)
16678         PL_custom_ops = newHV();
16679
16680     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16681         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16682 }
16683
16684 /*
16685
16686 =for apidoc core_prototype
16687
16688 This function assigns the prototype of the named core function to C<sv>, or
16689 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16690 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16691 by C<keyword()>.  It must not be equal to 0.
16692
16693 =cut
16694 */
16695
16696 SV *
16697 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16698                           int * const opnum)
16699 {
16700     int i = 0, n = 0, seen_question = 0, defgv = 0;
16701     I32 oa;
16702 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16703     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16704     bool nullret = FALSE;
16705
16706     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16707
16708     assert (code);
16709
16710     if (!sv) sv = sv_newmortal();
16711
16712 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16713
16714     switch (code < 0 ? -code : code) {
16715     case KEY_and   : case KEY_chop: case KEY_chomp:
16716     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16717     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16718     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16719     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16720     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16721     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16722     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16723     case KEY_x     : case KEY_xor    :
16724         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16725     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16726     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16727     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16728     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16729     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16730     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16731         retsetpvs("", 0);
16732     case KEY_evalbytes:
16733         name = "entereval"; break;
16734     case KEY_readpipe:
16735         name = "backtick";
16736     }
16737
16738 #undef retsetpvs
16739
16740   findopnum:
16741     while (i < MAXO) {  /* The slow way. */
16742         if (strEQ(name, PL_op_name[i])
16743             || strEQ(name, PL_op_desc[i]))
16744         {
16745             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16746             goto found;
16747         }
16748         i++;
16749     }
16750     return NULL;
16751   found:
16752     defgv = PL_opargs[i] & OA_DEFGV;
16753     oa = PL_opargs[i] >> OASHIFT;
16754     while (oa) {
16755         if (oa & OA_OPTIONAL && !seen_question && (
16756               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16757         )) {
16758             seen_question = 1;
16759             str[n++] = ';';
16760         }
16761         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16762             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16763             /* But globs are already references (kinda) */
16764             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16765         ) {
16766             str[n++] = '\\';
16767         }
16768         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16769          && !scalar_mod_type(NULL, i)) {
16770             str[n++] = '[';
16771             str[n++] = '$';
16772             str[n++] = '@';
16773             str[n++] = '%';
16774             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16775             str[n++] = '*';
16776             str[n++] = ']';
16777         }
16778         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16779         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16780             str[n-1] = '_'; defgv = 0;
16781         }
16782         oa = oa >> 4;
16783     }
16784     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16785     str[n++] = '\0';
16786     sv_setpvn(sv, str, n - 1);
16787     if (opnum) *opnum = i;
16788     return sv;
16789 }
16790
16791 OP *
16792 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16793                       const int opnum)
16794 {
16795     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16796     OP *o;
16797
16798     PERL_ARGS_ASSERT_CORESUB_OP;
16799
16800     switch(opnum) {
16801     case 0:
16802         return op_append_elem(OP_LINESEQ,
16803                        argop,
16804                        newSLICEOP(0,
16805                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16806                                   newOP(OP_CALLER,0)
16807                        )
16808                );
16809     case OP_EACH:
16810     case OP_KEYS:
16811     case OP_VALUES:
16812         o = newUNOP(OP_AVHVSWITCH,0,argop);
16813         o->op_private = opnum-OP_EACH;
16814         return o;
16815     case OP_SELECT: /* which represents OP_SSELECT as well */
16816         if (code)
16817             return newCONDOP(
16818                          0,
16819                          newBINOP(OP_GT, 0,
16820                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16821                                   newSVOP(OP_CONST, 0, newSVuv(1))
16822                                  ),
16823                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16824                                     OP_SSELECT),
16825                          coresub_op(coreargssv, 0, OP_SELECT)
16826                    );
16827         /* FALLTHROUGH */
16828     default:
16829         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16830         case OA_BASEOP:
16831             return op_append_elem(
16832                         OP_LINESEQ, argop,
16833                         newOP(opnum,
16834                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16835                                 ? OPpOFFBYONE << 8 : 0)
16836                    );
16837         case OA_BASEOP_OR_UNOP:
16838             if (opnum == OP_ENTEREVAL) {
16839                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16840                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16841             }
16842             else o = newUNOP(opnum,0,argop);
16843             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16844             else {
16845           onearg:
16846               if (is_handle_constructor(o, 1))
16847                 argop->op_private |= OPpCOREARGS_DEREF1;
16848               if (scalar_mod_type(NULL, opnum))
16849                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16850             }
16851             return o;
16852         default:
16853             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16854             if (is_handle_constructor(o, 2))
16855                 argop->op_private |= OPpCOREARGS_DEREF2;
16856             if (opnum == OP_SUBSTR) {
16857                 o->op_private |= OPpMAYBE_LVSUB;
16858                 return o;
16859             }
16860             else goto onearg;
16861         }
16862     }
16863 }
16864
16865 void
16866 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16867                                SV * const *new_const_svp)
16868 {
16869     const char *hvname;
16870     bool is_const = !!CvCONST(old_cv);
16871     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16872
16873     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16874
16875     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16876         return;
16877         /* They are 2 constant subroutines generated from
16878            the same constant. This probably means that
16879            they are really the "same" proxy subroutine
16880            instantiated in 2 places. Most likely this is
16881            when a constant is exported twice.  Don't warn.
16882         */
16883     if (
16884         (ckWARN(WARN_REDEFINE)
16885          && !(
16886                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16887              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16888              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16889                  strEQ(hvname, "autouse"))
16890              )
16891         )
16892      || (is_const
16893          && ckWARN_d(WARN_REDEFINE)
16894          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16895         )
16896     )
16897         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16898                           is_const
16899                             ? "Constant subroutine %" SVf " redefined"
16900                             : "Subroutine %" SVf " redefined",
16901                           SVfARG(name));
16902 }
16903
16904 /*
16905 =head1 Hook manipulation
16906
16907 These functions provide convenient and thread-safe means of manipulating
16908 hook variables.
16909
16910 =cut
16911 */
16912
16913 /*
16914 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16915
16916 Puts a C function into the chain of check functions for a specified op
16917 type.  This is the preferred way to manipulate the L</PL_check> array.
16918 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16919 is a pointer to the C function that is to be added to that opcode's
16920 check chain, and C<old_checker_p> points to the storage location where a
16921 pointer to the next function in the chain will be stored.  The value of
16922 C<new_checker> is written into the L</PL_check> array, while the value
16923 previously stored there is written to C<*old_checker_p>.
16924
16925 L</PL_check> is global to an entire process, and a module wishing to
16926 hook op checking may find itself invoked more than once per process,
16927 typically in different threads.  To handle that situation, this function
16928 is idempotent.  The location C<*old_checker_p> must initially (once
16929 per process) contain a null pointer.  A C variable of static duration
16930 (declared at file scope, typically also marked C<static> to give
16931 it internal linkage) will be implicitly initialised appropriately,
16932 if it does not have an explicit initialiser.  This function will only
16933 actually modify the check chain if it finds C<*old_checker_p> to be null.
16934 This function is also thread safe on the small scale.  It uses appropriate
16935 locking to avoid race conditions in accessing L</PL_check>.
16936
16937 When this function is called, the function referenced by C<new_checker>
16938 must be ready to be called, except for C<*old_checker_p> being unfilled.
16939 In a threading situation, C<new_checker> may be called immediately,
16940 even before this function has returned.  C<*old_checker_p> will always
16941 be appropriately set before C<new_checker> is called.  If C<new_checker>
16942 decides not to do anything special with an op that it is given (which
16943 is the usual case for most uses of op check hooking), it must chain the
16944 check function referenced by C<*old_checker_p>.
16945
16946 Taken all together, XS code to hook an op checker should typically look
16947 something like this:
16948
16949     static Perl_check_t nxck_frob;
16950     static OP *myck_frob(pTHX_ OP *op) {
16951         ...
16952         op = nxck_frob(aTHX_ op);
16953         ...
16954         return op;
16955     }
16956     BOOT:
16957         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16958
16959 If you want to influence compilation of calls to a specific subroutine,
16960 then use L</cv_set_call_checker_flags> rather than hooking checking of
16961 all C<entersub> ops.
16962
16963 =cut
16964 */
16965
16966 void
16967 Perl_wrap_op_checker(pTHX_ Optype opcode,
16968     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16969 {
16970     dVAR;
16971
16972     PERL_UNUSED_CONTEXT;
16973     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16974     if (*old_checker_p) return;
16975     OP_CHECK_MUTEX_LOCK;
16976     if (!*old_checker_p) {
16977         *old_checker_p = PL_check[opcode];
16978         PL_check[opcode] = new_checker;
16979     }
16980     OP_CHECK_MUTEX_UNLOCK;
16981 }
16982
16983 #include "XSUB.h"
16984
16985 /* Efficient sub that returns a constant scalar value. */
16986 static void
16987 const_sv_xsub(pTHX_ CV* cv)
16988 {
16989     dXSARGS;
16990     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16991     PERL_UNUSED_ARG(items);
16992     if (!sv) {
16993         XSRETURN(0);
16994     }
16995     EXTEND(sp, 1);
16996     ST(0) = sv;
16997     XSRETURN(1);
16998 }
16999
17000 static void
17001 const_av_xsub(pTHX_ CV* cv)
17002 {
17003     dXSARGS;
17004     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17005     SP -= items;
17006     assert(av);
17007 #ifndef DEBUGGING
17008     if (!av) {
17009         XSRETURN(0);
17010     }
17011 #endif
17012     if (SvRMAGICAL(av))
17013         Perl_croak(aTHX_ "Magical list constants are not supported");
17014     if (GIMME_V != G_ARRAY) {
17015         EXTEND(SP, 1);
17016         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17017         XSRETURN(1);
17018     }
17019     EXTEND(SP, AvFILLp(av)+1);
17020     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17021     XSRETURN(AvFILLp(av)+1);
17022 }
17023
17024
17025 /*
17026  * ex: set ts=8 sts=4 sw=4 et:
17027  */