op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define dDEFER_OP  \
 179     SSize_t defer_stack_alloc = 0; \
 180     SSize_t defer_ix = -1; \
 181     OP **defer_stack = NULL;
 182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
 183 #define DEFERRED_OP_STEP 100
 184 #define DEFER_OP(o) \
 185   STMT_START { \
 186     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 187         defer_stack_alloc += DEFERRED_OP_STEP; \
 188         assert(defer_stack_alloc > 0); \
 189         Renew(defer_stack, defer_stack_alloc, OP *); \
 190     } \
 191     defer_stack[++defer_ix] = o; \
 192   } STMT_END
 193 #define DEFER_REVERSE(count)                            \
 194     STMT_START {                                        \
 195         UV cnt = (count);                               \
 196         if (cnt > 1) {                                  \
 197             OP **top = defer_stack + defer_ix;          \
 198             /* top - (cnt) + 1 isn't safe here */       \
 199             OP **bottom = top - (cnt - 1);              \
 200             OP *tmp;                                    \
 201             assert(bottom >= defer_stack);              \
 202             while (top > bottom) {                      \
 203                 tmp = *top;                             \
 204                 *top-- = *bottom;                       \
 205                 *bottom++ = tmp;                        \
 206             }                                           \
 207         }                                               \
 208     } STMT_END;
 209
 210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 211
 212 /* remove any leading "empty" ops from the op_next chain whose first
 213  * node's address is stored in op_p. Store the updated address of the
 214  * first node in op_p.
 215  */
 216
 217 STATIC void
 218 S_prune_chain_head(OP** op_p)
 219 {
 220     while (*op_p
 221         && (   (*op_p)->op_type == OP_NULL
 222             || (*op_p)->op_type == OP_SCOPE
 223             || (*op_p)->op_type == OP_SCALAR
 224             || (*op_p)->op_type == OP_LINESEQ)
 225     )
 226         *op_p = (*op_p)->op_next;
 227 }
 228
 229
 230 /* See the explanatory comments above struct opslab in op.h. */
 231
 232 #ifdef PERL_DEBUG_READONLY_OPS
 233 #  define PERL_SLAB_SIZE 128
 234 #  define PERL_MAX_SLAB_SIZE 4096
 235 #  include <sys/mman.h>
 236 #endif
 237
 238 #ifndef PERL_SLAB_SIZE
 239 #  define PERL_SLAB_SIZE 64
 240 #endif
 241 #ifndef PERL_MAX_SLAB_SIZE
 242 #  define PERL_MAX_SLAB_SIZE 2048
 243 #endif
 244
 245 /* rounds up to nearest pointer */
 246 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 247 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 248
 249 /* malloc a new op slab (suitable for attaching to PL_compcv) */
 250
 251 static OPSLAB *
 252 S_new_slab(pTHX_ size_t sz)
 253 {
 254 #ifdef PERL_DEBUG_READONLY_OPS
 255     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 256                                    PROT_READ|PROT_WRITE,
 257                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 258     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 259                           (unsigned long) sz, slab));
 260     if (slab == MAP_FAILED) {
 261         perror("mmap failed");
 262         abort();
 263     }
 264     slab->opslab_size = (U16)sz;
 265 #else
 266     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 267 #endif
 268 #ifndef WIN32
 269     /* The context is unused in non-Windows */
 270     PERL_UNUSED_CONTEXT;
 271 #endif
 272     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 273     return slab;
 274 }
 275
 276 /* requires double parens and aTHX_ */
 277 #define DEBUG_S_warn(args)                                             \
 278     DEBUG_S(                                                            \
 279         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 280     )
 281
 282 /* Returns a sz-sized block of memory (suitable for holding an op) from
 283  * a free slot in the chain of op slabs attached to PL_compcv.
 284  * Allocates a new slab if necessary.
 285  * if PL_compcv isn't compiling, malloc() instead.
 286  */
 287
 288 void *
 289 Perl_Slab_Alloc(pTHX_ size_t sz)
 290 {
 291     OPSLAB *slab;
 292     OPSLAB *slab2;
 293     OPSLOT *slot;
 294     OP *o;
 295     size_t opsz, space;
 296
 297     /* We only allocate ops from the slab during subroutine compilation.
 298        We find the slab via PL_compcv, hence that must be non-NULL. It could
 299        also be pointing to a subroutine which is now fully set up (CvROOT()
 300        pointing to the top of the optree for that sub), or a subroutine
 301        which isn't using the slab allocator. If our sanity checks aren't met,
 302        don't use a slab, but allocate the OP directly from the heap.  */
 303     if (!PL_compcv || CvROOT(PL_compcv)
 304      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 305     {
 306         o = (OP*)PerlMemShared_calloc(1, sz);
 307         goto gotit;
 308     }
 309
 310     /* While the subroutine is under construction, the slabs are accessed via
 311        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 312        unneeded at runtime. Once a subroutine is constructed, the slabs are
 313        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 314        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 315        details.  */
 316     if (!CvSTART(PL_compcv)) {
 317         CvSTART(PL_compcv) =
 318             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 319         CvSLABBED_on(PL_compcv);
 320         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 321     }
 322     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 323
 324     opsz = SIZE_TO_PSIZE(sz);
 325     sz = opsz + OPSLOT_HEADER_P;
 326
 327     /* The slabs maintain a free list of OPs. In particular, constant folding
 328        will free up OPs, so it makes sense to re-use them where possible. A
 329        freed up slot is used in preference to a new allocation.  */
 330     if (slab->opslab_freed) {
 331         OP **too = &slab->opslab_freed;
 332         o = *too;
 333         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 334         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 335             DEBUG_S_warn((aTHX_ "Alas! too small"));
 336             o = *(too = &o->op_next);
 337             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 338         }
 339         if (o) {
 340             *too = o->op_next;
 341             Zero(o, opsz, I32 *);
 342             o->op_slabbed = 1;
 343             goto gotit;
 344         }
 345     }
 346
 347 #define INIT_OPSLOT \
 348             slot->opslot_slab = slab;                   \
 349             slot->opslot_next = slab2->opslab_first;    \
 350             slab2->opslab_first = slot;                 \
 351             o = &slot->opslot_op;                       \
 352             o->op_slabbed = 1
 353
 354     /* The partially-filled slab is next in the chain. */
 355     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 356     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 357         /* Remaining space is too small. */
 358
 359         /* If we can fit a BASEOP, add it to the free chain, so as not
 360            to waste it. */
 361         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 362             slot = &slab2->opslab_slots;
 363             INIT_OPSLOT;
 364             o->op_type = OP_FREED;
 365             o->op_next = slab->opslab_freed;
 366             slab->opslab_freed = o;
 367         }
 368
 369         /* Create a new slab.  Make this one twice as big. */
 370         slot = slab2->opslab_first;
 371         while (slot->opslot_next) slot = slot->opslot_next;
 372         slab2 = S_new_slab(aTHX_
 373                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 374                                         ? PERL_MAX_SLAB_SIZE
 375                                         : (DIFF(slab2, slot)+1)*2);
 376         slab2->opslab_next = slab->opslab_next;
 377         slab->opslab_next = slab2;
 378     }
 379     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 380
 381     /* Create a new op slot */
 382     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 383     assert(slot >= &slab2->opslab_slots);
 384     if (DIFF(&slab2->opslab_slots, slot)
 385          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 386         slot = &slab2->opslab_slots;
 387     INIT_OPSLOT;
 388     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 389
 390   gotit:
 391     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 392     assert(!o->op_moresib);
 393     assert(!o->op_sibparent);
 394
 395     return (void *)o;
 396 }
 397
 398 #undef INIT_OPSLOT
 399
 400 #ifdef PERL_DEBUG_READONLY_OPS
 401 void
 402 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 403 {
 404     PERL_ARGS_ASSERT_SLAB_TO_RO;
 405
 406     if (slab->opslab_readonly) return;
 407     slab->opslab_readonly = 1;
 408     for (; slab; slab = slab->opslab_next) {
 409         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 410                               (unsigned long) slab->opslab_size, slab));*/
 411         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 412             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 413                              (unsigned long)slab->opslab_size, errno);
 414     }
 415 }
 416
 417 void
 418 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 419 {
 420     OPSLAB *slab2;
 421
 422     PERL_ARGS_ASSERT_SLAB_TO_RW;
 423
 424     if (!slab->opslab_readonly) return;
 425     slab2 = slab;
 426     for (; slab2; slab2 = slab2->opslab_next) {
 427         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 428                               (unsigned long) size, slab2));*/
 429         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 430                      PROT_READ|PROT_WRITE)) {
 431             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 432                              (unsigned long)slab2->opslab_size, errno);
 433         }
 434     }
 435     slab->opslab_readonly = 0;
 436 }
 437
 438 #else
 439 #  define Slab_to_rw(op)    NOOP
 440 #endif
 441
 442 /* This cannot possibly be right, but it was copied from the old slab
 443    allocator, to which it was originally added, without explanation, in
 444    commit 083fcd5. */
 445 #ifdef NETWARE
 446 #    define PerlMemShared PerlMem
 447 #endif
 448
 449 /* make freed ops die if they're inadvertently executed */
 450 #ifdef DEBUGGING
 451 static OP *
 452 S_pp_freed(pTHX)
 453 {
 454     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 455 }
 456 #endif
 457
 458
 459 /* Return the block of memory used by an op to the free list of
 460  * the OP slab associated with that op.
 461  */
 462
 463 void
 464 Perl_Slab_Free(pTHX_ void *op)
 465 {
 466     OP * const o = (OP *)op;
 467     OPSLAB *slab;
 468
 469     PERL_ARGS_ASSERT_SLAB_FREE;
 470
 471 #ifdef DEBUGGING
 472     o->op_ppaddr = S_pp_freed;
 473 #endif
 474
 475     if (!o->op_slabbed) {
 476         if (!o->op_static)
 477             PerlMemShared_free(op);
 478         return;
 479     }
 480
 481     slab = OpSLAB(o);
 482     /* If this op is already freed, our refcount will get screwy. */
 483     assert(o->op_type != OP_FREED);
 484     o->op_type = OP_FREED;
 485     o->op_next = slab->opslab_freed;
 486     slab->opslab_freed = o;
 487     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 488     OpslabREFCNT_dec_padok(slab);
 489 }
 490
 491 void
 492 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 493 {
 494     const bool havepad = !!PL_comppad;
 495     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 496     if (havepad) {
 497         ENTER;
 498         PAD_SAVE_SETNULLPAD();
 499     }
 500     opslab_free(slab);
 501     if (havepad) LEAVE;
 502 }
 503
 504 /* Free a chain of OP slabs. Should only be called after all ops contained
 505  * in it have been freed. At this point, its reference count should be 1,
 506  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
 507  * and just directly calls opslab_free().
 508  * (Note that the reference count which PL_compcv held on the slab should
 509  * have been removed once compilation of the sub was complete).
 510  *
 511  *
 512  */
 513
 514 void
 515 Perl_opslab_free(pTHX_ OPSLAB *slab)
 516 {
 517     OPSLAB *slab2;
 518     PERL_ARGS_ASSERT_OPSLAB_FREE;
 519     PERL_UNUSED_CONTEXT;
 520     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 521     assert(slab->opslab_refcnt == 1);
 522     do {
 523         slab2 = slab->opslab_next;
 524 #ifdef DEBUGGING
 525         slab->opslab_refcnt = ~(size_t)0;
 526 #endif
 527 #ifdef PERL_DEBUG_READONLY_OPS
 528         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 529                                                (void*)slab));
 530         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 531             perror("munmap failed");
 532             abort();
 533         }
 534 #else
 535         PerlMemShared_free(slab);
 536 #endif
 537         slab = slab2;
 538     } while (slab);
 539 }
 540
 541 /* like opslab_free(), but first calls op_free() on any ops in the slab
 542  * not marked as OP_FREED
 543  */
 544
 545 void
 546 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 547 {
 548     OPSLAB *slab2;
 549 #ifdef DEBUGGING
 550     size_t savestack_count = 0;
 551 #endif
 552     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 553     slab2 = slab;
 554     do {
 555         OPSLOT *slot;
 556         for (slot = slab2->opslab_first;
 557              slot->opslot_next;
 558              slot = slot->opslot_next) {
 559             if (slot->opslot_op.op_type != OP_FREED
 560              && !(slot->opslot_op.op_savefree
 561 #ifdef DEBUGGING
 562                   && ++savestack_count
 563 #endif
 564                  )
 565             ) {
 566                 assert(slot->opslot_op.op_slabbed);
 567                 op_free(&slot->opslot_op);
 568                 if (slab->opslab_refcnt == 1) goto free;
 569             }
 570         }
 571     } while ((slab2 = slab2->opslab_next));
 572     /* > 1 because the CV still holds a reference count. */
 573     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 574 #ifdef DEBUGGING
 575         assert(savestack_count == slab->opslab_refcnt-1);
 576 #endif
 577         /* Remove the CV’s reference count. */
 578         slab->opslab_refcnt--;
 579         return;
 580     }
 581    free:
 582     opslab_free(slab);
 583 }
 584
 585 #ifdef PERL_DEBUG_READONLY_OPS
 586 OP *
 587 Perl_op_refcnt_inc(pTHX_ OP *o)
 588 {
 589     if(o) {
 590         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 591         if (slab && slab->opslab_readonly) {
 592             Slab_to_rw(slab);
 593             ++o->op_targ;
 594             Slab_to_ro(slab);
 595         } else {
 596             ++o->op_targ;
 597         }
 598     }
 599     return o;
 600
 601 }
 602
 603 PADOFFSET
 604 Perl_op_refcnt_dec(pTHX_ OP *o)
 605 {
 606     PADOFFSET result;
 607     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 608
 609     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 610
 611     if (slab && slab->opslab_readonly) {
 612         Slab_to_rw(slab);
 613         result = --o->op_targ;
 614         Slab_to_ro(slab);
 615     } else {
 616         result = --o->op_targ;
 617     }
 618     return result;
 619 }
 620 #endif
 621 /*
 622  * In the following definition, the ", (OP*)0" is just to make the compiler
 623  * think the expression is of the right type: croak actually does a Siglongjmp.
 624  */
 625 #define CHECKOP(type,o) \
 626     ((PL_op_mask && PL_op_mask[type])                           \
 627      ? ( op_free((OP*)o),                                       \
 628          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 629          (OP*)0 )                                               \
 630      : PL_check[type](aTHX_ (OP*)o))
 631
 632 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 633
 634 #define OpTYPE_set(o,type) \
 635     STMT_START {                                \
 636         o->op_type = (OPCODE)type;              \
 637         o->op_ppaddr = PL_ppaddr[type];         \
 638     } STMT_END
 639
 640 STATIC OP *
 641 S_no_fh_allowed(pTHX_ OP *o)
 642 {
 643     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 644
 645     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 646                  OP_DESC(o)));
 647     return o;
 648 }
 649
 650 STATIC OP *
 651 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 652 {
 653     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 654     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 655     return o;
 656 }
 657
 658 STATIC OP *
 659 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 660 {
 661     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 662
 663     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 664     return o;
 665 }
 666
 667 STATIC void
 668 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 669 {
 670     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 671
 672     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 673                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 674 }
 675
 676 /* remove flags var, its unused in all callers, move to to right end since gv
 677   and kid are always the same */
 678 STATIC void
 679 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 680 {
 681     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 682     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 683
 684     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 685                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 686 }
 687
 688 STATIC void
 689 S_no_bareword_allowed(pTHX_ OP *o)
 690 {
 691     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 692
 693     qerror(Perl_mess(aTHX_
 694                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 695                      SVfARG(cSVOPo_sv)));
 696     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 697 }
 698
 699 /* "register" allocation */
 700
 701 PADOFFSET
 702 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 703 {
 704     PADOFFSET off;
 705     const bool is_our = (PL_parser->in_my == KEY_our);
 706
 707     PERL_ARGS_ASSERT_ALLOCMY;
 708
 709     if (flags & ~SVf_UTF8)
 710         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 711                    (UV)flags);
 712
 713     /* complain about "my $<special_var>" etc etc */
 714     if (   len
 715         && !(  is_our
 716             || isALPHA(name[1])
 717             || (   (flags & SVf_UTF8)
 718                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 719             || (name[1] == '_' && len > 2)))
 720     {
 721         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 722          && isASCII(name[1])
 723          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 724             /* diag_listed_as: Can't use global %s in "%s" */
 725             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 726                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 727                               PL_parser->in_my == KEY_state ? "state" : "my"));
 728         } else {
 729             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 730                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 731         }
 732     }
 733
 734     /* allocate a spare slot and store the name in that slot */
 735
 736     off = pad_add_name_pvn(name, len,
 737                        (is_our ? padadd_OUR :
 738                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 739                     PL_parser->in_my_stash,
 740                     (is_our
 741                         /* $_ is always in main::, even with our */
 742                         ? (PL_curstash && !memEQs(name,len,"$_")
 743                             ? PL_curstash
 744                             : PL_defstash)
 745                         : NULL
 746                     )
 747     );
 748     /* anon sub prototypes contains state vars should always be cloned,
 749      * otherwise the state var would be shared between anon subs */
 750
 751     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 752         CvCLONE_on(PL_compcv);
 753
 754     return off;
 755 }
 756
 757 /*
 758 =head1 Optree Manipulation Functions
 759
 760 =for apidoc alloccopstash
 761
 762 Available only under threaded builds, this function allocates an entry in
 763 C<PL_stashpad> for the stash passed to it.
 764
 765 =cut
 766 */
 767
 768 #ifdef USE_ITHREADS
 769 PADOFFSET
 770 Perl_alloccopstash(pTHX_ HV *hv)
 771 {
 772     PADOFFSET off = 0, o = 1;
 773     bool found_slot = FALSE;
 774
 775     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 776
 777     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 778
 779     for (; o < PL_stashpadmax; ++o) {
 780         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 781         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 782             found_slot = TRUE, off = o;
 783     }
 784     if (!found_slot) {
 785         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 786         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 787         off = PL_stashpadmax;
 788         PL_stashpadmax += 10;
 789     }
 790
 791     PL_stashpad[PL_stashpadix = off] = hv;
 792     return off;
 793 }
 794 #endif
 795
 796 /* free the body of an op without examining its contents.
 797  * Always use this rather than FreeOp directly */
 798
 799 static void
 800 S_op_destroy(pTHX_ OP *o)
 801 {
 802     FreeOp(o);
 803 }
 804
 805 /* Destructor */
 806
 807 /*
 808 =for apidoc Am|void|op_free|OP *o
 809
 810 Free an op.  Only use this when an op is no longer linked to from any
 811 optree.
 812
 813 =cut
 814 */
 815
 816 void
 817 Perl_op_free(pTHX_ OP *o)
 818 {
 819     dVAR;
 820     OPCODE type;
 821     dDEFER_OP;
 822
 823     do {
 824
 825         /* Though ops may be freed twice, freeing the op after its slab is a
 826            big no-no. */
 827         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 828         /* During the forced freeing of ops after compilation failure, kidops
 829            may be freed before their parents. */
 830         if (!o || o->op_type == OP_FREED)
 831             continue;
 832
 833         type = o->op_type;
 834
 835         /* an op should only ever acquire op_private flags that we know about.
 836          * If this fails, you may need to fix something in regen/op_private.
 837          * Don't bother testing if:
 838          *   * the op_ppaddr doesn't match the op; someone may have
 839          *     overridden the op and be doing strange things with it;
 840          *   * we've errored, as op flags are often left in an
 841          *     inconsistent state then. Note that an error when
 842          *     compiling the main program leaves PL_parser NULL, so
 843          *     we can't spot faults in the main code, only
 844          *     evaled/required code */
 845 #ifdef DEBUGGING
 846         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 847             && PL_parser
 848             && !PL_parser->error_count)
 849         {
 850             assert(!(o->op_private & ~PL_op_private_valid[type]));
 851         }
 852 #endif
 853
 854         if (o->op_private & OPpREFCOUNTED) {
 855             switch (type) {
 856             case OP_LEAVESUB:
 857             case OP_LEAVESUBLV:
 858             case OP_LEAVEEVAL:
 859             case OP_LEAVE:
 860             case OP_SCOPE:
 861             case OP_LEAVEWRITE:
 862                 {
 863                 PADOFFSET refcnt;
 864                 OP_REFCNT_LOCK;
 865                 refcnt = OpREFCNT_dec(o);
 866                 OP_REFCNT_UNLOCK;
 867                 if (refcnt) {
 868                     /* Need to find and remove any pattern match ops from the list
 869                        we maintain for reset().  */
 870                     find_and_forget_pmops(o);
 871                     continue;
 872                 }
 873                 }
 874                 break;
 875             default:
 876                 break;
 877             }
 878         }
 879
 880         /* Call the op_free hook if it has been set. Do it now so that it's called
 881          * at the right time for refcounted ops, but still before all of the kids
 882          * are freed. */
 883         CALL_OPFREEHOOK(o);
 884
 885         if (o->op_flags & OPf_KIDS) {
 886             OP *kid, *nextkid;
 887             assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
 888             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 889                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 890                 if (kid->op_type == OP_FREED)
 891                     /* During the forced freeing of ops after
 892                        compilation failure, kidops may be freed before
 893                        their parents. */
 894                     continue;
 895                 if (!(kid->op_flags & OPf_KIDS))
 896                     /* If it has no kids, just free it now */
 897                     op_free(kid);
 898                 else
 899                     DEFER_OP(kid);
 900             }
 901         }
 902         if (type == OP_NULL)
 903             type = (OPCODE)o->op_targ;
 904
 905         if (o->op_slabbed)
 906             Slab_to_rw(OpSLAB(o));
 907
 908         /* COP* is not cleared by op_clear() so that we may track line
 909          * numbers etc even after null() */
 910         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 911             cop_free((COP*)o);
 912         }
 913
 914         op_clear(o);
 915         FreeOp(o);
 916         if (PL_op == o)
 917             PL_op = NULL;
 918     } while ( (o = POP_DEFERRED_OP()) );
 919
 920     DEFER_OP_CLEANUP;
 921 }
 922
 923 /* S_op_clear_gv(): free a GV attached to an OP */
 924
 925 STATIC
 926 #ifdef USE_ITHREADS
 927 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 928 #else
 929 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 930 #endif
 931 {
 932
 933     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 934             || o->op_type == OP_MULTIDEREF)
 935 #ifdef USE_ITHREADS
 936                 && PL_curpad
 937                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 938 #else
 939                 ? (GV*)(*svp) : NULL;
 940 #endif
 941     /* It's possible during global destruction that the GV is freed
 942        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 943        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 944        will trigger an assertion failure, because the entry to sv_clear
 945        checks that the scalar is not already freed.  A check of for
 946        !SvIS_FREED(gv) turns out to be invalid, because during global
 947        destruction the reference count can be forced down to zero
 948        (with SVf_BREAK set).  In which case raising to 1 and then
 949        dropping to 0 triggers cleanup before it should happen.  I
 950        *think* that this might actually be a general, systematic,
 951        weakness of the whole idea of SVf_BREAK, in that code *is*
 952        allowed to raise and lower references during global destruction,
 953        so any *valid* code that happens to do this during global
 954        destruction might well trigger premature cleanup.  */
 955     bool still_valid = gv && SvREFCNT(gv);
 956
 957     if (still_valid)
 958         SvREFCNT_inc_simple_void(gv);
 959 #ifdef USE_ITHREADS
 960     if (*ixp > 0) {
 961         pad_swipe(*ixp, TRUE);
 962         *ixp = 0;
 963     }
 964 #else
 965     SvREFCNT_dec(*svp);
 966     *svp = NULL;
 967 #endif
 968     if (still_valid) {
 969         int try_downgrade = SvREFCNT(gv) == 2;
 970         SvREFCNT_dec_NN(gv);
 971         if (try_downgrade)
 972             gv_try_downgrade(gv);
 973     }
 974 }
 975
 976
 977 void
 978 Perl_op_clear(pTHX_ OP *o)
 979 {
 980
 981     dVAR;
 982
 983     PERL_ARGS_ASSERT_OP_CLEAR;
 984
 985     switch (o->op_type) {
 986     case OP_NULL:       /* Was holding old type, if any. */
 987         /* FALLTHROUGH */
 988     case OP_ENTERTRY:
 989     case OP_ENTEREVAL:  /* Was holding hints. */
 990     case OP_ARGDEFELEM: /* Was holding signature index. */
 991         o->op_targ = 0;
 992         break;
 993     default:
 994         if (!(o->op_flags & OPf_REF)
 995             || (PL_check[o->op_type] != Perl_ck_ftst))
 996             break;
 997         /* FALLTHROUGH */
 998     case OP_GVSV:
 999     case OP_GV:
1000     case OP_AELEMFAST:
1001 #ifdef USE_ITHREADS
1002             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1003 #else
1004             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1005 #endif
1006         break;
1007     case OP_METHOD_REDIR:
1008     case OP_METHOD_REDIR_SUPER:
1009 #ifdef USE_ITHREADS
1010         if (cMETHOPx(o)->op_rclass_targ) {
1011             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1012             cMETHOPx(o)->op_rclass_targ = 0;
1013         }
1014 #else
1015         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1016         cMETHOPx(o)->op_rclass_sv = NULL;
1017 #endif
1018         /* FALLTHROUGH */
1019     case OP_METHOD_NAMED:
1020     case OP_METHOD_SUPER:
1021         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1022         cMETHOPx(o)->op_u.op_meth_sv = NULL;
1023 #ifdef USE_ITHREADS
1024         if (o->op_targ) {
1025             pad_swipe(o->op_targ, 1);
1026             o->op_targ = 0;
1027         }
1028 #endif
1029         break;
1030     case OP_CONST:
1031     case OP_HINTSEVAL:
1032         SvREFCNT_dec(cSVOPo->op_sv);
1033         cSVOPo->op_sv = NULL;
1034 #ifdef USE_ITHREADS
1035         /** Bug #15654
1036           Even if op_clear does a pad_free for the target of the op,
1037           pad_free doesn't actually remove the sv that exists in the pad;
1038           instead it lives on. This results in that it could be reused as
1039           a target later on when the pad was reallocated.
1040         **/
1041         if(o->op_targ) {
1042           pad_swipe(o->op_targ,1);
1043           o->op_targ = 0;
1044         }
1045 #endif
1046         break;
1047     case OP_DUMP:
1048     case OP_GOTO:
1049     case OP_NEXT:
1050     case OP_LAST:
1051     case OP_REDO:
1052         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1053             break;
1054         /* FALLTHROUGH */
1055     case OP_TRANS:
1056     case OP_TRANSR:
1057         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1058             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1059         {
1060 #ifdef USE_ITHREADS
1061             if (cPADOPo->op_padix > 0) {
1062                 pad_swipe(cPADOPo->op_padix, TRUE);
1063                 cPADOPo->op_padix = 0;
1064             }
1065 #else
1066             SvREFCNT_dec(cSVOPo->op_sv);
1067             cSVOPo->op_sv = NULL;
1068 #endif
1069         }
1070         else {
1071             PerlMemShared_free(cPVOPo->op_pv);
1072             cPVOPo->op_pv = NULL;
1073         }
1074         break;
1075     case OP_SUBST:
1076         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1077         goto clear_pmop;
1078
1079     case OP_SPLIT:
1080         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1081             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1082         {
1083             if (o->op_private & OPpSPLIT_LEX)
1084                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1085             else
1086 #ifdef USE_ITHREADS
1087                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1088 #else
1089                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1090 #endif
1091         }
1092         /* FALLTHROUGH */
1093     case OP_MATCH:
1094     case OP_QR:
1095     clear_pmop:
1096         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1097             op_free(cPMOPo->op_code_list);
1098         cPMOPo->op_code_list = NULL;
1099         forget_pmop(cPMOPo);
1100         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1101         /* we use the same protection as the "SAFE" version of the PM_ macros
1102          * here since sv_clean_all might release some PMOPs
1103          * after PL_regex_padav has been cleared
1104          * and the clearing of PL_regex_padav needs to
1105          * happen before sv_clean_all
1106          */
1107 #ifdef USE_ITHREADS
1108         if(PL_regex_pad) {        /* We could be in destruction */
1109             const IV offset = (cPMOPo)->op_pmoffset;
1110             ReREFCNT_dec(PM_GETRE(cPMOPo));
1111             PL_regex_pad[offset] = &PL_sv_undef;
1112             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1113                            sizeof(offset));
1114         }
1115 #else
1116         ReREFCNT_dec(PM_GETRE(cPMOPo));
1117         PM_SETRE(cPMOPo, NULL);
1118 #endif
1119
1120         break;
1121
1122     case OP_ARGCHECK:
1123         PerlMemShared_free(cUNOP_AUXo->op_aux);
1124         break;
1125
1126     case OP_MULTICONCAT:
1127         {
1128             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1129             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1130              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1131              * utf8 shared strings */
1132             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1133             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1134             if (p1)
1135                 PerlMemShared_free(p1);
1136             if (p2 && p1 != p2)
1137                 PerlMemShared_free(p2);
1138             PerlMemShared_free(aux);
1139         }
1140         break;
1141
1142     case OP_MULTIDEREF:
1143         {
1144             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1145             UV actions = items->uv;
1146             bool last = 0;
1147             bool is_hash = FALSE;
1148
1149             while (!last) {
1150                 switch (actions & MDEREF_ACTION_MASK) {
1151
1152                 case MDEREF_reload:
1153                     actions = (++items)->uv;
1154                     continue;
1155
1156                 case MDEREF_HV_padhv_helem:
1157                     is_hash = TRUE;
1158                     /* FALLTHROUGH */
1159                 case MDEREF_AV_padav_aelem:
1160                     pad_free((++items)->pad_offset);
1161                     goto do_elem;
1162
1163                 case MDEREF_HV_gvhv_helem:
1164                     is_hash = TRUE;
1165                     /* FALLTHROUGH */
1166                 case MDEREF_AV_gvav_aelem:
1167 #ifdef USE_ITHREADS
1168                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1169 #else
1170                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1171 #endif
1172                     goto do_elem;
1173
1174                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1175                     is_hash = TRUE;
1176                     /* FALLTHROUGH */
1177                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1178 #ifdef USE_ITHREADS
1179                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1180 #else
1181                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1182 #endif
1183                     goto do_vivify_rv2xv_elem;
1184
1185                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1186                     is_hash = TRUE;
1187                     /* FALLTHROUGH */
1188                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1189                     pad_free((++items)->pad_offset);
1190                     goto do_vivify_rv2xv_elem;
1191
1192                 case MDEREF_HV_pop_rv2hv_helem:
1193                 case MDEREF_HV_vivify_rv2hv_helem:
1194                     is_hash = TRUE;
1195                     /* FALLTHROUGH */
1196                 do_vivify_rv2xv_elem:
1197                 case MDEREF_AV_pop_rv2av_aelem:
1198                 case MDEREF_AV_vivify_rv2av_aelem:
1199                 do_elem:
1200                     switch (actions & MDEREF_INDEX_MASK) {
1201                     case MDEREF_INDEX_none:
1202                         last = 1;
1203                         break;
1204                     case MDEREF_INDEX_const:
1205                         if (is_hash) {
1206 #ifdef USE_ITHREADS
1207                             /* see RT #15654 */
1208                             pad_swipe((++items)->pad_offset, 1);
1209 #else
1210                             SvREFCNT_dec((++items)->sv);
1211 #endif
1212                         }
1213                         else
1214                             items++;
1215                         break;
1216                     case MDEREF_INDEX_padsv:
1217                         pad_free((++items)->pad_offset);
1218                         break;
1219                     case MDEREF_INDEX_gvsv:
1220 #ifdef USE_ITHREADS
1221                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1222 #else
1223                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1224 #endif
1225                         break;
1226                     }
1227
1228                     if (actions & MDEREF_FLAG_last)
1229                         last = 1;
1230                     is_hash = FALSE;
1231
1232                     break;
1233
1234                 default:
1235                     assert(0);
1236                     last = 1;
1237                     break;
1238
1239                 } /* switch */
1240
1241                 actions >>= MDEREF_SHIFT;
1242             } /* while */
1243
1244             /* start of malloc is at op_aux[-1], where the length is
1245              * stored */
1246             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1247         }
1248         break;
1249     }
1250
1251     if (o->op_targ > 0) {
1252         pad_free(o->op_targ);
1253         o->op_targ = 0;
1254     }
1255 }
1256
1257 STATIC void
1258 S_cop_free(pTHX_ COP* cop)
1259 {
1260     PERL_ARGS_ASSERT_COP_FREE;
1261
1262     CopFILE_free(cop);
1263     if (! specialWARN(cop->cop_warnings))
1264         PerlMemShared_free(cop->cop_warnings);
1265     cophh_free(CopHINTHASH_get(cop));
1266     if (PL_curcop == cop)
1267        PL_curcop = NULL;
1268 }
1269
1270 STATIC void
1271 S_forget_pmop(pTHX_ PMOP *const o)
1272 {
1273     HV * const pmstash = PmopSTASH(o);
1274
1275     PERL_ARGS_ASSERT_FORGET_PMOP;
1276
1277     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1278         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1279         if (mg) {
1280             PMOP **const array = (PMOP**) mg->mg_ptr;
1281             U32 count = mg->mg_len / sizeof(PMOP**);
1282             U32 i = count;
1283
1284             while (i--) {
1285                 if (array[i] == o) {
1286                     /* Found it. Move the entry at the end to overwrite it.  */
1287                     array[i] = array[--count];
1288                     mg->mg_len = count * sizeof(PMOP**);
1289                     /* Could realloc smaller at this point always, but probably
1290                        not worth it. Probably worth free()ing if we're the
1291                        last.  */
1292                     if(!count) {
1293                         Safefree(mg->mg_ptr);
1294                         mg->mg_ptr = NULL;
1295                     }
1296                     break;
1297                 }
1298             }
1299         }
1300     }
1301     if (PL_curpm == o)
1302         PL_curpm = NULL;
1303 }
1304
1305 STATIC void
1306 S_find_and_forget_pmops(pTHX_ OP *o)
1307 {
1308     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1309
1310     if (o->op_flags & OPf_KIDS) {
1311         OP *kid = cUNOPo->op_first;
1312         while (kid) {
1313             switch (kid->op_type) {
1314             case OP_SUBST:
1315             case OP_SPLIT:
1316             case OP_MATCH:
1317             case OP_QR:
1318                 forget_pmop((PMOP*)kid);
1319             }
1320             find_and_forget_pmops(kid);
1321             kid = OpSIBLING(kid);
1322         }
1323     }
1324 }
1325
1326 /*
1327 =for apidoc Am|void|op_null|OP *o
1328
1329 Neutralizes an op when it is no longer needed, but is still linked to from
1330 other ops.
1331
1332 =cut
1333 */
1334
1335 void
1336 Perl_op_null(pTHX_ OP *o)
1337 {
1338     dVAR;
1339
1340     PERL_ARGS_ASSERT_OP_NULL;
1341
1342     if (o->op_type == OP_NULL)
1343         return;
1344     op_clear(o);
1345     o->op_targ = o->op_type;
1346     OpTYPE_set(o, OP_NULL);
1347 }
1348
1349 void
1350 Perl_op_refcnt_lock(pTHX)
1351   PERL_TSA_ACQUIRE(PL_op_mutex)
1352 {
1353 #ifdef USE_ITHREADS
1354     dVAR;
1355 #endif
1356     PERL_UNUSED_CONTEXT;
1357     OP_REFCNT_LOCK;
1358 }
1359
1360 void
1361 Perl_op_refcnt_unlock(pTHX)
1362   PERL_TSA_RELEASE(PL_op_mutex)
1363 {
1364 #ifdef USE_ITHREADS
1365     dVAR;
1366 #endif
1367     PERL_UNUSED_CONTEXT;
1368     OP_REFCNT_UNLOCK;
1369 }
1370
1371
1372 /*
1373 =for apidoc op_sibling_splice
1374
1375 A general function for editing the structure of an existing chain of
1376 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1377 you to delete zero or more sequential nodes, replacing them with zero or
1378 more different nodes.  Performs the necessary op_first/op_last
1379 housekeeping on the parent node and op_sibling manipulation on the
1380 children.  The last deleted node will be marked as as the last node by
1381 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1382
1383 Note that op_next is not manipulated, and nodes are not freed; that is the
1384 responsibility of the caller.  It also won't create a new list op for an
1385 empty list etc; use higher-level functions like op_append_elem() for that.
1386
1387 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1388 the splicing doesn't affect the first or last op in the chain.
1389
1390 C<start> is the node preceding the first node to be spliced.  Node(s)
1391 following it will be deleted, and ops will be inserted after it.  If it is
1392 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1393 beginning.
1394
1395 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1396 If -1 or greater than or equal to the number of remaining kids, all
1397 remaining kids are deleted.
1398
1399 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1400 If C<NULL>, no nodes are inserted.
1401
1402 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1403 deleted.
1404
1405 For example:
1406
1407     action                    before      after         returns
1408     ------                    -----       -----         -------
1409
1410                               P           P
1411     splice(P, A, 2, X-Y-Z)    |           |             B-C
1412                               A-B-C-D     A-X-Y-Z-D
1413
1414                               P           P
1415     splice(P, NULL, 1, X-Y)   |           |             A
1416                               A-B-C-D     X-Y-B-C-D
1417
1418                               P           P
1419     splice(P, NULL, 3, NULL)  |           |             A-B-C
1420                               A-B-C-D     D
1421
1422                               P           P
1423     splice(P, B, 0, X-Y)      |           |             NULL
1424                               A-B-C-D     A-B-X-Y-C-D
1425
1426
1427 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1428 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1429
1430 =cut
1431 */
1432
1433 OP *
1434 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1435 {
1436     OP *first;
1437     OP *rest;
1438     OP *last_del = NULL;
1439     OP *last_ins = NULL;
1440
1441     if (start)
1442         first = OpSIBLING(start);
1443     else if (!parent)
1444         goto no_parent;
1445     else
1446         first = cLISTOPx(parent)->op_first;
1447
1448     assert(del_count >= -1);
1449
1450     if (del_count && first) {
1451         last_del = first;
1452         while (--del_count && OpHAS_SIBLING(last_del))
1453             last_del = OpSIBLING(last_del);
1454         rest = OpSIBLING(last_del);
1455         OpLASTSIB_set(last_del, NULL);
1456     }
1457     else
1458         rest = first;
1459
1460     if (insert) {
1461         last_ins = insert;
1462         while (OpHAS_SIBLING(last_ins))
1463             last_ins = OpSIBLING(last_ins);
1464         OpMAYBESIB_set(last_ins, rest, NULL);
1465     }
1466     else
1467         insert = rest;
1468
1469     if (start) {
1470         OpMAYBESIB_set(start, insert, NULL);
1471     }
1472     else {
1473         assert(parent);
1474         cLISTOPx(parent)->op_first = insert;
1475         if (insert)
1476             parent->op_flags |= OPf_KIDS;
1477         else
1478             parent->op_flags &= ~OPf_KIDS;
1479     }
1480
1481     if (!rest) {
1482         /* update op_last etc */
1483         U32 type;
1484         OP *lastop;
1485
1486         if (!parent)
1487             goto no_parent;
1488
1489         /* ought to use OP_CLASS(parent) here, but that can't handle
1490          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1491          * either */
1492         type = parent->op_type;
1493         if (type == OP_CUSTOM) {
1494             dTHX;
1495             type = XopENTRYCUSTOM(parent, xop_class);
1496         }
1497         else {
1498             if (type == OP_NULL)
1499                 type = parent->op_targ;
1500             type = PL_opargs[type] & OA_CLASS_MASK;
1501         }
1502
1503         lastop = last_ins ? last_ins : start ? start : NULL;
1504         if (   type == OA_BINOP
1505             || type == OA_LISTOP
1506             || type == OA_PMOP
1507             || type == OA_LOOP
1508         )
1509             cLISTOPx(parent)->op_last = lastop;
1510
1511         if (lastop)
1512             OpLASTSIB_set(lastop, parent);
1513     }
1514     return last_del ? first : NULL;
1515
1516   no_parent:
1517     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1518 }
1519
1520 /*
1521 =for apidoc op_parent
1522
1523 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1524
1525 =cut
1526 */
1527
1528 OP *
1529 Perl_op_parent(OP *o)
1530 {
1531     PERL_ARGS_ASSERT_OP_PARENT;
1532     while (OpHAS_SIBLING(o))
1533         o = OpSIBLING(o);
1534     return o->op_sibparent;
1535 }
1536
1537 /* replace the sibling following start with a new UNOP, which becomes
1538  * the parent of the original sibling; e.g.
1539  *
1540  *  op_sibling_newUNOP(P, A, unop-args...)
1541  *
1542  *  P              P
1543  *  |      becomes |
1544  *  A-B-C          A-U-C
1545  *                   |
1546  *                   B
1547  *
1548  * where U is the new UNOP.
1549  *
1550  * parent and start args are the same as for op_sibling_splice();
1551  * type and flags args are as newUNOP().
1552  *
1553  * Returns the new UNOP.
1554  */
1555
1556 STATIC OP *
1557 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1558 {
1559     OP *kid, *newop;
1560
1561     kid = op_sibling_splice(parent, start, 1, NULL);
1562     newop = newUNOP(type, flags, kid);
1563     op_sibling_splice(parent, start, 0, newop);
1564     return newop;
1565 }
1566
1567
1568 /* lowest-level newLOGOP-style function - just allocates and populates
1569  * the struct. Higher-level stuff should be done by S_new_logop() /
1570  * newLOGOP(). This function exists mainly to avoid op_first assignment
1571  * being spread throughout this file.
1572  */
1573
1574 LOGOP *
1575 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1576 {
1577     dVAR;
1578     LOGOP *logop;
1579     OP *kid = first;
1580     NewOp(1101, logop, 1, LOGOP);
1581     OpTYPE_set(logop, type);
1582     logop->op_first = first;
1583     logop->op_other = other;
1584     if (first)
1585         logop->op_flags = OPf_KIDS;
1586     while (kid && OpHAS_SIBLING(kid))
1587         kid = OpSIBLING(kid);
1588     if (kid)
1589         OpLASTSIB_set(kid, (OP*)logop);
1590     return logop;
1591 }
1592
1593
1594 /* Contextualizers */
1595
1596 /*
1597 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1598
1599 Applies a syntactic context to an op tree representing an expression.
1600 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1601 or C<G_VOID> to specify the context to apply.  The modified op tree
1602 is returned.
1603
1604 =cut
1605 */
1606
1607 OP *
1608 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1609 {
1610     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1611     switch (context) {
1612         case G_SCALAR: return scalar(o);
1613         case G_ARRAY:  return list(o);
1614         case G_VOID:   return scalarvoid(o);
1615         default:
1616             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1617                        (long) context);
1618     }
1619 }
1620
1621 /*
1622
1623 =for apidoc Am|OP*|op_linklist|OP *o
1624 This function is the implementation of the L</LINKLIST> macro.  It should
1625 not be called directly.
1626
1627 =cut
1628 */
1629
1630 OP *
1631 Perl_op_linklist(pTHX_ OP *o)
1632 {
1633     OP *first;
1634
1635     PERL_ARGS_ASSERT_OP_LINKLIST;
1636
1637     if (o->op_next)
1638         return o->op_next;
1639
1640     /* establish postfix order */
1641     first = cUNOPo->op_first;
1642     if (first) {
1643         OP *kid;
1644         o->op_next = LINKLIST(first);
1645         kid = first;
1646         for (;;) {
1647             OP *sibl = OpSIBLING(kid);
1648             if (sibl) {
1649                 kid->op_next = LINKLIST(sibl);
1650                 kid = sibl;
1651             } else {
1652                 kid->op_next = o;
1653                 break;
1654             }
1655         }
1656     }
1657     else
1658         o->op_next = o;
1659
1660     return o->op_next;
1661 }
1662
1663 static OP *
1664 S_scalarkids(pTHX_ OP *o)
1665 {
1666     if (o && o->op_flags & OPf_KIDS) {
1667         OP *kid;
1668         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1669             scalar(kid);
1670     }
1671     return o;
1672 }
1673
1674 STATIC OP *
1675 S_scalarboolean(pTHX_ OP *o)
1676 {
1677     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1678
1679     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1680          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1681         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1682          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1683          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1684         if (ckWARN(WARN_SYNTAX)) {
1685             const line_t oldline = CopLINE(PL_curcop);
1686
1687             if (PL_parser && PL_parser->copline != NOLINE) {
1688                 /* This ensures that warnings are reported at the first line
1689                    of the conditional, not the last.  */
1690                 CopLINE_set(PL_curcop, PL_parser->copline);
1691             }
1692             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1693             CopLINE_set(PL_curcop, oldline);
1694         }
1695     }
1696     return scalar(o);
1697 }
1698
1699 static SV *
1700 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1701 {
1702     assert(o);
1703     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1704            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1705     {
1706         const char funny  = o->op_type == OP_PADAV
1707                          || o->op_type == OP_RV2AV ? '@' : '%';
1708         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1709             GV *gv;
1710             if (cUNOPo->op_first->op_type != OP_GV
1711              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1712                 return NULL;
1713             return varname(gv, funny, 0, NULL, 0, subscript_type);
1714         }
1715         return
1716             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1717     }
1718 }
1719
1720 static SV *
1721 S_op_varname(pTHX_ const OP *o)
1722 {
1723     return S_op_varname_subscript(aTHX_ o, 1);
1724 }
1725
1726 static void
1727 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1728 { /* or not so pretty :-) */
1729     if (o->op_type == OP_CONST) {
1730         *retsv = cSVOPo_sv;
1731         if (SvPOK(*retsv)) {
1732             SV *sv = *retsv;
1733             *retsv = sv_newmortal();
1734             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1735                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1736         }
1737         else if (!SvOK(*retsv))
1738             *retpv = "undef";
1739     }
1740     else *retpv = "...";
1741 }
1742
1743 static void
1744 S_scalar_slice_warning(pTHX_ const OP *o)
1745 {
1746     OP *kid;
1747     const bool h = o->op_type == OP_HSLICE
1748                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1749     const char lbrack =
1750         h ? '{' : '[';
1751     const char rbrack =
1752         h ? '}' : ']';
1753     SV *name;
1754     SV *keysv = NULL; /* just to silence compiler warnings */
1755     const char *key = NULL;
1756
1757     if (!(o->op_private & OPpSLICEWARNING))
1758         return;
1759     if (PL_parser && PL_parser->error_count)
1760         /* This warning can be nonsensical when there is a syntax error. */
1761         return;
1762
1763     kid = cLISTOPo->op_first;
1764     kid = OpSIBLING(kid); /* get past pushmark */
1765     /* weed out false positives: any ops that can return lists */
1766     switch (kid->op_type) {
1767     case OP_BACKTICK:
1768     case OP_GLOB:
1769     case OP_READLINE:
1770     case OP_MATCH:
1771     case OP_RV2AV:
1772     case OP_EACH:
1773     case OP_VALUES:
1774     case OP_KEYS:
1775     case OP_SPLIT:
1776     case OP_LIST:
1777     case OP_SORT:
1778     case OP_REVERSE:
1779     case OP_ENTERSUB:
1780     case OP_CALLER:
1781     case OP_LSTAT:
1782     case OP_STAT:
1783     case OP_READDIR:
1784     case OP_SYSTEM:
1785     case OP_TMS:
1786     case OP_LOCALTIME:
1787     case OP_GMTIME:
1788     case OP_ENTEREVAL:
1789         return;
1790     }
1791
1792     /* Don't warn if we have a nulled list either. */
1793     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1794         return;
1795
1796     assert(OpSIBLING(kid));
1797     name = S_op_varname(aTHX_ OpSIBLING(kid));
1798     if (!name) /* XS module fiddling with the op tree */
1799         return;
1800     S_op_pretty(aTHX_ kid, &keysv, &key);
1801     assert(SvPOK(name));
1802     sv_chop(name,SvPVX(name)+1);
1803     if (key)
1804        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1805         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1806                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1807                    "%c%s%c",
1808                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1809                     lbrack, key, rbrack);
1810     else
1811        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1812         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1813                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1814                     SVf "%c%" SVf "%c",
1815                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1816                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1817 }
1818
1819 OP *
1820 Perl_scalar(pTHX_ OP *o)
1821 {
1822     OP *kid;
1823
1824     /* assumes no premature commitment */
1825     if (!o || (PL_parser && PL_parser->error_count)
1826          || (o->op_flags & OPf_WANT)
1827          || o->op_type == OP_RETURN)
1828     {
1829         return o;
1830     }
1831
1832     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1833
1834     switch (o->op_type) {
1835     case OP_REPEAT:
1836         scalar(cBINOPo->op_first);
1837         if (o->op_private & OPpREPEAT_DOLIST) {
1838             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1839             assert(kid->op_type == OP_PUSHMARK);
1840             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1841                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1842                 o->op_private &=~ OPpREPEAT_DOLIST;
1843             }
1844         }
1845         break;
1846     case OP_OR:
1847     case OP_AND:
1848     case OP_COND_EXPR:
1849         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1850             scalar(kid);
1851         break;
1852         /* FALLTHROUGH */
1853     case OP_SPLIT:
1854     case OP_MATCH:
1855     case OP_QR:
1856     case OP_SUBST:
1857     case OP_NULL:
1858     default:
1859         if (o->op_flags & OPf_KIDS) {
1860             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1861                 scalar(kid);
1862         }
1863         break;
1864     case OP_LEAVE:
1865     case OP_LEAVETRY:
1866         kid = cLISTOPo->op_first;
1867         scalar(kid);
1868         kid = OpSIBLING(kid);
1869     do_kids:
1870         while (kid) {
1871             OP *sib = OpSIBLING(kid);
1872             if (sib && kid->op_type != OP_LEAVEWHEN
1873              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1874                 || (  sib->op_targ != OP_NEXTSTATE
1875                    && sib->op_targ != OP_DBSTATE  )))
1876                 scalarvoid(kid);
1877             else
1878                 scalar(kid);
1879             kid = sib;
1880         }
1881         PL_curcop = &PL_compiling;
1882         break;
1883     case OP_SCOPE:
1884     case OP_LINESEQ:
1885     case OP_LIST:
1886         kid = cLISTOPo->op_first;
1887         goto do_kids;
1888     case OP_SORT:
1889         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1890         break;
1891     case OP_KVHSLICE:
1892     case OP_KVASLICE:
1893     {
1894         /* Warn about scalar context */
1895         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1896         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1897         SV *name;
1898         SV *keysv;
1899         const char *key = NULL;
1900
1901         /* This warning can be nonsensical when there is a syntax error. */
1902         if (PL_parser && PL_parser->error_count)
1903             break;
1904
1905         if (!ckWARN(WARN_SYNTAX)) break;
1906
1907         kid = cLISTOPo->op_first;
1908         kid = OpSIBLING(kid); /* get past pushmark */
1909         assert(OpSIBLING(kid));
1910         name = S_op_varname(aTHX_ OpSIBLING(kid));
1911         if (!name) /* XS module fiddling with the op tree */
1912             break;
1913         S_op_pretty(aTHX_ kid, &keysv, &key);
1914         assert(SvPOK(name));
1915         sv_chop(name,SvPVX(name)+1);
1916         if (key)
1917   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1918             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1919                        "%%%" SVf "%c%s%c in scalar context better written "
1920                        "as $%" SVf "%c%s%c",
1921                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1922                         lbrack, key, rbrack);
1923         else
1924   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1925             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1926                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1927                        "written as $%" SVf "%c%" SVf "%c",
1928                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1929                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1930     }
1931     }
1932     return o;
1933 }
1934
1935 OP *
1936 Perl_scalarvoid(pTHX_ OP *arg)
1937 {
1938     dVAR;
1939     OP *kid;
1940     SV* sv;
1941     OP *o = arg;
1942     dDEFER_OP;
1943
1944     PERL_ARGS_ASSERT_SCALARVOID;
1945
1946     do {
1947         U8 want;
1948         SV *useless_sv = NULL;
1949         const char* useless = NULL;
1950
1951         if (o->op_type == OP_NEXTSTATE
1952             || o->op_type == OP_DBSTATE
1953             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1954                                           || o->op_targ == OP_DBSTATE)))
1955             PL_curcop = (COP*)o;                /* for warning below */
1956
1957         /* assumes no premature commitment */
1958         want = o->op_flags & OPf_WANT;
1959         if ((want && want != OPf_WANT_SCALAR)
1960             || (PL_parser && PL_parser->error_count)
1961             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1962         {
1963             continue;
1964         }
1965
1966         if ((o->op_private & OPpTARGET_MY)
1967             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1968         {
1969             /* newASSIGNOP has already applied scalar context, which we
1970                leave, as if this op is inside SASSIGN.  */
1971             continue;
1972         }
1973
1974         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1975
1976         switch (o->op_type) {
1977         default:
1978             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1979                 break;
1980             /* FALLTHROUGH */
1981         case OP_REPEAT:
1982             if (o->op_flags & OPf_STACKED)
1983                 break;
1984             if (o->op_type == OP_REPEAT)
1985                 scalar(cBINOPo->op_first);
1986             goto func_ops;
1987         case OP_CONCAT:
1988             if ((o->op_flags & OPf_STACKED) &&
1989                     !(o->op_private & OPpCONCAT_NESTED))
1990                 break;
1991             goto func_ops;
1992         case OP_SUBSTR:
1993             if (o->op_private == 4)
1994                 break;
1995             /* FALLTHROUGH */
1996         case OP_WANTARRAY:
1997         case OP_GV:
1998         case OP_SMARTMATCH:
1999         case OP_AV2ARYLEN:
2000         case OP_REF:
2001         case OP_REFGEN:
2002         case OP_SREFGEN:
2003         case OP_DEFINED:
2004         case OP_HEX:
2005         case OP_OCT:
2006         case OP_LENGTH:
2007         case OP_VEC:
2008         case OP_INDEX:
2009         case OP_RINDEX:
2010         case OP_SPRINTF:
2011         case OP_KVASLICE:
2012         case OP_KVHSLICE:
2013         case OP_UNPACK:
2014         case OP_PACK:
2015         case OP_JOIN:
2016         case OP_LSLICE:
2017         case OP_ANONLIST:
2018         case OP_ANONHASH:
2019         case OP_SORT:
2020         case OP_REVERSE:
2021         case OP_RANGE:
2022         case OP_FLIP:
2023         case OP_FLOP:
2024         case OP_CALLER:
2025         case OP_FILENO:
2026         case OP_EOF:
2027         case OP_TELL:
2028         case OP_GETSOCKNAME:
2029         case OP_GETPEERNAME:
2030         case OP_READLINK:
2031         case OP_TELLDIR:
2032         case OP_GETPPID:
2033         case OP_GETPGRP:
2034         case OP_GETPRIORITY:
2035         case OP_TIME:
2036         case OP_TMS:
2037         case OP_LOCALTIME:
2038         case OP_GMTIME:
2039         case OP_GHBYNAME:
2040         case OP_GHBYADDR:
2041         case OP_GHOSTENT:
2042         case OP_GNBYNAME:
2043         case OP_GNBYADDR:
2044         case OP_GNETENT:
2045         case OP_GPBYNAME:
2046         case OP_GPBYNUMBER:
2047         case OP_GPROTOENT:
2048         case OP_GSBYNAME:
2049         case OP_GSBYPORT:
2050         case OP_GSERVENT:
2051         case OP_GPWNAM:
2052         case OP_GPWUID:
2053         case OP_GGRNAM:
2054         case OP_GGRGID:
2055         case OP_GETLOGIN:
2056         case OP_PROTOTYPE:
2057         case OP_RUNCV:
2058         func_ops:
2059             useless = OP_DESC(o);
2060             break;
2061
2062         case OP_GVSV:
2063         case OP_PADSV:
2064         case OP_PADAV:
2065         case OP_PADHV:
2066         case OP_PADANY:
2067         case OP_AELEM:
2068         case OP_AELEMFAST:
2069         case OP_AELEMFAST_LEX:
2070         case OP_ASLICE:
2071         case OP_HELEM:
2072         case OP_HSLICE:
2073             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2074                 /* Otherwise it's "Useless use of grep iterator" */
2075                 useless = OP_DESC(o);
2076             break;
2077
2078         case OP_SPLIT:
2079             if (!(o->op_private & OPpSPLIT_ASSIGN))
2080                 useless = OP_DESC(o);
2081             break;
2082
2083         case OP_NOT:
2084             kid = cUNOPo->op_first;
2085             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2086                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2087                 goto func_ops;
2088             }
2089             useless = "negative pattern binding (!~)";
2090             break;
2091
2092         case OP_SUBST:
2093             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2094                 useless = "non-destructive substitution (s///r)";
2095             break;
2096
2097         case OP_TRANSR:
2098             useless = "non-destructive transliteration (tr///r)";
2099             break;
2100
2101         case OP_RV2GV:
2102         case OP_RV2SV:
2103         case OP_RV2AV:
2104         case OP_RV2HV:
2105             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2106                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2107                 useless = "a variable";
2108             break;
2109
2110         case OP_CONST:
2111             sv = cSVOPo_sv;
2112             if (cSVOPo->op_private & OPpCONST_STRICT)
2113                 no_bareword_allowed(o);
2114             else {
2115                 if (ckWARN(WARN_VOID)) {
2116                     NV nv;
2117                     /* don't warn on optimised away booleans, eg
2118                      * use constant Foo, 5; Foo || print; */
2119                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2120                         useless = NULL;
2121                     /* the constants 0 and 1 are permitted as they are
2122                        conventionally used as dummies in constructs like
2123                        1 while some_condition_with_side_effects;  */
2124                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2125                         useless = NULL;
2126                     else if (SvPOK(sv)) {
2127                         SV * const dsv = newSVpvs("");
2128                         useless_sv
2129                             = Perl_newSVpvf(aTHX_
2130                                             "a constant (%s)",
2131                                             pv_pretty(dsv, SvPVX_const(sv),
2132                                                       SvCUR(sv), 32, NULL, NULL,
2133                                                       PERL_PV_PRETTY_DUMP
2134                                                       | PERL_PV_ESCAPE_NOCLEAR
2135                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2136                         SvREFCNT_dec_NN(dsv);
2137                     }
2138                     else if (SvOK(sv)) {
2139                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2140                     }
2141                     else
2142                         useless = "a constant (undef)";
2143                 }
2144             }
2145             op_null(o);         /* don't execute or even remember it */
2146             break;
2147
2148         case OP_POSTINC:
2149             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2150             break;
2151
2152         case OP_POSTDEC:
2153             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2154             break;
2155
2156         case OP_I_POSTINC:
2157             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2158             break;
2159
2160         case OP_I_POSTDEC:
2161             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2162             break;
2163
2164         case OP_SASSIGN: {
2165             OP *rv2gv;
2166             UNOP *refgen, *rv2cv;
2167             LISTOP *exlist;
2168
2169             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2170                 break;
2171
2172             rv2gv = ((BINOP *)o)->op_last;
2173             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2174                 break;
2175
2176             refgen = (UNOP *)((BINOP *)o)->op_first;
2177
2178             if (!refgen || (refgen->op_type != OP_REFGEN
2179                             && refgen->op_type != OP_SREFGEN))
2180                 break;
2181
2182             exlist = (LISTOP *)refgen->op_first;
2183             if (!exlist || exlist->op_type != OP_NULL
2184                 || exlist->op_targ != OP_LIST)
2185                 break;
2186
2187             if (exlist->op_first->op_type != OP_PUSHMARK
2188                 && exlist->op_first != exlist->op_last)
2189                 break;
2190
2191             rv2cv = (UNOP*)exlist->op_last;
2192
2193             if (rv2cv->op_type != OP_RV2CV)
2194                 break;
2195
2196             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2197             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2198             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2199
2200             o->op_private |= OPpASSIGN_CV_TO_GV;
2201             rv2gv->op_private |= OPpDONT_INIT_GV;
2202             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2203
2204             break;
2205         }
2206
2207         case OP_AASSIGN: {
2208             inplace_aassign(o);
2209             break;
2210         }
2211
2212         case OP_OR:
2213         case OP_AND:
2214             kid = cLOGOPo->op_first;
2215             if (kid->op_type == OP_NOT
2216                 && (kid->op_flags & OPf_KIDS)) {
2217                 if (o->op_type == OP_AND) {
2218                     OpTYPE_set(o, OP_OR);
2219                 } else {
2220                     OpTYPE_set(o, OP_AND);
2221                 }
2222                 op_null(kid);
2223             }
2224             /* FALLTHROUGH */
2225
2226         case OP_DOR:
2227         case OP_COND_EXPR:
2228         case OP_ENTERGIVEN:
2229         case OP_ENTERWHEN:
2230             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2231                 if (!(kid->op_flags & OPf_KIDS))
2232                     scalarvoid(kid);
2233                 else
2234                     DEFER_OP(kid);
2235         break;
2236
2237         case OP_NULL:
2238             if (o->op_flags & OPf_STACKED)
2239                 break;
2240             /* FALLTHROUGH */
2241         case OP_NEXTSTATE:
2242         case OP_DBSTATE:
2243         case OP_ENTERTRY:
2244         case OP_ENTER:
2245             if (!(o->op_flags & OPf_KIDS))
2246                 break;
2247             /* FALLTHROUGH */
2248         case OP_SCOPE:
2249         case OP_LEAVE:
2250         case OP_LEAVETRY:
2251         case OP_LEAVELOOP:
2252         case OP_LINESEQ:
2253         case OP_LEAVEGIVEN:
2254         case OP_LEAVEWHEN:
2255         kids:
2256             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2257                 if (!(kid->op_flags & OPf_KIDS))
2258                     scalarvoid(kid);
2259                 else
2260                     DEFER_OP(kid);
2261             break;
2262         case OP_LIST:
2263             /* If the first kid after pushmark is something that the padrange
2264                optimisation would reject, then null the list and the pushmark.
2265             */
2266             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2267                 && (  !(kid = OpSIBLING(kid))
2268                       || (  kid->op_type != OP_PADSV
2269                             && kid->op_type != OP_PADAV
2270                             && kid->op_type != OP_PADHV)
2271                       || kid->op_private & ~OPpLVAL_INTRO
2272                       || !(kid = OpSIBLING(kid))
2273                       || (  kid->op_type != OP_PADSV
2274                             && kid->op_type != OP_PADAV
2275                             && kid->op_type != OP_PADHV)
2276                       || kid->op_private & ~OPpLVAL_INTRO)
2277             ) {
2278                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2279                 op_null(o); /* NULL the list */
2280             }
2281             goto kids;
2282         case OP_ENTEREVAL:
2283             scalarkids(o);
2284             break;
2285         case OP_SCALAR:
2286             scalar(o);
2287             break;
2288         }
2289
2290         if (useless_sv) {
2291             /* mortalise it, in case warnings are fatal.  */
2292             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2293                            "Useless use of %" SVf " in void context",
2294                            SVfARG(sv_2mortal(useless_sv)));
2295         }
2296         else if (useless) {
2297             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2298                            "Useless use of %s in void context",
2299                            useless);
2300         }
2301     } while ( (o = POP_DEFERRED_OP()) );
2302
2303     DEFER_OP_CLEANUP;
2304
2305     return arg;
2306 }
2307
2308 static OP *
2309 S_listkids(pTHX_ OP *o)
2310 {
2311     if (o && o->op_flags & OPf_KIDS) {
2312         OP *kid;
2313         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2314             list(kid);
2315     }
2316     return o;
2317 }
2318
2319 OP *
2320 Perl_list(pTHX_ OP *o)
2321 {
2322     OP *kid;
2323
2324     /* assumes no premature commitment */
2325     if (!o || (o->op_flags & OPf_WANT)
2326          || (PL_parser && PL_parser->error_count)
2327          || o->op_type == OP_RETURN)
2328     {
2329         return o;
2330     }
2331
2332     if ((o->op_private & OPpTARGET_MY)
2333         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2334     {
2335         return o;                               /* As if inside SASSIGN */
2336     }
2337
2338     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2339
2340     switch (o->op_type) {
2341     case OP_FLOP:
2342         list(cBINOPo->op_first);
2343         break;
2344     case OP_REPEAT:
2345         if (o->op_private & OPpREPEAT_DOLIST
2346          && !(o->op_flags & OPf_STACKED))
2347         {
2348             list(cBINOPo->op_first);
2349             kid = cBINOPo->op_last;
2350             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2351              && SvIVX(kSVOP_sv) == 1)
2352             {
2353                 op_null(o); /* repeat */
2354                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2355                 /* const (rhs): */
2356                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2357             }
2358         }
2359         break;
2360     case OP_OR:
2361     case OP_AND:
2362     case OP_COND_EXPR:
2363         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2364             list(kid);
2365         break;
2366     default:
2367     case OP_MATCH:
2368     case OP_QR:
2369     case OP_SUBST:
2370     case OP_NULL:
2371         if (!(o->op_flags & OPf_KIDS))
2372             break;
2373         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2374             list(cBINOPo->op_first);
2375             return gen_constant_list(o);
2376         }
2377         listkids(o);
2378         break;
2379     case OP_LIST:
2380         listkids(o);
2381         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2382             op_null(cUNOPo->op_first); /* NULL the pushmark */
2383             op_null(o); /* NULL the list */
2384         }
2385         break;
2386     case OP_LEAVE:
2387     case OP_LEAVETRY:
2388         kid = cLISTOPo->op_first;
2389         list(kid);
2390         kid = OpSIBLING(kid);
2391     do_kids:
2392         while (kid) {
2393             OP *sib = OpSIBLING(kid);
2394             if (sib && kid->op_type != OP_LEAVEWHEN)
2395                 scalarvoid(kid);
2396             else
2397                 list(kid);
2398             kid = sib;
2399         }
2400         PL_curcop = &PL_compiling;
2401         break;
2402     case OP_SCOPE:
2403     case OP_LINESEQ:
2404         kid = cLISTOPo->op_first;
2405         goto do_kids;
2406     }
2407     return o;
2408 }
2409
2410 static OP *
2411 S_scalarseq(pTHX_ OP *o)
2412 {
2413     if (o) {
2414         const OPCODE type = o->op_type;
2415
2416         if (type == OP_LINESEQ || type == OP_SCOPE ||
2417             type == OP_LEAVE || type == OP_LEAVETRY)
2418         {
2419             OP *kid, *sib;
2420             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2421                 if ((sib = OpSIBLING(kid))
2422                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2423                     || (  sib->op_targ != OP_NEXTSTATE
2424                        && sib->op_targ != OP_DBSTATE  )))
2425                 {
2426                     scalarvoid(kid);
2427                 }
2428             }
2429             PL_curcop = &PL_compiling;
2430         }
2431         o->op_flags &= ~OPf_PARENS;
2432         if (PL_hints & HINT_BLOCK_SCOPE)
2433             o->op_flags |= OPf_PARENS;
2434     }
2435     else
2436         o = newOP(OP_STUB, 0);
2437     return o;
2438 }
2439
2440 STATIC OP *
2441 S_modkids(pTHX_ OP *o, I32 type)
2442 {
2443     if (o && o->op_flags & OPf_KIDS) {
2444         OP *kid;
2445         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2446             op_lvalue(kid, type);
2447     }
2448     return o;
2449 }
2450
2451
2452 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2453  * const fields. Also, convert CONST keys to HEK-in-SVs.
2454  * rop    is the op that retrieves the hash;
2455  * key_op is the first key
2456  * real   if false, only check (and possibly croak); don't update op
2457  */
2458
2459 STATIC void
2460 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2461 {
2462     PADNAME *lexname;
2463     GV **fields;
2464     bool check_fields;
2465
2466     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2467     if (rop) {
2468         if (rop->op_first->op_type == OP_PADSV)
2469             /* @$hash{qw(keys here)} */
2470             rop = (UNOP*)rop->op_first;
2471         else {
2472             /* @{$hash}{qw(keys here)} */
2473             if (rop->op_first->op_type == OP_SCOPE
2474                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2475                 {
2476                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2477                 }
2478             else
2479                 rop = NULL;
2480         }
2481     }
2482
2483     lexname = NULL; /* just to silence compiler warnings */
2484     fields  = NULL; /* just to silence compiler warnings */
2485
2486     check_fields =
2487             rop
2488          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2489              SvPAD_TYPED(lexname))
2490          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2491          && isGV(*fields) && GvHV(*fields);
2492
2493     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2494         SV **svp, *sv;
2495         if (key_op->op_type != OP_CONST)
2496             continue;
2497         svp = cSVOPx_svp(key_op);
2498
2499         /* make sure it's not a bareword under strict subs */
2500         if (key_op->op_private & OPpCONST_BARE &&
2501             key_op->op_private & OPpCONST_STRICT)
2502         {
2503             no_bareword_allowed((OP*)key_op);
2504         }
2505
2506         /* Make the CONST have a shared SV */
2507         if (   !SvIsCOW_shared_hash(sv = *svp)
2508             && SvTYPE(sv) < SVt_PVMG
2509             && SvOK(sv)
2510             && !SvROK(sv)
2511             && real)
2512         {
2513             SSize_t keylen;
2514             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2515             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2516             SvREFCNT_dec_NN(sv);
2517             *svp = nsv;
2518         }
2519
2520         if (   check_fields
2521             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2522         {
2523             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2524                         "in variable %" PNf " of type %" HEKf,
2525                         SVfARG(*svp), PNfARG(lexname),
2526                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2527         }
2528     }
2529 }
2530
2531 /* info returned by S_sprintf_is_multiconcatable() */
2532
2533 struct sprintf_ismc_info {
2534     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2535     char  *start;     /* start of raw format string */
2536     char  *end;       /* bytes after end of raw format string */
2537     STRLEN total_len; /* total length (in bytes) of format string, not
2538                          including '%s' and  half of '%%' */
2539     STRLEN variant;   /* number of bytes by which total_len_p would grow
2540                          if upgraded to utf8 */
2541     bool   utf8;      /* whether the format is utf8 */
2542 };
2543
2544
2545 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2546  * i.e. its format argument is a const string with only '%s' and '%%'
2547  * formats, and the number of args is known, e.g.
2548  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2549  * but not
2550  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2551  *
2552  * If successful, the sprintf_ismc_info struct pointed to by info will be
2553  * populated.
2554  */
2555
2556 STATIC bool
2557 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2558 {
2559     OP    *pm, *constop, *kid;
2560     SV    *sv;
2561     char  *s, *e, *p;
2562     SSize_t nargs, nformats;
2563     STRLEN cur, total_len, variant;
2564     bool   utf8;
2565
2566     /* if sprintf's behaviour changes, die here so that someone
2567      * can decide whether to enhance this function or skip optimising
2568      * under those new circumstances */
2569     assert(!(o->op_flags & OPf_STACKED));
2570     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2571     assert(!(o->op_private & ~OPpARG4_MASK));
2572
2573     pm = cUNOPo->op_first;
2574     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2575         return FALSE;
2576     constop = OpSIBLING(pm);
2577     if (!constop || constop->op_type != OP_CONST)
2578         return FALSE;
2579     sv = cSVOPx_sv(constop);
2580     if (SvMAGICAL(sv) || !SvPOK(sv))
2581         return FALSE;
2582
2583     s = SvPV(sv, cur);
2584     e = s + cur;
2585
2586     /* Scan format for %% and %s and work out how many %s there are.
2587      * Abandon if other format types are found.
2588      */
2589
2590     nformats  = 0;
2591     total_len = 0;
2592     variant   = 0;
2593
2594     for (p = s; p < e; p++) {
2595         if (*p != '%') {
2596             total_len++;
2597             if (!UTF8_IS_INVARIANT(*p))
2598                 variant++;
2599             continue;
2600         }
2601         p++;
2602         if (p >= e)
2603             return FALSE; /* lone % at end gives "Invalid conversion" */
2604         if (*p == '%')
2605             total_len++;
2606         else if (*p == 's')
2607             nformats++;
2608         else
2609             return FALSE;
2610     }
2611
2612     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2613         return FALSE;
2614
2615     utf8 = cBOOL(SvUTF8(sv));
2616     if (utf8)
2617         variant = 0;
2618
2619     /* scan args; they must all be in scalar cxt */
2620
2621     nargs = 0;
2622     kid = OpSIBLING(constop);
2623
2624     while (kid) {
2625         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2626             return FALSE;
2627         nargs++;
2628         kid = OpSIBLING(kid);
2629     }
2630
2631     if (nargs != nformats)
2632         return FALSE; /* e.g. sprintf("%s%s", $a); */
2633
2634
2635     info->nargs      = nargs;
2636     info->start      = s;
2637     info->end        = e;
2638     info->total_len  = total_len;
2639     info->variant    = variant;
2640     info->utf8       = utf8;
2641
2642     return TRUE;
2643 }
2644
2645
2646
2647 /* S_maybe_multiconcat():
2648  *
2649  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2650  * convert it (and its children) into an OP_MULTICONCAT. See the code
2651  * comments just before pp_multiconcat() for the full details of what
2652  * OP_MULTICONCAT supports.
2653  *
2654  * Basically we're looking for an optree with a chain of OP_CONCATS down
2655  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2656  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2657  *
2658  *      $x = "$a$b-$c"
2659  *
2660  *  looks like
2661  *
2662  *      SASSIGN
2663  *         |
2664  *      STRINGIFY   -- PADSV[$x]
2665  *         |
2666  *         |
2667  *      ex-PUSHMARK -- CONCAT/S
2668  *                        |
2669  *                     CONCAT/S  -- PADSV[$d]
2670  *                        |
2671  *                     CONCAT    -- CONST["-"]
2672  *                        |
2673  *                     PADSV[$a] -- PADSV[$b]
2674  *
2675  * Note that at this stage the OP_SASSIGN may have already been optimised
2676  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2677  */
2678
2679 STATIC void
2680 S_maybe_multiconcat(pTHX_ OP *o)
2681 {
2682     dVAR;
2683     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2684     OP *topop;       /* the top-most op in the concat tree (often equals o,
2685                         unless there are assign/stringify ops above it */
2686     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2687     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2688     OP *targetop;    /* the op corresponding to target=... or target.=... */
2689     OP *stringop;    /* the OP_STRINGIFY op, if any */
2690     OP *nextop;      /* used for recreating the op_next chain without consts */
2691     OP *kid;         /* general-purpose op pointer */
2692     UNOP_AUX_item *aux;
2693     UNOP_AUX_item *lenp;
2694     char *const_str, *p;
2695     struct sprintf_ismc_info sprintf_info;
2696
2697                      /* store info about each arg in args[];
2698                       * toparg is the highest used slot; argp is a general
2699                       * pointer to args[] slots */
2700     struct {
2701         void *p;      /* initially points to const sv (or null for op);
2702                          later, set to SvPV(constsv), with ... */
2703         STRLEN len;   /* ... len set to SvPV(..., len) */
2704     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2705
2706     SSize_t nargs  = 0;
2707     SSize_t nconst = 0;
2708     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2709     STRLEN variant;
2710     bool utf8 = FALSE;
2711     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2712                                  the last-processed arg will the LHS of one,
2713                                  as args are processed in reverse order */
2714     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2715     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2716     U8 flags          = 0;   /* what will become the op_flags and ... */
2717     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2718     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2719     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2720     bool prev_was_const = FALSE; /* previous arg was a const */
2721
2722     /* -----------------------------------------------------------------
2723      * Phase 1:
2724      *
2725      * Examine the optree non-destructively to determine whether it's
2726      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2727      * information about the optree in args[].
2728      */
2729
2730     argp     = args;
2731     targmyop = NULL;
2732     targetop = NULL;
2733     stringop = NULL;
2734     topop    = o;
2735     parentop = o;
2736
2737     assert(   o->op_type == OP_SASSIGN
2738            || o->op_type == OP_CONCAT
2739            || o->op_type == OP_SPRINTF
2740            || o->op_type == OP_STRINGIFY);
2741
2742     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2743
2744     /* first see if, at the top of the tree, there is an assign,
2745      * append and/or stringify */
2746
2747     if (topop->op_type == OP_SASSIGN) {
2748         /* expr = ..... */
2749         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2750             return;
2751         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2752             return;
2753         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2754
2755         parentop = topop;
2756         topop = cBINOPo->op_first;
2757         targetop = OpSIBLING(topop);
2758         if (!targetop) /* probably some sort of syntax error */
2759             return;
2760     }
2761     else if (   topop->op_type == OP_CONCAT
2762              && (topop->op_flags & OPf_STACKED)
2763              && (!(topop->op_private & OPpCONCAT_NESTED))
2764             )
2765     {
2766         /* expr .= ..... */
2767
2768         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2769          * decide what to do about it */
2770         assert(!(o->op_private & OPpTARGET_MY));
2771
2772         /* barf on unknown flags */
2773         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2774         private_flags |= OPpMULTICONCAT_APPEND;
2775         targetop = cBINOPo->op_first;
2776         parentop = topop;
2777         topop    = OpSIBLING(targetop);
2778
2779         /* $x .= <FOO> gets optimised to rcatline instead */
2780         if (topop->op_type == OP_READLINE)
2781             return;
2782     }
2783
2784     if (targetop) {
2785         /* Can targetop (the LHS) if it's a padsv, be be optimised
2786          * away and use OPpTARGET_MY instead?
2787          */
2788         if (    (targetop->op_type == OP_PADSV)
2789             && !(targetop->op_private & OPpDEREF)
2790             && !(targetop->op_private & OPpPAD_STATE)
2791                /* we don't support 'my $x .= ...' */
2792             && (   o->op_type == OP_SASSIGN
2793                 || !(targetop->op_private & OPpLVAL_INTRO))
2794         )
2795             is_targable = TRUE;
2796     }
2797
2798     if (topop->op_type == OP_STRINGIFY) {
2799         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2800             return;
2801         stringop = topop;
2802
2803         /* barf on unknown flags */
2804         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2805
2806         if ((topop->op_private & OPpTARGET_MY)) {
2807             if (o->op_type == OP_SASSIGN)
2808                 return; /* can't have two assigns */
2809             targmyop = topop;
2810         }
2811
2812         private_flags |= OPpMULTICONCAT_STRINGIFY;
2813         parentop = topop;
2814         topop = cBINOPx(topop)->op_first;
2815         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2816         topop = OpSIBLING(topop);
2817     }
2818
2819     if (topop->op_type == OP_SPRINTF) {
2820         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2821             return;
2822         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2823             nargs     = sprintf_info.nargs;
2824             total_len = sprintf_info.total_len;
2825             variant   = sprintf_info.variant;
2826             utf8      = sprintf_info.utf8;
2827             is_sprintf = TRUE;
2828             private_flags |= OPpMULTICONCAT_FAKE;
2829             toparg = argp;
2830             /* we have an sprintf op rather than a concat optree.
2831              * Skip most of the code below which is associated with
2832              * processing that optree. We also skip phase 2, determining
2833              * whether its cost effective to optimise, since for sprintf,
2834              * multiconcat is *always* faster */
2835             goto create_aux;
2836         }
2837         /* note that even if the sprintf itself isn't multiconcatable,
2838          * the expression as a whole may be, e.g. in
2839          *    $x .= sprintf("%d",...)
2840          * the sprintf op will be left as-is, but the concat/S op may
2841          * be upgraded to multiconcat
2842          */
2843     }
2844     else if (topop->op_type == OP_CONCAT) {
2845         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2846             return;
2847
2848         if ((topop->op_private & OPpTARGET_MY)) {
2849             if (o->op_type == OP_SASSIGN || targmyop)
2850                 return; /* can't have two assigns */
2851             targmyop = topop;
2852         }
2853     }
2854
2855     /* Is it safe to convert a sassign/stringify/concat op into
2856      * a multiconcat? */
2857     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2858     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2859     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2860     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2861     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2862                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2863     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2864                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2865
2866     /* Now scan the down the tree looking for a series of
2867      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2868      * stacked). For example this tree:
2869      *
2870      *     |
2871      *   CONCAT/STACKED
2872      *     |
2873      *   CONCAT/STACKED -- EXPR5
2874      *     |
2875      *   CONCAT/STACKED -- EXPR4
2876      *     |
2877      *   CONCAT -- EXPR3
2878      *     |
2879      *   EXPR1  -- EXPR2
2880      *
2881      * corresponds to an expression like
2882      *
2883      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2884      *
2885      * Record info about each EXPR in args[]: in particular, whether it is
2886      * a stringifiable OP_CONST and if so what the const sv is.
2887      *
2888      * The reason why the last concat can't be STACKED is the difference
2889      * between
2890      *
2891      *    ((($a .= $a) .= $a) .= $a) .= $a
2892      *
2893      * and
2894      *    $a . $a . $a . $a . $a
2895      *
2896      * The main difference between the optrees for those two constructs
2897      * is the presence of the last STACKED. As well as modifying $a,
2898      * the former sees the changed $a between each concat, so if $s is
2899      * initially 'a', the first returns 'a' x 16, while the latter returns
2900      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2901      */
2902
2903     kid = topop;
2904
2905     for (;;) {
2906         OP *argop;
2907         SV *sv;
2908         bool last = FALSE;
2909
2910         if (    kid->op_type == OP_CONCAT
2911             && !kid_is_last
2912         ) {
2913             OP *k1, *k2;
2914             k1 = cUNOPx(kid)->op_first;
2915             k2 = OpSIBLING(k1);
2916             /* shouldn't happen except maybe after compile err? */
2917             if (!k2)
2918                 return;
2919
2920             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2921             if (kid->op_private & OPpTARGET_MY)
2922                 kid_is_last = TRUE;
2923
2924             stacked_last = (kid->op_flags & OPf_STACKED);
2925             if (!stacked_last)
2926                 kid_is_last = TRUE;
2927
2928             kid   = k1;
2929             argop = k2;
2930         }
2931         else {
2932             argop = kid;
2933             last = TRUE;
2934         }
2935
2936         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2937             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2938         {
2939             /* At least two spare slots are needed to decompose both
2940              * concat args. If there are no slots left, continue to
2941              * examine the rest of the optree, but don't push new values
2942              * on args[]. If the optree as a whole is legal for conversion
2943              * (in particular that the last concat isn't STACKED), then
2944              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2945              * can be converted into an OP_MULTICONCAT now, with the first
2946              * child of that op being the remainder of the optree -
2947              * which may itself later be converted to a multiconcat op
2948              * too.
2949              */
2950             if (last) {
2951                 /* the last arg is the rest of the optree */
2952                 argp++->p = NULL;
2953                 nargs++;
2954             }
2955         }
2956         else if (   argop->op_type == OP_CONST
2957             && ((sv = cSVOPx_sv(argop)))
2958             /* defer stringification until runtime of 'constant'
2959              * things that might stringify variantly, e.g. the radix
2960              * point of NVs, or overloaded RVs */
2961             && (SvPOK(sv) || SvIOK(sv))
2962             && (!SvGMAGICAL(sv))
2963         ) {
2964             argp++->p = sv;
2965             utf8   |= cBOOL(SvUTF8(sv));
2966             nconst++;
2967             if (prev_was_const)
2968                 /* this const may be demoted back to a plain arg later;
2969                  * make sure we have enough arg slots left */
2970                 nadjconst++;
2971             prev_was_const = !prev_was_const;
2972         }
2973         else {
2974             argp++->p = NULL;
2975             nargs++;
2976             prev_was_const = FALSE;
2977         }
2978
2979         if (last)
2980             break;
2981     }
2982
2983     toparg = argp - 1;
2984
2985     if (stacked_last)
2986         return; /* we don't support ((A.=B).=C)...) */
2987
2988     /* look for two adjacent consts and don't fold them together:
2989      *     $o . "a" . "b"
2990      * should do
2991      *     $o->concat("a")->concat("b")
2992      * rather than
2993      *     $o->concat("ab")
2994      * (but $o .=  "a" . "b" should still fold)
2995      */
2996     {
2997         bool seen_nonconst = FALSE;
2998         for (argp = toparg; argp >= args; argp--) {
2999             if (argp->p == NULL) {
3000                 seen_nonconst = TRUE;
3001                 continue;
3002             }
3003             if (!seen_nonconst)
3004                 continue;
3005             if (argp[1].p) {
3006                 /* both previous and current arg were constants;
3007                  * leave the current OP_CONST as-is */
3008                 argp->p = NULL;
3009                 nconst--;
3010                 nargs++;
3011             }
3012         }
3013     }
3014
3015     /* -----------------------------------------------------------------
3016      * Phase 2:
3017      *
3018      * At this point we have determined that the optree *can* be converted
3019      * into a multiconcat. Having gathered all the evidence, we now decide
3020      * whether it *should*.
3021      */
3022
3023
3024     /* we need at least one concat action, e.g.:
3025      *
3026      *  Y . Z
3027      *  X = Y . Z
3028      *  X .= Y
3029      *
3030      * otherwise we could be doing something like $x = "foo", which
3031      * if treated as as a concat, would fail to COW.
3032      */
3033     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3034         return;
3035
3036     /* Benchmarking seems to indicate that we gain if:
3037      * * we optimise at least two actions into a single multiconcat
3038      *    (e.g concat+concat, sassign+concat);
3039      * * or if we can eliminate at least 1 OP_CONST;
3040      * * or if we can eliminate a padsv via OPpTARGET_MY
3041      */
3042
3043     if (
3044            /* eliminated at least one OP_CONST */
3045            nconst >= 1
3046            /* eliminated an OP_SASSIGN */
3047         || o->op_type == OP_SASSIGN
3048            /* eliminated an OP_PADSV */
3049         || (!targmyop && is_targable)
3050     )
3051         /* definitely a net gain to optimise */
3052         goto optimise;
3053
3054     /* ... if not, what else? */
3055
3056     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3057      * multiconcat is faster (due to not creating a temporary copy of
3058      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3059      * faster.
3060      */
3061     if (   nconst == 0
3062          && nargs == 2
3063          && targmyop
3064          && topop->op_type == OP_CONCAT
3065     ) {
3066         PADOFFSET t = targmyop->op_targ;
3067         OP *k1 = cBINOPx(topop)->op_first;
3068         OP *k2 = cBINOPx(topop)->op_last;
3069         if (   k2->op_type == OP_PADSV
3070             && k2->op_targ == t
3071             && (   k1->op_type != OP_PADSV
3072                 || k1->op_targ != t)
3073         )
3074             goto optimise;
3075     }
3076
3077     /* need at least two concats */
3078     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3079         return;
3080
3081
3082
3083     /* -----------------------------------------------------------------
3084      * Phase 3:
3085      *
3086      * At this point the optree has been verified as ok to be optimised
3087      * into an OP_MULTICONCAT. Now start changing things.
3088      */
3089
3090    optimise:
3091
3092     /* stringify all const args and determine utf8ness */
3093
3094     variant = 0;
3095     for (argp = args; argp <= toparg; argp++) {
3096         SV *sv = (SV*)argp->p;
3097         if (!sv)
3098             continue; /* not a const op */
3099         if (utf8 && !SvUTF8(sv))
3100             sv_utf8_upgrade_nomg(sv);
3101         argp->p = SvPV_nomg(sv, argp->len);
3102         total_len += argp->len;
3103
3104         /* see if any strings would grow if converted to utf8 */
3105         if (!utf8) {
3106             variant += variant_under_utf8_count((U8 *) argp->p,
3107                                                 (U8 *) argp->p + argp->len);
3108         }
3109     }
3110
3111     /* create and populate aux struct */
3112
3113   create_aux:
3114
3115     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3116                     sizeof(UNOP_AUX_item)
3117                     *  (
3118                            PERL_MULTICONCAT_HEADER_SIZE
3119                          + ((nargs + 1) * (variant ? 2 : 1))
3120                         )
3121                     );
3122     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3123
3124     /* Extract all the non-const expressions from the concat tree then
3125      * dispose of the old tree, e.g. convert the tree from this:
3126      *
3127      *  o => SASSIGN
3128      *         |
3129      *       STRINGIFY   -- TARGET
3130      *         |
3131      *       ex-PUSHMARK -- CONCAT
3132      *                        |
3133      *                      CONCAT -- EXPR5
3134      *                        |
3135      *                      CONCAT -- EXPR4
3136      *                        |
3137      *                      CONCAT -- EXPR3
3138      *                        |
3139      *                      EXPR1  -- EXPR2
3140      *
3141      *
3142      * to:
3143      *
3144      *  o => MULTICONCAT
3145      *         |
3146      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3147      *
3148      * except that if EXPRi is an OP_CONST, it's discarded.
3149      *
3150      * During the conversion process, EXPR ops are stripped from the tree
3151      * and unshifted onto o. Finally, any of o's remaining original
3152      * childen are discarded and o is converted into an OP_MULTICONCAT.
3153      *
3154      * In this middle of this, o may contain both: unshifted args on the
3155      * left, and some remaining original args on the right. lastkidop
3156      * is set to point to the right-most unshifted arg to delineate
3157      * between the two sets.
3158      */
3159
3160
3161     if (is_sprintf) {
3162         /* create a copy of the format with the %'s removed, and record
3163          * the sizes of the const string segments in the aux struct */
3164         char *q, *oldq;
3165         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3166
3167         p    = sprintf_info.start;
3168         q    = const_str;
3169         oldq = q;
3170         for (; p < sprintf_info.end; p++) {
3171             if (*p == '%') {
3172                 p++;
3173                 if (*p != '%') {
3174                     (lenp++)->ssize = q - oldq;
3175                     oldq = q;
3176                     continue;
3177                 }
3178             }
3179             *q++ = *p;
3180         }
3181         lenp->ssize = q - oldq;
3182         assert((STRLEN)(q - const_str) == total_len);
3183
3184         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3185          * may or may not be topop) The pushmark and const ops need to be
3186          * kept in case they're an op_next entry point.
3187          */
3188         lastkidop = cLISTOPx(topop)->op_last;
3189         kid = cUNOPx(topop)->op_first; /* pushmark */
3190         op_null(kid);
3191         op_null(OpSIBLING(kid));       /* const */
3192         if (o != topop) {
3193             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3194             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3195             lastkidop->op_next = o;
3196         }
3197     }
3198     else {
3199         p = const_str;
3200         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3201
3202         lenp->ssize = -1;
3203
3204         /* Concatenate all const strings into const_str.
3205          * Note that args[] contains the RHS args in reverse order, so
3206          * we scan args[] from top to bottom to get constant strings
3207          * in L-R order
3208          */
3209         for (argp = toparg; argp >= args; argp--) {
3210             if (!argp->p)
3211                 /* not a const op */
3212                 (++lenp)->ssize = -1;
3213             else {
3214                 STRLEN l = argp->len;
3215                 Copy(argp->p, p, l, char);
3216                 p += l;
3217                 if (lenp->ssize == -1)
3218                     lenp->ssize = l;
3219                 else
3220                     lenp->ssize += l;
3221             }
3222         }
3223
3224         kid = topop;
3225         nextop = o;
3226         lastkidop = NULL;
3227
3228         for (argp = args; argp <= toparg; argp++) {
3229             /* only keep non-const args, except keep the first-in-next-chain
3230              * arg no matter what it is (but nulled if OP_CONST), because it
3231              * may be the entry point to this subtree from the previous
3232              * op_next.
3233              */
3234             bool last = (argp == toparg);
3235             OP *prev;
3236
3237             /* set prev to the sibling *before* the arg to be cut out,
3238              * e.g. when cutting EXPR:
3239              *
3240              *         |
3241              * kid=  CONCAT
3242              *         |
3243              * prev= CONCAT -- EXPR
3244              *         |
3245              */
3246             if (argp == args && kid->op_type != OP_CONCAT) {
3247                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3248                  * so the expression to be cut isn't kid->op_last but
3249                  * kid itself */
3250                 OP *o1, *o2;
3251                 /* find the op before kid */
3252                 o1 = NULL;
3253                 o2 = cUNOPx(parentop)->op_first;
3254                 while (o2 && o2 != kid) {
3255                     o1 = o2;
3256                     o2 = OpSIBLING(o2);
3257                 }
3258                 assert(o2 == kid);
3259                 prev = o1;
3260                 kid  = parentop;
3261             }
3262             else if (kid == o && lastkidop)
3263                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3264             else
3265                 prev = last ? NULL : cUNOPx(kid)->op_first;
3266
3267             if (!argp->p || last) {
3268                 /* cut RH op */
3269                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3270                 /* and unshift to front of o */
3271                 op_sibling_splice(o, NULL, 0, aop);
3272                 /* record the right-most op added to o: later we will
3273                  * free anything to the right of it */
3274                 if (!lastkidop)
3275                     lastkidop = aop;
3276                 aop->op_next = nextop;
3277                 if (last) {
3278                     if (argp->p)
3279                         /* null the const at start of op_next chain */
3280                         op_null(aop);
3281                 }
3282                 else if (prev)
3283                     nextop = prev->op_next;
3284             }
3285
3286             /* the last two arguments are both attached to the same concat op */
3287             if (argp < toparg - 1)
3288                 kid = prev;
3289         }
3290     }
3291
3292     /* Populate the aux struct */
3293
3294     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3295     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3296     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3297     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3298     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3299
3300     /* if variant > 0, calculate a variant const string and lengths where
3301      * the utf8 version of the string will take 'variant' more bytes than
3302      * the plain one. */
3303
3304     if (variant) {
3305         char              *p = const_str;
3306         STRLEN          ulen = total_len + variant;
3307         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3308         UNOP_AUX_item *ulens = lens + (nargs + 1);
3309         char             *up = (char*)PerlMemShared_malloc(ulen);
3310         SSize_t            n;
3311
3312         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3313         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3314
3315         for (n = 0; n < (nargs + 1); n++) {
3316             SSize_t i;
3317             char * orig_up = up;
3318             for (i = (lens++)->ssize; i > 0; i--) {
3319                 U8 c = *p++;
3320                 append_utf8_from_native_byte(c, (U8**)&up);
3321             }
3322             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3323         }
3324     }
3325
3326     if (stringop) {
3327         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3328          * that op's first child - an ex-PUSHMARK - because the op_next of
3329          * the previous op may point to it (i.e. it's the entry point for
3330          * the o optree)
3331          */
3332         OP *pmop =
3333             (stringop == o)
3334                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3335                 : op_sibling_splice(stringop, NULL, 1, NULL);
3336         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3337         op_sibling_splice(o, NULL, 0, pmop);
3338         if (!lastkidop)
3339             lastkidop = pmop;
3340     }
3341
3342     /* Optimise
3343      *    target  = A.B.C...
3344      *    target .= A.B.C...
3345      */
3346
3347     if (targetop) {
3348         assert(!targmyop);
3349
3350         if (o->op_type == OP_SASSIGN) {
3351             /* Move the target subtree from being the last of o's children
3352              * to being the last of o's preserved children.
3353              * Note the difference between 'target = ...' and 'target .= ...':
3354              * for the former, target is executed last; for the latter,
3355              * first.
3356              */
3357             kid = OpSIBLING(lastkidop);
3358             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3359             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3360             lastkidop->op_next = kid->op_next;
3361             lastkidop = targetop;
3362         }
3363         else {
3364             /* Move the target subtree from being the first of o's
3365              * original children to being the first of *all* o's children.
3366              */
3367             if (lastkidop) {
3368                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3369                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3370             }
3371             else {
3372                 /* if the RHS of .= doesn't contain a concat (e.g.
3373                  * $x .= "foo"), it gets missed by the "strip ops from the
3374                  * tree and add to o" loop earlier */
3375                 assert(topop->op_type != OP_CONCAT);
3376                 if (stringop) {
3377                     /* in e.g. $x .= "$y", move the $y expression
3378                      * from being a child of OP_STRINGIFY to being the
3379                      * second child of the OP_CONCAT
3380                      */
3381                     assert(cUNOPx(stringop)->op_first == topop);
3382                     op_sibling_splice(stringop, NULL, 1, NULL);
3383                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3384                 }
3385                 assert(topop == OpSIBLING(cBINOPo->op_first));
3386                 if (toparg->p)
3387                     op_null(topop);
3388                 lastkidop = topop;
3389             }
3390         }
3391
3392         if (is_targable) {
3393             /* optimise
3394              *  my $lex  = A.B.C...
3395              *     $lex  = A.B.C...
3396              *     $lex .= A.B.C...
3397              * The original padsv op is kept but nulled in case it's the
3398              * entry point for the optree (which it will be for
3399              * '$lex .=  ... '
3400              */
3401             private_flags |= OPpTARGET_MY;
3402             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3403             o->op_targ = targetop->op_targ;
3404             targetop->op_targ = 0;
3405             op_null(targetop);
3406         }
3407         else
3408             flags |= OPf_STACKED;
3409     }
3410     else if (targmyop) {
3411         private_flags |= OPpTARGET_MY;
3412         if (o != targmyop) {
3413             o->op_targ = targmyop->op_targ;
3414             targmyop->op_targ = 0;
3415         }
3416     }
3417
3418     /* detach the emaciated husk of the sprintf/concat optree and free it */
3419     for (;;) {
3420         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3421         if (!kid)
3422             break;
3423         op_free(kid);
3424     }
3425
3426     /* and convert o into a multiconcat */
3427
3428     o->op_flags        = (flags|OPf_KIDS|stacked_last
3429                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3430     o->op_private      = private_flags;
3431     o->op_type         = OP_MULTICONCAT;
3432     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3433     cUNOP_AUXo->op_aux = aux;
3434 }
3435
3436
3437 /* do all the final processing on an optree (e.g. running the peephole
3438  * optimiser on it), then attach it to cv (if cv is non-null)
3439  */
3440
3441 static void
3442 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3443 {
3444     OP **startp;
3445
3446     /* XXX for some reason, evals, require and main optrees are
3447      * never attached to their CV; instead they just hang off
3448      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3449      * and get manually freed when appropriate */
3450     if (cv)
3451         startp = &CvSTART(cv);
3452     else
3453         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3454
3455     *startp = start;
3456     optree->op_private |= OPpREFCOUNTED;
3457     OpREFCNT_set(optree, 1);
3458     optimize_optree(optree);
3459     CALL_PEEP(*startp);
3460     finalize_optree(optree);
3461     S_prune_chain_head(startp);
3462
3463     if (cv) {
3464         /* now that optimizer has done its work, adjust pad values */
3465         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3466                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3467     }
3468 }
3469
3470
3471 /*
3472 =for apidoc optimize_optree
3473
3474 This function applies some optimisations to the optree in top-down order.
3475 It is called before the peephole optimizer, which processes ops in
3476 execution order. Note that finalize_optree() also does a top-down scan,
3477 but is called *after* the peephole optimizer.
3478
3479 =cut
3480 */
3481
3482 void
3483 Perl_optimize_optree(pTHX_ OP* o)
3484 {
3485     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3486
3487     ENTER;
3488     SAVEVPTR(PL_curcop);
3489
3490     optimize_op(o);
3491
3492     LEAVE;
3493 }
3494
3495
3496 /* helper for optimize_optree() which optimises on op then recurses
3497  * to optimise any children.
3498  */
3499
3500 STATIC void
3501 S_optimize_op(pTHX_ OP* o)
3502 {
3503     dDEFER_OP;
3504
3505     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3506     do {
3507         assert(o->op_type != OP_FREED);
3508
3509         switch (o->op_type) {
3510         case OP_NEXTSTATE:
3511         case OP_DBSTATE:
3512             PL_curcop = ((COP*)o);              /* for warnings */
3513             break;
3514
3515
3516         case OP_CONCAT:
3517         case OP_SASSIGN:
3518         case OP_STRINGIFY:
3519         case OP_SPRINTF:
3520             S_maybe_multiconcat(aTHX_ o);
3521             break;
3522
3523         case OP_SUBST:
3524             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3525                 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3526             break;
3527
3528         default:
3529             break;
3530         }
3531
3532         if (o->op_flags & OPf_KIDS) {
3533             OP *kid;
3534             IV child_count = 0;
3535             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3536                 DEFER_OP(kid);
3537                 ++child_count;
3538             }
3539             DEFER_REVERSE(child_count);
3540         }
3541     } while ( ( o = POP_DEFERRED_OP() ) );
3542
3543     DEFER_OP_CLEANUP;
3544 }
3545
3546
3547 /*
3548 =for apidoc finalize_optree
3549
3550 This function finalizes the optree.  Should be called directly after
3551 the complete optree is built.  It does some additional
3552 checking which can't be done in the normal C<ck_>xxx functions and makes
3553 the tree thread-safe.
3554
3555 =cut
3556 */
3557 void
3558 Perl_finalize_optree(pTHX_ OP* o)
3559 {
3560     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3561
3562     ENTER;
3563     SAVEVPTR(PL_curcop);
3564
3565     finalize_op(o);
3566
3567     LEAVE;
3568 }
3569
3570 #ifdef USE_ITHREADS
3571 /* Relocate sv to the pad for thread safety.
3572  * Despite being a "constant", the SV is written to,
3573  * for reference counts, sv_upgrade() etc. */
3574 PERL_STATIC_INLINE void
3575 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3576 {
3577     PADOFFSET ix;
3578     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3579     if (!*svp) return;
3580     ix = pad_alloc(OP_CONST, SVf_READONLY);
3581     SvREFCNT_dec(PAD_SVl(ix));
3582     PAD_SETSV(ix, *svp);
3583     /* XXX I don't know how this isn't readonly already. */
3584     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3585     *svp = NULL;
3586     *targp = ix;
3587 }
3588 #endif
3589
3590 /*
3591 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3592
3593 Return the next op in a depth-first traversal of the op tree,
3594 returning NULL when the traversal is complete.
3595
3596 The initial call must supply the root of the tree as both top and o.
3597
3598 For now it's static, but it may be exposed to the API in the future.
3599
3600 =cut
3601 */
3602
3603 STATIC OP*
3604 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3605     OP *sib;
3606
3607     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3608
3609     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3610         return cUNOPo->op_first;
3611     }
3612     else if ((sib = OpSIBLING(o))) {
3613         return sib;
3614     }
3615     else {
3616         OP *parent = o->op_sibparent;
3617         assert(!(o->op_moresib));
3618         while (parent && parent != top) {
3619             OP *sib = OpSIBLING(parent);
3620             if (sib)
3621                 return sib;
3622             parent = parent->op_sibparent;
3623         }
3624
3625         return NULL;
3626     }
3627 }
3628
3629 STATIC void
3630 S_finalize_op(pTHX_ OP* o)
3631 {
3632     OP * const top = o;
3633     PERL_ARGS_ASSERT_FINALIZE_OP;
3634
3635     do {
3636         assert(o->op_type != OP_FREED);
3637
3638         switch (o->op_type) {
3639         case OP_NEXTSTATE:
3640         case OP_DBSTATE:
3641             PL_curcop = ((COP*)o);              /* for warnings */
3642             break;
3643         case OP_EXEC:
3644             if (OpHAS_SIBLING(o)) {
3645                 OP *sib = OpSIBLING(o);
3646                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3647                     && ckWARN(WARN_EXEC)
3648                     && OpHAS_SIBLING(sib))
3649                 {
3650                     const OPCODE type = OpSIBLING(sib)->op_type;
3651                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3652                         const line_t oldline = CopLINE(PL_curcop);
3653                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3654                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3655                             "Statement unlikely to be reached");
3656                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3657                             "\t(Maybe you meant system() when you said exec()?)\n");
3658                         CopLINE_set(PL_curcop, oldline);
3659                     }
3660                 }
3661             }
3662             break;
3663
3664         case OP_GV:
3665             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3666                 GV * const gv = cGVOPo_gv;
3667                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3668                     /* XXX could check prototype here instead of just carping */
3669                     SV * const sv = sv_newmortal();
3670                     gv_efullname3(sv, gv, NULL);
3671                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3672                                 "%" SVf "() called too early to check prototype",
3673                                 SVfARG(sv));
3674                 }
3675             }
3676             break;
3677
3678         case OP_CONST:
3679             if (cSVOPo->op_private & OPpCONST_STRICT)
3680                 no_bareword_allowed(o);
3681 #ifdef USE_ITHREADS
3682             /* FALLTHROUGH */
3683         case OP_HINTSEVAL:
3684             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3685 #endif
3686             break;
3687
3688 #ifdef USE_ITHREADS
3689             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3690         case OP_METHOD_NAMED:
3691         case OP_METHOD_SUPER:
3692         case OP_METHOD_REDIR:
3693         case OP_METHOD_REDIR_SUPER:
3694             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3695             break;
3696 #endif
3697
3698         case OP_HELEM: {
3699             UNOP *rop;
3700             SVOP *key_op;
3701             OP *kid;
3702
3703             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3704                 break;
3705
3706             rop = (UNOP*)((BINOP*)o)->op_first;
3707
3708             goto check_keys;
3709
3710             case OP_HSLICE:
3711                 S_scalar_slice_warning(aTHX_ o);
3712                 /* FALLTHROUGH */
3713
3714             case OP_KVHSLICE:
3715                 kid = OpSIBLING(cLISTOPo->op_first);
3716             if (/* I bet there's always a pushmark... */
3717                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3718                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3719             {
3720                 break;
3721             }
3722
3723             key_op = (SVOP*)(kid->op_type == OP_CONST
3724                              ? kid
3725                              : OpSIBLING(kLISTOP->op_first));
3726
3727             rop = (UNOP*)((LISTOP*)o)->op_last;
3728
3729         check_keys:
3730             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3731                 rop = NULL;
3732             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3733             break;
3734         }
3735         case OP_NULL:
3736             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3737                 break;
3738             /* FALLTHROUGH */
3739         case OP_ASLICE:
3740             S_scalar_slice_warning(aTHX_ o);
3741             break;
3742
3743         case OP_SUBST: {
3744             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3745                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3746             break;
3747         }
3748         default:
3749             break;
3750         }
3751
3752 #ifdef DEBUGGING
3753         if (o->op_flags & OPf_KIDS) {
3754             OP *kid;
3755
3756             /* check that op_last points to the last sibling, and that
3757              * the last op_sibling/op_sibparent field points back to the
3758              * parent, and that the only ops with KIDS are those which are
3759              * entitled to them */
3760             U32 type = o->op_type;
3761             U32 family;
3762             bool has_last;
3763
3764             if (type == OP_NULL) {
3765                 type = o->op_targ;
3766                 /* ck_glob creates a null UNOP with ex-type GLOB
3767                  * (which is a list op. So pretend it wasn't a listop */
3768                 if (type == OP_GLOB)
3769                     type = OP_NULL;
3770             }
3771             family = PL_opargs[type] & OA_CLASS_MASK;
3772
3773             has_last = (   family == OA_BINOP
3774                         || family == OA_LISTOP
3775                         || family == OA_PMOP
3776                         || family == OA_LOOP
3777                        );
3778             assert(  has_last /* has op_first and op_last, or ...
3779                   ... has (or may have) op_first: */
3780                   || family == OA_UNOP
3781                   || family == OA_UNOP_AUX
3782                   || family == OA_LOGOP
3783                   || family == OA_BASEOP_OR_UNOP
3784                   || family == OA_FILESTATOP
3785                   || family == OA_LOOPEXOP
3786                   || family == OA_METHOP
3787                   || type == OP_CUSTOM
3788                   || type == OP_NULL /* new_logop does this */
3789                   );
3790
3791             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3792                 if (!OpHAS_SIBLING(kid)) {
3793                     if (has_last)
3794                         assert(kid == cLISTOPo->op_last);
3795                     assert(kid->op_sibparent == o);
3796                 }
3797             }
3798         }
3799 #endif
3800     } while (( o = traverse_op_tree(top, o)) != NULL);
3801 }
3802
3803 /*
3804 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3805
3806 Propagate lvalue ("modifiable") context to an op and its children.
3807 C<type> represents the context type, roughly based on the type of op that
3808 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3809 because it has no op type of its own (it is signalled by a flag on
3810 the lvalue op).
3811
3812 This function detects things that can't be modified, such as C<$x+1>, and
3813 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3814 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3815
3816 It also flags things that need to behave specially in an lvalue context,
3817 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3818
3819 =cut
3820 */
3821
3822 static void
3823 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3824 {
3825     CV *cv = PL_compcv;
3826     PadnameLVALUE_on(pn);
3827     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3828         cv = CvOUTSIDE(cv);
3829         /* RT #127786: cv can be NULL due to an eval within the DB package
3830          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3831          * unless they contain an eval, but calling eval within DB
3832          * pretends the eval was done in the caller's scope.
3833          */
3834         if (!cv)
3835             break;
3836         assert(CvPADLIST(cv));
3837         pn =
3838            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3839         assert(PadnameLEN(pn));
3840         PadnameLVALUE_on(pn);
3841     }
3842 }
3843
3844 static bool
3845 S_vivifies(const OPCODE type)
3846 {
3847     switch(type) {
3848     case OP_RV2AV:     case   OP_ASLICE:
3849     case OP_RV2HV:     case OP_KVASLICE:
3850     case OP_RV2SV:     case   OP_HSLICE:
3851     case OP_AELEMFAST: case OP_KVHSLICE:
3852     case OP_HELEM:
3853     case OP_AELEM:
3854         return 1;
3855     }
3856     return 0;
3857 }
3858
3859 static void
3860 S_lvref(pTHX_ OP *o, I32 type)
3861 {
3862     dVAR;
3863     OP *kid;
3864     switch (o->op_type) {
3865     case OP_COND_EXPR:
3866         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3867              kid = OpSIBLING(kid))
3868             S_lvref(aTHX_ kid, type);
3869         /* FALLTHROUGH */
3870     case OP_PUSHMARK:
3871         return;
3872     case OP_RV2AV:
3873         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3874         o->op_flags |= OPf_STACKED;
3875         if (o->op_flags & OPf_PARENS) {
3876             if (o->op_private & OPpLVAL_INTRO) {
3877                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3878                       "localized parenthesized array in list assignment"));
3879                 return;
3880             }
3881           slurpy:
3882             OpTYPE_set(o, OP_LVAVREF);
3883             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3884             o->op_flags |= OPf_MOD|OPf_REF;
3885             return;
3886         }
3887         o->op_private |= OPpLVREF_AV;
3888         goto checkgv;
3889     case OP_RV2CV:
3890         kid = cUNOPo->op_first;
3891         if (kid->op_type == OP_NULL)
3892             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3893                 ->op_first;
3894         o->op_private = OPpLVREF_CV;
3895         if (kid->op_type == OP_GV)
3896             o->op_flags |= OPf_STACKED;
3897         else if (kid->op_type == OP_PADCV) {
3898             o->op_targ = kid->op_targ;
3899             kid->op_targ = 0;
3900             op_free(cUNOPo->op_first);
3901             cUNOPo->op_first = NULL;
3902             o->op_flags &=~ OPf_KIDS;
3903         }
3904         else goto badref;
3905         break;
3906     case OP_RV2HV:
3907         if (o->op_flags & OPf_PARENS) {
3908           parenhash:
3909             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3910                                  "parenthesized hash in list assignment"));
3911                 return;
3912         }
3913         o->op_private |= OPpLVREF_HV;
3914         /* FALLTHROUGH */
3915     case OP_RV2SV:
3916       checkgv:
3917         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3918         o->op_flags |= OPf_STACKED;
3919         break;
3920     case OP_PADHV:
3921         if (o->op_flags & OPf_PARENS) goto parenhash;
3922         o->op_private |= OPpLVREF_HV;
3923         /* FALLTHROUGH */
3924     case OP_PADSV:
3925         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3926         break;
3927     case OP_PADAV:
3928         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3929         if (o->op_flags & OPf_PARENS) goto slurpy;
3930         o->op_private |= OPpLVREF_AV;
3931         break;
3932     case OP_AELEM:
3933     case OP_HELEM:
3934         o->op_private |= OPpLVREF_ELEM;
3935         o->op_flags   |= OPf_STACKED;
3936         break;
3937     case OP_ASLICE:
3938     case OP_HSLICE:
3939         OpTYPE_set(o, OP_LVREFSLICE);
3940         o->op_private &= OPpLVAL_INTRO;
3941         return;
3942     case OP_NULL:
3943         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3944             goto badref;
3945         else if (!(o->op_flags & OPf_KIDS))
3946             return;
3947         if (o->op_targ != OP_LIST) {
3948             S_lvref(aTHX_ cBINOPo->op_first, type);
3949             return;
3950         }
3951         /* FALLTHROUGH */
3952     case OP_LIST:
3953         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3954             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3955             S_lvref(aTHX_ kid, type);
3956         }
3957         return;
3958     case OP_STUB:
3959         if (o->op_flags & OPf_PARENS)
3960             return;
3961         /* FALLTHROUGH */
3962     default:
3963       badref:
3964         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3965         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3966                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3967                       ? "do block"
3968                       : OP_DESC(o),
3969                      PL_op_desc[type]));
3970         return;
3971     }
3972     OpTYPE_set(o, OP_LVREF);
3973     o->op_private &=
3974         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3975     if (type == OP_ENTERLOOP)
3976         o->op_private |= OPpLVREF_ITER;
3977 }
3978
3979 PERL_STATIC_INLINE bool
3980 S_potential_mod_type(I32 type)
3981 {
3982     /* Types that only potentially result in modification.  */
3983     return type == OP_GREPSTART || type == OP_ENTERSUB
3984         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3985 }
3986
3987 OP *
3988 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3989 {
3990     dVAR;
3991     OP *kid;
3992     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3993     int localize = -1;
3994
3995     if (!o || (PL_parser && PL_parser->error_count))
3996         return o;
3997
3998     if ((o->op_private & OPpTARGET_MY)
3999         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4000     {
4001         return o;
4002     }
4003
4004     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4005
4006     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4007
4008     switch (o->op_type) {
4009     case OP_UNDEF:
4010         PL_modcount++;
4011         return o;
4012     case OP_STUB:
4013         if ((o->op_flags & OPf_PARENS))
4014             break;
4015         goto nomod;
4016     case OP_ENTERSUB:
4017         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4018             !(o->op_flags & OPf_STACKED)) {
4019             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4020             assert(cUNOPo->op_first->op_type == OP_NULL);
4021             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4022             break;
4023         }
4024         else {                          /* lvalue subroutine call */
4025             o->op_private |= OPpLVAL_INTRO;
4026             PL_modcount = RETURN_UNLIMITED_NUMBER;
4027             if (S_potential_mod_type(type)) {
4028                 o->op_private |= OPpENTERSUB_INARGS;
4029                 break;
4030             }
4031             else {                      /* Compile-time error message: */
4032                 OP *kid = cUNOPo->op_first;
4033                 CV *cv;
4034                 GV *gv;
4035                 SV *namesv;
4036
4037                 if (kid->op_type != OP_PUSHMARK) {
4038                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4039                         Perl_croak(aTHX_
4040                                 "panic: unexpected lvalue entersub "
4041                                 "args: type/targ %ld:%" UVuf,
4042                                 (long)kid->op_type, (UV)kid->op_targ);
4043                     kid = kLISTOP->op_first;
4044                 }
4045                 while (OpHAS_SIBLING(kid))
4046                     kid = OpSIBLING(kid);
4047                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4048                     break;      /* Postpone until runtime */
4049                 }
4050
4051                 kid = kUNOP->op_first;
4052                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4053                     kid = kUNOP->op_first;
4054                 if (kid->op_type == OP_NULL)
4055                     Perl_croak(aTHX_
4056                                "Unexpected constant lvalue entersub "
4057                                "entry via type/targ %ld:%" UVuf,
4058                                (long)kid->op_type, (UV)kid->op_targ);
4059                 if (kid->op_type != OP_GV) {
4060                     break;
4061                 }
4062
4063                 gv = kGVOP_gv;
4064                 cv = isGV(gv)
4065                     ? GvCV(gv)
4066                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4067                         ? MUTABLE_CV(SvRV(gv))
4068                         : NULL;
4069                 if (!cv)
4070                     break;
4071                 if (CvLVALUE(cv))
4072                     break;
4073                 if (flags & OP_LVALUE_NO_CROAK)
4074                     return NULL;
4075
4076                 namesv = cv_name(cv, NULL, 0);
4077                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4078                                      "subroutine call of &%" SVf " in %s",
4079                                      SVfARG(namesv), PL_op_desc[type]),
4080                            SvUTF8(namesv));
4081                 return o;
4082             }
4083         }
4084         /* FALLTHROUGH */
4085     default:
4086       nomod:
4087         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4088         /* grep, foreach, subcalls, refgen */
4089         if (S_potential_mod_type(type))
4090             break;
4091         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4092                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4093                       ? "do block"
4094                       : OP_DESC(o)),
4095                      type ? PL_op_desc[type] : "local"));
4096         return o;
4097
4098     case OP_PREINC:
4099     case OP_PREDEC:
4100     case OP_POW:
4101     case OP_MULTIPLY:
4102     case OP_DIVIDE:
4103     case OP_MODULO:
4104     case OP_ADD:
4105     case OP_SUBTRACT:
4106     case OP_CONCAT:
4107     case OP_LEFT_SHIFT:
4108     case OP_RIGHT_SHIFT:
4109     case OP_BIT_AND:
4110     case OP_BIT_XOR:
4111     case OP_BIT_OR:
4112     case OP_I_MULTIPLY:
4113     case OP_I_DIVIDE:
4114     case OP_I_MODULO:
4115     case OP_I_ADD:
4116     case OP_I_SUBTRACT:
4117         if (!(o->op_flags & OPf_STACKED))
4118             goto nomod;
4119         PL_modcount++;
4120         break;
4121
4122     case OP_REPEAT:
4123         if (o->op_flags & OPf_STACKED) {
4124             PL_modcount++;
4125             break;
4126         }
4127         if (!(o->op_private & OPpREPEAT_DOLIST))
4128             goto nomod;
4129         else {
4130             const I32 mods = PL_modcount;
4131             modkids(cBINOPo->op_first, type);
4132             if (type != OP_AASSIGN)
4133                 goto nomod;
4134             kid = cBINOPo->op_last;
4135             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4136                 const IV iv = SvIV(kSVOP_sv);
4137                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4138                     PL_modcount =
4139                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4140             }
4141             else
4142                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4143         }
4144         break;
4145
4146     case OP_COND_EXPR:
4147         localize = 1;
4148         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4149             op_lvalue(kid, type);
4150         break;
4151
4152     case OP_RV2AV:
4153     case OP_RV2HV:
4154         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4155            PL_modcount = RETURN_UNLIMITED_NUMBER;
4156            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4157               fiable since some contexts need to know.  */
4158            o->op_flags |= OPf_MOD;
4159            return o;
4160         }
4161         /* FALLTHROUGH */
4162     case OP_RV2GV:
4163         if (scalar_mod_type(o, type))
4164             goto nomod;
4165         ref(cUNOPo->op_first, o->op_type);
4166         /* FALLTHROUGH */
4167     case OP_ASLICE:
4168     case OP_HSLICE:
4169         localize = 1;
4170         /* FALLTHROUGH */
4171     case OP_AASSIGN:
4172         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4173         if (type == OP_LEAVESUBLV && (
4174                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4175              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4176            ))
4177             o->op_private |= OPpMAYBE_LVSUB;
4178         /* FALLTHROUGH */
4179     case OP_NEXTSTATE:
4180     case OP_DBSTATE:
4181        PL_modcount = RETURN_UNLIMITED_NUMBER;
4182         break;
4183     case OP_KVHSLICE:
4184     case OP_KVASLICE:
4185     case OP_AKEYS:
4186         if (type == OP_LEAVESUBLV)
4187             o->op_private |= OPpMAYBE_LVSUB;
4188         goto nomod;
4189     case OP_AVHVSWITCH:
4190         if (type == OP_LEAVESUBLV
4191          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4192             o->op_private |= OPpMAYBE_LVSUB;
4193         goto nomod;
4194     case OP_AV2ARYLEN:
4195         PL_hints |= HINT_BLOCK_SCOPE;
4196         if (type == OP_LEAVESUBLV)
4197             o->op_private |= OPpMAYBE_LVSUB;
4198         PL_modcount++;
4199         break;
4200     case OP_RV2SV:
4201         ref(cUNOPo->op_first, o->op_type);
4202         localize = 1;
4203         /* FALLTHROUGH */
4204     case OP_GV:
4205         PL_hints |= HINT_BLOCK_SCOPE;
4206         /* FALLTHROUGH */
4207     case OP_SASSIGN:
4208     case OP_ANDASSIGN:
4209     case OP_ORASSIGN:
4210     case OP_DORASSIGN:
4211         PL_modcount++;
4212         break;
4213
4214     case OP_AELEMFAST:
4215     case OP_AELEMFAST_LEX:
4216         localize = -1;
4217         PL_modcount++;
4218         break;
4219
4220     case OP_PADAV:
4221     case OP_PADHV:
4222        PL_modcount = RETURN_UNLIMITED_NUMBER;
4223         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4224         {
4225            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4226               fiable since some contexts need to know.  */
4227             o->op_flags |= OPf_MOD;
4228             return o;
4229         }
4230         if (scalar_mod_type(o, type))
4231             goto nomod;
4232         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4233           && type == OP_LEAVESUBLV)
4234             o->op_private |= OPpMAYBE_LVSUB;
4235         /* FALLTHROUGH */
4236     case OP_PADSV:
4237         PL_modcount++;
4238         if (!type) /* local() */
4239             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4240                               PNfARG(PAD_COMPNAME(o->op_targ)));
4241         if (!(o->op_private & OPpLVAL_INTRO)
4242          || (  type != OP_SASSIGN && type != OP_AASSIGN
4243             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4244             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4245         break;
4246
4247     case OP_PUSHMARK:
4248         localize = 0;
4249         break;
4250
4251     case OP_KEYS:
4252         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4253             goto nomod;
4254         goto lvalue_func;
4255     case OP_SUBSTR:
4256         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4257             goto nomod;
4258         /* FALLTHROUGH */
4259     case OP_POS:
4260     case OP_VEC:
4261       lvalue_func:
4262         if (type == OP_LEAVESUBLV)
4263             o->op_private |= OPpMAYBE_LVSUB;
4264         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4265             /* substr and vec */
4266             /* If this op is in merely potential (non-fatal) modifiable
4267                context, then apply OP_ENTERSUB context to
4268                the kid op (to avoid croaking).  Other-
4269                wise pass this op’s own type so the correct op is mentioned
4270                in error messages.  */
4271             op_lvalue(OpSIBLING(cBINOPo->op_first),
4272                       S_potential_mod_type(type)
4273                         ? (I32)OP_ENTERSUB
4274                         : o->op_type);
4275         }
4276         break;
4277
4278     case OP_AELEM:
4279     case OP_HELEM:
4280         ref(cBINOPo->op_first, o->op_type);
4281         if (type == OP_ENTERSUB &&
4282              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4283             o->op_private |= OPpLVAL_DEFER;
4284         if (type == OP_LEAVESUBLV)
4285             o->op_private |= OPpMAYBE_LVSUB;
4286         localize = 1;
4287         PL_modcount++;
4288         break;
4289
4290     case OP_LEAVE:
4291     case OP_LEAVELOOP:
4292         o->op_private |= OPpLVALUE;
4293         /* FALLTHROUGH */
4294     case OP_SCOPE:
4295     case OP_ENTER:
4296     case OP_LINESEQ:
4297         localize = 0;
4298         if (o->op_flags & OPf_KIDS)
4299             op_lvalue(cLISTOPo->op_last, type);
4300         break;
4301
4302     case OP_NULL:
4303         localize = 0;
4304         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4305             goto nomod;
4306         else if (!(o->op_flags & OPf_KIDS))
4307             break;
4308
4309         if (o->op_targ != OP_LIST) {
4310             OP *sib = OpSIBLING(cLISTOPo->op_first);
4311             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4312              * that looks like
4313              *
4314              *   null
4315              *      arg
4316              *      trans
4317              *
4318              * compared with things like OP_MATCH which have the argument
4319              * as a child:
4320              *
4321              *   match
4322              *      arg
4323              *
4324              * so handle specially to correctly get "Can't modify" croaks etc
4325              */
4326
4327             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4328             {
4329                 /* this should trigger a "Can't modify transliteration" err */
4330                 op_lvalue(sib, type);
4331             }
4332             op_lvalue(cBINOPo->op_first, type);
4333             break;
4334         }
4335         /* FALLTHROUGH */
4336     case OP_LIST:
4337         localize = 0;
4338         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4339             /* elements might be in void context because the list is
4340                in scalar context or because they are attribute sub calls */
4341             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4342                 op_lvalue(kid, type);
4343         break;
4344
4345     case OP_COREARGS:
4346         return o;
4347
4348     case OP_AND:
4349     case OP_OR:
4350         if (type == OP_LEAVESUBLV
4351          || !S_vivifies(cLOGOPo->op_first->op_type))
4352             op_lvalue(cLOGOPo->op_first, type);
4353         if (type == OP_LEAVESUBLV
4354          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4355             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4356         goto nomod;
4357
4358     case OP_SREFGEN:
4359         if (type == OP_NULL) { /* local */
4360           local_refgen:
4361             if (!FEATURE_MYREF_IS_ENABLED)
4362                 Perl_croak(aTHX_ "The experimental declared_refs "
4363                                  "feature is not enabled");
4364             Perl_ck_warner_d(aTHX_
4365                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4366                     "Declaring references is experimental");
4367             op_lvalue(cUNOPo->op_first, OP_NULL);
4368             return o;
4369         }
4370         if (type != OP_AASSIGN && type != OP_SASSIGN
4371          && type != OP_ENTERLOOP)
4372             goto nomod;
4373         /* Don’t bother applying lvalue context to the ex-list.  */
4374         kid = cUNOPx(cUNOPo->op_first)->op_first;
4375         assert (!OpHAS_SIBLING(kid));
4376         goto kid_2lvref;
4377     case OP_REFGEN:
4378         if (type == OP_NULL) /* local */
4379             goto local_refgen;
4380         if (type != OP_AASSIGN) goto nomod;
4381         kid = cUNOPo->op_first;
4382       kid_2lvref:
4383         {
4384             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4385             S_lvref(aTHX_ kid, type);
4386             if (!PL_parser || PL_parser->error_count == ec) {
4387                 if (!FEATURE_REFALIASING_IS_ENABLED)
4388                     Perl_croak(aTHX_
4389                        "Experimental aliasing via reference not enabled");
4390                 Perl_ck_warner_d(aTHX_
4391                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4392                                 "Aliasing via reference is experimental");
4393             }
4394         }
4395         if (o->op_type == OP_REFGEN)
4396             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4397         op_null(o);
4398         return o;
4399
4400     case OP_SPLIT:
4401         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4402             /* This is actually @array = split.  */
4403             PL_modcount = RETURN_UNLIMITED_NUMBER;
4404             break;
4405         }
4406         goto nomod;
4407
4408     case OP_SCALAR:
4409         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4410         goto nomod;
4411     }
4412
4413     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4414        their argument is a filehandle; thus \stat(".") should not set
4415        it. AMS 20011102 */
4416     if (type == OP_REFGEN &&
4417         PL_check[o->op_type] == Perl_ck_ftst)
4418         return o;
4419
4420     if (type != OP_LEAVESUBLV)
4421         o->op_flags |= OPf_MOD;
4422
4423     if (type == OP_AASSIGN || type == OP_SASSIGN)
4424         o->op_flags |= OPf_SPECIAL
4425                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4426     else if (!type) { /* local() */
4427         switch (localize) {
4428         case 1:
4429             o->op_private |= OPpLVAL_INTRO;
4430             o->op_flags &= ~OPf_SPECIAL;
4431             PL_hints |= HINT_BLOCK_SCOPE;
4432             break;
4433         case 0:
4434             break;
4435         case -1:
4436             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4437                            "Useless localization of %s", OP_DESC(o));
4438         }
4439     }
4440     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4441              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4442         o->op_flags |= OPf_REF;
4443     return o;
4444 }
4445
4446 STATIC bool
4447 S_scalar_mod_type(const OP *o, I32 type)
4448 {
4449     switch (type) {
4450     case OP_POS:
4451     case OP_SASSIGN:
4452         if (o && o->op_type == OP_RV2GV)
4453             return FALSE;
4454         /* FALLTHROUGH */
4455     case OP_PREINC:
4456     case OP_PREDEC:
4457     case OP_POSTINC:
4458     case OP_POSTDEC:
4459     case OP_I_PREINC:
4460     case OP_I_PREDEC:
4461     case OP_I_POSTINC:
4462     case OP_I_POSTDEC:
4463     case OP_POW:
4464     case OP_MULTIPLY:
4465     case OP_DIVIDE:
4466     case OP_MODULO:
4467     case OP_REPEAT:
4468     case OP_ADD:
4469     case OP_SUBTRACT:
4470     case OP_I_MULTIPLY:
4471     case OP_I_DIVIDE:
4472     case OP_I_MODULO:
4473     case OP_I_ADD:
4474     case OP_I_SUBTRACT:
4475     case OP_LEFT_SHIFT:
4476     case OP_RIGHT_SHIFT:
4477     case OP_BIT_AND:
4478     case OP_BIT_XOR:
4479     case OP_BIT_OR:
4480     case OP_NBIT_AND:
4481     case OP_NBIT_XOR:
4482     case OP_NBIT_OR:
4483     case OP_SBIT_AND:
4484     case OP_SBIT_XOR:
4485     case OP_SBIT_OR:
4486     case OP_CONCAT:
4487     case OP_SUBST:
4488     case OP_TRANS:
4489     case OP_TRANSR:
4490     case OP_READ:
4491     case OP_SYSREAD:
4492     case OP_RECV:
4493     case OP_ANDASSIGN:
4494     case OP_ORASSIGN:
4495     case OP_DORASSIGN:
4496     case OP_VEC:
4497     case OP_SUBSTR:
4498         return TRUE;
4499     default:
4500         return FALSE;
4501     }
4502 }
4503
4504 STATIC bool
4505 S_is_handle_constructor(const OP *o, I32 numargs)
4506 {
4507     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4508
4509     switch (o->op_type) {
4510     case OP_PIPE_OP:
4511     case OP_SOCKPAIR:
4512         if (numargs == 2)
4513             return TRUE;
4514         /* FALLTHROUGH */
4515     case OP_SYSOPEN:
4516     case OP_OPEN:
4517     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4518     case OP_SOCKET:
4519     case OP_OPEN_DIR:
4520     case OP_ACCEPT:
4521         if (numargs == 1)
4522             return TRUE;
4523         /* FALLTHROUGH */
4524     default:
4525         return FALSE;
4526     }
4527 }
4528
4529 static OP *
4530 S_refkids(pTHX_ OP *o, I32 type)
4531 {
4532     if (o && o->op_flags & OPf_KIDS) {
4533         OP *kid;
4534         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4535             ref(kid, type);
4536     }
4537     return o;
4538 }
4539
4540 OP *
4541 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4542 {
4543     dVAR;
4544     OP *kid;
4545
4546     PERL_ARGS_ASSERT_DOREF;
4547
4548     if (PL_parser && PL_parser->error_count)
4549         return o;
4550
4551     switch (o->op_type) {
4552     case OP_ENTERSUB:
4553         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4554             !(o->op_flags & OPf_STACKED)) {
4555             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4556             assert(cUNOPo->op_first->op_type == OP_NULL);
4557             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4558             o->op_flags |= OPf_SPECIAL;
4559         }
4560         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4561             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4562                               : type == OP_RV2HV ? OPpDEREF_HV
4563                               : OPpDEREF_SV);
4564             o->op_flags |= OPf_MOD;
4565         }
4566
4567         break;
4568
4569     case OP_COND_EXPR:
4570         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4571             doref(kid, type, set_op_ref);
4572         break;
4573     case OP_RV2SV:
4574         if (type == OP_DEFINED)
4575             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4576         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4577         /* FALLTHROUGH */
4578     case OP_PADSV:
4579         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4580             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4581                               : type == OP_RV2HV ? OPpDEREF_HV
4582                               : OPpDEREF_SV);
4583             o->op_flags |= OPf_MOD;
4584         }
4585         break;
4586
4587     case OP_RV2AV:
4588     case OP_RV2HV:
4589         if (set_op_ref)
4590             o->op_flags |= OPf_REF;
4591         /* FALLTHROUGH */
4592     case OP_RV2GV:
4593         if (type == OP_DEFINED)
4594             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4595         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4596         break;
4597
4598     case OP_PADAV:
4599     case OP_PADHV:
4600         if (set_op_ref)
4601             o->op_flags |= OPf_REF;
4602         break;
4603
4604     case OP_SCALAR:
4605     case OP_NULL:
4606         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4607             break;
4608         doref(cBINOPo->op_first, type, set_op_ref);
4609         break;
4610     case OP_AELEM:
4611     case OP_HELEM:
4612         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4613         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4614             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4615                               : type == OP_RV2HV ? OPpDEREF_HV
4616                               : OPpDEREF_SV);
4617             o->op_flags |= OPf_MOD;
4618         }
4619         break;
4620
4621     case OP_SCOPE:
4622     case OP_LEAVE:
4623         set_op_ref = FALSE;
4624         /* FALLTHROUGH */
4625     case OP_ENTER:
4626     case OP_LIST:
4627         if (!(o->op_flags & OPf_KIDS))
4628             break;
4629         doref(cLISTOPo->op_last, type, set_op_ref);
4630         break;
4631     default:
4632         break;
4633     }
4634     return scalar(o);
4635
4636 }
4637
4638 STATIC OP *
4639 S_dup_attrlist(pTHX_ OP *o)
4640 {
4641     OP *rop;
4642
4643     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4644
4645     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4646      * where the first kid is OP_PUSHMARK and the remaining ones
4647      * are OP_CONST.  We need to push the OP_CONST values.
4648      */
4649     if (o->op_type == OP_CONST)
4650         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4651     else {
4652         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4653         rop = NULL;
4654         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4655             if (o->op_type == OP_CONST)
4656                 rop = op_append_elem(OP_LIST, rop,
4657                                   newSVOP(OP_CONST, o->op_flags,
4658                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4659         }
4660     }
4661     return rop;
4662 }
4663
4664 STATIC void
4665 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4666 {
4667     PERL_ARGS_ASSERT_APPLY_ATTRS;
4668     {
4669         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4670
4671         /* fake up C<use attributes $pkg,$rv,@attrs> */
4672
4673 #define ATTRSMODULE "attributes"
4674 #define ATTRSMODULE_PM "attributes.pm"
4675
4676         Perl_load_module(
4677           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4678           newSVpvs(ATTRSMODULE),
4679           NULL,
4680           op_prepend_elem(OP_LIST,
4681                           newSVOP(OP_CONST, 0, stashsv),
4682                           op_prepend_elem(OP_LIST,
4683                                           newSVOP(OP_CONST, 0,
4684                                                   newRV(target)),
4685                                           dup_attrlist(attrs))));
4686     }
4687 }
4688
4689 STATIC void
4690 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4691 {
4692     OP *pack, *imop, *arg;
4693     SV *meth, *stashsv, **svp;
4694
4695     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4696
4697     if (!attrs)
4698         return;
4699
4700     assert(target->op_type == OP_PADSV ||
4701            target->op_type == OP_PADHV ||
4702            target->op_type == OP_PADAV);
4703
4704     /* Ensure that attributes.pm is loaded. */
4705     /* Don't force the C<use> if we don't need it. */
4706     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4707     if (svp && *svp != &PL_sv_undef)
4708         NOOP;   /* already in %INC */
4709     else
4710         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4711                                newSVpvs(ATTRSMODULE), NULL);
4712
4713     /* Need package name for method call. */
4714     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4715
4716     /* Build up the real arg-list. */
4717     stashsv = newSVhek(HvNAME_HEK(stash));
4718
4719     arg = newOP(OP_PADSV, 0);
4720     arg->op_targ = target->op_targ;
4721     arg = op_prepend_elem(OP_LIST,
4722                        newSVOP(OP_CONST, 0, stashsv),
4723                        op_prepend_elem(OP_LIST,
4724                                     newUNOP(OP_REFGEN, 0,
4725                                             arg),
4726                                     dup_attrlist(attrs)));
4727
4728     /* Fake up a method call to import */
4729     meth = newSVpvs_share("import");
4730     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4731                    op_append_elem(OP_LIST,
4732                                op_prepend_elem(OP_LIST, pack, arg),
4733                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4734
4735     /* Combine the ops. */
4736     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4737 }
4738
4739 /*
4740 =notfor apidoc apply_attrs_string
4741
4742 Attempts to apply a list of attributes specified by the C<attrstr> and
4743 C<len> arguments to the subroutine identified by the C<cv> argument which
4744 is expected to be associated with the package identified by the C<stashpv>
4745 argument (see L<attributes>).  It gets this wrong, though, in that it
4746 does not correctly identify the boundaries of the individual attribute
4747 specifications within C<attrstr>.  This is not really intended for the
4748 public API, but has to be listed here for systems such as AIX which
4749 need an explicit export list for symbols.  (It's called from XS code
4750 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4751 to respect attribute syntax properly would be welcome.
4752
4753 =cut
4754 */
4755
4756 void
4757 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4758                         const char *attrstr, STRLEN len)
4759 {
4760     OP *attrs = NULL;
4761
4762     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4763
4764     if (!len) {
4765         len = strlen(attrstr);
4766     }
4767
4768     while (len) {
4769         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4770         if (len) {
4771             const char * const sstr = attrstr;
4772             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4773             attrs = op_append_elem(OP_LIST, attrs,
4774                                 newSVOP(OP_CONST, 0,
4775                                         newSVpvn(sstr, attrstr-sstr)));
4776         }
4777     }
4778
4779     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4780                      newSVpvs(ATTRSMODULE),
4781                      NULL, op_prepend_elem(OP_LIST,
4782                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4783                                   op_prepend_elem(OP_LIST,
4784                                                newSVOP(OP_CONST, 0,
4785                                                        newRV(MUTABLE_SV(cv))),
4786                                                attrs)));
4787 }
4788
4789 STATIC void
4790 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4791                         bool curstash)
4792 {
4793     OP *new_proto = NULL;
4794     STRLEN pvlen;
4795     char *pv;
4796     OP *o;
4797
4798     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4799
4800     if (!*attrs)
4801         return;
4802
4803     o = *attrs;
4804     if (o->op_type == OP_CONST) {
4805         pv = SvPV(cSVOPo_sv, pvlen);
4806         if (memBEGINs(pv, pvlen, "prototype(")) {
4807             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4808             SV ** const tmpo = cSVOPx_svp(o);
4809             SvREFCNT_dec(cSVOPo_sv);
4810             *tmpo = tmpsv;
4811             new_proto = o;
4812             *attrs = NULL;
4813         }
4814     } else if (o->op_type == OP_LIST) {
4815         OP * lasto;
4816         assert(o->op_flags & OPf_KIDS);
4817         lasto = cLISTOPo->op_first;
4818         assert(lasto->op_type == OP_PUSHMARK);
4819         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4820             if (o->op_type == OP_CONST) {
4821                 pv = SvPV(cSVOPo_sv, pvlen);
4822                 if (memBEGINs(pv, pvlen, "prototype(")) {
4823                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4824                     SV ** const tmpo = cSVOPx_svp(o);
4825                     SvREFCNT_dec(cSVOPo_sv);
4826                     *tmpo = tmpsv;
4827                     if (new_proto && ckWARN(WARN_MISC)) {
4828                         STRLEN new_len;
4829                         const char * newp = SvPV(cSVOPo_sv, new_len);
4830                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4831                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4832                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4833                         op_free(new_proto);
4834                     }
4835                     else if (new_proto)
4836                         op_free(new_proto);
4837                     new_proto = o;
4838                     /* excise new_proto from the list */
4839                     op_sibling_splice(*attrs, lasto, 1, NULL);
4840                     o = lasto;
4841                     continue;
4842                 }
4843             }
4844             lasto = o;
4845         }
4846         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4847            would get pulled in with no real need */
4848         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4849             op_free(*attrs);
4850             *attrs = NULL;
4851         }
4852     }
4853
4854     if (new_proto) {
4855         SV *svname;
4856         if (isGV(name)) {
4857             svname = sv_newmortal();
4858             gv_efullname3(svname, name, NULL);
4859         }
4860         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4861             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4862         else
4863             svname = (SV *)name;
4864         if (ckWARN(WARN_ILLEGALPROTO))
4865             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4866                                  curstash);
4867         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4868             STRLEN old_len, new_len;
4869             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4870             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4871
4872             if (curstash && svname == (SV *)name
4873              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4874                 svname = sv_2mortal(newSVsv(PL_curstname));
4875                 sv_catpvs(svname, "::");
4876                 sv_catsv(svname, (SV *)name);
4877             }
4878
4879             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4880                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4881                 " in %" SVf,
4882                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4883                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4884                 SVfARG(svname));
4885         }
4886         if (*proto)
4887             op_free(*proto);
4888         *proto = new_proto;
4889     }
4890 }
4891
4892 static void
4893 S_cant_declare(pTHX_ OP *o)
4894 {
4895     if (o->op_type == OP_NULL
4896      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4897         o = cUNOPo->op_first;
4898     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4899                              o->op_type == OP_NULL
4900                                && o->op_flags & OPf_SPECIAL
4901                                  ? "do block"
4902                                  : OP_DESC(o),
4903                              PL_parser->in_my == KEY_our   ? "our"   :
4904                              PL_parser->in_my == KEY_state ? "state" :
4905                                                              "my"));
4906 }
4907
4908 STATIC OP *
4909 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4910 {
4911     I32 type;
4912     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4913
4914     PERL_ARGS_ASSERT_MY_KID;
4915
4916     if (!o || (PL_parser && PL_parser->error_count))
4917         return o;
4918
4919     type = o->op_type;
4920
4921     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4922         OP *kid;
4923         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4924             my_kid(kid, attrs, imopsp);
4925         return o;
4926     } else if (type == OP_UNDEF || type == OP_STUB) {
4927         return o;
4928     } else if (type == OP_RV2SV ||      /* "our" declaration */
4929                type == OP_RV2AV ||
4930                type == OP_RV2HV) {
4931         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4932             S_cant_declare(aTHX_ o);
4933         } else if (attrs) {
4934             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4935             assert(PL_parser);
4936             PL_parser->in_my = FALSE;
4937             PL_parser->in_my_stash = NULL;
4938             apply_attrs(GvSTASH(gv),
4939                         (type == OP_RV2SV ? GvSVn(gv) :
4940                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4941                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4942                         attrs);
4943         }
4944         o->op_private |= OPpOUR_INTRO;
4945         return o;
4946     }
4947     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4948         if (!FEATURE_MYREF_IS_ENABLED)
4949             Perl_croak(aTHX_ "The experimental declared_refs "
4950                              "feature is not enabled");
4951         Perl_ck_warner_d(aTHX_
4952              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4953             "Declaring references is experimental");
4954         /* Kid is a nulled OP_LIST, handled above.  */
4955         my_kid(cUNOPo->op_first, attrs, imopsp);
4956         return o;
4957     }
4958     else if (type != OP_PADSV &&
4959              type != OP_PADAV &&
4960              type != OP_PADHV &&
4961              type != OP_PUSHMARK)
4962     {
4963         S_cant_declare(aTHX_ o);
4964         return o;
4965     }
4966     else if (attrs && type != OP_PUSHMARK) {
4967         HV *stash;
4968
4969         assert(PL_parser);
4970         PL_parser->in_my = FALSE;
4971         PL_parser->in_my_stash = NULL;
4972
4973         /* check for C<my Dog $spot> when deciding package */
4974         stash = PAD_COMPNAME_TYPE(o->op_targ);
4975         if (!stash)
4976             stash = PL_curstash;
4977         apply_attrs_my(stash, o, attrs, imopsp);
4978     }
4979     o->op_flags |= OPf_MOD;
4980     o->op_private |= OPpLVAL_INTRO;
4981     if (stately)
4982         o->op_private |= OPpPAD_STATE;
4983     return o;
4984 }
4985
4986 OP *
4987 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4988 {
4989     OP *rops;
4990     int maybe_scalar = 0;
4991
4992     PERL_ARGS_ASSERT_MY_ATTRS;
4993
4994 /* [perl #17376]: this appears to be premature, and results in code such as
4995    C< our(%x); > executing in list mode rather than void mode */
4996 #if 0
4997     if (o->op_flags & OPf_PARENS)
4998         list(o);
4999     else
5000         maybe_scalar = 1;
5001 #else
5002     maybe_scalar = 1;
5003 #endif
5004     if (attrs)
5005         SAVEFREEOP(attrs);
5006     rops = NULL;
5007     o = my_kid(o, attrs, &rops);
5008     if (rops) {
5009         if (maybe_scalar && o->op_type == OP_PADSV) {
5010             o = scalar(op_append_list(OP_LIST, rops, o));
5011             o->op_private |= OPpLVAL_INTRO;
5012         }
5013         else {
5014             /* The listop in rops might have a pushmark at the beginning,
5015                which will mess up list assignment. */
5016             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5017             if (rops->op_type == OP_LIST &&
5018                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5019             {
5020                 OP * const pushmark = lrops->op_first;
5021                 /* excise pushmark */
5022                 op_sibling_splice(rops, NULL, 1, NULL);
5023                 op_free(pushmark);
5024             }
5025             o = op_append_list(OP_LIST, o, rops);
5026         }
5027     }
5028     PL_parser->in_my = FALSE;
5029     PL_parser->in_my_stash = NULL;
5030     return o;
5031 }
5032
5033 OP *
5034 Perl_sawparens(pTHX_ OP *o)
5035 {
5036     PERL_UNUSED_CONTEXT;
5037     if (o)
5038         o->op_flags |= OPf_PARENS;
5039     return o;
5040 }
5041
5042 OP *
5043 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5044 {
5045     OP *o;
5046     bool ismatchop = 0;
5047     const OPCODE ltype = left->op_type;
5048     const OPCODE rtype = right->op_type;
5049
5050     PERL_ARGS_ASSERT_BIND_MATCH;
5051
5052     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5053           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5054     {
5055       const char * const desc
5056           = PL_op_desc[(
5057                           rtype == OP_SUBST || rtype == OP_TRANS
5058                        || rtype == OP_TRANSR
5059                        )
5060                        ? (int)rtype : OP_MATCH];
5061       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5062       SV * const name =
5063         S_op_varname(aTHX_ left);
5064       if (name)
5065         Perl_warner(aTHX_ packWARN(WARN_MISC),
5066              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5067              desc, SVfARG(name), SVfARG(name));
5068       else {
5069         const char * const sample = (isary
5070              ? "@array" : "%hash");
5071         Perl_warner(aTHX_ packWARN(WARN_MISC),
5072              "Applying %s to %s will act on scalar(%s)",
5073              desc, sample, sample);
5074       }
5075     }
5076
5077     if (rtype == OP_CONST &&
5078         cSVOPx(right)->op_private & OPpCONST_BARE &&
5079         cSVOPx(right)->op_private & OPpCONST_STRICT)
5080     {
5081         no_bareword_allowed(right);
5082     }
5083
5084     /* !~ doesn't make sense with /r, so error on it for now */
5085     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5086         type == OP_NOT)
5087         /* diag_listed_as: Using !~ with %s doesn't make sense */
5088         yyerror("Using !~ with s///r doesn't make sense");
5089     if (rtype == OP_TRANSR && type == OP_NOT)
5090         /* diag_listed_as: Using !~ with %s doesn't make sense */
5091         yyerror("Using !~ with tr///r doesn't make sense");
5092
5093     ismatchop = (rtype == OP_MATCH ||
5094                  rtype == OP_SUBST ||
5095                  rtype == OP_TRANS || rtype == OP_TRANSR)
5096              && !(right->op_flags & OPf_SPECIAL);
5097     if (ismatchop && right->op_private & OPpTARGET_MY) {
5098         right->op_targ = 0;
5099         right->op_private &= ~OPpTARGET_MY;
5100     }
5101     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5102         if (left->op_type == OP_PADSV
5103          && !(left->op_private & OPpLVAL_INTRO))
5104         {
5105             right->op_targ = left->op_targ;
5106             op_free(left);
5107             o = right;
5108         }
5109         else {
5110             right->op_flags |= OPf_STACKED;
5111             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5112             ! (rtype == OP_TRANS &&
5113                right->op_private & OPpTRANS_IDENTICAL) &&
5114             ! (rtype == OP_SUBST &&
5115                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5116                 left = op_lvalue(left, rtype);
5117             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5118                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5119             else
5120                 o = op_prepend_elem(rtype, scalar(left), right);
5121         }
5122         if (type == OP_NOT)
5123             return newUNOP(OP_NOT, 0, scalar(o));
5124         return o;
5125     }
5126     else
5127         return bind_match(type, left,
5128                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5129 }
5130
5131 OP *
5132 Perl_invert(pTHX_ OP *o)
5133 {
5134     if (!o)
5135         return NULL;
5136     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5137 }
5138
5139 /*
5140 =for apidoc Amx|OP *|op_scope|OP *o
5141
5142 Wraps up an op tree with some additional ops so that at runtime a dynamic
5143 scope will be created.  The original ops run in the new dynamic scope,
5144 and then, provided that they exit normally, the scope will be unwound.
5145 The additional ops used to create and unwind the dynamic scope will
5146 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5147 instead if the ops are simple enough to not need the full dynamic scope
5148 structure.
5149
5150 =cut
5151 */
5152
5153 OP *
5154 Perl_op_scope(pTHX_ OP *o)
5155 {
5156     dVAR;
5157     if (o) {
5158         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5159             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5160             OpTYPE_set(o, OP_LEAVE);
5161         }
5162         else if (o->op_type == OP_LINESEQ) {
5163             OP *kid;
5164             OpTYPE_set(o, OP_SCOPE);
5165             kid = ((LISTOP*)o)->op_first;
5166             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5167                 op_null(kid);
5168
5169                 /* The following deals with things like 'do {1 for 1}' */
5170                 kid = OpSIBLING(kid);
5171                 if (kid &&
5172                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5173                     op_null(kid);
5174             }
5175         }
5176         else
5177             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5178     }
5179     return o;
5180 }
5181
5182 OP *
5183 Perl_op_unscope(pTHX_ OP *o)
5184 {
5185     if (o && o->op_type == OP_LINESEQ) {
5186         OP *kid = cLISTOPo->op_first;
5187         for(; kid; kid = OpSIBLING(kid))
5188             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5189                 op_null(kid);
5190     }
5191     return o;
5192 }
5193
5194 /*
5195 =for apidoc Am|int|block_start|int full
5196
5197 Handles compile-time scope entry.
5198 Arranges for hints to be restored on block
5199 exit and also handles pad sequence numbers to make lexical variables scope
5200 right.  Returns a savestack index for use with C<block_end>.
5201
5202 =cut
5203 */
5204
5205 int
5206 Perl_block_start(pTHX_ int full)
5207 {
5208     const int retval = PL_savestack_ix;
5209
5210     PL_compiling.cop_seq = PL_cop_seqmax;
5211     COP_SEQMAX_INC;
5212     pad_block_start(full);
5213     SAVEHINTS();
5214     PL_hints &= ~HINT_BLOCK_SCOPE;
5215     SAVECOMPILEWARNINGS();
5216     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5217     SAVEI32(PL_compiling.cop_seq);
5218     PL_compiling.cop_seq = 0;
5219
5220     CALL_BLOCK_HOOKS(bhk_start, full);
5221
5222     return retval;
5223 }
5224
5225 /*
5226 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5227
5228 Handles compile-time scope exit.  C<floor>
5229 is the savestack index returned by
5230 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5231 possibly modified.
5232
5233 =cut
5234 */
5235
5236 OP*
5237 Perl_block_end(pTHX_ I32 floor, OP *seq)
5238 {
5239     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5240     OP* retval = scalarseq(seq);
5241     OP *o;
5242
5243     /* XXX Is the null PL_parser check necessary here? */
5244     assert(PL_parser); /* Let’s find out under debugging builds.  */
5245     if (PL_parser && PL_parser->parsed_sub) {
5246         o = newSTATEOP(0, NULL, NULL);
5247         op_null(o);
5248         retval = op_append_elem(OP_LINESEQ, retval, o);
5249     }
5250
5251     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5252
5253     LEAVE_SCOPE(floor);
5254     if (needblockscope)
5255         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5256     o = pad_leavemy();
5257
5258     if (o) {
5259         /* pad_leavemy has created a sequence of introcv ops for all my
5260            subs declared in the block.  We have to replicate that list with
5261            clonecv ops, to deal with this situation:
5262
5263                sub {
5264                    my sub s1;
5265                    my sub s2;
5266                    sub s1 { state sub foo { \&s2 } }
5267                }->()
5268
5269            Originally, I was going to have introcv clone the CV and turn
5270            off the stale flag.  Since &s1 is declared before &s2, the
5271            introcv op for &s1 is executed (on sub entry) before the one for
5272            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5273            cloned, since it is a state sub) closes over &s2 and expects
5274            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5275            then &s2 is still marked stale.  Since &s1 is not active, and
5276            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5277            ble will not stay shared’ warning.  Because it is the same stub
5278            that will be used when the introcv op for &s2 is executed, clos-
5279            ing over it is safe.  Hence, we have to turn off the stale flag
5280            on all lexical subs in the block before we clone any of them.
5281            Hence, having introcv clone the sub cannot work.  So we create a
5282            list of ops like this:
5283
5284                lineseq
5285                   |
5286                   +-- introcv
5287                   |
5288                   +-- introcv
5289                   |
5290                   +-- introcv
5291                   |
5292                   .
5293                   .
5294                   .
5295                   |
5296                   +-- clonecv
5297                   |
5298                   +-- clonecv
5299                   |
5300                   +-- clonecv
5301                   |
5302                   .
5303                   .
5304                   .
5305          */
5306         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5307         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5308         for (;; kid = OpSIBLING(kid)) {
5309             OP *newkid = newOP(OP_CLONECV, 0);
5310             newkid->op_targ = kid->op_targ;
5311             o = op_append_elem(OP_LINESEQ, o, newkid);
5312             if (kid == last) break;
5313         }
5314         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5315     }
5316
5317     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5318
5319     return retval;
5320 }
5321
5322 /*
5323 =head1 Compile-time scope hooks
5324
5325 =for apidoc Aox||blockhook_register
5326
5327 Register a set of hooks to be called when the Perl lexical scope changes
5328 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5329
5330 =cut
5331 */
5332
5333 void
5334 Perl_blockhook_register(pTHX_ BHK *hk)
5335 {
5336     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5337
5338     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5339 }
5340
5341 void
5342 Perl_newPROG(pTHX_ OP *o)
5343 {
5344     OP *start;
5345
5346     PERL_ARGS_ASSERT_NEWPROG;
5347
5348     if (PL_in_eval) {
5349         PERL_CONTEXT *cx;
5350         I32 i;
5351         if (PL_eval_root)
5352                 return;
5353         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5354                                ((PL_in_eval & EVAL_KEEPERR)
5355                                 ? OPf_SPECIAL : 0), o);
5356
5357         cx = CX_CUR();
5358         assert(CxTYPE(cx) == CXt_EVAL);
5359
5360         if ((cx->blk_gimme & G_WANT) == G_VOID)
5361             scalarvoid(PL_eval_root);
5362         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5363             list(PL_eval_root);
5364         else
5365             scalar(PL_eval_root);
5366
5367         start = op_linklist(PL_eval_root);
5368         PL_eval_root->op_next = 0;
5369         i = PL_savestack_ix;
5370         SAVEFREEOP(o);
5371         ENTER;
5372         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5373         LEAVE;
5374         PL_savestack_ix = i;
5375     }
5376     else {
5377         if (o->op_type == OP_STUB) {
5378             /* This block is entered if nothing is compiled for the main
5379                program. This will be the case for an genuinely empty main
5380                program, or one which only has BEGIN blocks etc, so already
5381                run and freed.
5382
5383                Historically (5.000) the guard above was !o. However, commit
5384                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5385                c71fccf11fde0068, changed perly.y so that newPROG() is now
5386                called with the output of block_end(), which returns a new
5387                OP_STUB for the case of an empty optree. ByteLoader (and
5388                maybe other things) also take this path, because they set up
5389                PL_main_start and PL_main_root directly, without generating an
5390                optree.
5391
5392                If the parsing the main program aborts (due to parse errors,
5393                or due to BEGIN or similar calling exit), then newPROG()
5394                isn't even called, and hence this code path and its cleanups
5395                are skipped. This shouldn't make a make a difference:
5396                * a non-zero return from perl_parse is a failure, and
5397                  perl_destruct() should be called immediately.
5398                * however, if exit(0) is called during the parse, then
5399                  perl_parse() returns 0, and perl_run() is called. As
5400                  PL_main_start will be NULL, perl_run() will return
5401                  promptly, and the exit code will remain 0.
5402             */
5403
5404             PL_comppad_name = 0;
5405             PL_compcv = 0;
5406             S_op_destroy(aTHX_ o);
5407             return;
5408         }
5409         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5410         PL_curcop = &PL_compiling;
5411         start = LINKLIST(PL_main_root);
5412         PL_main_root->op_next = 0;
5413         S_process_optree(aTHX_ NULL, PL_main_root, start);
5414         if (!PL_parser->error_count)
5415             /* on error, leave CV slabbed so that ops left lying around
5416              * will eb cleaned up. Else unslab */
5417             cv_forget_slab(PL_compcv);
5418         PL_compcv = 0;
5419
5420         /* Register with debugger */
5421         if (PERLDB_INTER) {
5422             CV * const cv = get_cvs("DB::postponed", 0);
5423             if (cv) {
5424                 dSP;
5425                 PUSHMARK(SP);
5426                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5427                 PUTBACK;
5428                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5429             }
5430         }
5431     }
5432 }
5433
5434 OP *
5435 Perl_localize(pTHX_ OP *o, I32 lex)
5436 {
5437     PERL_ARGS_ASSERT_LOCALIZE;
5438
5439     if (o->op_flags & OPf_PARENS)
5440 /* [perl #17376]: this appears to be premature, and results in code such as
5441    C< our(%x); > executing in list mode rather than void mode */
5442 #if 0
5443         list(o);
5444 #else
5445         NOOP;
5446 #endif
5447     else {
5448         if ( PL_parser->bufptr > PL_parser->oldbufptr
5449             && PL_parser->bufptr[-1] == ','
5450             && ckWARN(WARN_PARENTHESIS))
5451         {
5452             char *s = PL_parser->bufptr;
5453             bool sigil = FALSE;
5454
5455             /* some heuristics to detect a potential error */
5456             while (*s && (strchr(", \t\n", *s)))
5457                 s++;
5458
5459             while (1) {
5460                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5461                        && *++s
5462                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5463                     s++;
5464                     sigil = TRUE;
5465                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5466                         s++;
5467                     while (*s && (strchr(", \t\n", *s)))
5468                         s++;
5469                 }
5470                 else
5471                     break;
5472             }
5473             if (sigil && (*s == ';' || *s == '=')) {
5474                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5475                                 "Parentheses missing around \"%s\" list",
5476                                 lex
5477                                     ? (PL_parser->in_my == KEY_our
5478                                         ? "our"
5479                                         : PL_parser->in_my == KEY_state
5480                                             ? "state"
5481                                             : "my")
5482                                     : "local");
5483             }
5484         }
5485     }
5486     if (lex)
5487         o = my(o);
5488     else
5489         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5490     PL_parser->in_my = FALSE;
5491     PL_parser->in_my_stash = NULL;
5492     return o;
5493 }
5494
5495 OP *
5496 Perl_jmaybe(pTHX_ OP *o)
5497 {
5498     PERL_ARGS_ASSERT_JMAYBE;
5499
5500     if (o->op_type == OP_LIST) {
5501         OP * const o2
5502             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5503         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5504     }
5505     return o;
5506 }
5507
5508 PERL_STATIC_INLINE OP *
5509 S_op_std_init(pTHX_ OP *o)
5510 {
5511     I32 type = o->op_type;
5512
5513     PERL_ARGS_ASSERT_OP_STD_INIT;
5514
5515     if (PL_opargs[type] & OA_RETSCALAR)
5516         scalar(o);
5517     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5518         o->op_targ = pad_alloc(type, SVs_PADTMP);
5519
5520     return o;
5521 }
5522
5523 PERL_STATIC_INLINE OP *
5524 S_op_integerize(pTHX_ OP *o)
5525 {
5526     I32 type = o->op_type;
5527
5528     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5529
5530     /* integerize op. */
5531     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5532     {
5533         dVAR;
5534         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5535     }
5536
5537     if (type == OP_NEGATE)
5538         /* XXX might want a ck_negate() for this */
5539         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5540
5541     return o;
5542 }
5543
5544 /* This function exists solely to provide a scope to limit
5545    setjmp/longjmp() messing with auto variables.
5546  */
5547 PERL_STATIC_INLINE int
5548 S_fold_constants_eval(pTHX) {
5549     int ret = 0;
5550     dJMPENV;
5551
5552     JMPENV_PUSH(ret);
5553
5554     if (ret == 0) {
5555         CALLRUNOPS(aTHX);
5556     }
5557
5558     JMPENV_POP;
5559
5560     return ret;
5561 }
5562
5563 static OP *
5564 S_fold_constants(pTHX_ OP *const o)
5565 {
5566     dVAR;
5567     OP *curop;
5568     OP *newop;
5569     I32 type = o->op_type;
5570     bool is_stringify;
5571     SV *sv = NULL;
5572     int ret = 0;
5573     OP *old_next;
5574     SV * const oldwarnhook = PL_warnhook;
5575     SV * const olddiehook  = PL_diehook;
5576     COP not_compiling;
5577     U8 oldwarn = PL_dowarn;
5578     I32 old_cxix;
5579
5580     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5581
5582     if (!(PL_opargs[type] & OA_FOLDCONST))
5583         goto nope;
5584
5585     switch (type) {
5586     case OP_UCFIRST:
5587     case OP_LCFIRST:
5588     case OP_UC:
5589     case OP_LC:
5590     case OP_FC:
5591 #ifdef USE_LOCALE_CTYPE
5592         if (IN_LC_COMPILETIME(LC_CTYPE))
5593             goto nope;
5594 #endif
5595         break;
5596     case OP_SLT:
5597     case OP_SGT:
5598     case OP_SLE:
5599     case OP_SGE:
5600     case OP_SCMP:
5601 #ifdef USE_LOCALE_COLLATE
5602         if (IN_LC_COMPILETIME(LC_COLLATE))
5603             goto nope;
5604 #endif
5605         break;
5606     case OP_SPRINTF:
5607         /* XXX what about the numeric ops? */
5608 #ifdef USE_LOCALE_NUMERIC
5609         if (IN_LC_COMPILETIME(LC_NUMERIC))
5610             goto nope;
5611 #endif
5612         break;
5613     case OP_PACK:
5614         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5615           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5616             goto nope;
5617         {
5618             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5619             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5620             {
5621                 const char *s = SvPVX_const(sv);
5622                 while (s < SvEND(sv)) {
5623                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5624                     s++;
5625                 }
5626             }
5627         }
5628         break;
5629     case OP_REPEAT:
5630         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5631         break;
5632     case OP_SREFGEN:
5633         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5634          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5635             goto nope;
5636     }
5637
5638     if (PL_parser && PL_parser->error_count)
5639         goto nope;              /* Don't try to run w/ errors */
5640
5641     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5642         switch (curop->op_type) {
5643         case OP_CONST:
5644             if (   (curop->op_private & OPpCONST_BARE)
5645                 && (curop->op_private & OPpCONST_STRICT)) {
5646                 no_bareword_allowed(curop);
5647                 goto nope;
5648             }
5649             /* FALLTHROUGH */
5650         case OP_LIST:
5651         case OP_SCALAR:
5652         case OP_NULL:
5653         case OP_PUSHMARK:
5654             /* Foldable; move to next op in list */
5655             break;
5656
5657         default:
5658             /* No other op types are considered foldable */
5659             goto nope;
5660         }
5661     }
5662
5663     curop = LINKLIST(o);
5664     old_next = o->op_next;
5665     o->op_next = 0;
5666     PL_op = curop;
5667
5668     old_cxix = cxstack_ix;
5669     create_eval_scope(NULL, G_FAKINGEVAL);
5670
5671     /* Verify that we don't need to save it:  */
5672     assert(PL_curcop == &PL_compiling);
5673     StructCopy(&PL_compiling, &not_compiling, COP);
5674     PL_curcop = &not_compiling;
5675     /* The above ensures that we run with all the correct hints of the
5676        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5677     assert(IN_PERL_RUNTIME);
5678     PL_warnhook = PERL_WARNHOOK_FATAL;
5679     PL_diehook  = NULL;
5680
5681     /* Effective $^W=1.  */
5682     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5683         PL_dowarn |= G_WARN_ON;
5684
5685     ret = S_fold_constants_eval(aTHX);
5686
5687     switch (ret) {
5688     case 0:
5689         sv = *(PL_stack_sp--);
5690         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5691             pad_swipe(o->op_targ,  FALSE);
5692         }
5693         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5694             SvREFCNT_inc_simple_void(sv);
5695             SvTEMP_off(sv);
5696         }
5697         else { assert(SvIMMORTAL(sv)); }
5698         break;
5699     case 3:
5700         /* Something tried to die.  Abandon constant folding.  */
5701         /* Pretend the error never happened.  */
5702         CLEAR_ERRSV();
5703         o->op_next = old_next;
5704         break;
5705     default:
5706         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5707         PL_warnhook = oldwarnhook;
5708         PL_diehook  = olddiehook;
5709         /* XXX note that this croak may fail as we've already blown away
5710          * the stack - eg any nested evals */
5711         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5712     }
5713     PL_dowarn   = oldwarn;
5714     PL_warnhook = oldwarnhook;
5715     PL_diehook  = olddiehook;
5716     PL_curcop = &PL_compiling;
5717
5718     /* if we croaked, depending on how we croaked the eval scope
5719      * may or may not have already been popped */
5720     if (cxstack_ix > old_cxix) {
5721         assert(cxstack_ix == old_cxix + 1);
5722         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5723         delete_eval_scope();
5724     }
5725     if (ret)
5726         goto nope;
5727
5728     /* OP_STRINGIFY and constant folding are used to implement qq.
5729        Here the constant folding is an implementation detail that we
5730        want to hide.  If the stringify op is itself already marked
5731        folded, however, then it is actually a folded join.  */
5732     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5733     op_free(o);
5734     assert(sv);
5735     if (is_stringify)
5736         SvPADTMP_off(sv);
5737     else if (!SvIMMORTAL(sv)) {
5738         SvPADTMP_on(sv);
5739         SvREADONLY_on(sv);
5740     }
5741     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5742     if (!is_stringify) newop->op_folded = 1;
5743     return newop;
5744
5745  nope:
5746     return o;
5747 }
5748
5749 static OP *
5750 S_gen_constant_list(pTHX_ OP *o)
5751 {
5752     dVAR;
5753     OP *curop, *old_next;
5754     SV * const oldwarnhook = PL_warnhook;
5755     SV * const olddiehook  = PL_diehook;
5756     COP *old_curcop;
5757     U8 oldwarn = PL_dowarn;
5758     SV **svp;
5759     AV *av;
5760     I32 old_cxix;
5761     COP not_compiling;
5762     int ret = 0;
5763     dJMPENV;
5764     bool op_was_null;
5765
5766     list(o);
5767     if (PL_parser && PL_parser->error_count)
5768         return o;               /* Don't attempt to run with errors */
5769
5770     curop = LINKLIST(o);
5771     old_next = o->op_next;
5772     o->op_next = 0;
5773     op_was_null = o->op_type == OP_NULL;
5774     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5775         o->op_type = OP_CUSTOM;
5776     CALL_PEEP(curop);
5777     if (op_was_null)
5778         o->op_type = OP_NULL;
5779     S_prune_chain_head(&curop);
5780     PL_op = curop;
5781
5782     old_cxix = cxstack_ix;
5783     create_eval_scope(NULL, G_FAKINGEVAL);
5784
5785     old_curcop = PL_curcop;
5786     StructCopy(old_curcop, &not_compiling, COP);
5787     PL_curcop = &not_compiling;
5788     /* The above ensures that we run with all the correct hints of the
5789        current COP, but that IN_PERL_RUNTIME is true. */
5790     assert(IN_PERL_RUNTIME);
5791     PL_warnhook = PERL_WARNHOOK_FATAL;
5792     PL_diehook  = NULL;
5793     JMPENV_PUSH(ret);
5794
5795     /* Effective $^W=1.  */
5796     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5797         PL_dowarn |= G_WARN_ON;
5798
5799     switch (ret) {
5800     case 0:
5801 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5802         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5803 #endif
5804         Perl_pp_pushmark(aTHX);
5805         CALLRUNOPS(aTHX);
5806         PL_op = curop;
5807         assert (!(curop->op_flags & OPf_SPECIAL));
5808         assert(curop->op_type == OP_RANGE);
5809         Perl_pp_anonlist(aTHX);
5810         break;
5811     case 3:
5812         CLEAR_ERRSV();
5813         o->op_next = old_next;
5814         break;
5815     default:
5816         JMPENV_POP;
5817         PL_warnhook = oldwarnhook;
5818         PL_diehook = olddiehook;
5819         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5820             ret);
5821     }
5822
5823     JMPENV_POP;
5824     PL_dowarn = oldwarn;
5825     PL_warnhook = oldwarnhook;
5826     PL_diehook = olddiehook;
5827     PL_curcop = old_curcop;
5828
5829     if (cxstack_ix > old_cxix) {
5830         assert(cxstack_ix == old_cxix + 1);
5831         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5832         delete_eval_scope();
5833     }
5834     if (ret)
5835         return o;
5836
5837     OpTYPE_set(o, OP_RV2AV);
5838     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5839     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5840     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5841     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5842
5843     /* replace subtree with an OP_CONST */
5844     curop = ((UNOP*)o)->op_first;
5845     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5846     op_free(curop);
5847
5848     if (AvFILLp(av) != -1)
5849         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5850         {
5851             SvPADTMP_on(*svp);
5852             SvREADONLY_on(*svp);
5853         }
5854     LINKLIST(o);
5855     return list(o);
5856 }
5857
5858 /*
5859 =head1 Optree Manipulation Functions
5860 */
5861
5862 /* List constructors */
5863
5864 /*
5865 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5866
5867 Append an item to the list of ops contained directly within a list-type
5868 op, returning the lengthened list.  C<first> is the list-type op,
5869 and C<last> is the op to append to the list.  C<optype> specifies the
5870 intended opcode for the list.  If C<first> is not already a list of the
5871 right type, it will be upgraded into one.  If either C<first> or C<last>
5872 is null, the other is returned unchanged.
5873
5874 =cut
5875 */
5876
5877 OP *
5878 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5879 {
5880     if (!first)
5881         return last;
5882
5883     if (!last)
5884         return first;
5885
5886     if (first->op_type != (unsigned)type
5887         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5888     {
5889         return newLISTOP(type, 0, first, last);
5890     }
5891
5892     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5893     first->op_flags |= OPf_KIDS;
5894     return first;
5895 }
5896
5897 /*
5898 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5899
5900 Concatenate the lists of ops contained directly within two list-type ops,
5901 returning the combined list.  C<first> and C<last> are the list-type ops
5902 to concatenate.  C<optype> specifies the intended opcode for the list.
5903 If either C<first> or C<last> is not already a list of the right type,
5904 it will be upgraded into one.  If either C<first> or C<last> is null,
5905 the other is returned unchanged.
5906
5907 =cut
5908 */
5909
5910 OP *
5911 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5912 {
5913     if (!first)
5914         return last;
5915
5916     if (!last)
5917         return first;
5918
5919     if (first->op_type != (unsigned)type)
5920         return op_prepend_elem(type, first, last);
5921
5922     if (last->op_type != (unsigned)type)
5923         return op_append_elem(type, first, last);
5924
5925     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5926     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5927     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5928     first->op_flags |= (last->op_flags & OPf_KIDS);
5929
5930     S_op_destroy(aTHX_ last);
5931
5932     return first;
5933 }
5934
5935 /*
5936 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5937
5938 Prepend an item to the list of ops contained directly within a list-type
5939 op, returning the lengthened list.  C<first> is the op to prepend to the
5940 list, and C<last> is the list-type op.  C<optype> specifies the intended
5941 opcode for the list.  If C<last> is not already a list of the right type,
5942 it will be upgraded into one.  If either C<first> or C<last> is null,
5943 the other is returned unchanged.
5944
5945 =cut
5946 */
5947
5948 OP *
5949 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5950 {
5951     if (!first)
5952         return last;
5953
5954     if (!last)
5955         return first;
5956
5957     if (last->op_type == (unsigned)type) {
5958         if (type == OP_LIST) {  /* already a PUSHMARK there */
5959             /* insert 'first' after pushmark */
5960             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5961             if (!(first->op_flags & OPf_PARENS))
5962                 last->op_flags &= ~OPf_PARENS;
5963         }
5964         else
5965             op_sibling_splice(last, NULL, 0, first);
5966         last->op_flags |= OPf_KIDS;
5967         return last;
5968     }
5969
5970     return newLISTOP(type, 0, first, last);
5971 }
5972
5973 /*
5974 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5975
5976 Converts C<o> into a list op if it is not one already, and then converts it
5977 into the specified C<type>, calling its check function, allocating a target if
5978 it needs one, and folding constants.
5979
5980 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5981 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5982 C<op_convert_list> to make it the right type.
5983
5984 =cut
5985 */
5986
5987 OP *
5988 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5989 {
5990     dVAR;
5991     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5992     if (!o || o->op_type != OP_LIST)
5993         o = force_list(o, 0);
5994     else
5995     {
5996         o->op_flags &= ~OPf_WANT;
5997         o->op_private &= ~OPpLVAL_INTRO;
5998     }
5999
6000     if (!(PL_opargs[type] & OA_MARK))
6001         op_null(cLISTOPo->op_first);
6002     else {
6003         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6004         if (kid2 && kid2->op_type == OP_COREARGS) {
6005             op_null(cLISTOPo->op_first);
6006             kid2->op_private |= OPpCOREARGS_PUSHMARK;
6007         }
6008     }
6009
6010     if (type != OP_SPLIT)
6011         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6012          * ck_split() create a real PMOP and leave the op's type as listop
6013          * for now. Otherwise op_free() etc will crash.
6014          */
6015         OpTYPE_set(o, type);
6016
6017     o->op_flags |= flags;
6018     if (flags & OPf_FOLDED)
6019         o->op_folded = 1;
6020
6021     o = CHECKOP(type, o);
6022     if (o->op_type != (unsigned)type)
6023         return o;
6024
6025     return fold_constants(op_integerize(op_std_init(o)));
6026 }
6027
6028 /* Constructors */
6029
6030
6031 /*
6032 =head1 Optree construction
6033
6034 =for apidoc Am|OP *|newNULLLIST
6035
6036 Constructs, checks, and returns a new C<stub> op, which represents an
6037 empty list expression.
6038
6039 =cut
6040 */
6041
6042 OP *
6043 Perl_newNULLLIST(pTHX)
6044 {
6045     return newOP(OP_STUB, 0);
6046 }
6047
6048 /* promote o and any siblings to be a list if its not already; i.e.
6049  *
6050  *  o - A - B
6051  *
6052  * becomes
6053  *
6054  *  list
6055  *    |
6056  *  pushmark - o - A - B
6057  *
6058  * If nullit it true, the list op is nulled.
6059  */
6060
6061 static OP *
6062 S_force_list(pTHX_ OP *o, bool nullit)
6063 {
6064     if (!o || o->op_type != OP_LIST) {
6065         OP *rest = NULL;
6066         if (o) {
6067             /* manually detach any siblings then add them back later */
6068             rest = OpSIBLING(o);
6069             OpLASTSIB_set(o, NULL);
6070         }
6071         o = newLISTOP(OP_LIST, 0, o, NULL);
6072         if (rest)
6073             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6074     }
6075     if (nullit)
6076         op_null(o);
6077     return o;
6078 }
6079
6080 /*
6081 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6082
6083 Constructs, checks, and returns an op of any list type.  C<type> is
6084 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6085 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6086 supply up to two ops to be direct children of the list op; they are
6087 consumed by this function and become part of the constructed op tree.
6088
6089 For most list operators, the check function expects all the kid ops to be
6090 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6091 appropriate.  What you want to do in that case is create an op of type
6092 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6093 See L</op_convert_list> for more information.
6094
6095
6096 =cut
6097 */
6098
6099 OP *
6100 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6101 {
6102     dVAR;
6103     LISTOP *listop;
6104
6105     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6106         || type == OP_CUSTOM);
6107
6108     NewOp(1101, listop, 1, LISTOP);
6109
6110     OpTYPE_set(listop, type);
6111     if (first || last)
6112         flags |= OPf_KIDS;
6113     listop->op_flags = (U8)flags;
6114
6115     if (!last && first)
6116         last = first;
6117     else if (!first && last)
6118         first = last;
6119     else if (first)
6120         OpMORESIB_set(first, last);
6121     listop->op_first = first;
6122     listop->op_last = last;
6123     if (type == OP_LIST) {
6124         OP* const pushop = newOP(OP_PUSHMARK, 0);
6125         OpMORESIB_set(pushop, first);
6126         listop->op_first = pushop;
6127         listop->op_flags |= OPf_KIDS;
6128         if (!last)
6129             listop->op_last = pushop;
6130     }
6131     if (listop->op_last)
6132         OpLASTSIB_set(listop->op_last, (OP*)listop);
6133
6134     return CHECKOP(type, listop);
6135 }
6136
6137 /*
6138 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6139
6140 Constructs, checks, and returns an op of any base type (any type that
6141 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6142 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6143 of C<op_private>.
6144
6145 =cut
6146 */
6147
6148 OP *
6149 Perl_newOP(pTHX_ I32 type, I32 flags)
6150 {
6151     dVAR;
6152     OP *o;
6153
6154     if (type == -OP_ENTEREVAL) {
6155         type = OP_ENTEREVAL;
6156         flags |= OPpEVAL_BYTES<<8;
6157     }
6158
6159     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6160         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6161         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6162         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6163
6164     NewOp(1101, o, 1, OP);
6165     OpTYPE_set(o, type);
6166     o->op_flags = (U8)flags;
6167
6168     o->op_next = o;
6169     o->op_private = (U8)(0 | (flags >> 8));
6170     if (PL_opargs[type] & OA_RETSCALAR)
6171         scalar(o);
6172     if (PL_opargs[type] & OA_TARGET)
6173         o->op_targ = pad_alloc(type, SVs_PADTMP);
6174     return CHECKOP(type, o);
6175 }
6176
6177 /*
6178 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6179
6180 Constructs, checks, and returns an op of any unary type.  C<type> is
6181 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6182 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6183 bits, the eight bits of C<op_private>, except that the bit with value 1
6184 is automatically set.  C<first> supplies an optional op to be the direct
6185 child of the unary op; it is consumed by this function and become part
6186 of the constructed op tree.
6187
6188 =cut
6189 */
6190
6191 OP *
6192 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6193 {
6194     dVAR;
6195     UNOP *unop;
6196
6197     if (type == -OP_ENTEREVAL) {
6198         type = OP_ENTEREVAL;
6199         flags |= OPpEVAL_BYTES<<8;
6200     }
6201
6202     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6203         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6204         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6205         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6206         || type == OP_SASSIGN
6207         || type == OP_ENTERTRY
6208         || type == OP_CUSTOM
6209         || type == OP_NULL );
6210
6211     if (!first)
6212         first = newOP(OP_STUB, 0);
6213     if (PL_opargs[type] & OA_MARK)
6214         first = force_list(first, 1);
6215
6216     NewOp(1101, unop, 1, UNOP);
6217     OpTYPE_set(unop, type);
6218     unop->op_first = first;
6219     unop->op_flags = (U8)(flags | OPf_KIDS);
6220     unop->op_private = (U8)(1 | (flags >> 8));
6221
6222     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6223         OpLASTSIB_set(first, (OP*)unop);
6224
6225     unop = (UNOP*) CHECKOP(type, unop);
6226     if (unop->op_next)
6227         return (OP*)unop;
6228
6229     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6230 }
6231
6232 /*
6233 =for apidoc newUNOP_AUX
6234
6235 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6236 initialised to C<aux>
6237
6238 =cut
6239 */
6240
6241 OP *
6242 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6243 {
6244     dVAR;
6245     UNOP_AUX *unop;
6246
6247     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6248         || type == OP_CUSTOM);
6249
6250     NewOp(1101, unop, 1, UNOP_AUX);
6251     unop->op_type = (OPCODE)type;
6252     unop->op_ppaddr = PL_ppaddr[type];
6253     unop->op_first = first;
6254     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6255     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6256     unop->op_aux = aux;
6257
6258     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6259         OpLASTSIB_set(first, (OP*)unop);
6260
6261     unop = (UNOP_AUX*) CHECKOP(type, unop);
6262
6263     return op_std_init((OP *) unop);
6264 }
6265
6266 /*
6267 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6268
6269 Constructs, checks, and returns an op of method type with a method name
6270 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6271 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6272 and, shifted up eight bits, the eight bits of C<op_private>, except that
6273 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6274 op which evaluates method name; it is consumed by this function and
6275 become part of the constructed op tree.
6276 Supported optypes: C<OP_METHOD>.
6277
6278 =cut
6279 */
6280
6281 static OP*
6282 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6283     dVAR;
6284     METHOP *methop;
6285
6286     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6287         || type == OP_CUSTOM);
6288
6289     NewOp(1101, methop, 1, METHOP);
6290     if (dynamic_meth) {
6291         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6292         methop->op_flags = (U8)(flags | OPf_KIDS);
6293         methop->op_u.op_first = dynamic_meth;
6294         methop->op_private = (U8)(1 | (flags >> 8));
6295
6296         if (!OpHAS_SIBLING(dynamic_meth))
6297             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6298     }
6299     else {
6300         assert(const_meth);
6301         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6302         methop->op_u.op_meth_sv = const_meth;
6303         methop->op_private = (U8)(0 | (flags >> 8));
6304         methop->op_next = (OP*)methop;
6305     }
6306
6307 #ifdef USE_ITHREADS
6308     methop->op_rclass_targ = 0;
6309 #else
6310     methop->op_rclass_sv = NULL;
6311 #endif
6312
6313     OpTYPE_set(methop, type);
6314     return CHECKOP(type, methop);
6315 }
6316
6317 OP *
6318 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6319     PERL_ARGS_ASSERT_NEWMETHOP;
6320     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6321 }
6322
6323 /*
6324 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6325
6326 Constructs, checks, and returns an op of method type with a constant
6327 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6328 C<op_flags>, and, shifted up eight bits, the eight bits of
6329 C<op_private>.  C<const_meth> supplies a constant method name;
6330 it must be a shared COW string.
6331 Supported optypes: C<OP_METHOD_NAMED>.
6332
6333 =cut
6334 */
6335
6336 OP *
6337 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6338     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6339     return newMETHOP_internal(type, flags, NULL, const_meth);
6340 }
6341
6342 /*
6343 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6344
6345 Constructs, checks, and returns an op of any binary type.  C<type>
6346 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6347 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6348 the eight bits of C<op_private>, except that the bit with value 1 or
6349 2 is automatically set as required.  C<first> and C<last> supply up to
6350 two ops to be the direct children of the binary op; they are consumed
6351 by this function and become part of the constructed op tree.
6352
6353 =cut
6354 */
6355
6356 OP *
6357 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6358 {
6359     dVAR;
6360     BINOP *binop;
6361
6362     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6363         || type == OP_NULL || type == OP_CUSTOM);
6364
6365     NewOp(1101, binop, 1, BINOP);
6366
6367     if (!first)
6368         first = newOP(OP_NULL, 0);
6369
6370     OpTYPE_set(binop, type);
6371     binop->op_first = first;
6372     binop->op_flags = (U8)(flags | OPf_KIDS);
6373     if (!last) {
6374         last = first;
6375         binop->op_private = (U8)(1 | (flags >> 8));
6376     }
6377     else {
6378         binop->op_private = (U8)(2 | (flags >> 8));
6379         OpMORESIB_set(first, last);
6380     }
6381
6382     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6383         OpLASTSIB_set(last, (OP*)binop);
6384
6385     binop->op_last = OpSIBLING(binop->op_first);
6386     if (binop->op_last)
6387         OpLASTSIB_set(binop->op_last, (OP*)binop);
6388
6389     binop = (BINOP*)CHECKOP(type, binop);
6390     if (binop->op_next || binop->op_type != (OPCODE)type)
6391         return (OP*)binop;
6392
6393     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6394 }
6395
6396 /* Helper function for S_pmtrans(): comparison function to sort an array
6397  * of codepoint range pairs. Sorts by start point, or if equal, by end
6398  * point */
6399
6400 static int uvcompare(const void *a, const void *b)
6401     __attribute__nonnull__(1)
6402     __attribute__nonnull__(2)
6403     __attribute__pure__;
6404 static int uvcompare(const void *a, const void *b)
6405 {
6406     if (*((const UV *)a) < (*(const UV *)b))
6407         return -1;
6408     if (*((const UV *)a) > (*(const UV *)b))
6409         return 1;
6410     if (*((const UV *)a+1) < (*(const UV *)b+1))
6411         return -1;
6412     if (*((const UV *)a+1) > (*(const UV *)b+1))
6413         return 1;
6414     return 0;
6415 }
6416
6417 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6418  * containing the search and replacement strings, assemble into
6419  * a translation table attached as o->op_pv.
6420  * Free expr and repl.
6421  * It expects the toker to have already set the
6422  *   OPpTRANS_COMPLEMENT
6423  *   OPpTRANS_SQUASH
6424  *   OPpTRANS_DELETE
6425  * flags as appropriate; this function may add
6426  *   OPpTRANS_FROM_UTF
6427  *   OPpTRANS_TO_UTF
6428  *   OPpTRANS_IDENTICAL
6429  *   OPpTRANS_GROWS
6430  * flags
6431  */
6432
6433 static OP *
6434 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6435 {
6436     SV * const tstr = ((SVOP*)expr)->op_sv;
6437     SV * const rstr = ((SVOP*)repl)->op_sv;
6438     STRLEN tlen;
6439     STRLEN rlen;
6440     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6441     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6442     Size_t i, j;
6443     bool grows = FALSE;
6444     OPtrans_map *tbl;
6445     SSize_t struct_size; /* malloced size of table struct */
6446
6447     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6448     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6449     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6450     SV* swash;
6451
6452     PERL_ARGS_ASSERT_PMTRANS;
6453
6454     PL_hints |= HINT_BLOCK_SCOPE;
6455
6456     if (SvUTF8(tstr))
6457         o->op_private |= OPpTRANS_FROM_UTF;
6458
6459     if (SvUTF8(rstr))
6460         o->op_private |= OPpTRANS_TO_UTF;
6461
6462     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6463
6464         /* for utf8 translations, op_sv will be set to point to a swash
6465          * containing codepoint ranges. This is done by first assembling
6466          * a textual representation of the ranges in listsv then compiling
6467          * it using swash_init(). For more details of the textual format,
6468          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6469          */
6470
6471         SV* const listsv = newSVpvs("# comment\n");
6472         SV* transv = NULL;
6473         const U8* tend = t + tlen;
6474         const U8* rend = r + rlen;
6475         STRLEN ulen;
6476         UV tfirst = 1;
6477         UV tlast = 0;
6478         IV tdiff;
6479         STRLEN tcount = 0;
6480         UV rfirst = 1;
6481         UV rlast = 0;
6482         IV rdiff;
6483         STRLEN rcount = 0;
6484         IV diff;
6485         I32 none = 0;
6486         U32 max = 0;
6487         I32 bits;
6488         I32 havefinal = 0;
6489         U32 final = 0;
6490         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6491         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6492         U8* tsave = NULL;
6493         U8* rsave = NULL;
6494         const U32 flags = UTF8_ALLOW_DEFAULT;
6495
6496         if (!from_utf) {
6497             STRLEN len = tlen;
6498             t = tsave = bytes_to_utf8(t, &len);
6499             tend = t + len;
6500         }
6501         if (!to_utf && rlen) {
6502             STRLEN len = rlen;
6503             r = rsave = bytes_to_utf8(r, &len);
6504             rend = r + len;
6505         }
6506
6507 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6508  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6509  * odd.  */
6510
6511         if (complement) {
6512             /* utf8 and /c:
6513              * replace t/tlen/tend with a version that has the ranges
6514              * complemented
6515              */
6516             U8 tmpbuf[UTF8_MAXBYTES+1];
6517             UV *cp;
6518             UV nextmin = 0;
6519             Newx(cp, 2*tlen, UV);
6520             i = 0;
6521             transv = newSVpvs("");
6522
6523             /* convert search string into array of (start,end) range
6524              * codepoint pairs stored in cp[]. Most "ranges" will start
6525              * and end at the same char */
6526             while (t < tend) {
6527                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6528                 t += ulen;
6529                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6530                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6531                     t++;
6532                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6533                     t += ulen;
6534                 }
6535                 else {
6536                  cp[2*i+1] = cp[2*i];
6537                 }
6538                 i++;
6539             }
6540
6541             /* sort the ranges */
6542             qsort(cp, i, 2*sizeof(UV), uvcompare);
6543
6544             /* Create a utf8 string containing the complement of the
6545              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6546              * then transv will contain the equivalent of:
6547              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6548              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6549              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6550              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6551              * end cp.
6552              */
6553             for (j = 0; j < i; j++) {
6554                 UV  val = cp[2*j];
6555                 diff = val - nextmin;
6556                 if (diff > 0) {
6557                     t = uvchr_to_utf8(tmpbuf,nextmin);
6558                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6559                     if (diff > 1) {
6560                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6561                         t = uvchr_to_utf8(tmpbuf, val - 1);
6562                         sv_catpvn(transv, (char *)&range_mark, 1);
6563                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6564                     }
6565                 }
6566                 val = cp[2*j+1];
6567                 if (val >= nextmin)
6568                     nextmin = val + 1;
6569             }
6570
6571             t = uvchr_to_utf8(tmpbuf,nextmin);
6572             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6573             {
6574                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6575                 sv_catpvn(transv, (char *)&range_mark, 1);
6576             }
6577             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6578             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6579             t = (const U8*)SvPVX_const(transv);
6580             tlen = SvCUR(transv);
6581             tend = t + tlen;
6582             Safefree(cp);
6583         }
6584         else if (!rlen && !del) {
6585             r = t; rlen = tlen; rend = tend;
6586         }
6587
6588         if (!squash) {
6589                 if ((!rlen && !del) || t == r ||
6590                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6591                 {
6592                     o->op_private |= OPpTRANS_IDENTICAL;
6593                 }
6594         }
6595
6596         /* extract char ranges from t and r and append them to listsv */
6597
6598         while (t < tend || tfirst <= tlast) {
6599             /* see if we need more "t" chars */
6600             if (tfirst > tlast) {
6601                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6602                 t += ulen;
6603                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6604                     t++;
6605                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6606                     t += ulen;
6607                 }
6608                 else
6609                     tlast = tfirst;
6610             }
6611
6612             /* now see if we need more "r" chars */
6613             if (rfirst > rlast) {
6614                 if (r < rend) {
6615                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6616                     r += ulen;
6617                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6618                         r++;
6619                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6620                         r += ulen;
6621                     }
6622                     else
6623                         rlast = rfirst;
6624                 }
6625                 else {
6626                     if (!havefinal++)
6627                         final = rlast;
6628                     rfirst = rlast = 0xffffffff;
6629                 }
6630             }
6631
6632             /* now see which range will peter out first, if either. */
6633             tdiff = tlast - tfirst;
6634             rdiff = rlast - rfirst;
6635             tcount += tdiff + 1;
6636             rcount += rdiff + 1;
6637
6638             if (tdiff <= rdiff)
6639                 diff = tdiff;
6640             else
6641                 diff = rdiff;
6642
6643             if (rfirst == 0xffffffff) {
6644                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6645                 if (diff > 0)
6646                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6647                                    (long)tfirst, (long)tlast);
6648                 else
6649                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6650             }
6651             else {
6652                 if (diff > 0)
6653                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6654                                    (long)tfirst, (long)(tfirst + diff),
6655                                    (long)rfirst);
6656                 else
6657                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6658                                    (long)tfirst, (long)rfirst);
6659
6660                 if (rfirst + diff > max)
6661                     max = rfirst + diff;
6662                 if (!grows)
6663                     grows = (tfirst < rfirst &&
6664                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6665                 rfirst += diff + 1;
6666             }
6667             tfirst += diff + 1;
6668         }
6669
6670         /* compile listsv into a swash and attach to o */
6671
6672         none = ++max;
6673         if (del)
6674             ++max;
6675
6676         if (max > 0xffff)
6677             bits = 32;
6678         else if (max > 0xff)
6679             bits = 16;
6680         else
6681             bits = 8;
6682
6683         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6684 #ifdef USE_ITHREADS
6685         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6686         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6687         PAD_SETSV(cPADOPo->op_padix, swash);
6688         SvPADTMP_on(swash);
6689         SvREADONLY_on(swash);
6690 #else
6691         cSVOPo->op_sv = swash;
6692 #endif
6693         SvREFCNT_dec(listsv);
6694         SvREFCNT_dec(transv);
6695
6696         if (!del && havefinal && rlen)
6697             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6698                            newSVuv((UV)final), 0);
6699
6700         Safefree(tsave);
6701         Safefree(rsave);
6702
6703         tlen = tcount;
6704         rlen = rcount;
6705         if (r < rend)
6706             rlen++;
6707         else if (rlast == 0xffffffff)
6708             rlen = 0;
6709
6710         goto warnins;
6711     }
6712
6713     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6714      * table. Entries with the value -1 indicate chars not to be
6715      * translated, while -2 indicates a search char without a
6716      * corresponding replacement char under /d.
6717      *
6718      * Normally, the table has 256 slots. However, in the presence of
6719      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6720      * added, and if there are enough replacement chars to start pairing
6721      * with the \x{100},... search chars, then a larger (> 256) table
6722      * is allocated.
6723      *
6724      * In addition, regardless of whether under /c, an extra slot at the
6725      * end is used to store the final repeating char, or -3 under an empty
6726      * replacement list, or -2 under /d; which makes the runtime code
6727      * easier.
6728      *
6729      * The toker will have already expanded char ranges in t and r.
6730      */
6731
6732     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6733      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6734      * The OPtrans_map struct already contains one slot; hence the -1.
6735      */
6736     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6737     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6738     tbl->size = 256;
6739     cPVOPo->op_pv = (char*)tbl;
6740
6741     if (complement) {
6742         Size_t excess;
6743
6744         /* in this branch, j is a count of 'consumed' (i.e. paired off
6745          * with a search char) replacement chars (so j <= rlen always)
6746          */
6747         for (i = 0; i < tlen; i++)
6748             tbl->map[t[i]] = -1;
6749
6750         for (i = 0, j = 0; i < 256; i++) {
6751             if (!tbl->map[i]) {
6752                 if (j == rlen) {
6753                     if (del)
6754                         tbl->map[i] = -2;
6755                     else if (rlen)
6756                         tbl->map[i] = r[j-1];
6757                     else
6758                         tbl->map[i] = (short)i;
6759                 }
6760                 else {
6761                     tbl->map[i] = r[j++];
6762                 }
6763                 if (   tbl->map[i] >= 0
6764                     &&  UVCHR_IS_INVARIANT((UV)i)
6765                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6766                 )
6767                     grows = TRUE;
6768             }
6769         }
6770
6771         ASSUME(j <= rlen);
6772         excess = rlen - j;
6773
6774         if (excess) {
6775             /* More replacement chars than search chars:
6776              * store excess replacement chars at end of main table.
6777              */
6778
6779             struct_size += excess;
6780             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6781                         struct_size + excess * sizeof(short));
6782             tbl->size += excess;
6783             cPVOPo->op_pv = (char*)tbl;
6784
6785             for (i = 0; i < excess; i++)
6786                 tbl->map[i + 256] = r[j+i];
6787         }
6788         else {
6789             /* no more replacement chars than search chars */
6790             if (!rlen && !del && !squash)
6791                 o->op_private |= OPpTRANS_IDENTICAL;
6792         }
6793
6794         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6795     }
6796     else {
6797         if (!rlen && !del) {
6798             r = t; rlen = tlen;
6799             if (!squash)
6800                 o->op_private |= OPpTRANS_IDENTICAL;
6801         }
6802         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6803             o->op_private |= OPpTRANS_IDENTICAL;
6804         }
6805
6806         for (i = 0; i < 256; i++)
6807             tbl->map[i] = -1;
6808         for (i = 0, j = 0; i < tlen; i++,j++) {
6809             if (j >= rlen) {
6810                 if (del) {
6811                     if (tbl->map[t[i]] == -1)
6812                         tbl->map[t[i]] = -2;
6813                     continue;
6814                 }
6815                 --j;
6816             }
6817             if (tbl->map[t[i]] == -1) {
6818                 if (     UVCHR_IS_INVARIANT(t[i])
6819                     && ! UVCHR_IS_INVARIANT(r[j]))
6820                     grows = TRUE;
6821                 tbl->map[t[i]] = r[j];
6822             }
6823         }
6824         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6825     }
6826
6827     /* both non-utf8 and utf8 code paths end up here */
6828
6829   warnins:
6830     if(del && rlen == tlen) {
6831         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6832     } else if(rlen > tlen && !complement) {
6833         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6834     }
6835
6836     if (grows)
6837         o->op_private |= OPpTRANS_GROWS;
6838     op_free(expr);
6839     op_free(repl);
6840
6841     return o;
6842 }
6843
6844
6845 /*
6846 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6847
6848 Constructs, checks, and returns an op of any pattern matching type.
6849 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6850 and, shifted up eight bits, the eight bits of C<op_private>.
6851
6852 =cut
6853 */
6854
6855 OP *
6856 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6857 {
6858     dVAR;
6859     PMOP *pmop;
6860
6861     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6862         || type == OP_CUSTOM);
6863
6864     NewOp(1101, pmop, 1, PMOP);
6865     OpTYPE_set(pmop, type);
6866     pmop->op_flags = (U8)flags;
6867     pmop->op_private = (U8)(0 | (flags >> 8));
6868     if (PL_opargs[type] & OA_RETSCALAR)
6869         scalar((OP *)pmop);
6870
6871     if (PL_hints & HINT_RE_TAINT)
6872         pmop->op_pmflags |= PMf_RETAINT;
6873 #ifdef USE_LOCALE_CTYPE
6874     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6875         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6876     }
6877     else
6878 #endif
6879          if (IN_UNI_8_BIT) {
6880         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6881     }
6882     if (PL_hints & HINT_RE_FLAGS) {
6883         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6884          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6885         );
6886         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6887         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6888          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6889         );
6890         if (reflags && SvOK(reflags)) {
6891             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6892         }
6893     }
6894
6895
6896 #ifdef USE_ITHREADS
6897     assert(SvPOK(PL_regex_pad[0]));
6898     if (SvCUR(PL_regex_pad[0])) {
6899         /* Pop off the "packed" IV from the end.  */
6900         SV *const repointer_list = PL_regex_pad[0];
6901         const char *p = SvEND(repointer_list) - sizeof(IV);
6902         const IV offset = *((IV*)p);
6903
6904         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6905
6906         SvEND_set(repointer_list, p);
6907
6908         pmop->op_pmoffset = offset;
6909         /* This slot should be free, so assert this:  */
6910         assert(PL_regex_pad[offset] == &PL_sv_undef);
6911     } else {
6912         SV * const repointer = &PL_sv_undef;
6913         av_push(PL_regex_padav, repointer);
6914         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6915         PL_regex_pad = AvARRAY(PL_regex_padav);
6916     }
6917 #endif
6918
6919     return CHECKOP(type, pmop);
6920 }
6921
6922 static void
6923 S_set_haseval(pTHX)
6924 {
6925     PADOFFSET i = 1;
6926     PL_cv_has_eval = 1;
6927     /* Any pad names in scope are potentially lvalues.  */
6928     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6929         PADNAME *pn = PAD_COMPNAME_SV(i);
6930         if (!pn || !PadnameLEN(pn))
6931             continue;
6932         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6933             S_mark_padname_lvalue(aTHX_ pn);
6934     }
6935 }
6936
6937 /* Given some sort of match op o, and an expression expr containing a
6938  * pattern, either compile expr into a regex and attach it to o (if it's
6939  * constant), or convert expr into a runtime regcomp op sequence (if it's
6940  * not)
6941  *
6942  * Flags currently has 2 bits of meaning:
6943  * 1: isreg indicates that the pattern is part of a regex construct, eg
6944  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6945  * split "pattern", which aren't. In the former case, expr will be a list
6946  * if the pattern contains more than one term (eg /a$b/).
6947  * 2: The pattern is for a split.
6948  *
6949  * When the pattern has been compiled within a new anon CV (for
6950  * qr/(?{...})/ ), then floor indicates the savestack level just before
6951  * the new sub was created
6952  */
6953
6954 OP *
6955 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6956 {
6957     PMOP *pm;
6958     LOGOP *rcop;
6959     I32 repl_has_vars = 0;
6960     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6961     bool is_compiletime;
6962     bool has_code;
6963     bool isreg    = cBOOL(flags & 1);
6964     bool is_split = cBOOL(flags & 2);
6965
6966     PERL_ARGS_ASSERT_PMRUNTIME;
6967
6968     if (is_trans) {
6969         return pmtrans(o, expr, repl);
6970     }
6971
6972     /* find whether we have any runtime or code elements;
6973      * at the same time, temporarily set the op_next of each DO block;
6974      * then when we LINKLIST, this will cause the DO blocks to be excluded
6975      * from the op_next chain (and from having LINKLIST recursively
6976      * applied to them). We fix up the DOs specially later */
6977
6978     is_compiletime = 1;
6979     has_code = 0;
6980     if (expr->op_type == OP_LIST) {
6981         OP *o;
6982         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6983             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6984                 has_code = 1;
6985                 assert(!o->op_next);
6986                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6987                     assert(PL_parser && PL_parser->error_count);
6988                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6989                        the op we were expecting to see, to avoid crashing
6990                        elsewhere.  */
6991                     op_sibling_splice(expr, o, 0,
6992                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6993                 }
6994                 o->op_next = OpSIBLING(o);
6995             }
6996             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6997                 is_compiletime = 0;
6998         }
6999     }
7000     else if (expr->op_type != OP_CONST)
7001         is_compiletime = 0;
7002
7003     LINKLIST(expr);
7004
7005     /* fix up DO blocks; treat each one as a separate little sub;
7006      * also, mark any arrays as LIST/REF */
7007
7008     if (expr->op_type == OP_LIST) {
7009         OP *o;
7010         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7011
7012             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7013                 assert( !(o->op_flags  & OPf_WANT));
7014                 /* push the array rather than its contents. The regex
7015                  * engine will retrieve and join the elements later */
7016                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7017                 continue;
7018             }
7019
7020             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7021                 continue;
7022             o->op_next = NULL; /* undo temporary hack from above */
7023             scalar(o);
7024             LINKLIST(o);
7025             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7026                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7027                 /* skip ENTER */
7028                 assert(leaveop->op_first->op_type == OP_ENTER);
7029                 assert(OpHAS_SIBLING(leaveop->op_first));
7030                 o->op_next = OpSIBLING(leaveop->op_first);
7031                 /* skip leave */
7032                 assert(leaveop->op_flags & OPf_KIDS);
7033                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7034                 leaveop->op_next = NULL; /* stop on last op */
7035                 op_null((OP*)leaveop);
7036             }
7037             else {
7038                 /* skip SCOPE */
7039                 OP *scope = cLISTOPo->op_first;
7040                 assert(scope->op_type == OP_SCOPE);
7041                 assert(scope->op_flags & OPf_KIDS);
7042                 scope->op_next = NULL; /* stop on last op */
7043                 op_null(scope);
7044             }
7045
7046             /* XXX optimize_optree() must be called on o before
7047              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7048              * currently cope with a peephole-optimised optree.
7049              * Calling optimize_optree() here ensures that condition
7050              * is met, but may mean optimize_optree() is applied
7051              * to the same optree later (where hopefully it won't do any
7052              * harm as it can't convert an op to multiconcat if it's
7053              * already been converted */
7054             optimize_optree(o);
7055
7056             /* have to peep the DOs individually as we've removed it from
7057              * the op_next chain */
7058             CALL_PEEP(o);
7059             S_prune_chain_head(&(o->op_next));
7060             if (is_compiletime)
7061                 /* runtime finalizes as part of finalizing whole tree */
7062                 finalize_optree(o);
7063         }
7064     }
7065     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7066         assert( !(expr->op_flags  & OPf_WANT));
7067         /* push the array rather than its contents. The regex
7068          * engine will retrieve and join the elements later */
7069         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7070     }
7071
7072     PL_hints |= HINT_BLOCK_SCOPE;
7073     pm = (PMOP*)o;
7074     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7075
7076     if (is_compiletime) {
7077         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7078         regexp_engine const *eng = current_re_engine();
7079
7080         if (is_split) {
7081             /* make engine handle split ' ' specially */
7082             pm->op_pmflags |= PMf_SPLIT;
7083             rx_flags |= RXf_SPLIT;
7084         }
7085
7086         if (!has_code || !eng->op_comp) {
7087             /* compile-time simple constant pattern */
7088
7089             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7090                 /* whoops! we guessed that a qr// had a code block, but we
7091                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7092                  * that isn't required now. Note that we have to be pretty
7093                  * confident that nothing used that CV's pad while the
7094                  * regex was parsed, except maybe op targets for \Q etc.
7095                  * If there were any op targets, though, they should have
7096                  * been stolen by constant folding.
7097                  */
7098 #ifdef DEBUGGING
7099                 SSize_t i = 0;
7100                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7101                 while (++i <= AvFILLp(PL_comppad)) {
7102 #  ifdef USE_PAD_RESET
7103                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7104                      * folded constant with a fresh padtmp */
7105                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7106 #  else
7107                     assert(!PL_curpad[i]);
7108 #  endif
7109                 }
7110 #endif
7111                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7112                  * outer CV (the one whose slab holds the pm op). The
7113                  * inner CV (which holds expr) will be freed later, once
7114                  * all the entries on the parse stack have been popped on
7115                  * return from this function. Which is why its safe to
7116                  * call op_free(expr) below.
7117                  */
7118                 LEAVE_SCOPE(floor);
7119                 pm->op_pmflags &= ~PMf_HAS_CV;
7120             }
7121
7122             /* Skip compiling if parser found an error for this pattern */
7123             if (pm->op_pmflags & PMf_HAS_ERROR) {
7124                 return o;
7125             }
7126
7127             PM_SETRE(pm,
7128                 eng->op_comp
7129                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7130                                         rx_flags, pm->op_pmflags)
7131                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7132                                         rx_flags, pm->op_pmflags)
7133             );
7134             op_free(expr);
7135         }
7136         else {
7137             /* compile-time pattern that includes literal code blocks */
7138
7139             REGEXP* re;
7140
7141             /* Skip compiling if parser found an error for this pattern */
7142             if (pm->op_pmflags & PMf_HAS_ERROR) {
7143                 return o;
7144             }
7145
7146             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7147                         rx_flags,
7148                         (pm->op_pmflags |
7149                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7150                     );
7151             PM_SETRE(pm, re);
7152             if (pm->op_pmflags & PMf_HAS_CV) {
7153                 CV *cv;
7154                 /* this QR op (and the anon sub we embed it in) is never
7155                  * actually executed. It's just a placeholder where we can
7156                  * squirrel away expr in op_code_list without the peephole
7157                  * optimiser etc processing it for a second time */
7158                 OP *qr = newPMOP(OP_QR, 0);
7159                 ((PMOP*)qr)->op_code_list = expr;
7160
7161                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7162                 SvREFCNT_inc_simple_void(PL_compcv);
7163                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7164                 ReANY(re)->qr_anoncv = cv;
7165
7166                 /* attach the anon CV to the pad so that
7167                  * pad_fixup_inner_anons() can find it */
7168                 (void)pad_add_anon(cv, o->op_type);
7169                 SvREFCNT_inc_simple_void(cv);
7170             }
7171             else {
7172                 pm->op_code_list = expr;
7173             }
7174         }
7175     }
7176     else {
7177         /* runtime pattern: build chain of regcomp etc ops */
7178         bool reglist;
7179         PADOFFSET cv_targ = 0;
7180
7181         reglist = isreg && expr->op_type == OP_LIST;
7182         if (reglist)
7183             op_null(expr);
7184
7185         if (has_code) {
7186             pm->op_code_list = expr;
7187             /* don't free op_code_list; its ops are embedded elsewhere too */
7188             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7189         }
7190
7191         if (is_split)
7192             /* make engine handle split ' ' specially */
7193             pm->op_pmflags |= PMf_SPLIT;
7194
7195         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7196          * to allow its op_next to be pointed past the regcomp and
7197          * preceding stacking ops;
7198          * OP_REGCRESET is there to reset taint before executing the
7199          * stacking ops */
7200         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7201             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7202
7203         if (pm->op_pmflags & PMf_HAS_CV) {
7204             /* we have a runtime qr with literal code. This means
7205              * that the qr// has been wrapped in a new CV, which
7206              * means that runtime consts, vars etc will have been compiled
7207              * against a new pad. So... we need to execute those ops
7208              * within the environment of the new CV. So wrap them in a call
7209              * to a new anon sub. i.e. for
7210              *
7211              *     qr/a$b(?{...})/,
7212              *
7213              * we build an anon sub that looks like
7214              *
7215              *     sub { "a", $b, '(?{...})' }
7216              *
7217              * and call it, passing the returned list to regcomp.
7218              * Or to put it another way, the list of ops that get executed
7219              * are:
7220              *
7221              *     normal              PMf_HAS_CV
7222              *     ------              -------------------
7223              *                         pushmark (for regcomp)
7224              *                         pushmark (for entersub)
7225              *                         anoncode
7226              *                         srefgen
7227              *                         entersub
7228              *     regcreset                  regcreset
7229              *     pushmark                   pushmark
7230              *     const("a")                 const("a")
7231              *     gvsv(b)                    gvsv(b)
7232              *     const("(?{...})")          const("(?{...})")
7233              *                                leavesub
7234              *     regcomp             regcomp
7235              */
7236
7237             SvREFCNT_inc_simple_void(PL_compcv);
7238             CvLVALUE_on(PL_compcv);
7239             /* these lines are just an unrolled newANONATTRSUB */
7240             expr = newSVOP(OP_ANONCODE, 0,
7241                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7242             cv_targ = expr->op_targ;
7243             expr = newUNOP(OP_REFGEN, 0, expr);
7244
7245             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7246         }
7247
7248         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7249         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7250                            | (reglist ? OPf_STACKED : 0);
7251         rcop->op_targ = cv_targ;
7252
7253         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7254         if (PL_hints & HINT_RE_EVAL)
7255             S_set_haseval(aTHX);
7256
7257         /* establish postfix order */
7258         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7259             LINKLIST(expr);
7260             rcop->op_next = expr;
7261             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7262         }
7263         else {
7264             rcop->op_next = LINKLIST(expr);
7265             expr->op_next = (OP*)rcop;
7266         }
7267
7268         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7269     }
7270
7271     if (repl) {
7272         OP *curop = repl;
7273         bool konst;
7274         /* If we are looking at s//.../e with a single statement, get past
7275            the implicit do{}. */
7276         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7277              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7278              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7279          {
7280             OP *sib;
7281             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7282             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7283              && !OpHAS_SIBLING(sib))
7284                 curop = sib;
7285         }
7286         if (curop->op_type == OP_CONST)
7287             konst = TRUE;
7288         else if (( (curop->op_type == OP_RV2SV ||
7289                     curop->op_type == OP_RV2AV ||
7290                     curop->op_type == OP_RV2HV ||
7291                     curop->op_type == OP_RV2GV)
7292                    && cUNOPx(curop)->op_first
7293                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7294                 || curop->op_type == OP_PADSV
7295                 || curop->op_type == OP_PADAV
7296                 || curop->op_type == OP_PADHV
7297                 || curop->op_type == OP_PADANY) {
7298             repl_has_vars = 1;
7299             konst = TRUE;
7300         }
7301         else konst = FALSE;
7302         if (konst
7303             && !(repl_has_vars
7304                  && (!PM_GETRE(pm)
7305                      || !RX_PRELEN(PM_GETRE(pm))
7306                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7307         {
7308             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7309             op_prepend_elem(o->op_type, scalar(repl), o);
7310         }
7311         else {
7312             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7313             rcop->op_private = 1;
7314
7315             /* establish postfix order */
7316             rcop->op_next = LINKLIST(repl);
7317             repl->op_next = (OP*)rcop;
7318
7319             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7320             assert(!(pm->op_pmflags & PMf_ONCE));
7321             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7322             rcop->op_next = 0;
7323         }
7324     }
7325
7326     return (OP*)pm;
7327 }
7328
7329 /*
7330 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7331
7332 Constructs, checks, and returns an op of any type that involves an
7333 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7334 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7335 takes ownership of one reference to it.
7336
7337 =cut
7338 */
7339
7340 OP *
7341 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7342 {
7343     dVAR;
7344     SVOP *svop;
7345
7346     PERL_ARGS_ASSERT_NEWSVOP;
7347
7348     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7349         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7350         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7351         || type == OP_CUSTOM);
7352
7353     NewOp(1101, svop, 1, SVOP);
7354     OpTYPE_set(svop, type);
7355     svop->op_sv = sv;
7356     svop->op_next = (OP*)svop;
7357     svop->op_flags = (U8)flags;
7358     svop->op_private = (U8)(0 | (flags >> 8));
7359     if (PL_opargs[type] & OA_RETSCALAR)
7360         scalar((OP*)svop);
7361     if (PL_opargs[type] & OA_TARGET)
7362         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7363     return CHECKOP(type, svop);
7364 }
7365
7366 /*
7367 =for apidoc Am|OP *|newDEFSVOP|
7368
7369 Constructs and returns an op to access C<$_>.
7370
7371 =cut
7372 */
7373
7374 OP *
7375 Perl_newDEFSVOP(pTHX)
7376 {
7377         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7378 }
7379
7380 #ifdef USE_ITHREADS
7381
7382 /*
7383 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7384
7385 Constructs, checks, and returns an op of any type that involves a
7386 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7387 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7388 is populated with C<sv>; this function takes ownership of one reference
7389 to it.
7390
7391 This function only exists if Perl has been compiled to use ithreads.
7392
7393 =cut
7394 */
7395
7396 OP *
7397 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7398 {
7399     dVAR;
7400     PADOP *padop;
7401
7402     PERL_ARGS_ASSERT_NEWPADOP;
7403
7404     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7405         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7406         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7407         || type == OP_CUSTOM);
7408
7409     NewOp(1101, padop, 1, PADOP);
7410     OpTYPE_set(padop, type);
7411     padop->op_padix =
7412         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7413     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7414     PAD_SETSV(padop->op_padix, sv);
7415     assert(sv);
7416     padop->op_next = (OP*)padop;
7417     padop->op_flags = (U8)flags;
7418     if (PL_opargs[type] & OA_RETSCALAR)
7419         scalar((OP*)padop);
7420     if (PL_opargs[type] & OA_TARGET)
7421         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7422     return CHECKOP(type, padop);
7423 }
7424
7425 #endif /* USE_ITHREADS */
7426
7427 /*
7428 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7429
7430 Constructs, checks, and returns an op of any type that involves an
7431 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7432 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7433 reference; calling this function does not transfer ownership of any
7434 reference to it.
7435
7436 =cut
7437 */
7438
7439 OP *
7440 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7441 {
7442     PERL_ARGS_ASSERT_NEWGVOP;
7443
7444 #ifdef USE_ITHREADS
7445     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7446 #else
7447     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7448 #endif
7449 }
7450
7451 /*
7452 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7453
7454 Constructs, checks, and returns an op of any type that involves an
7455 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7456 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7457 Depending on the op type, the memory referenced by C<pv> may be freed
7458 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7459 have been allocated using C<PerlMemShared_malloc>.
7460
7461 =cut
7462 */
7463
7464 OP *
7465 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7466 {
7467     dVAR;
7468     const bool utf8 = cBOOL(flags & SVf_UTF8);
7469     PVOP *pvop;
7470
7471     flags &= ~SVf_UTF8;
7472
7473     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7474         || type == OP_RUNCV || type == OP_CUSTOM
7475         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7476
7477     NewOp(1101, pvop, 1, PVOP);
7478     OpTYPE_set(pvop, type);
7479     pvop->op_pv = pv;
7480     pvop->op_next = (OP*)pvop;
7481     pvop->op_flags = (U8)flags;
7482     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7483     if (PL_opargs[type] & OA_RETSCALAR)
7484         scalar((OP*)pvop);
7485     if (PL_opargs[type] & OA_TARGET)
7486         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7487     return CHECKOP(type, pvop);
7488 }
7489
7490 void
7491 Perl_package(pTHX_ OP *o)
7492 {
7493     SV *const sv = cSVOPo->op_sv;
7494
7495     PERL_ARGS_ASSERT_PACKAGE;
7496
7497     SAVEGENERICSV(PL_curstash);
7498     save_item(PL_curstname);
7499
7500     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7501
7502     sv_setsv(PL_curstname, sv);
7503
7504     PL_hints |= HINT_BLOCK_SCOPE;
7505     PL_parser->copline = NOLINE;
7506
7507     op_free(o);
7508 }
7509
7510 void
7511 Perl_package_version( pTHX_ OP *v )
7512 {
7513     U32 savehints = PL_hints;
7514     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7515     PL_hints &= ~HINT_STRICT_VARS;
7516     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7517     PL_hints = savehints;
7518     op_free(v);
7519 }
7520
7521 void
7522 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7523 {
7524     OP *pack;
7525     OP *imop;
7526     OP *veop;
7527     SV *use_version = NULL;
7528
7529     PERL_ARGS_ASSERT_UTILIZE;
7530
7531     if (idop->op_type != OP_CONST)
7532         Perl_croak(aTHX_ "Module name must be constant");
7533
7534     veop = NULL;
7535
7536     if (version) {
7537         SV * const vesv = ((SVOP*)version)->op_sv;
7538
7539         if (!arg && !SvNIOKp(vesv)) {
7540             arg = version;
7541         }
7542         else {
7543             OP *pack;
7544             SV *meth;
7545
7546             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7547                 Perl_croak(aTHX_ "Version number must be a constant number");
7548
7549             /* Make copy of idop so we don't free it twice */
7550             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7551
7552             /* Fake up a method call to VERSION */
7553             meth = newSVpvs_share("VERSION");
7554             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7555                             op_append_elem(OP_LIST,
7556                                         op_prepend_elem(OP_LIST, pack, version),
7557                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7558         }
7559     }
7560
7561     /* Fake up an import/unimport */
7562     if (arg && arg->op_type == OP_STUB) {
7563         imop = arg;             /* no import on explicit () */
7564     }
7565     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7566         imop = NULL;            /* use 5.0; */
7567         if (aver)
7568             use_version = ((SVOP*)idop)->op_sv;
7569         else
7570             idop->op_private |= OPpCONST_NOVER;
7571     }
7572     else {
7573         SV *meth;
7574
7575         /* Make copy of idop so we don't free it twice */
7576         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7577
7578         /* Fake up a method call to import/unimport */
7579         meth = aver
7580             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7581         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7582                        op_append_elem(OP_LIST,
7583                                    op_prepend_elem(OP_LIST, pack, arg),
7584                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7585                        ));
7586     }
7587
7588     /* Fake up the BEGIN {}, which does its thing immediately. */
7589     newATTRSUB(floor,
7590         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7591         NULL,
7592         NULL,
7593         op_append_elem(OP_LINESEQ,
7594             op_append_elem(OP_LINESEQ,
7595                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7596                 newSTATEOP(0, NULL, veop)),
7597             newSTATEOP(0, NULL, imop) ));
7598
7599     if (use_version) {
7600         /* Enable the
7601          * feature bundle that corresponds to the required version. */
7602         use_version = sv_2mortal(new_version(use_version));
7603         S_enable_feature_bundle(aTHX_ use_version);
7604
7605         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7606         if (vcmp(use_version,
7607                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7608             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7609                 PL_hints |= HINT_STRICT_REFS;
7610             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7611                 PL_hints |= HINT_STRICT_SUBS;
7612             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7613                 PL_hints |= HINT_STRICT_VARS;
7614         }
7615         /* otherwise they are off */
7616         else {
7617             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7618                 PL_hints &= ~HINT_STRICT_REFS;
7619             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7620                 PL_hints &= ~HINT_STRICT_SUBS;
7621             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7622                 PL_hints &= ~HINT_STRICT_VARS;
7623         }
7624     }
7625
7626     /* The "did you use incorrect case?" warning used to be here.
7627      * The problem is that on case-insensitive filesystems one
7628      * might get false positives for "use" (and "require"):
7629      * "use Strict" or "require CARP" will work.  This causes
7630      * portability problems for the script: in case-strict
7631      * filesystems the script will stop working.
7632      *
7633      * The "incorrect case" warning checked whether "use Foo"
7634      * imported "Foo" to your namespace, but that is wrong, too:
7635      * there is no requirement nor promise in the language that
7636      * a Foo.pm should or would contain anything in package "Foo".
7637      *
7638      * There is very little Configure-wise that can be done, either:
7639      * the case-sensitivity of the build filesystem of Perl does not
7640      * help in guessing the case-sensitivity of the runtime environment.
7641      */
7642
7643     PL_hints |= HINT_BLOCK_SCOPE;
7644     PL_parser->copline = NOLINE;
7645     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7646 }
7647
7648 /*
7649 =head1 Embedding Functions
7650
7651 =for apidoc load_module
7652
7653 Loads the module whose name is pointed to by the string part of C<name>.
7654 Note that the actual module name, not its filename, should be given.
7655 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7656 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7657 trailing arguments can be used to specify arguments to the module's C<import()>
7658 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7659 on the flags. The flags argument is a bitwise-ORed collection of any of
7660 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7661 (or 0 for no flags).
7662
7663 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7664 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7665 the trailing optional arguments may be omitted entirely. Otherwise, if
7666 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7667 exactly one C<OP*>, containing the op tree that produces the relevant import
7668 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7669 will be used as import arguments; and the list must be terminated with C<(SV*)
7670 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7671 set, the trailing C<NULL> pointer is needed even if no import arguments are
7672 desired. The reference count for each specified C<SV*> argument is
7673 decremented. In addition, the C<name> argument is modified.
7674
7675 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7676 than C<use>.
7677
7678 =cut */
7679
7680 void
7681 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7682 {
7683     va_list args;
7684
7685     PERL_ARGS_ASSERT_LOAD_MODULE;
7686
7687     va_start(args, ver);
7688     vload_module(flags, name, ver, &args);
7689     va_end(args);
7690 }
7691
7692 #ifdef PERL_IMPLICIT_CONTEXT
7693 void
7694 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7695 {
7696     dTHX;
7697     va_list args;
7698     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7699     va_start(args, ver);
7700     vload_module(flags, name, ver, &args);
7701     va_end(args);
7702 }
7703 #endif
7704
7705 void
7706 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7707 {
7708     OP *veop, *imop;
7709     OP * modname;
7710     I32 floor;
7711
7712     PERL_ARGS_ASSERT_VLOAD_MODULE;
7713
7714     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7715      * that it has a PL_parser to play with while doing that, and also
7716      * that it doesn't mess with any existing parser, by creating a tmp
7717      * new parser with lex_start(). This won't actually be used for much,
7718      * since pp_require() will create another parser for the real work.
7719      * The ENTER/LEAVE pair protect callers from any side effects of use.
7720      *
7721      * start_subparse() creates a new PL_compcv. This means that any ops
7722      * allocated below will be allocated from that CV's op slab, and so
7723      * will be automatically freed if the utilise() fails
7724      */
7725
7726     ENTER;
7727     SAVEVPTR(PL_curcop);
7728     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7729     floor = start_subparse(FALSE, 0);
7730
7731     modname = newSVOP(OP_CONST, 0, name);
7732     modname->op_private |= OPpCONST_BARE;
7733     if (ver) {
7734         veop = newSVOP(OP_CONST, 0, ver);
7735     }
7736     else
7737         veop = NULL;
7738     if (flags & PERL_LOADMOD_NOIMPORT) {
7739         imop = sawparens(newNULLLIST());
7740     }
7741     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7742         imop = va_arg(*args, OP*);
7743     }
7744     else {
7745         SV *sv;
7746         imop = NULL;
7747         sv = va_arg(*args, SV*);
7748         while (sv) {
7749             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7750             sv = va_arg(*args, SV*);
7751         }
7752     }
7753
7754     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7755     LEAVE;
7756 }
7757
7758 PERL_STATIC_INLINE OP *
7759 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7760 {
7761     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7762                    newLISTOP(OP_LIST, 0, arg,
7763                              newUNOP(OP_RV2CV, 0,
7764                                      newGVOP(OP_GV, 0, gv))));
7765 }
7766
7767 OP *
7768 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7769 {
7770     OP *doop;
7771     GV *gv;
7772
7773     PERL_ARGS_ASSERT_DOFILE;
7774
7775     if (!force_builtin && (gv = gv_override("do", 2))) {
7776         doop = S_new_entersubop(aTHX_ gv, term);
7777     }
7778     else {
7779         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7780     }
7781     return doop;
7782 }
7783
7784 /*
7785 =head1 Optree construction
7786
7787 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7788
7789 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7790 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7791 be set automatically, and, shifted up eight bits, the eight bits of
7792 C<op_private>, except that the bit with value 1 or 2 is automatically
7793 set as required.  C<listval> and C<subscript> supply the parameters of
7794 the slice; they are consumed by this function and become part of the
7795 constructed op tree.
7796
7797 =cut
7798 */
7799
7800 OP *
7801 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7802 {
7803     return newBINOP(OP_LSLICE, flags,
7804             list(force_list(subscript, 1)),
7805             list(force_list(listval,   1)) );
7806 }
7807
7808 #define ASSIGN_LIST   1
7809 #define ASSIGN_REF    2
7810
7811 STATIC I32
7812 S_assignment_type(pTHX_ const OP *o)
7813 {
7814     unsigned type;
7815     U8 flags;
7816     U8 ret;
7817
7818     if (!o)
7819         return TRUE;
7820
7821     if (o->op_type == OP_SREFGEN)
7822     {
7823         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7824         type = kid->op_type;
7825         flags = o->op_flags | kid->op_flags;
7826         if (!(flags & OPf_PARENS)
7827           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7828               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7829             return ASSIGN_REF;
7830         ret = ASSIGN_REF;
7831     } else {
7832         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7833             o = cUNOPo->op_first;
7834         flags = o->op_flags;
7835         type = o->op_type;
7836         ret = 0;
7837     }
7838
7839     if (type == OP_COND_EXPR) {
7840         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7841         const I32 t = assignment_type(sib);
7842         const I32 f = assignment_type(OpSIBLING(sib));
7843
7844         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7845             return ASSIGN_LIST;
7846         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7847             yyerror("Assignment to both a list and a scalar");
7848         return FALSE;
7849     }
7850
7851     if (type == OP_LIST &&
7852         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7853         o->op_private & OPpLVAL_INTRO)
7854         return ret;
7855
7856     if (type == OP_LIST || flags & OPf_PARENS ||
7857         type == OP_RV2AV || type == OP_RV2HV ||
7858         type == OP_ASLICE || type == OP_HSLICE ||
7859         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7860         return TRUE;
7861
7862     if (type == OP_PADAV || type == OP_PADHV)
7863         return TRUE;
7864
7865     if (type == OP_RV2SV)
7866         return ret;
7867
7868     return ret;
7869 }
7870
7871 static OP *
7872 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7873 {
7874     dVAR;
7875     const PADOFFSET target = padop->op_targ;
7876     OP *const other = newOP(OP_PADSV,
7877                             padop->op_flags
7878                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7879     OP *const first = newOP(OP_NULL, 0);
7880     OP *const nullop = newCONDOP(0, first, initop, other);
7881     /* XXX targlex disabled for now; see ticket #124160
7882         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7883      */
7884     OP *const condop = first->op_next;
7885
7886     OpTYPE_set(condop, OP_ONCE);
7887     other->op_targ = target;
7888     nullop->op_flags |= OPf_WANT_SCALAR;
7889
7890     /* Store the initializedness of state vars in a separate
7891        pad entry.  */
7892     condop->op_targ =
7893       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7894     /* hijacking PADSTALE for uninitialized state variables */
7895     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7896
7897     return nullop;
7898 }
7899
7900 /*
7901 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7902
7903 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7904 supply the parameters of the assignment; they are consumed by this
7905 function and become part of the constructed op tree.
7906
7907 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7908 a suitable conditional optree is constructed.  If C<optype> is the opcode
7909 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7910 performs the binary operation and assigns the result to the left argument.
7911 Either way, if C<optype> is non-zero then C<flags> has no effect.
7912
7913 If C<optype> is zero, then a plain scalar or list assignment is
7914 constructed.  Which type of assignment it is is automatically determined.
7915 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7916 will be set automatically, and, shifted up eight bits, the eight bits
7917 of C<op_private>, except that the bit with value 1 or 2 is automatically
7918 set as required.
7919
7920 =cut
7921 */
7922
7923 OP *
7924 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7925 {
7926     OP *o;
7927     I32 assign_type;
7928
7929     if (optype) {
7930         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7931             right = scalar(right);
7932             return newLOGOP(optype, 0,
7933                 op_lvalue(scalar(left), optype),
7934                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7935         }
7936         else {
7937             return newBINOP(optype, OPf_STACKED,
7938                 op_lvalue(scalar(left), optype), scalar(right));
7939         }
7940     }
7941
7942     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7943         OP *state_var_op = NULL;
7944         static const char no_list_state[] = "Initialization of state variables"
7945             " in list currently forbidden";
7946         OP *curop;
7947
7948         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7949             left->op_private &= ~ OPpSLICEWARNING;
7950
7951         PL_modcount = 0;
7952         left = op_lvalue(left, OP_AASSIGN);
7953         curop = list(force_list(left, 1));
7954         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7955         o->op_private = (U8)(0 | (flags >> 8));
7956
7957         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7958         {
7959             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7960             if (!(left->op_flags & OPf_PARENS) &&
7961                     lop->op_type == OP_PUSHMARK &&
7962                     (vop = OpSIBLING(lop)) &&
7963                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7964                     !(vop->op_flags & OPf_PARENS) &&
7965                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7966                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7967                     (eop = OpSIBLING(vop)) &&
7968                     eop->op_type == OP_ENTERSUB &&
7969                     !OpHAS_SIBLING(eop)) {
7970                 state_var_op = vop;
7971             } else {
7972                 while (lop) {
7973                     if ((lop->op_type == OP_PADSV ||
7974                          lop->op_type == OP_PADAV ||
7975                          lop->op_type == OP_PADHV ||
7976                          lop->op_type == OP_PADANY)
7977                       && (lop->op_private & OPpPAD_STATE)
7978                     )
7979                         yyerror(no_list_state);
7980                     lop = OpSIBLING(lop);
7981                 }
7982             }
7983         }
7984         else if (  (left->op_private & OPpLVAL_INTRO)
7985                 && (left->op_private & OPpPAD_STATE)
7986                 && (   left->op_type == OP_PADSV
7987                     || left->op_type == OP_PADAV
7988                     || left->op_type == OP_PADHV
7989                     || left->op_type == OP_PADANY)
7990         ) {
7991                 /* All single variable list context state assignments, hence
7992                    state ($a) = ...
7993                    (state $a) = ...
7994                    state @a = ...
7995                    state (@a) = ...
7996                    (state @a) = ...
7997                    state %a = ...
7998                    state (%a) = ...
7999                    (state %a) = ...
8000                 */
8001                 if (left->op_flags & OPf_PARENS)
8002                     yyerror(no_list_state);
8003                 else
8004                     state_var_op = left;
8005         }
8006
8007         /* optimise @a = split(...) into:
8008         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8009         * @a, my @a, local @a:  split(...)          (where @a is attached to
8010         *                                            the split op itself)
8011         */
8012
8013         if (   right
8014             && right->op_type == OP_SPLIT
8015             /* don't do twice, e.g. @b = (@a = split) */
8016             && !(right->op_private & OPpSPLIT_ASSIGN))
8017         {
8018             OP *gvop = NULL;
8019
8020             if (   (  left->op_type == OP_RV2AV
8021                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8022                 || left->op_type == OP_PADAV)
8023             {
8024                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8025                 OP *tmpop;
8026                 if (gvop) {
8027 #ifdef USE_ITHREADS
8028                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8029                         = cPADOPx(gvop)->op_padix;
8030                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
8031 #else
8032                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8033                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8034                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
8035 #endif
8036                     right->op_private |=
8037                         left->op_private & OPpOUR_INTRO;
8038                 }
8039                 else {
8040                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8041                     left->op_targ = 0;  /* steal it */
8042                     right->op_private |= OPpSPLIT_LEX;
8043                 }
8044                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8045
8046               detach_split:
8047                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8048                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8049                 assert(OpSIBLING(tmpop) == right);
8050                 assert(!OpHAS_SIBLING(right));
8051                 /* detach the split subtreee from the o tree,
8052                  * then free the residual o tree */
8053                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8054                 op_free(o);                     /* blow off assign */
8055                 right->op_private |= OPpSPLIT_ASSIGN;
8056                 right->op_flags &= ~OPf_WANT;
8057                         /* "I don't know and I don't care." */
8058                 return right;
8059             }
8060             else if (left->op_type == OP_RV2AV) {
8061                 /* @{expr} */
8062
8063                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8064                 assert(OpSIBLING(pushop) == left);
8065                 /* Detach the array ...  */
8066                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8067                 /* ... and attach it to the split.  */
8068                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8069                                   0, left);
8070                 right->op_flags |= OPf_STACKED;
8071                 /* Detach split and expunge aassign as above.  */
8072                 goto detach_split;
8073             }
8074             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8075                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8076             {
8077                 /* convert split(...,0) to split(..., PL_modcount+1) */
8078                 SV ** const svp =
8079                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8080                 SV * const sv = *svp;
8081                 if (SvIOK(sv) && SvIVX(sv) == 0)
8082                 {
8083                   if (right->op_private & OPpSPLIT_IMPLIM) {
8084                     /* our own SV, created in ck_split */
8085                     SvREADONLY_off(sv);
8086                     sv_setiv(sv, PL_modcount+1);
8087                   }
8088                   else {
8089                     /* SV may belong to someone else */
8090                     SvREFCNT_dec(sv);
8091                     *svp = newSViv(PL_modcount+1);
8092                   }
8093                 }
8094             }
8095         }
8096
8097         if (state_var_op)
8098             o = S_newONCEOP(aTHX_ o, state_var_op);
8099         return o;
8100     }
8101     if (assign_type == ASSIGN_REF)
8102         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8103     if (!right)
8104         right = newOP(OP_UNDEF, 0);
8105     if (right->op_type == OP_READLINE) {
8106         right->op_flags |= OPf_STACKED;
8107         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8108                 scalar(right));
8109     }
8110     else {
8111         o = newBINOP(OP_SASSIGN, flags,
8112             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8113     }
8114     return o;
8115 }
8116
8117 /*
8118 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8119
8120 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8121 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8122 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8123 If C<label> is non-null, it supplies the name of a label to attach to
8124 the state op; this function takes ownership of the memory pointed at by
8125 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8126 for the state op.
8127
8128 If C<o> is null, the state op is returned.  Otherwise the state op is
8129 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8130 is consumed by this function and becomes part of the returned op tree.
8131
8132 =cut
8133 */
8134
8135 OP *
8136 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8137 {
8138     dVAR;
8139     const U32 seq = intro_my();
8140     const U32 utf8 = flags & SVf_UTF8;
8141     COP *cop;
8142
8143     PL_parser->parsed_sub = 0;
8144
8145     flags &= ~SVf_UTF8;
8146
8147     NewOp(1101, cop, 1, COP);
8148     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8149         OpTYPE_set(cop, OP_DBSTATE);
8150     }
8151     else {
8152         OpTYPE_set(cop, OP_NEXTSTATE);
8153     }
8154     cop->op_flags = (U8)flags;
8155     CopHINTS_set(cop, PL_hints);
8156 #ifdef VMS
8157     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8158 #endif
8159     cop->op_next = (OP*)cop;
8160
8161     cop->cop_seq = seq;
8162     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8163     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8164     if (label) {
8165         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8166
8167         PL_hints |= HINT_BLOCK_SCOPE;
8168         /* It seems that we need to defer freeing this pointer, as other parts
8169            of the grammar end up wanting to copy it after this op has been
8170            created. */
8171         SAVEFREEPV(label);
8172     }
8173
8174     if (PL_parser->preambling != NOLINE) {
8175         CopLINE_set(cop, PL_parser->preambling);
8176         PL_parser->copline = NOLINE;
8177     }
8178     else if (PL_parser->copline == NOLINE)
8179         CopLINE_set(cop, CopLINE(PL_curcop));
8180     else {
8181         CopLINE_set(cop, PL_parser->copline);
8182         PL_parser->copline = NOLINE;
8183     }
8184 #ifdef USE_ITHREADS
8185     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8186 #else
8187     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8188 #endif
8189     CopSTASH_set(cop, PL_curstash);
8190
8191     if (cop->op_type == OP_DBSTATE) {
8192         /* this line can have a breakpoint - store the cop in IV */
8193         AV *av = CopFILEAVx(PL_curcop);
8194         if (av) {
8195             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8196             if (svp && *svp != &PL_sv_undef ) {
8197                 (void)SvIOK_on(*svp);
8198                 SvIV_set(*svp, PTR2IV(cop));
8199             }
8200         }
8201     }
8202
8203     if (flags & OPf_SPECIAL)
8204         op_null((OP*)cop);
8205     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8206 }
8207
8208 /*
8209 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8210
8211 Constructs, checks, and returns a logical (flow control) op.  C<type>
8212 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8213 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8214 the eight bits of C<op_private>, except that the bit with value 1 is
8215 automatically set.  C<first> supplies the expression controlling the
8216 flow, and C<other> supplies the side (alternate) chain of ops; they are
8217 consumed by this function and become part of the constructed op tree.
8218
8219 =cut
8220 */
8221
8222 OP *
8223 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8224 {
8225     PERL_ARGS_ASSERT_NEWLOGOP;
8226
8227     return new_logop(type, flags, &first, &other);
8228 }
8229
8230 STATIC OP *
8231 S_search_const(pTHX_ OP *o)
8232 {
8233     PERL_ARGS_ASSERT_SEARCH_CONST;
8234
8235     switch (o->op_type) {
8236         case OP_CONST:
8237             return o;
8238         case OP_NULL:
8239             if (o->op_flags & OPf_KIDS)
8240                 return search_const(cUNOPo->op_first);
8241             break;
8242         case OP_LEAVE:
8243         case OP_SCOPE:
8244         case OP_LINESEQ:
8245         {
8246             OP *kid;
8247             if (!(o->op_flags & OPf_KIDS))
8248                 return NULL;
8249             kid = cLISTOPo->op_first;
8250             do {
8251                 switch (kid->op_type) {
8252                     case OP_ENTER:
8253                     case OP_NULL:
8254                     case OP_NEXTSTATE:
8255                         kid = OpSIBLING(kid);
8256                         break;
8257                     default:
8258                         if (kid != cLISTOPo->op_last)
8259                             return NULL;
8260                         goto last;
8261                 }
8262             } while (kid);
8263             if (!kid)
8264                 kid = cLISTOPo->op_last;
8265           last:
8266             return search_const(kid);
8267         }
8268     }
8269
8270     return NULL;
8271 }
8272
8273 STATIC OP *
8274 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8275 {
8276     dVAR;
8277     LOGOP *logop;
8278     OP *o;
8279     OP *first;
8280     OP *other;
8281     OP *cstop = NULL;
8282     int prepend_not = 0;
8283
8284     PERL_ARGS_ASSERT_NEW_LOGOP;
8285
8286     first = *firstp;
8287     other = *otherp;
8288
8289     /* [perl #59802]: Warn about things like "return $a or $b", which
8290        is parsed as "(return $a) or $b" rather than "return ($a or
8291        $b)".  NB: This also applies to xor, which is why we do it
8292        here.
8293      */
8294     switch (first->op_type) {
8295     case OP_NEXT:
8296     case OP_LAST:
8297     case OP_REDO:
8298         /* XXX: Perhaps we should emit a stronger warning for these.
8299            Even with the high-precedence operator they don't seem to do
8300            anything sensible.
8301
8302            But until we do, fall through here.
8303          */
8304     case OP_RETURN:
8305     case OP_EXIT:
8306     case OP_DIE:
8307     case OP_GOTO:
8308         /* XXX: Currently we allow people to "shoot themselves in the
8309            foot" by explicitly writing "(return $a) or $b".
8310
8311            Warn unless we are looking at the result from folding or if
8312            the programmer explicitly grouped the operators like this.
8313            The former can occur with e.g.
8314
8315                 use constant FEATURE => ( $] >= ... );
8316                 sub { not FEATURE and return or do_stuff(); }
8317          */
8318         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8319             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8320                            "Possible precedence issue with control flow operator");
8321         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8322            the "or $b" part)?
8323         */
8324         break;
8325     }
8326
8327     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8328         return newBINOP(type, flags, scalar(first), scalar(other));
8329
8330     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8331         || type == OP_CUSTOM);
8332
8333     scalarboolean(first);
8334
8335     /* search for a constant op that could let us fold the test */
8336     if ((cstop = search_const(first))) {
8337         if (cstop->op_private & OPpCONST_STRICT)
8338             no_bareword_allowed(cstop);
8339         else if ((cstop->op_private & OPpCONST_BARE))
8340                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8341         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8342             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8343             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8344             /* Elide the (constant) lhs, since it can't affect the outcome */
8345             *firstp = NULL;
8346             if (other->op_type == OP_CONST)
8347                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8348             op_free(first);
8349             if (other->op_type == OP_LEAVE)
8350                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8351             else if (other->op_type == OP_MATCH
8352                   || other->op_type == OP_SUBST
8353                   || other->op_type == OP_TRANSR
8354                   || other->op_type == OP_TRANS)
8355                 /* Mark the op as being unbindable with =~ */
8356                 other->op_flags |= OPf_SPECIAL;
8357
8358             other->op_folded = 1;
8359             return other;
8360         }
8361         else {
8362             /* Elide the rhs, since the outcome is entirely determined by
8363              * the (constant) lhs */
8364
8365             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8366             const OP *o2 = other;
8367             if ( ! (o2->op_type == OP_LIST
8368                     && (( o2 = cUNOPx(o2)->op_first))
8369                     && o2->op_type == OP_PUSHMARK
8370                     && (( o2 = OpSIBLING(o2))) )
8371             )
8372                 o2 = other;
8373             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8374                         || o2->op_type == OP_PADHV)
8375                 && o2->op_private & OPpLVAL_INTRO
8376                 && !(o2->op_private & OPpPAD_STATE))
8377             {
8378         Perl_croak(aTHX_ "This use of my() in false conditional is "
8379                           "no longer allowed");
8380             }
8381
8382             *otherp = NULL;
8383             if (cstop->op_type == OP_CONST)
8384                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8385             op_free(other);
8386             return first;
8387         }
8388     }
8389     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8390         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8391     {
8392         const OP * const k1 = ((UNOP*)first)->op_first;
8393         const OP * const k2 = OpSIBLING(k1);
8394         OPCODE warnop = 0;
8395         switch (first->op_type)
8396         {
8397         case OP_NULL:
8398             if (k2 && k2->op_type == OP_READLINE
8399                   && (k2->op_flags & OPf_STACKED)
8400                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8401             {
8402                 warnop = k2->op_type;
8403             }
8404             break;
8405
8406         case OP_SASSIGN:
8407             if (k1->op_type == OP_READDIR
8408                   || k1->op_type == OP_GLOB
8409                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8410                  || k1->op_type == OP_EACH
8411                  || k1->op_type == OP_AEACH)
8412             {
8413                 warnop = ((k1->op_type == OP_NULL)
8414                           ? (OPCODE)k1->op_targ : k1->op_type);
8415             }
8416             break;
8417         }
8418         if (warnop) {
8419             const line_t oldline = CopLINE(PL_curcop);
8420             /* This ensures that warnings are reported at the first line
8421                of the construction, not the last.  */
8422             CopLINE_set(PL_curcop, PL_parser->copline);
8423             Perl_warner(aTHX_ packWARN(WARN_MISC),
8424                  "Value of %s%s can be \"0\"; test with defined()",
8425                  PL_op_desc[warnop],
8426                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8427                   ? " construct" : "() operator"));
8428             CopLINE_set(PL_curcop, oldline);
8429         }
8430     }
8431
8432     /* optimize AND and OR ops that have NOTs as children */
8433     if (first->op_type == OP_NOT
8434         && (first->op_flags & OPf_KIDS)
8435         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8436             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8437         ) {
8438         if (type == OP_AND || type == OP_OR) {
8439             if (type == OP_AND)
8440                 type = OP_OR;
8441             else
8442                 type = OP_AND;
8443             op_null(first);
8444             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8445                 op_null(other);
8446                 prepend_not = 1; /* prepend a NOT op later */
8447             }
8448         }
8449     }
8450
8451     logop = alloc_LOGOP(type, first, LINKLIST(other));
8452     logop->op_flags |= (U8)flags;
8453     logop->op_private = (U8)(1 | (flags >> 8));
8454
8455     /* establish postfix order */
8456     logop->op_next = LINKLIST(first);
8457     first->op_next = (OP*)logop;
8458     assert(!OpHAS_SIBLING(first));
8459     op_sibling_splice((OP*)logop, first, 0, other);
8460
8461     CHECKOP(type,logop);
8462
8463     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8464                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8465                 (OP*)logop);
8466     other->op_next = o;
8467
8468     return o;
8469 }
8470
8471 /*
8472 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8473
8474 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8475 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8476 will be set automatically, and, shifted up eight bits, the eight bits of
8477 C<op_private>, except that the bit with value 1 is automatically set.
8478 C<first> supplies the expression selecting between the two branches,
8479 and C<trueop> and C<falseop> supply the branches; they are consumed by
8480 this function and become part of the constructed op tree.
8481
8482 =cut
8483 */
8484
8485 OP *
8486 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8487 {
8488     dVAR;
8489     LOGOP *logop;
8490     OP *start;
8491     OP *o;
8492     OP *cstop;
8493
8494     PERL_ARGS_ASSERT_NEWCONDOP;
8495
8496     if (!falseop)
8497         return newLOGOP(OP_AND, 0, first, trueop);
8498     if (!trueop)
8499         return newLOGOP(OP_OR, 0, first, falseop);
8500
8501     scalarboolean(first);
8502     if ((cstop = search_const(first))) {
8503         /* Left or right arm of the conditional?  */
8504         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8505         OP *live = left ? trueop : falseop;
8506         OP *const dead = left ? falseop : trueop;
8507         if (cstop->op_private & OPpCONST_BARE &&
8508             cstop->op_private & OPpCONST_STRICT) {
8509             no_bareword_allowed(cstop);
8510         }
8511         op_free(first);
8512         op_free(dead);
8513         if (live->op_type == OP_LEAVE)
8514             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8515         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8516               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8517             /* Mark the op as being unbindable with =~ */
8518             live->op_flags |= OPf_SPECIAL;
8519         live->op_folded = 1;
8520         return live;
8521     }
8522     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8523     logop->op_flags |= (U8)flags;
8524     logop->op_private = (U8)(1 | (flags >> 8));
8525     logop->op_next = LINKLIST(falseop);
8526
8527     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8528             logop);
8529
8530     /* establish postfix order */
8531     start = LINKLIST(first);
8532     first->op_next = (OP*)logop;
8533
8534     /* make first, trueop, falseop siblings */
8535     op_sibling_splice((OP*)logop, first,  0, trueop);
8536     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8537
8538     o = newUNOP(OP_NULL, 0, (OP*)logop);
8539
8540     trueop->op_next = falseop->op_next = o;
8541
8542     o->op_next = start;
8543     return o;
8544 }
8545
8546 /*
8547 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8548
8549 Constructs and returns a C<range> op, with subordinate C<flip> and
8550 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8551 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8552 for both the C<flip> and C<range> ops, except that the bit with value
8553 1 is automatically set.  C<left> and C<right> supply the expressions
8554 controlling the endpoints of the range; they are consumed by this function
8555 and become part of the constructed op tree.
8556
8557 =cut
8558 */
8559
8560 OP *
8561 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8562 {
8563     LOGOP *range;
8564     OP *flip;
8565     OP *flop;
8566     OP *leftstart;
8567     OP *o;
8568
8569     PERL_ARGS_ASSERT_NEWRANGE;
8570
8571     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8572     range->op_flags = OPf_KIDS;
8573     leftstart = LINKLIST(left);
8574     range->op_private = (U8)(1 | (flags >> 8));
8575
8576     /* make left and right siblings */
8577     op_sibling_splice((OP*)range, left, 0, right);
8578
8579     range->op_next = (OP*)range;
8580     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8581     flop = newUNOP(OP_FLOP, 0, flip);
8582     o = newUNOP(OP_NULL, 0, flop);
8583     LINKLIST(flop);
8584     range->op_next = leftstart;
8585
8586     left->op_next = flip;
8587     right->op_next = flop;
8588
8589     range->op_targ =
8590         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8591     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8592     flip->op_targ =
8593         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8594     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8595     SvPADTMP_on(PAD_SV(flip->op_targ));
8596
8597     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8598     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8599
8600     /* check barewords before they might be optimized aways */
8601     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8602         no_bareword_allowed(left);
8603     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8604         no_bareword_allowed(right);
8605
8606     flip->op_next = o;
8607     if (!flip->op_private || !flop->op_private)
8608         LINKLIST(o);            /* blow off optimizer unless constant */
8609
8610     return o;
8611 }
8612
8613 /*
8614 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8615
8616 Constructs, checks, and returns an op tree expressing a loop.  This is
8617 only a loop in the control flow through the op tree; it does not have
8618 the heavyweight loop structure that allows exiting the loop by C<last>
8619 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8620 top-level op, except that some bits will be set automatically as required.
8621 C<expr> supplies the expression controlling loop iteration, and C<block>
8622 supplies the body of the loop; they are consumed by this function and
8623 become part of the constructed op tree.  C<debuggable> is currently
8624 unused and should always be 1.
8625
8626 =cut
8627 */
8628
8629 OP *
8630 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8631 {
8632     OP* listop;
8633     OP* o;
8634     const bool once = block && block->op_flags & OPf_SPECIAL &&
8635                       block->op_type == OP_NULL;
8636
8637     PERL_UNUSED_ARG(debuggable);
8638
8639     if (expr) {
8640         if (once && (
8641               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8642            || (  expr->op_type == OP_NOT
8643               && cUNOPx(expr)->op_first->op_type == OP_CONST
8644               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8645               )
8646            ))
8647             /* Return the block now, so that S_new_logop does not try to
8648                fold it away. */
8649             return block;       /* do {} while 0 does once */
8650         if (expr->op_type == OP_READLINE
8651             || expr->op_type == OP_READDIR
8652             || expr->op_type == OP_GLOB
8653             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8654             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8655             expr = newUNOP(OP_DEFINED, 0,
8656                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8657         } else if (expr->op_flags & OPf_KIDS) {
8658             const OP * const k1 = ((UNOP*)expr)->op_first;
8659             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8660             switch (expr->op_type) {
8661               case OP_NULL:
8662                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8663                       && (k2->op_flags & OPf_STACKED)
8664                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8665                     expr = newUNOP(OP_DEFINED, 0, expr);
8666                 break;
8667
8668               case OP_SASSIGN:
8669                 if (k1 && (k1->op_type == OP_READDIR
8670                       || k1->op_type == OP_GLOB
8671                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8672                      || k1->op_type == OP_EACH
8673                      || k1->op_type == OP_AEACH))
8674                     expr = newUNOP(OP_DEFINED, 0, expr);
8675                 break;
8676             }
8677         }
8678     }
8679
8680     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8681      * op, in listop. This is wrong. [perl #27024] */
8682     if (!block)
8683         block = newOP(OP_NULL, 0);
8684     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8685     o = new_logop(OP_AND, 0, &expr, &listop);
8686
8687     if (once) {
8688         ASSUME(listop);
8689     }
8690
8691     if (listop)
8692         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8693
8694     if (once && o != listop)
8695     {
8696         assert(cUNOPo->op_first->op_type == OP_AND
8697             || cUNOPo->op_first->op_type == OP_OR);
8698         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8699     }
8700
8701     if (o == listop)
8702         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8703
8704     o->op_flags |= flags;
8705     o = op_scope(o);
8706     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8707     return o;
8708 }
8709
8710 /*
8711 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8712
8713 Constructs, checks, and returns an op tree expressing a C<while> loop.
8714 This is a heavyweight loop, with structure that allows exiting the loop
8715 by C<last> and suchlike.
8716
8717 C<loop> is an optional preconstructed C<enterloop> op to use in the
8718 loop; if it is null then a suitable op will be constructed automatically.
8719 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8720 main body of the loop, and C<cont> optionally supplies a C<continue> block
8721 that operates as a second half of the body.  All of these optree inputs
8722 are consumed by this function and become part of the constructed op tree.
8723
8724 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8725 op and, shifted up eight bits, the eight bits of C<op_private> for
8726 the C<leaveloop> op, except that (in both cases) some bits will be set
8727 automatically.  C<debuggable> is currently unused and should always be 1.
8728 C<has_my> can be supplied as true to force the
8729 loop body to be enclosed in its own scope.
8730
8731 =cut
8732 */
8733
8734 OP *
8735 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8736         OP *expr, OP *block, OP *cont, I32 has_my)
8737 {
8738     dVAR;
8739     OP *redo;
8740     OP *next = NULL;
8741     OP *listop;
8742     OP *o;
8743     U8 loopflags = 0;
8744
8745     PERL_UNUSED_ARG(debuggable);
8746
8747     if (expr) {
8748         if (expr->op_type == OP_READLINE
8749          || expr->op_type == OP_READDIR
8750          || expr->op_type == OP_GLOB
8751          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8752                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8753             expr = newUNOP(OP_DEFINED, 0,
8754                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8755         } else if (expr->op_flags & OPf_KIDS) {
8756             const OP * const k1 = ((UNOP*)expr)->op_first;
8757             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8758             switch (expr->op_type) {
8759               case OP_NULL:
8760                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8761                       && (k2->op_flags & OPf_STACKED)
8762                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8763                     expr = newUNOP(OP_DEFINED, 0, expr);
8764                 break;
8765
8766               case OP_SASSIGN:
8767                 if (k1 && (k1->op_type == OP_READDIR
8768                       || k1->op_type == OP_GLOB
8769                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8770                      || k1->op_type == OP_EACH
8771                      || k1->op_type == OP_AEACH))
8772                     expr = newUNOP(OP_DEFINED, 0, expr);
8773                 break;
8774             }
8775         }
8776     }
8777
8778     if (!block)
8779         block = newOP(OP_NULL, 0);
8780     else if (cont || has_my) {
8781         block = op_scope(block);
8782     }
8783
8784     if (cont) {
8785         next = LINKLIST(cont);
8786     }
8787     if (expr) {
8788         OP * const unstack = newOP(OP_UNSTACK, 0);
8789         if (!next)
8790             next = unstack;
8791         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8792     }
8793
8794     assert(block);
8795     listop = op_append_list(OP_LINESEQ, block, cont);
8796     assert(listop);
8797     redo = LINKLIST(listop);
8798
8799     if (expr) {
8800         scalar(listop);
8801         o = new_logop(OP_AND, 0, &expr, &listop);
8802         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8803             op_free((OP*)loop);
8804             return expr;                /* listop already freed by new_logop */
8805         }
8806         if (listop)
8807             ((LISTOP*)listop)->op_last->op_next =
8808                 (o == listop ? redo : LINKLIST(o));
8809     }
8810     else
8811         o = listop;
8812
8813     if (!loop) {
8814         NewOp(1101,loop,1,LOOP);
8815         OpTYPE_set(loop, OP_ENTERLOOP);
8816         loop->op_private = 0;
8817         loop->op_next = (OP*)loop;
8818     }
8819
8820     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8821
8822     loop->op_redoop = redo;
8823     loop->op_lastop = o;
8824     o->op_private |= loopflags;
8825
8826     if (next)
8827         loop->op_nextop = next;
8828     else
8829         loop->op_nextop = o;
8830
8831     o->op_flags |= flags;
8832     o->op_private |= (flags >> 8);
8833     return o;
8834 }
8835
8836 /*
8837 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8838
8839 Constructs, checks, and returns an op tree expressing a C<foreach>
8840 loop (iteration through a list of values).  This is a heavyweight loop,
8841 with structure that allows exiting the loop by C<last> and suchlike.
8842
8843 C<sv> optionally supplies the variable that will be aliased to each
8844 item in turn; if null, it defaults to C<$_>.
8845 C<expr> supplies the list of values to iterate over.  C<block> supplies
8846 the main body of the loop, and C<cont> optionally supplies a C<continue>
8847 block that operates as a second half of the body.  All of these optree
8848 inputs are consumed by this function and become part of the constructed
8849 op tree.
8850
8851 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8852 op and, shifted up eight bits, the eight bits of C<op_private> for
8853 the C<leaveloop> op, except that (in both cases) some bits will be set
8854 automatically.
8855
8856 =cut
8857 */
8858
8859 OP *
8860 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8861 {
8862     dVAR;
8863     LOOP *loop;
8864     OP *wop;
8865     PADOFFSET padoff = 0;
8866     I32 iterflags = 0;
8867     I32 iterpflags = 0;
8868
8869     PERL_ARGS_ASSERT_NEWFOROP;
8870
8871     if (sv) {
8872         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8873             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8874             OpTYPE_set(sv, OP_RV2GV);
8875
8876             /* The op_type check is needed to prevent a possible segfault
8877              * if the loop variable is undeclared and 'strict vars' is in
8878              * effect. This is illegal but is nonetheless parsed, so we
8879              * may reach this point with an OP_CONST where we're expecting
8880              * an OP_GV.
8881              */
8882             if (cUNOPx(sv)->op_first->op_type == OP_GV
8883              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8884                 iterpflags |= OPpITER_DEF;
8885         }
8886         else if (sv->op_type == OP_PADSV) { /* private variable */
8887             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8888             padoff = sv->op_targ;
8889             sv->op_targ = 0;
8890             op_free(sv);
8891             sv = NULL;
8892             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8893         }
8894         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8895             NOOP;
8896         else
8897             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8898         if (padoff) {
8899             PADNAME * const pn = PAD_COMPNAME(padoff);
8900             const char * const name = PadnamePV(pn);
8901
8902             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8903                 iterpflags |= OPpITER_DEF;
8904         }
8905     }
8906     else {
8907         sv = newGVOP(OP_GV, 0, PL_defgv);
8908         iterpflags |= OPpITER_DEF;
8909     }
8910
8911     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8912         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8913         iterflags |= OPf_STACKED;
8914     }
8915     else if (expr->op_type == OP_NULL &&
8916              (expr->op_flags & OPf_KIDS) &&
8917              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8918     {
8919         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8920          * set the STACKED flag to indicate that these values are to be
8921          * treated as min/max values by 'pp_enteriter'.
8922          */
8923         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8924         LOGOP* const range = (LOGOP*) flip->op_first;
8925         OP* const left  = range->op_first;
8926         OP* const right = OpSIBLING(left);
8927         LISTOP* listop;
8928
8929         range->op_flags &= ~OPf_KIDS;
8930         /* detach range's children */
8931         op_sibling_splice((OP*)range, NULL, -1, NULL);
8932
8933         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8934         listop->op_first->op_next = range->op_next;
8935         left->op_next = range->op_other;
8936         right->op_next = (OP*)listop;
8937         listop->op_next = listop->op_first;
8938
8939         op_free(expr);
8940         expr = (OP*)(listop);
8941         op_null(expr);
8942         iterflags |= OPf_STACKED;
8943     }
8944     else {
8945         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8946     }
8947
8948     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8949                                   op_append_elem(OP_LIST, list(expr),
8950                                                  scalar(sv)));
8951     assert(!loop->op_next);
8952     /* for my  $x () sets OPpLVAL_INTRO;
8953      * for our $x () sets OPpOUR_INTRO */
8954     loop->op_private = (U8)iterpflags;
8955     if (loop->op_slabbed
8956      && DIFF(loop, OpSLOT(loop)->opslot_next)
8957          < SIZE_TO_PSIZE(sizeof(LOOP)))
8958     {
8959         LOOP *tmp;
8960         NewOp(1234,tmp,1,LOOP);
8961         Copy(loop,tmp,1,LISTOP);
8962         assert(loop->op_last->op_sibparent == (OP*)loop);
8963         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8964         S_op_destroy(aTHX_ (OP*)loop);
8965         loop = tmp;
8966     }
8967     else if (!loop->op_slabbed)
8968     {
8969         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8970         OpLASTSIB_set(loop->op_last, (OP*)loop);
8971     }
8972     loop->op_targ = padoff;
8973     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8974     return wop;
8975 }
8976
8977 /*
8978 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8979
8980 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8981 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8982 determining the target of the op; it is consumed by this function and
8983 becomes part of the constructed op tree.
8984
8985 =cut
8986 */
8987
8988 OP*
8989 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8990 {
8991     OP *o = NULL;
8992
8993     PERL_ARGS_ASSERT_NEWLOOPEX;
8994
8995     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8996         || type == OP_CUSTOM);
8997
8998     if (type != OP_GOTO) {
8999         /* "last()" means "last" */
9000         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9001             o = newOP(type, OPf_SPECIAL);
9002         }
9003     }
9004     else {
9005         /* Check whether it's going to be a goto &function */
9006         if (label->op_type == OP_ENTERSUB
9007                 && !(label->op_flags & OPf_STACKED))
9008             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9009     }
9010
9011     /* Check for a constant argument */
9012     if (label->op_type == OP_CONST) {
9013             SV * const sv = ((SVOP *)label)->op_sv;
9014             STRLEN l;
9015             const char *s = SvPV_const(sv,l);
9016             if (l == strlen(s)) {
9017                 o = newPVOP(type,
9018                             SvUTF8(((SVOP*)label)->op_sv),
9019                             savesharedpv(
9020                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9021             }
9022     }
9023
9024     /* If we have already created an op, we do not need the label. */
9025     if (o)
9026                 op_free(label);
9027     else o = newUNOP(type, OPf_STACKED, label);
9028
9029     PL_hints |= HINT_BLOCK_SCOPE;
9030     return o;
9031 }
9032
9033 /* if the condition is a literal array or hash
9034    (or @{ ... } etc), make a reference to it.
9035  */
9036 STATIC OP *
9037 S_ref_array_or_hash(pTHX_ OP *cond)
9038 {
9039     if (cond
9040     && (cond->op_type == OP_RV2AV
9041     ||  cond->op_type == OP_PADAV
9042     ||  cond->op_type == OP_RV2HV
9043     ||  cond->op_type == OP_PADHV))
9044
9045         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9046
9047     else if(cond
9048     && (cond->op_type == OP_ASLICE
9049     ||  cond->op_type == OP_KVASLICE
9050     ||  cond->op_type == OP_HSLICE
9051     ||  cond->op_type == OP_KVHSLICE)) {
9052
9053         /* anonlist now needs a list from this op, was previously used in
9054          * scalar context */
9055         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9056         cond->op_flags |= OPf_WANT_LIST;
9057
9058         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9059     }
9060
9061     else
9062         return cond;
9063 }
9064
9065 /* These construct the optree fragments representing given()
9066    and when() blocks.
9067
9068    entergiven and enterwhen are LOGOPs; the op_other pointer
9069    points up to the associated leave op. We need this so we
9070    can put it in the context and make break/continue work.
9071    (Also, of course, pp_enterwhen will jump straight to
9072    op_other if the match fails.)
9073  */
9074
9075 STATIC OP *
9076 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9077                    I32 enter_opcode, I32 leave_opcode,
9078                    PADOFFSET entertarg)
9079 {
9080     dVAR;
9081     LOGOP *enterop;
9082     OP *o;
9083
9084     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9085     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9086
9087     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9088     enterop->op_targ = 0;
9089     enterop->op_private = 0;
9090
9091     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9092
9093     if (cond) {
9094         /* prepend cond if we have one */
9095         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9096
9097         o->op_next = LINKLIST(cond);
9098         cond->op_next = (OP *) enterop;
9099     }
9100     else {
9101         /* This is a default {} block */
9102         enterop->op_flags |= OPf_SPECIAL;
9103         o      ->op_flags |= OPf_SPECIAL;
9104
9105         o->op_next = (OP *) enterop;
9106     }
9107
9108     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9109                                        entergiven and enterwhen both
9110                                        use ck_null() */
9111
9112     enterop->op_next = LINKLIST(block);
9113     block->op_next = enterop->op_other = o;
9114
9115     return o;
9116 }
9117
9118 /* Does this look like a boolean operation? For these purposes
9119    a boolean operation is:
9120      - a subroutine call [*]
9121      - a logical connective
9122      - a comparison operator
9123      - a filetest operator, with the exception of -s -M -A -C
9124      - defined(), exists() or eof()
9125      - /$re/ or $foo =~ /$re/
9126
9127    [*] possibly surprising
9128  */
9129 STATIC bool
9130 S_looks_like_bool(pTHX_ const OP *o)
9131 {
9132     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9133
9134     switch(o->op_type) {
9135         case OP_OR:
9136         case OP_DOR:
9137             return looks_like_bool(cLOGOPo->op_first);
9138
9139         case OP_AND:
9140         {
9141             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9142             ASSUME(sibl);
9143             return (
9144                 looks_like_bool(cLOGOPo->op_first)
9145              && looks_like_bool(sibl));
9146         }
9147
9148         case OP_NULL:
9149         case OP_SCALAR:
9150             return (
9151                 o->op_flags & OPf_KIDS
9152             && looks_like_bool(cUNOPo->op_first));
9153
9154         case OP_ENTERSUB:
9155
9156         case OP_NOT:    case OP_XOR:
9157
9158         case OP_EQ:     case OP_NE:     case OP_LT:
9159         case OP_GT:     case OP_LE:     case OP_GE:
9160
9161         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9162         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9163
9164         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9165         case OP_SGT:    case OP_SLE:    case OP_SGE:
9166
9167         case OP_SMARTMATCH:
9168
9169         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9170         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9171         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9172         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9173         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9174         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9175         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9176         case OP_FTTEXT:   case OP_FTBINARY:
9177
9178         case OP_DEFINED: case OP_EXISTS:
9179         case OP_MATCH:   case OP_EOF:
9180
9181         case OP_FLOP:
9182
9183             return TRUE;
9184
9185         case OP_INDEX:
9186         case OP_RINDEX:
9187             /* optimised-away (index() != -1) or similar comparison */
9188             if (o->op_private & OPpTRUEBOOL)
9189                 return TRUE;
9190             return FALSE;
9191
9192         case OP_CONST:
9193             /* Detect comparisons that have been optimized away */
9194             if (cSVOPo->op_sv == &PL_sv_yes
9195             ||  cSVOPo->op_sv == &PL_sv_no)
9196
9197                 return TRUE;
9198             else
9199                 return FALSE;
9200         /* FALLTHROUGH */
9201         default:
9202             return FALSE;
9203     }
9204 }
9205
9206 /*
9207 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9208
9209 Constructs, checks, and returns an op tree expressing a C<given> block.
9210 C<cond> supplies the expression to whose value C<$_> will be locally
9211 aliased, and C<block> supplies the body of the C<given> construct; they
9212 are consumed by this function and become part of the constructed op tree.
9213 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9214
9215 =cut
9216 */
9217
9218 OP *
9219 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9220 {
9221     PERL_ARGS_ASSERT_NEWGIVENOP;
9222     PERL_UNUSED_ARG(defsv_off);
9223
9224     assert(!defsv_off);
9225     return newGIVWHENOP(
9226         ref_array_or_hash(cond),
9227         block,
9228         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9229         0);
9230 }
9231
9232 /*
9233 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9234
9235 Constructs, checks, and returns an op tree expressing a C<when> block.
9236 C<cond> supplies the test expression, and C<block> supplies the block
9237 that will be executed if the test evaluates to true; they are consumed
9238 by this function and become part of the constructed op tree.  C<cond>
9239 will be interpreted DWIMically, often as a comparison against C<$_>,
9240 and may be null to generate a C<default> block.
9241
9242 =cut
9243 */
9244
9245 OP *
9246 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9247 {
9248     const bool cond_llb = (!cond || looks_like_bool(cond));
9249     OP *cond_op;
9250
9251     PERL_ARGS_ASSERT_NEWWHENOP;
9252
9253     if (cond_llb)
9254         cond_op = cond;
9255     else {
9256         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9257                 newDEFSVOP(),
9258                 scalar(ref_array_or_hash(cond)));
9259     }
9260
9261     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9262 }
9263
9264 /* must not conflict with SVf_UTF8 */
9265 #define CV_CKPROTO_CURSTASH     0x1
9266
9267 void
9268 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9269                     const STRLEN len, const U32 flags)
9270 {
9271     SV *name = NULL, *msg;
9272     const char * cvp = SvROK(cv)
9273                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9274                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9275                            : ""
9276                         : CvPROTO(cv);
9277     STRLEN clen = CvPROTOLEN(cv), plen = len;
9278
9279     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9280
9281     if (p == NULL && cvp == NULL)
9282         return;
9283
9284     if (!ckWARN_d(WARN_PROTOTYPE))
9285         return;
9286
9287     if (p && cvp) {
9288         p = S_strip_spaces(aTHX_ p, &plen);
9289         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9290         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9291             if (plen == clen && memEQ(cvp, p, plen))
9292                 return;
9293         } else {
9294             if (flags & SVf_UTF8) {
9295                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9296                     return;
9297             }
9298             else {
9299                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9300                     return;
9301             }
9302         }
9303     }
9304
9305     msg = sv_newmortal();
9306
9307     if (gv)
9308     {
9309         if (isGV(gv))
9310             gv_efullname3(name = sv_newmortal(), gv, NULL);
9311         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9312             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9313         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9314             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9315             sv_catpvs(name, "::");
9316             if (SvROK(gv)) {
9317                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9318                 assert (CvNAMED(SvRV_const(gv)));
9319                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9320             }
9321             else sv_catsv(name, (SV *)gv);
9322         }
9323         else name = (SV *)gv;
9324     }
9325     sv_setpvs(msg, "Prototype mismatch:");
9326     if (name)
9327         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9328     if (cvp)
9329         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9330             UTF8fARG(SvUTF8(cv),clen,cvp)
9331         );
9332     else
9333         sv_catpvs(msg, ": none");
9334     sv_catpvs(msg, " vs ");
9335     if (p)
9336         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9337     else
9338         sv_catpvs(msg, "none");
9339     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9340 }
9341
9342 static void const_sv_xsub(pTHX_ CV* cv);
9343 static void const_av_xsub(pTHX_ CV* cv);
9344
9345 /*
9346
9347 =head1 Optree Manipulation Functions
9348
9349 =for apidoc cv_const_sv
9350
9351 If C<cv> is a constant sub eligible for inlining, returns the constant
9352 value returned by the sub.  Otherwise, returns C<NULL>.
9353
9354 Constant subs can be created with C<newCONSTSUB> or as described in
9355 L<perlsub/"Constant Functions">.
9356
9357 =cut
9358 */
9359 SV *
9360 Perl_cv_const_sv(const CV *const cv)
9361 {
9362     SV *sv;
9363     if (!cv)
9364         return NULL;
9365     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9366         return NULL;
9367     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9368     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9369     return sv;
9370 }
9371
9372 SV *
9373 Perl_cv_const_sv_or_av(const CV * const cv)
9374 {
9375     if (!cv)
9376         return NULL;
9377     if (SvROK(cv)) return SvRV((SV *)cv);
9378     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9379     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9380 }
9381
9382 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9383  * Can be called in 2 ways:
9384  *
9385  * !allow_lex
9386  *      look for a single OP_CONST with attached value: return the value
9387  *
9388  * allow_lex && !CvCONST(cv);
9389  *
9390  *      examine the clone prototype, and if contains only a single
9391  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9392  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9393  *      a candidate for "constizing" at clone time, and return NULL.
9394  */
9395
9396 static SV *
9397 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9398 {
9399     SV *sv = NULL;
9400     bool padsv = FALSE;
9401
9402     assert(o);
9403     assert(cv);
9404
9405     for (; o; o = o->op_next) {
9406         const OPCODE type = o->op_type;
9407
9408         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9409              || type == OP_NULL
9410              || type == OP_PUSHMARK)
9411                 continue;
9412         if (type == OP_DBSTATE)
9413                 continue;
9414         if (type == OP_LEAVESUB)
9415             break;
9416         if (sv)
9417             return NULL;
9418         if (type == OP_CONST && cSVOPo->op_sv)
9419             sv = cSVOPo->op_sv;
9420         else if (type == OP_UNDEF && !o->op_private) {
9421             sv = newSV(0);
9422             SAVEFREESV(sv);
9423         }
9424         else if (allow_lex && type == OP_PADSV) {
9425                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9426                 {
9427                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9428                     padsv = TRUE;
9429                 }
9430                 else
9431                     return NULL;
9432         }
9433         else {
9434             return NULL;
9435         }
9436     }
9437     if (padsv) {
9438         CvCONST_on(cv);
9439         return NULL;
9440     }
9441     return sv;
9442 }
9443
9444 static void
9445 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9446                         PADNAME * const name, SV ** const const_svp)
9447 {
9448     assert (cv);
9449     assert (o || name);
9450     assert (const_svp);
9451     if (!block) {
9452         if (CvFLAGS(PL_compcv)) {
9453             /* might have had built-in attrs applied */
9454             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9455             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9456              && ckWARN(WARN_MISC))
9457             {
9458                 /* protect against fatal warnings leaking compcv */
9459                 SAVEFREESV(PL_compcv);
9460                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9461                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9462             }
9463             CvFLAGS(cv) |=
9464                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9465                   & ~(CVf_LVALUE * pureperl));
9466         }
9467         return;
9468     }
9469
9470     /* redundant check for speed: */
9471     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9472         const line_t oldline = CopLINE(PL_curcop);
9473         SV *namesv = o
9474             ? cSVOPo->op_sv
9475             : sv_2mortal(newSVpvn_utf8(
9476                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9477               ));
9478         if (PL_parser && PL_parser->copline != NOLINE)
9479             /* This ensures that warnings are reported at the first
9480                line of a redefinition, not the last.  */
9481             CopLINE_set(PL_curcop, PL_parser->copline);
9482         /* protect against fatal warnings leaking compcv */
9483         SAVEFREESV(PL_compcv);
9484         report_redefined_cv(namesv, cv, const_svp);
9485         SvREFCNT_inc_simple_void_NN(PL_compcv);
9486         CopLINE_set(PL_curcop, oldline);
9487     }
9488     SAVEFREESV(cv);
9489     return;
9490 }
9491
9492 CV *
9493 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9494 {
9495     CV **spot;
9496     SV **svspot;
9497     const char *ps;
9498     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9499     U32 ps_utf8 = 0;
9500     CV *cv = NULL;
9501     CV *compcv = PL_compcv;
9502     SV *const_sv;
9503     PADNAME *name;
9504     PADOFFSET pax = o->op_targ;
9505     CV *outcv = CvOUTSIDE(PL_compcv);
9506     CV *clonee = NULL;
9507     HEK *hek = NULL;
9508     bool reusable = FALSE;
9509     OP *start = NULL;
9510 #ifdef PERL_DEBUG_READONLY_OPS
9511     OPSLAB *slab = NULL;
9512 #endif
9513
9514     PERL_ARGS_ASSERT_NEWMYSUB;
9515
9516     PL_hints |= HINT_BLOCK_SCOPE;
9517
9518     /* Find the pad slot for storing the new sub.
9519        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9520        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9521        ing sub.  And then we need to dig deeper if this is a lexical from
9522        outside, as in:
9523            my sub foo; sub { sub foo { } }
9524      */
9525   redo:
9526     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9527     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9528         pax = PARENT_PAD_INDEX(name);
9529         outcv = CvOUTSIDE(outcv);
9530         assert(outcv);
9531         goto redo;
9532     }
9533     svspot =
9534         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9535                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9536     spot = (CV **)svspot;
9537
9538     if (!(PL_parser && PL_parser->error_count))
9539         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9540
9541     if (proto) {
9542         assert(proto->op_type == OP_CONST);
9543         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9544         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9545     }
9546     else
9547         ps = NULL;
9548
9549     if (proto)
9550         SAVEFREEOP(proto);
9551     if (attrs)
9552         SAVEFREEOP(attrs);
9553
9554     if (PL_parser && PL_parser->error_count) {
9555         op_free(block);
9556         SvREFCNT_dec(PL_compcv);
9557         PL_compcv = 0;
9558         goto done;
9559     }
9560
9561     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9562         cv = *spot;
9563         svspot = (SV **)(spot = &clonee);
9564     }
9565     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9566         cv = *spot;
9567     else {
9568         assert (SvTYPE(*spot) == SVt_PVCV);
9569         if (CvNAMED(*spot))
9570             hek = CvNAME_HEK(*spot);
9571         else {
9572             dVAR;
9573             U32 hash;
9574             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9575             CvNAME_HEK_set(*spot, hek =
9576                 share_hek(
9577                     PadnamePV(name)+1,
9578                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9579                     hash
9580                 )
9581             );
9582             CvLEXICAL_on(*spot);
9583         }
9584         cv = PadnamePROTOCV(name);
9585         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9586     }
9587
9588     if (block) {
9589         /* This makes sub {}; work as expected.  */
9590         if (block->op_type == OP_STUB) {
9591             const line_t l = PL_parser->copline;
9592             op_free(block);
9593             block = newSTATEOP(0, NULL, 0);
9594             PL_parser->copline = l;
9595         }
9596         block = CvLVALUE(compcv)
9597              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9598                    ? newUNOP(OP_LEAVESUBLV, 0,
9599                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9600                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9601         start = LINKLIST(block);
9602         block->op_next = 0;
9603         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9604             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9605         else
9606             const_sv = NULL;
9607     }
9608     else
9609         const_sv = NULL;
9610
9611     if (cv) {
9612         const bool exists = CvROOT(cv) || CvXSUB(cv);
9613
9614         /* if the subroutine doesn't exist and wasn't pre-declared
9615          * with a prototype, assume it will be AUTOLOADed,
9616          * skipping the prototype check
9617          */
9618         if (exists || SvPOK(cv))
9619             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9620                                  ps_utf8);
9621         /* already defined? */
9622         if (exists) {
9623             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9624             if (block)
9625                 cv = NULL;
9626             else {
9627                 if (attrs)
9628                     goto attrs;
9629                 /* just a "sub foo;" when &foo is already defined */
9630                 SAVEFREESV(compcv);
9631                 goto done;
9632             }
9633         }
9634         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9635             cv = NULL;
9636             reusable = TRUE;
9637         }
9638     }
9639
9640     if (const_sv) {
9641         SvREFCNT_inc_simple_void_NN(const_sv);
9642         SvFLAGS(const_sv) |= SVs_PADTMP;
9643         if (cv) {
9644             assert(!CvROOT(cv) && !CvCONST(cv));
9645             cv_forget_slab(cv);
9646         }
9647         else {
9648             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9649             CvFILE_set_from_cop(cv, PL_curcop);
9650             CvSTASH_set(cv, PL_curstash);
9651             *spot = cv;
9652         }
9653         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9654         CvXSUBANY(cv).any_ptr = const_sv;
9655         CvXSUB(cv) = const_sv_xsub;
9656         CvCONST_on(cv);
9657         CvISXSUB_on(cv);
9658         PoisonPADLIST(cv);
9659         CvFLAGS(cv) |= CvMETHOD(compcv);
9660         op_free(block);
9661         SvREFCNT_dec(compcv);
9662         PL_compcv = NULL;
9663         goto setname;
9664     }
9665
9666     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9667        determine whether this sub definition is in the same scope as its
9668        declaration.  If this sub definition is inside an inner named pack-
9669        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9670        the package sub.  So check PadnameOUTER(name) too.
9671      */
9672     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9673         assert(!CvWEAKOUTSIDE(compcv));
9674         SvREFCNT_dec(CvOUTSIDE(compcv));
9675         CvWEAKOUTSIDE_on(compcv);
9676     }
9677     /* XXX else do we have a circular reference? */
9678
9679     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9680         /* transfer PL_compcv to cv */
9681         if (block) {
9682             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9683             cv_flags_t preserved_flags =
9684                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9685             PADLIST *const temp_padl = CvPADLIST(cv);
9686             CV *const temp_cv = CvOUTSIDE(cv);
9687             const cv_flags_t other_flags =
9688                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9689             OP * const cvstart = CvSTART(cv);
9690
9691             SvPOK_off(cv);
9692             CvFLAGS(cv) =
9693                 CvFLAGS(compcv) | preserved_flags;
9694             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9695             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9696             CvPADLIST_set(cv, CvPADLIST(compcv));
9697             CvOUTSIDE(compcv) = temp_cv;
9698             CvPADLIST_set(compcv, temp_padl);
9699             CvSTART(cv) = CvSTART(compcv);
9700             CvSTART(compcv) = cvstart;
9701             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9702             CvFLAGS(compcv) |= other_flags;
9703
9704             if (free_file) {
9705                 Safefree(CvFILE(cv));
9706                 CvFILE(cv) = NULL;
9707             }
9708
9709             /* inner references to compcv must be fixed up ... */
9710             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9711             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9712                 ++PL_sub_generation;
9713         }
9714         else {
9715             /* Might have had built-in attributes applied -- propagate them. */
9716             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9717         }
9718         /* ... before we throw it away */
9719         SvREFCNT_dec(compcv);
9720         PL_compcv = compcv = cv;
9721     }
9722     else {
9723         cv = compcv;
9724         *spot = cv;
9725     }
9726
9727   setname:
9728     CvLEXICAL_on(cv);
9729     if (!CvNAME_HEK(cv)) {
9730         if (hek) (void)share_hek_hek(hek);
9731         else {
9732             dVAR;
9733             U32 hash;
9734             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9735             hek = share_hek(PadnamePV(name)+1,
9736                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9737                       hash);
9738         }
9739         CvNAME_HEK_set(cv, hek);
9740     }
9741
9742     if (const_sv)
9743         goto clone;
9744
9745     if (CvFILE(cv) && CvDYNFILE(cv))
9746         Safefree(CvFILE(cv));
9747     CvFILE_set_from_cop(cv, PL_curcop);
9748     CvSTASH_set(cv, PL_curstash);
9749
9750     if (ps) {
9751         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9752         if (ps_utf8)
9753             SvUTF8_on(MUTABLE_SV(cv));
9754     }
9755
9756     if (block) {
9757         /* If we assign an optree to a PVCV, then we've defined a
9758          * subroutine that the debugger could be able to set a breakpoint
9759          * in, so signal to pp_entereval that it should not throw away any
9760          * saved lines at scope exit.  */
9761
9762         PL_breakable_sub_gen++;
9763         CvROOT(cv) = block;
9764         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9765            itself has a refcount. */
9766         CvSLABBED_off(cv);
9767         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9768 #ifdef PERL_DEBUG_READONLY_OPS
9769         slab = (OPSLAB *)CvSTART(cv);
9770 #endif
9771         S_process_optree(aTHX_ cv, block, start);
9772     }
9773
9774   attrs:
9775     if (attrs) {
9776         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9777         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9778     }
9779
9780     if (block) {
9781         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9782             SV * const tmpstr = sv_newmortal();
9783             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9784                                                   GV_ADDMULTI, SVt_PVHV);
9785             HV *hv;
9786             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9787                                           CopFILE(PL_curcop),
9788                                           (long)PL_subline,
9789                                           (long)CopLINE(PL_curcop));
9790             if (HvNAME_HEK(PL_curstash)) {
9791                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9792                 sv_catpvs(tmpstr, "::");
9793             }
9794             else
9795                 sv_setpvs(tmpstr, "__ANON__::");
9796
9797             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9798                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9799             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9800                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9801             hv = GvHVn(db_postponed);
9802             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9803                 CV * const pcv = GvCV(db_postponed);
9804                 if (pcv) {
9805                     dSP;
9806                     PUSHMARK(SP);
9807                     XPUSHs(tmpstr);
9808                     PUTBACK;
9809                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9810                 }
9811             }
9812         }
9813     }
9814
9815   clone:
9816     if (clonee) {
9817         assert(CvDEPTH(outcv));
9818         spot = (CV **)
9819             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9820         if (reusable)
9821             cv_clone_into(clonee, *spot);
9822         else *spot = cv_clone(clonee);
9823         SvREFCNT_dec_NN(clonee);
9824         cv = *spot;
9825     }
9826
9827     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9828         PADOFFSET depth = CvDEPTH(outcv);
9829         while (--depth) {
9830             SV *oldcv;
9831             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9832             oldcv = *svspot;
9833             *svspot = SvREFCNT_inc_simple_NN(cv);
9834             SvREFCNT_dec(oldcv);
9835         }
9836     }
9837
9838   done:
9839     if (PL_parser)
9840         PL_parser->copline = NOLINE;
9841     LEAVE_SCOPE(floor);
9842 #ifdef PERL_DEBUG_READONLY_OPS
9843     if (slab)
9844         Slab_to_ro(slab);
9845 #endif
9846     op_free(o);
9847     return cv;
9848 }
9849
9850 /*
9851 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9852
9853 Construct a Perl subroutine, also performing some surrounding jobs.
9854
9855 This function is expected to be called in a Perl compilation context,
9856 and some aspects of the subroutine are taken from global variables
9857 associated with compilation.  In particular, C<PL_compcv> represents
9858 the subroutine that is currently being compiled.  It must be non-null
9859 when this function is called, and some aspects of the subroutine being
9860 constructed are taken from it.  The constructed subroutine may actually
9861 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9862
9863 If C<block> is null then the subroutine will have no body, and for the
9864 time being it will be an error to call it.  This represents a forward
9865 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9866 non-null then it provides the Perl code of the subroutine body, which
9867 will be executed when the subroutine is called.  This body includes
9868 any argument unwrapping code resulting from a subroutine signature or
9869 similar.  The pad use of the code must correspond to the pad attached
9870 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9871 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9872 by this function and will become part of the constructed subroutine.
9873
9874 C<proto> specifies the subroutine's prototype, unless one is supplied
9875 as an attribute (see below).  If C<proto> is null, then the subroutine
9876 will not have a prototype.  If C<proto> is non-null, it must point to a
9877 C<const> op whose value is a string, and the subroutine will have that
9878 string as its prototype.  If a prototype is supplied as an attribute, the
9879 attribute takes precedence over C<proto>, but in that case C<proto> should
9880 preferably be null.  In any case, C<proto> is consumed by this function.
9881
9882 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9883 attributes take effect by built-in means, being applied to C<PL_compcv>
9884 immediately when seen.  Other attributes are collected up and attached
9885 to the subroutine by this route.  C<attrs> may be null to supply no
9886 attributes, or point to a C<const> op for a single attribute, or point
9887 to a C<list> op whose children apart from the C<pushmark> are C<const>
9888 ops for one or more attributes.  Each C<const> op must be a string,
9889 giving the attribute name optionally followed by parenthesised arguments,
9890 in the manner in which attributes appear in Perl source.  The attributes
9891 will be applied to the sub by this function.  C<attrs> is consumed by
9892 this function.
9893
9894 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9895 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9896 must point to a C<const> op, which will be consumed by this function,
9897 and its string value supplies a name for the subroutine.  The name may
9898 be qualified or unqualified, and if it is unqualified then a default
9899 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9900 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9901 by which the subroutine will be named.
9902
9903 If there is already a subroutine of the specified name, then the new
9904 sub will either replace the existing one in the glob or be merged with
9905 the existing one.  A warning may be generated about redefinition.
9906
9907 If the subroutine has one of a few special names, such as C<BEGIN> or
9908 C<END>, then it will be claimed by the appropriate queue for automatic
9909 running of phase-related subroutines.  In this case the relevant glob will
9910 be left not containing any subroutine, even if it did contain one before.
9911 In the case of C<BEGIN>, the subroutine will be executed and the reference
9912 to it disposed of before this function returns.
9913
9914 The function returns a pointer to the constructed subroutine.  If the sub
9915 is anonymous then ownership of one counted reference to the subroutine
9916 is transferred to the caller.  If the sub is named then the caller does
9917 not get ownership of a reference.  In most such cases, where the sub
9918 has a non-phase name, the sub will be alive at the point it is returned
9919 by virtue of being contained in the glob that names it.  A phase-named
9920 subroutine will usually be alive by virtue of the reference owned by the
9921 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9922 been executed, will quite likely have been destroyed already by the
9923 time this function returns, making it erroneous for the caller to make
9924 any use of the returned pointer.  It is the caller's responsibility to
9925 ensure that it knows which of these situations applies.
9926
9927 =cut
9928 */
9929
9930 /* _x = extended */
9931 CV *
9932 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9933                             OP *block, bool o_is_gv)
9934 {
9935     GV *gv;
9936     const char *ps;
9937     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9938     U32 ps_utf8 = 0;
9939     CV *cv = NULL;     /* the previous CV with this name, if any */
9940     SV *const_sv;
9941     const bool ec = PL_parser && PL_parser->error_count;
9942     /* If the subroutine has no body, no attributes, and no builtin attributes
9943        then it's just a sub declaration, and we may be able to get away with
9944        storing with a placeholder scalar in the symbol table, rather than a
9945        full CV.  If anything is present then it will take a full CV to
9946        store it.  */
9947     const I32 gv_fetch_flags
9948         = ec ? GV_NOADD_NOINIT :
9949         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9950         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9951     STRLEN namlen = 0;
9952     const char * const name =
9953          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9954     bool has_name;
9955     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9956     bool evanescent = FALSE;
9957     OP *start = NULL;
9958 #ifdef PERL_DEBUG_READONLY_OPS
9959     OPSLAB *slab = NULL;
9960 #endif
9961
9962     if (o_is_gv) {
9963         gv = (GV*)o;
9964         o = NULL;
9965         has_name = TRUE;
9966     } else if (name) {
9967         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9968            hek and CvSTASH pointer together can imply the GV.  If the name
9969            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9970            CvSTASH, so forego the optimisation if we find any.
9971            Also, we may be called from load_module at run time, so
9972            PL_curstash (which sets CvSTASH) may not point to the stash the
9973            sub is stored in.  */
9974         /* XXX This optimization is currently disabled for packages other
9975                than main, since there was too much CPAN breakage.  */
9976         const I32 flags =
9977            ec ? GV_NOADD_NOINIT
9978               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9979                || PL_curstash != PL_defstash
9980                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9981                     ? gv_fetch_flags
9982                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9983         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9984         has_name = TRUE;
9985     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9986         SV * const sv = sv_newmortal();
9987         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9988                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9989                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9990         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9991         has_name = TRUE;
9992     } else if (PL_curstash) {
9993         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9994         has_name = FALSE;
9995     } else {
9996         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9997         has_name = FALSE;
9998     }
9999
10000     if (!ec) {
10001         if (isGV(gv)) {
10002             move_proto_attr(&proto, &attrs, gv, 0);
10003         } else {
10004             assert(cSVOPo);
10005             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10006         }
10007     }
10008
10009     if (proto) {
10010         assert(proto->op_type == OP_CONST);
10011         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10012         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10013     }
10014     else
10015         ps = NULL;
10016
10017     if (o)
10018         SAVEFREEOP(o);
10019     if (proto)
10020         SAVEFREEOP(proto);
10021     if (attrs)
10022         SAVEFREEOP(attrs);
10023
10024     if (ec) {
10025         op_free(block);
10026
10027         if (name)
10028             SvREFCNT_dec(PL_compcv);
10029         else
10030             cv = PL_compcv;
10031
10032         PL_compcv = 0;
10033         if (name && block) {
10034             const char *s = (char *) my_memrchr(name, ':', namlen);
10035             s = s ? s+1 : name;
10036             if (strEQ(s, "BEGIN")) {
10037                 if (PL_in_eval & EVAL_KEEPERR)
10038                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10039                 else {
10040                     SV * const errsv = ERRSV;
10041                     /* force display of errors found but not reported */
10042                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10043                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10044                 }
10045             }
10046         }
10047         goto done;
10048     }
10049
10050     if (!block && SvTYPE(gv) != SVt_PVGV) {
10051         /* If we are not defining a new sub and the existing one is not a
10052            full GV + CV... */
10053         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10054             /* We are applying attributes to an existing sub, so we need it
10055                upgraded if it is a constant.  */
10056             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10057                 gv_init_pvn(gv, PL_curstash, name, namlen,
10058                             SVf_UTF8 * name_is_utf8);
10059         }
10060         else {                  /* Maybe prototype now, and had at maximum
10061                                    a prototype or const/sub ref before.  */
10062             if (SvTYPE(gv) > SVt_NULL) {
10063                 cv_ckproto_len_flags((const CV *)gv,
10064                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10065                                     ps_len, ps_utf8);
10066             }
10067
10068             if (!SvROK(gv)) {
10069                 if (ps) {
10070                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10071                     if (ps_utf8)
10072                         SvUTF8_on(MUTABLE_SV(gv));
10073                 }
10074                 else
10075                     sv_setiv(MUTABLE_SV(gv), -1);
10076             }
10077
10078             SvREFCNT_dec(PL_compcv);
10079             cv = PL_compcv = NULL;
10080             goto done;
10081         }
10082     }
10083
10084     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10085         ? NULL
10086         : isGV(gv)
10087             ? GvCV(gv)
10088             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10089                 ? (CV *)SvRV(gv)
10090                 : NULL;
10091
10092     if (block) {
10093         assert(PL_parser);
10094         /* This makes sub {}; work as expected.  */
10095         if (block->op_type == OP_STUB) {
10096             const line_t l = PL_parser->copline;
10097             op_free(block);
10098             block = newSTATEOP(0, NULL, 0);
10099             PL_parser->copline = l;
10100         }
10101         block = CvLVALUE(PL_compcv)
10102              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10103                     && (!isGV(gv) || !GvASSUMECV(gv)))
10104                    ? newUNOP(OP_LEAVESUBLV, 0,
10105                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10106                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10107         start = LINKLIST(block);
10108         block->op_next = 0;
10109         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10110             const_sv =
10111                 S_op_const_sv(aTHX_ start, PL_compcv,
10112                                         cBOOL(CvCLONE(PL_compcv)));
10113         else
10114             const_sv = NULL;
10115     }
10116     else
10117         const_sv = NULL;
10118
10119     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10120         cv_ckproto_len_flags((const CV *)gv,
10121                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10122                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10123         if (SvROK(gv)) {
10124             /* All the other code for sub redefinition warnings expects the
10125                clobbered sub to be a CV.  Instead of making all those code
10126                paths more complex, just inline the RV version here.  */
10127             const line_t oldline = CopLINE(PL_curcop);
10128             assert(IN_PERL_COMPILETIME);
10129             if (PL_parser && PL_parser->copline != NOLINE)
10130                 /* This ensures that warnings are reported at the first
10131                    line of a redefinition, not the last.  */
10132                 CopLINE_set(PL_curcop, PL_parser->copline);
10133             /* protect against fatal warnings leaking compcv */
10134             SAVEFREESV(PL_compcv);
10135
10136             if (ckWARN(WARN_REDEFINE)
10137              || (  ckWARN_d(WARN_REDEFINE)
10138                 && (  !const_sv || SvRV(gv) == const_sv
10139                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10140                 assert(cSVOPo);
10141                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10142                           "Constant subroutine %" SVf " redefined",
10143                           SVfARG(cSVOPo->op_sv));
10144             }
10145
10146             SvREFCNT_inc_simple_void_NN(PL_compcv);
10147             CopLINE_set(PL_curcop, oldline);
10148             SvREFCNT_dec(SvRV(gv));
10149         }
10150     }
10151
10152     if (cv) {
10153         const bool exists = CvROOT(cv) || CvXSUB(cv);
10154
10155         /* if the subroutine doesn't exist and wasn't pre-declared
10156          * with a prototype, assume it will be AUTOLOADed,
10157          * skipping the prototype check
10158          */
10159         if (exists || SvPOK(cv))
10160             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10161         /* already defined (or promised)? */
10162         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10163             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10164             if (block)
10165                 cv = NULL;
10166             else {
10167                 if (attrs)
10168                     goto attrs;
10169                 /* just a "sub foo;" when &foo is already defined */
10170                 SAVEFREESV(PL_compcv);
10171                 goto done;
10172             }
10173         }
10174     }
10175
10176     if (const_sv) {
10177         SvREFCNT_inc_simple_void_NN(const_sv);
10178         SvFLAGS(const_sv) |= SVs_PADTMP;
10179         if (cv) {
10180             assert(!CvROOT(cv) && !CvCONST(cv));
10181             cv_forget_slab(cv);
10182             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10183             CvXSUBANY(cv).any_ptr = const_sv;
10184             CvXSUB(cv) = const_sv_xsub;
10185             CvCONST_on(cv);
10186             CvISXSUB_on(cv);
10187             PoisonPADLIST(cv);
10188             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10189         }
10190         else {
10191             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10192                 if (name && isGV(gv))
10193                     GvCV_set(gv, NULL);
10194                 cv = newCONSTSUB_flags(
10195                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10196                     const_sv
10197                 );
10198                 assert(cv);
10199                 assert(SvREFCNT((SV*)cv) != 0);
10200                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10201             }
10202             else {
10203                 if (!SvROK(gv)) {
10204                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10205                     prepare_SV_for_RV((SV *)gv);
10206                     SvOK_off((SV *)gv);
10207                     SvROK_on(gv);
10208                 }
10209                 SvRV_set(gv, const_sv);
10210             }
10211         }
10212         op_free(block);
10213         SvREFCNT_dec(PL_compcv);
10214         PL_compcv = NULL;
10215         goto done;
10216     }
10217
10218     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10219     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10220         cv = NULL;
10221
10222     if (cv) {                           /* must reuse cv if autoloaded */
10223         /* transfer PL_compcv to cv */
10224         if (block) {
10225             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10226             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10227             PADLIST *const temp_av = CvPADLIST(cv);
10228             CV *const temp_cv = CvOUTSIDE(cv);
10229             const cv_flags_t other_flags =
10230                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10231             OP * const cvstart = CvSTART(cv);
10232
10233             if (isGV(gv)) {
10234                 CvGV_set(cv,gv);
10235                 assert(!CvCVGV_RC(cv));
10236                 assert(CvGV(cv) == gv);
10237             }
10238             else {
10239                 dVAR;
10240                 U32 hash;
10241                 PERL_HASH(hash, name, namlen);
10242                 CvNAME_HEK_set(cv,
10243                                share_hek(name,
10244                                          name_is_utf8
10245                                             ? -(SSize_t)namlen
10246                                             :  (SSize_t)namlen,
10247                                          hash));
10248             }
10249
10250             SvPOK_off(cv);
10251             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10252                                              | CvNAMED(cv);
10253             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10254             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10255             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10256             CvOUTSIDE(PL_compcv) = temp_cv;
10257             CvPADLIST_set(PL_compcv, temp_av);
10258             CvSTART(cv) = CvSTART(PL_compcv);
10259             CvSTART(PL_compcv) = cvstart;
10260             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10261             CvFLAGS(PL_compcv) |= other_flags;
10262
10263             if (free_file) {
10264                 Safefree(CvFILE(cv));
10265             }
10266             CvFILE_set_from_cop(cv, PL_curcop);
10267             CvSTASH_set(cv, PL_curstash);
10268
10269             /* inner references to PL_compcv must be fixed up ... */
10270             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10271             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10272                 ++PL_sub_generation;
10273         }
10274         else {
10275             /* Might have had built-in attributes applied -- propagate them. */
10276             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10277         }
10278         /* ... before we throw it away */
10279         SvREFCNT_dec(PL_compcv);
10280         PL_compcv = cv;
10281     }
10282     else {
10283         cv = PL_compcv;
10284         if (name && isGV(gv)) {
10285             GvCV_set(gv, cv);
10286             GvCVGEN(gv) = 0;
10287             if (HvENAME_HEK(GvSTASH(gv)))
10288                 /* sub Foo::bar { (shift)+1 } */
10289                 gv_method_changed(gv);
10290         }
10291         else if (name) {
10292             if (!SvROK(gv)) {
10293                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10294                 prepare_SV_for_RV((SV *)gv);
10295                 SvOK_off((SV *)gv);
10296                 SvROK_on(gv);
10297             }
10298             SvRV_set(gv, (SV *)cv);
10299             if (HvENAME_HEK(PL_curstash))
10300                 mro_method_changed_in(PL_curstash);
10301         }
10302     }
10303     assert(cv);
10304     assert(SvREFCNT((SV*)cv) != 0);
10305
10306     if (!CvHASGV(cv)) {
10307         if (isGV(gv))
10308             CvGV_set(cv, gv);
10309         else {
10310             dVAR;
10311             U32 hash;
10312             PERL_HASH(hash, name, namlen);
10313             CvNAME_HEK_set(cv, share_hek(name,
10314                                          name_is_utf8
10315                                             ? -(SSize_t)namlen
10316                                             :  (SSize_t)namlen,
10317                                          hash));
10318         }
10319         CvFILE_set_from_cop(cv, PL_curcop);
10320         CvSTASH_set(cv, PL_curstash);
10321     }
10322
10323     if (ps) {
10324         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10325         if ( ps_utf8 )
10326             SvUTF8_on(MUTABLE_SV(cv));
10327     }
10328
10329     if (block) {
10330         /* If we assign an optree to a PVCV, then we've defined a
10331          * subroutine that the debugger could be able to set a breakpoint
10332          * in, so signal to pp_entereval that it should not throw away any
10333          * saved lines at scope exit.  */
10334
10335         PL_breakable_sub_gen++;
10336         CvROOT(cv) = block;
10337         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10338            itself has a refcount. */
10339         CvSLABBED_off(cv);
10340         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10341 #ifdef PERL_DEBUG_READONLY_OPS
10342         slab = (OPSLAB *)CvSTART(cv);
10343 #endif
10344         S_process_optree(aTHX_ cv, block, start);
10345     }
10346
10347   attrs:
10348     if (attrs) {
10349         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10350         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10351                         ? GvSTASH(CvGV(cv))
10352                         : PL_curstash;
10353         if (!name)
10354             SAVEFREESV(cv);
10355         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10356         if (!name)
10357             SvREFCNT_inc_simple_void_NN(cv);
10358     }
10359
10360     if (block && has_name) {
10361         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10362             SV * const tmpstr = cv_name(cv,NULL,0);
10363             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10364                                                   GV_ADDMULTI, SVt_PVHV);
10365             HV *hv;
10366             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10367                                           CopFILE(PL_curcop),
10368                                           (long)PL_subline,
10369                                           (long)CopLINE(PL_curcop));
10370             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10371                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10372             hv = GvHVn(db_postponed);
10373             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10374                 CV * const pcv = GvCV(db_postponed);
10375                 if (pcv) {
10376                     dSP;
10377                     PUSHMARK(SP);
10378                     XPUSHs(tmpstr);
10379                     PUTBACK;
10380                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10381                 }
10382             }
10383         }
10384
10385         if (name) {
10386             if (PL_parser && PL_parser->error_count)
10387                 clear_special_blocks(name, gv, cv);
10388             else
10389                 evanescent =
10390                     process_special_blocks(floor, name, gv, cv);
10391         }
10392     }
10393     assert(cv);
10394
10395   done:
10396     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10397     if (PL_parser)
10398         PL_parser->copline = NOLINE;
10399     LEAVE_SCOPE(floor);
10400
10401     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10402     if (!evanescent) {
10403 #ifdef PERL_DEBUG_READONLY_OPS
10404     if (slab)
10405         Slab_to_ro(slab);
10406 #endif
10407     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10408         pad_add_weakref(cv);
10409     }
10410     return cv;
10411 }
10412
10413 STATIC void
10414 S_clear_special_blocks(pTHX_ const char *const fullname,
10415                        GV *const gv, CV *const cv) {
10416     const char *colon;
10417     const char *name;
10418
10419     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10420
10421     colon = strrchr(fullname,':');
10422     name = colon ? colon + 1 : fullname;
10423
10424     if ((*name == 'B' && strEQ(name, "BEGIN"))
10425         || (*name == 'E' && strEQ(name, "END"))
10426         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10427         || (*name == 'C' && strEQ(name, "CHECK"))
10428         || (*name == 'I' && strEQ(name, "INIT"))) {
10429         if (!isGV(gv)) {
10430             (void)CvGV(cv);
10431             assert(isGV(gv));
10432         }
10433         GvCV_set(gv, NULL);
10434         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10435     }
10436 }
10437
10438 /* Returns true if the sub has been freed.  */
10439 STATIC bool
10440 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10441                          GV *const gv,
10442                          CV *const cv)
10443 {
10444     const char *const colon = strrchr(fullname,':');
10445     const char *const name = colon ? colon + 1 : fullname;
10446
10447     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10448
10449     if (*name == 'B') {
10450         if (strEQ(name, "BEGIN")) {
10451             const I32 oldscope = PL_scopestack_ix;
10452             dSP;
10453             (void)CvGV(cv);
10454             if (floor) LEAVE_SCOPE(floor);
10455             ENTER;
10456             PUSHSTACKi(PERLSI_REQUIRE);
10457             SAVECOPFILE(&PL_compiling);
10458             SAVECOPLINE(&PL_compiling);
10459             SAVEVPTR(PL_curcop);
10460
10461             DEBUG_x( dump_sub(gv) );
10462             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10463             GvCV_set(gv,0);             /* cv has been hijacked */
10464             call_list(oldscope, PL_beginav);
10465
10466             POPSTACK;
10467             LEAVE;
10468             return !PL_savebegin;
10469         }
10470         else
10471             return FALSE;
10472     } else {
10473         if (*name == 'E') {
10474             if strEQ(name, "END") {
10475                 DEBUG_x( dump_sub(gv) );
10476                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10477             } else
10478                 return FALSE;
10479         } else if (*name == 'U') {
10480             if (strEQ(name, "UNITCHECK")) {
10481                 /* It's never too late to run a unitcheck block */
10482                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10483             }
10484             else
10485                 return FALSE;
10486         } else if (*name == 'C') {
10487             if (strEQ(name, "CHECK")) {
10488                 if (PL_main_start)
10489                     /* diag_listed_as: Too late to run %s block */
10490                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10491                                    "Too late to run CHECK block");
10492                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10493             }
10494             else
10495                 return FALSE;
10496         } else if (*name == 'I') {
10497             if (strEQ(name, "INIT")) {
10498                 if (PL_main_start)
10499                     /* diag_listed_as: Too late to run %s block */
10500                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10501                                    "Too late to run INIT block");
10502                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10503             }
10504             else
10505                 return FALSE;
10506         } else
10507             return FALSE;
10508         DEBUG_x( dump_sub(gv) );
10509         (void)CvGV(cv);
10510         GvCV_set(gv,0);         /* cv has been hijacked */
10511         return FALSE;
10512     }
10513 }
10514
10515 /*
10516 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10517
10518 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10519 rather than of counted length, and no flags are set.  (This means that
10520 C<name> is always interpreted as Latin-1.)
10521
10522 =cut
10523 */
10524
10525 CV *
10526 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10527 {
10528     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10529 }
10530
10531 /*
10532 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10533
10534 Construct a constant subroutine, also performing some surrounding
10535 jobs.  A scalar constant-valued subroutine is eligible for inlining
10536 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10537 123 }>>.  Other kinds of constant subroutine have other treatment.
10538
10539 The subroutine will have an empty prototype and will ignore any arguments
10540 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10541 is null, the subroutine will yield an empty list.  If C<sv> points to a
10542 scalar, the subroutine will always yield that scalar.  If C<sv> points
10543 to an array, the subroutine will always yield a list of the elements of
10544 that array in list context, or the number of elements in the array in
10545 scalar context.  This function takes ownership of one counted reference
10546 to the scalar or array, and will arrange for the object to live as long
10547 as the subroutine does.  If C<sv> points to a scalar then the inlining
10548 assumes that the value of the scalar will never change, so the caller
10549 must ensure that the scalar is not subsequently written to.  If C<sv>
10550 points to an array then no such assumption is made, so it is ostensibly
10551 safe to mutate the array or its elements, but whether this is really
10552 supported has not been determined.
10553
10554 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10555 Other aspects of the subroutine will be left in their default state.
10556 The caller is free to mutate the subroutine beyond its initial state
10557 after this function has returned.
10558
10559 If C<name> is null then the subroutine will be anonymous, with its
10560 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10561 subroutine will be named accordingly, referenced by the appropriate glob.
10562 C<name> is a string of length C<len> bytes giving a sigilless symbol
10563 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10564 otherwise.  The name may be either qualified or unqualified.  If the
10565 name is unqualified then it defaults to being in the stash specified by
10566 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10567 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10568 semantics.
10569
10570 C<flags> should not have bits set other than C<SVf_UTF8>.
10571
10572 If there is already a subroutine of the specified name, then the new sub
10573 will replace the existing one in the glob.  A warning may be generated
10574 about the redefinition.
10575
10576 If the subroutine has one of a few special names, such as C<BEGIN> or
10577 C<END>, then it will be claimed by the appropriate queue for automatic
10578 running of phase-related subroutines.  In this case the relevant glob will
10579 be left not containing any subroutine, even if it did contain one before.
10580 Execution of the subroutine will likely be a no-op, unless C<sv> was
10581 a tied array or the caller modified the subroutine in some interesting
10582 way before it was executed.  In the case of C<BEGIN>, the treatment is
10583 buggy: the sub will be executed when only half built, and may be deleted
10584 prematurely, possibly causing a crash.
10585
10586 The function returns a pointer to the constructed subroutine.  If the sub
10587 is anonymous then ownership of one counted reference to the subroutine
10588 is transferred to the caller.  If the sub is named then the caller does
10589 not get ownership of a reference.  In most such cases, where the sub
10590 has a non-phase name, the sub will be alive at the point it is returned
10591 by virtue of being contained in the glob that names it.  A phase-named
10592 subroutine will usually be alive by virtue of the reference owned by
10593 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10594 destroyed already by the time this function returns, but currently bugs
10595 occur in that case before the caller gets control.  It is the caller's
10596 responsibility to ensure that it knows which of these situations applies.
10597
10598 =cut
10599 */
10600
10601 CV *
10602 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10603                              U32 flags, SV *sv)
10604 {
10605     CV* cv;
10606     const char *const file = CopFILE(PL_curcop);
10607
10608     ENTER;
10609
10610     if (IN_PERL_RUNTIME) {
10611         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10612          * an op shared between threads. Use a non-shared COP for our
10613          * dirty work */
10614          SAVEVPTR(PL_curcop);
10615          SAVECOMPILEWARNINGS();
10616          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10617          PL_curcop = &PL_compiling;
10618     }
10619     SAVECOPLINE(PL_curcop);
10620     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10621
10622     SAVEHINTS();
10623     PL_hints &= ~HINT_BLOCK_SCOPE;
10624
10625     if (stash) {
10626         SAVEGENERICSV(PL_curstash);
10627         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10628     }
10629
10630     /* Protect sv against leakage caused by fatal warnings. */
10631     if (sv) SAVEFREESV(sv);
10632
10633     /* file becomes the CvFILE. For an XS, it's usually static storage,
10634        and so doesn't get free()d.  (It's expected to be from the C pre-
10635        processor __FILE__ directive). But we need a dynamically allocated one,
10636        and we need it to get freed.  */
10637     cv = newXS_len_flags(name, len,
10638                          sv && SvTYPE(sv) == SVt_PVAV
10639                              ? const_av_xsub
10640                              : const_sv_xsub,
10641                          file ? file : "", "",
10642                          &sv, XS_DYNAMIC_FILENAME | flags);
10643     assert(cv);
10644     assert(SvREFCNT((SV*)cv) != 0);
10645     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10646     CvCONST_on(cv);
10647
10648     LEAVE;
10649
10650     return cv;
10651 }
10652
10653 /*
10654 =for apidoc U||newXS
10655
10656 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10657 static storage, as it is used directly as CvFILE(), without a copy being made.
10658
10659 =cut
10660 */
10661
10662 CV *
10663 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10664 {
10665     PERL_ARGS_ASSERT_NEWXS;
10666     return newXS_len_flags(
10667         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10668     );
10669 }
10670
10671 CV *
10672 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10673                  const char *const filename, const char *const proto,
10674                  U32 flags)
10675 {
10676     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10677     return newXS_len_flags(
10678        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10679     );
10680 }
10681
10682 CV *
10683 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10684 {
10685     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10686     return newXS_len_flags(
10687         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10688     );
10689 }
10690
10691 /*
10692 =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
10693
10694 Construct an XS subroutine, also performing some surrounding jobs.
10695
10696 The subroutine will have the entry point C<subaddr>.  It will have
10697 the prototype specified by the nul-terminated string C<proto>, or
10698 no prototype if C<proto> is null.  The prototype string is copied;
10699 the caller can mutate the supplied string afterwards.  If C<filename>
10700 is non-null, it must be a nul-terminated filename, and the subroutine
10701 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10702 point directly to the supplied string, which must be static.  If C<flags>
10703 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10704 be taken instead.
10705
10706 Other aspects of the subroutine will be left in their default state.
10707 If anything else needs to be done to the subroutine for it to function
10708 correctly, it is the caller's responsibility to do that after this
10709 function has constructed it.  However, beware of the subroutine
10710 potentially being destroyed before this function returns, as described
10711 below.
10712
10713 If C<name> is null then the subroutine will be anonymous, with its
10714 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10715 subroutine will be named accordingly, referenced by the appropriate glob.
10716 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10717 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10718 The name may be either qualified or unqualified, with the stash defaulting
10719 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10720 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10721 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10722 the stash if necessary, with C<GV_ADDMULTI> semantics.
10723
10724 If there is already a subroutine of the specified name, then the new sub
10725 will replace the existing one in the glob.  A warning may be generated
10726 about the redefinition.  If the old subroutine was C<CvCONST> then the
10727 decision about whether to warn is influenced by an expectation about
10728 whether the new subroutine will become a constant of similar value.
10729 That expectation is determined by C<const_svp>.  (Note that the call to
10730 this function doesn't make the new subroutine C<CvCONST> in any case;
10731 that is left to the caller.)  If C<const_svp> is null then it indicates
10732 that the new subroutine will not become a constant.  If C<const_svp>
10733 is non-null then it indicates that the new subroutine will become a
10734 constant, and it points to an C<SV*> that provides the constant value
10735 that the subroutine will have.
10736
10737 If the subroutine has one of a few special names, such as C<BEGIN> or
10738 C<END>, then it will be claimed by the appropriate queue for automatic
10739 running of phase-related subroutines.  In this case the relevant glob will
10740 be left not containing any subroutine, even if it did contain one before.
10741 In the case of C<BEGIN>, the subroutine will be executed and the reference
10742 to it disposed of before this function returns, and also before its
10743 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10744 constructed by this function to be ready for execution then the caller
10745 must prevent this happening by giving the subroutine a different name.
10746
10747 The function returns a pointer to the constructed subroutine.  If the sub
10748 is anonymous then ownership of one counted reference to the subroutine
10749 is transferred to the caller.  If the sub is named then the caller does
10750 not get ownership of a reference.  In most such cases, where the sub
10751 has a non-phase name, the sub will be alive at the point it is returned
10752 by virtue of being contained in the glob that names it.  A phase-named
10753 subroutine will usually be alive by virtue of the reference owned by the
10754 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10755 been executed, will quite likely have been destroyed already by the
10756 time this function returns, making it erroneous for the caller to make
10757 any use of the returned pointer.  It is the caller's responsibility to
10758 ensure that it knows which of these situations applies.
10759
10760 =cut
10761 */
10762
10763 CV *
10764 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10765                            XSUBADDR_t subaddr, const char *const filename,
10766                            const char *const proto, SV **const_svp,
10767                            U32 flags)
10768 {
10769     CV *cv;
10770     bool interleave = FALSE;
10771     bool evanescent = FALSE;
10772
10773     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10774
10775     {
10776         GV * const gv = gv_fetchpvn(
10777                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10778                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10779                                 sizeof("__ANON__::__ANON__") - 1,
10780                             GV_ADDMULTI | flags, SVt_PVCV);
10781
10782         if ((cv = (name ? GvCV(gv) : NULL))) {
10783             if (GvCVGEN(gv)) {
10784                 /* just a cached method */
10785                 SvREFCNT_dec(cv);
10786                 cv = NULL;
10787             }
10788             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10789                 /* already defined (or promised) */
10790                 /* Redundant check that allows us to avoid creating an SV
10791                    most of the time: */
10792                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10793                     report_redefined_cv(newSVpvn_flags(
10794                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10795                                         ),
10796                                         cv, const_svp);
10797                 }
10798                 interleave = TRUE;
10799                 ENTER;
10800                 SAVEFREESV(cv);
10801                 cv = NULL;
10802             }
10803         }
10804
10805         if (cv)                         /* must reuse cv if autoloaded */
10806             cv_undef(cv);
10807         else {
10808             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10809             if (name) {
10810                 GvCV_set(gv,cv);
10811                 GvCVGEN(gv) = 0;
10812                 if (HvENAME_HEK(GvSTASH(gv)))
10813                     gv_method_changed(gv); /* newXS */
10814             }
10815         }
10816         assert(cv);
10817         assert(SvREFCNT((SV*)cv) != 0);
10818
10819         CvGV_set(cv, gv);
10820         if(filename) {
10821             /* XSUBs can't be perl lang/perl5db.pl debugged
10822             if (PERLDB_LINE_OR_SAVESRC)
10823                 (void)gv_fetchfile(filename); */
10824             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10825             if (flags & XS_DYNAMIC_FILENAME) {
10826                 CvDYNFILE_on(cv);
10827                 CvFILE(cv) = savepv(filename);
10828             } else {
10829             /* NOTE: not copied, as it is expected to be an external constant string */
10830                 CvFILE(cv) = (char *)filename;
10831             }
10832         } else {
10833             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10834             CvFILE(cv) = (char*)PL_xsubfilename;
10835         }
10836         CvISXSUB_on(cv);
10837         CvXSUB(cv) = subaddr;
10838 #ifndef PERL_IMPLICIT_CONTEXT
10839         CvHSCXT(cv) = &PL_stack_sp;
10840 #else
10841         PoisonPADLIST(cv);
10842 #endif
10843
10844         if (name)
10845             evanescent = process_special_blocks(0, name, gv, cv);
10846         else
10847             CvANON_on(cv);
10848     } /* <- not a conditional branch */
10849
10850     assert(cv);
10851     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10852
10853     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10854     if (interleave) LEAVE;
10855     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10856     return cv;
10857 }
10858
10859 /* Add a stub CV to a typeglob.
10860  * This is the implementation of a forward declaration, 'sub foo';'
10861  */
10862
10863 CV *
10864 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10865 {
10866     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10867     GV *cvgv;
10868     PERL_ARGS_ASSERT_NEWSTUB;
10869     assert(!GvCVu(gv));
10870     GvCV_set(gv, cv);
10871     GvCVGEN(gv) = 0;
10872     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10873         gv_method_changed(gv);
10874     if (SvFAKE(gv)) {
10875         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10876         SvFAKE_off(cvgv);
10877     }
10878     else cvgv = gv;
10879     CvGV_set(cv, cvgv);
10880     CvFILE_set_from_cop(cv, PL_curcop);
10881     CvSTASH_set(cv, PL_curstash);
10882     GvMULTI_on(gv);
10883     return cv;
10884 }
10885
10886 void
10887 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10888 {
10889     CV *cv;
10890     GV *gv;
10891     OP *root;
10892     OP *start;
10893
10894     if (PL_parser && PL_parser->error_count) {
10895         op_free(block);
10896         goto finish;
10897     }
10898
10899     gv = o
10900         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10901         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10902
10903     GvMULTI_on(gv);
10904     if ((cv = GvFORM(gv))) {
10905         if (ckWARN(WARN_REDEFINE)) {
10906             const line_t oldline = CopLINE(PL_curcop);
10907             if (PL_parser && PL_parser->copline != NOLINE)
10908                 CopLINE_set(PL_curcop, PL_parser->copline);
10909             if (o) {
10910                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10911                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10912             } else {
10913                 /* diag_listed_as: Format %s redefined */
10914                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10915                             "Format STDOUT redefined");
10916             }
10917             CopLINE_set(PL_curcop, oldline);
10918         }
10919         SvREFCNT_dec(cv);
10920     }
10921     cv = PL_compcv;
10922     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10923     CvGV_set(cv, gv);
10924     CvFILE_set_from_cop(cv, PL_curcop);
10925
10926
10927     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10928     CvROOT(cv) = root;
10929     start = LINKLIST(root);
10930     root->op_next = 0;
10931     S_process_optree(aTHX_ cv, root, start);
10932     cv_forget_slab(cv);
10933
10934   finish:
10935     op_free(o);
10936     if (PL_parser)
10937         PL_parser->copline = NOLINE;
10938     LEAVE_SCOPE(floor);
10939     PL_compiling.cop_seq = 0;
10940 }
10941
10942 OP *
10943 Perl_newANONLIST(pTHX_ OP *o)
10944 {
10945     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10946 }
10947
10948 OP *
10949 Perl_newANONHASH(pTHX_ OP *o)
10950 {
10951     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10952 }
10953
10954 OP *
10955 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10956 {
10957     return newANONATTRSUB(floor, proto, NULL, block);
10958 }
10959
10960 OP *
10961 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10962 {
10963     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10964     OP * anoncode =
10965         newSVOP(OP_ANONCODE, 0,
10966                 cv);
10967     if (CvANONCONST(cv))
10968         anoncode = newUNOP(OP_ANONCONST, 0,
10969                            op_convert_list(OP_ENTERSUB,
10970                                            OPf_STACKED|OPf_WANT_SCALAR,
10971                                            anoncode));
10972     return newUNOP(OP_REFGEN, 0, anoncode);
10973 }
10974
10975 OP *
10976 Perl_oopsAV(pTHX_ OP *o)
10977 {
10978     dVAR;
10979
10980     PERL_ARGS_ASSERT_OOPSAV;
10981
10982     switch (o->op_type) {
10983     case OP_PADSV:
10984     case OP_PADHV:
10985         OpTYPE_set(o, OP_PADAV);
10986         return ref(o, OP_RV2AV);
10987
10988     case OP_RV2SV:
10989     case OP_RV2HV:
10990         OpTYPE_set(o, OP_RV2AV);
10991         ref(o, OP_RV2AV);
10992         break;
10993
10994     default:
10995         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10996         break;
10997     }
10998     return o;
10999 }
11000
11001 OP *
11002 Perl_oopsHV(pTHX_ OP *o)
11003 {
11004     dVAR;
11005
11006     PERL_ARGS_ASSERT_OOPSHV;
11007
11008     switch (o->op_type) {
11009     case OP_PADSV:
11010     case OP_PADAV:
11011         OpTYPE_set(o, OP_PADHV);
11012         return ref(o, OP_RV2HV);
11013
11014     case OP_RV2SV:
11015     case OP_RV2AV:
11016         OpTYPE_set(o, OP_RV2HV);
11017         /* rv2hv steals the bottom bit for its own uses */
11018         o->op_private &= ~OPpARG1_MASK;
11019         ref(o, OP_RV2HV);
11020         break;
11021
11022     default:
11023         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11024         break;
11025     }
11026     return o;
11027 }
11028
11029 OP *
11030 Perl_newAVREF(pTHX_ OP *o)
11031 {
11032     dVAR;
11033
11034     PERL_ARGS_ASSERT_NEWAVREF;
11035
11036     if (o->op_type == OP_PADANY) {
11037         OpTYPE_set(o, OP_PADAV);
11038         return o;
11039     }
11040     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11041         Perl_croak(aTHX_ "Can't use an array as a reference");
11042     }
11043     return newUNOP(OP_RV2AV, 0, scalar(o));
11044 }
11045
11046 OP *
11047 Perl_newGVREF(pTHX_ I32 type, OP *o)
11048 {
11049     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11050         return newUNOP(OP_NULL, 0, o);
11051     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11052 }
11053
11054 OP *
11055 Perl_newHVREF(pTHX_ OP *o)
11056 {
11057     dVAR;
11058
11059     PERL_ARGS_ASSERT_NEWHVREF;
11060
11061     if (o->op_type == OP_PADANY) {
11062         OpTYPE_set(o, OP_PADHV);
11063         return o;
11064     }
11065     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11066         Perl_croak(aTHX_ "Can't use a hash as a reference");
11067     }
11068     return newUNOP(OP_RV2HV, 0, scalar(o));
11069 }
11070
11071 OP *
11072 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11073 {
11074     if (o->op_type == OP_PADANY) {
11075         dVAR;
11076         OpTYPE_set(o, OP_PADCV);
11077     }
11078     return newUNOP(OP_RV2CV, flags, scalar(o));
11079 }
11080
11081 OP *
11082 Perl_newSVREF(pTHX_ OP *o)
11083 {
11084     dVAR;
11085
11086     PERL_ARGS_ASSERT_NEWSVREF;
11087
11088     if (o->op_type == OP_PADANY) {
11089         OpTYPE_set(o, OP_PADSV);
11090         scalar(o);
11091         return o;
11092     }
11093     return newUNOP(OP_RV2SV, 0, scalar(o));
11094 }
11095
11096 /* Check routines. See the comments at the top of this file for details
11097  * on when these are called */
11098
11099 OP *
11100 Perl_ck_anoncode(pTHX_ OP *o)
11101 {
11102     PERL_ARGS_ASSERT_CK_ANONCODE;
11103
11104     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11105     cSVOPo->op_sv = NULL;
11106     return o;
11107 }
11108
11109 static void
11110 S_io_hints(pTHX_ OP *o)
11111 {
11112 #if O_BINARY != 0 || O_TEXT != 0
11113     HV * const table =
11114         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11115     if (table) {
11116         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11117         if (svp && *svp) {
11118             STRLEN len = 0;
11119             const char *d = SvPV_const(*svp, len);
11120             const I32 mode = mode_from_discipline(d, len);
11121             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11122 #  if O_BINARY != 0
11123             if (mode & O_BINARY)
11124                 o->op_private |= OPpOPEN_IN_RAW;
11125 #  endif
11126 #  if O_TEXT != 0
11127             if (mode & O_TEXT)
11128                 o->op_private |= OPpOPEN_IN_CRLF;
11129 #  endif
11130         }
11131
11132         svp = hv_fetchs(table, "open_OUT", FALSE);
11133         if (svp && *svp) {
11134             STRLEN len = 0;
11135             const char *d = SvPV_const(*svp, len);
11136             const I32 mode = mode_from_discipline(d, len);
11137             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11138 #  if O_BINARY != 0
11139             if (mode & O_BINARY)
11140                 o->op_private |= OPpOPEN_OUT_RAW;
11141 #  endif
11142 #  if O_TEXT != 0
11143             if (mode & O_TEXT)
11144                 o->op_private |= OPpOPEN_OUT_CRLF;
11145 #  endif
11146         }
11147     }
11148 #else
11149     PERL_UNUSED_CONTEXT;
11150     PERL_UNUSED_ARG(o);
11151 #endif
11152 }
11153
11154 OP *
11155 Perl_ck_backtick(pTHX_ OP *o)
11156 {
11157     GV *gv;
11158     OP *newop = NULL;
11159     OP *sibl;
11160     PERL_ARGS_ASSERT_CK_BACKTICK;
11161     o = ck_fun(o);
11162     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11163     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11164      && (gv = gv_override("readpipe",8)))
11165     {
11166         /* detach rest of siblings from o and its first child */
11167         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11168         newop = S_new_entersubop(aTHX_ gv, sibl);
11169     }
11170     else if (!(o->op_flags & OPf_KIDS))
11171         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11172     if (newop) {
11173         op_free(o);
11174         return newop;
11175     }
11176     S_io_hints(aTHX_ o);
11177     return o;
11178 }
11179
11180 OP *
11181 Perl_ck_bitop(pTHX_ OP *o)
11182 {
11183     PERL_ARGS_ASSERT_CK_BITOP;
11184
11185     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11186
11187     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11188             && OP_IS_INFIX_BIT(o->op_type))
11189     {
11190         const OP * const left = cBINOPo->op_first;
11191         const OP * const right = OpSIBLING(left);
11192         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11193                 (left->op_flags & OPf_PARENS) == 0) ||
11194             (OP_IS_NUMCOMPARE(right->op_type) &&
11195                 (right->op_flags & OPf_PARENS) == 0))
11196             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11197                           "Possible precedence problem on bitwise %s operator",
11198                            o->op_type ==  OP_BIT_OR
11199                          ||o->op_type == OP_NBIT_OR  ? "|"
11200                         :  o->op_type ==  OP_BIT_AND
11201                          ||o->op_type == OP_NBIT_AND ? "&"
11202                         :  o->op_type ==  OP_BIT_XOR
11203                          ||o->op_type == OP_NBIT_XOR ? "^"
11204                         :  o->op_type == OP_SBIT_OR  ? "|."
11205                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11206                            );
11207     }
11208     return o;
11209 }
11210
11211 PERL_STATIC_INLINE bool
11212 is_dollar_bracket(pTHX_ const OP * const o)
11213 {
11214     const OP *kid;
11215     PERL_UNUSED_CONTEXT;
11216     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11217         && (kid = cUNOPx(o)->op_first)
11218         && kid->op_type == OP_GV
11219         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11220 }
11221
11222 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11223
11224 OP *
11225 Perl_ck_cmp(pTHX_ OP *o)
11226 {
11227     bool is_eq;
11228     bool neg;
11229     bool reverse;
11230     bool iv0;
11231     OP *indexop, *constop, *start;
11232     SV *sv;
11233     IV iv;
11234
11235     PERL_ARGS_ASSERT_CK_CMP;
11236
11237     is_eq = (   o->op_type == OP_EQ
11238              || o->op_type == OP_NE
11239              || o->op_type == OP_I_EQ
11240              || o->op_type == OP_I_NE);
11241
11242     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11243         const OP *kid = cUNOPo->op_first;
11244         if (kid &&
11245             (
11246                 (   is_dollar_bracket(aTHX_ kid)
11247                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11248                 )
11249              || (   kid->op_type == OP_CONST
11250                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11251                 )
11252            )
11253         )
11254             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11255                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11256     }
11257
11258     /* convert (index(...) == -1) and variations into
11259      *   (r)index/BOOL(,NEG)
11260      */
11261
11262     reverse = FALSE;
11263
11264     indexop = cUNOPo->op_first;
11265     constop = OpSIBLING(indexop);
11266     start = NULL;
11267     if (indexop->op_type == OP_CONST) {
11268         constop = indexop;
11269         indexop = OpSIBLING(constop);
11270         start = constop;
11271         reverse = TRUE;
11272     }
11273
11274     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11275         return o;
11276
11277     /* ($lex = index(....)) == -1 */
11278     if (indexop->op_private & OPpTARGET_MY)
11279         return o;
11280
11281     if (constop->op_type != OP_CONST)
11282         return o;
11283
11284     sv = cSVOPx_sv(constop);
11285     if (!(sv && SvIOK_notUV(sv)))
11286         return o;
11287
11288     iv = SvIVX(sv);
11289     if (iv != -1 && iv != 0)
11290         return o;
11291     iv0 = (iv == 0);
11292
11293     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11294         if (!(iv0 ^ reverse))
11295             return o;
11296         neg = iv0;
11297     }
11298     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11299         if (iv0 ^ reverse)
11300             return o;
11301         neg = !iv0;
11302     }
11303     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11304         if (!(iv0 ^ reverse))
11305             return o;
11306         neg = !iv0;
11307     }
11308     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11309         if (iv0 ^ reverse)
11310             return o;
11311         neg = iv0;
11312     }
11313     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11314         if (iv0)
11315             return o;
11316         neg = TRUE;
11317     }
11318     else {
11319         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11320         if (iv0)
11321             return o;
11322         neg = FALSE;
11323     }
11324
11325     indexop->op_flags &= ~OPf_PARENS;
11326     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11327     indexop->op_private |= OPpTRUEBOOL;
11328     if (neg)
11329         indexop->op_private |= OPpINDEX_BOOLNEG;
11330     /* cut out the index op and free the eq,const ops */
11331     (void)op_sibling_splice(o, start, 1, NULL);
11332     op_free(o);
11333
11334     return indexop;
11335 }
11336
11337
11338 OP *
11339 Perl_ck_concat(pTHX_ OP *o)
11340 {
11341     const OP * const kid = cUNOPo->op_first;
11342
11343     PERL_ARGS_ASSERT_CK_CONCAT;
11344     PERL_UNUSED_CONTEXT;
11345
11346     /* reuse the padtmp returned by the concat child */
11347     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11348             !(kUNOP->op_first->op_flags & OPf_MOD))
11349     {
11350         o->op_flags |= OPf_STACKED;
11351         o->op_private |= OPpCONCAT_NESTED;
11352     }
11353     return o;
11354 }
11355
11356 OP *
11357 Perl_ck_spair(pTHX_ OP *o)
11358 {
11359     dVAR;
11360
11361     PERL_ARGS_ASSERT_CK_SPAIR;
11362
11363     if (o->op_flags & OPf_KIDS) {
11364         OP* newop;
11365         OP* kid;
11366         OP* kidkid;
11367         const OPCODE type = o->op_type;
11368         o = modkids(ck_fun(o), type);
11369         kid    = cUNOPo->op_first;
11370         kidkid = kUNOP->op_first;
11371         newop = OpSIBLING(kidkid);
11372         if (newop) {
11373             const OPCODE type = newop->op_type;
11374             if (OpHAS_SIBLING(newop))
11375                 return o;
11376             if (o->op_type == OP_REFGEN
11377              && (  type == OP_RV2CV
11378                 || (  !(newop->op_flags & OPf_PARENS)
11379                    && (  type == OP_RV2AV || type == OP_PADAV
11380                       || type == OP_RV2HV || type == OP_PADHV))))
11381                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11382             else if (OP_GIMME(newop,0) != G_SCALAR)
11383                 return o;
11384         }
11385         /* excise first sibling */
11386         op_sibling_splice(kid, NULL, 1, NULL);
11387         op_free(kidkid);
11388     }
11389     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11390      * and OP_CHOMP into OP_SCHOMP */
11391     o->op_ppaddr = PL_ppaddr[++o->op_type];
11392     return ck_fun(o);
11393 }
11394
11395 OP *
11396 Perl_ck_delete(pTHX_ OP *o)
11397 {
11398     PERL_ARGS_ASSERT_CK_DELETE;
11399
11400     o = ck_fun(o);
11401     o->op_private = 0;
11402     if (o->op_flags & OPf_KIDS) {
11403         OP * const kid = cUNOPo->op_first;
11404         switch (kid->op_type) {
11405         case OP_ASLICE:
11406             o->op_flags |= OPf_SPECIAL;
11407             /* FALLTHROUGH */
11408         case OP_HSLICE:
11409             o->op_private |= OPpSLICE;
11410             break;
11411         case OP_AELEM:
11412             o->op_flags |= OPf_SPECIAL;
11413             /* FALLTHROUGH */
11414         case OP_HELEM:
11415             break;
11416         case OP_KVASLICE:
11417             o->op_flags |= OPf_SPECIAL;
11418             /* FALLTHROUGH */
11419         case OP_KVHSLICE:
11420             o->op_private |= OPpKVSLICE;
11421             break;
11422         default:
11423             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11424                              "element or slice");
11425         }
11426         if (kid->op_private & OPpLVAL_INTRO)
11427             o->op_private |= OPpLVAL_INTRO;
11428         op_null(kid);
11429     }
11430     return o;
11431 }
11432
11433 OP *
11434 Perl_ck_eof(pTHX_ OP *o)
11435 {
11436     PERL_ARGS_ASSERT_CK_EOF;
11437
11438     if (o->op_flags & OPf_KIDS) {
11439         OP *kid;
11440         if (cLISTOPo->op_first->op_type == OP_STUB) {
11441             OP * const newop
11442                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11443             op_free(o);
11444             o = newop;
11445         }
11446         o = ck_fun(o);
11447         kid = cLISTOPo->op_first;
11448         if (kid->op_type == OP_RV2GV)
11449             kid->op_private |= OPpALLOW_FAKE;
11450     }
11451     return o;
11452 }
11453
11454
11455 OP *
11456 Perl_ck_eval(pTHX_ OP *o)
11457 {
11458     dVAR;
11459
11460     PERL_ARGS_ASSERT_CK_EVAL;
11461
11462     PL_hints |= HINT_BLOCK_SCOPE;
11463     if (o->op_flags & OPf_KIDS) {
11464         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11465         assert(kid);
11466
11467         if (o->op_type == OP_ENTERTRY) {
11468             LOGOP *enter;
11469
11470             /* cut whole sibling chain free from o */
11471             op_sibling_splice(o, NULL, -1, NULL);
11472             op_free(o);
11473
11474             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11475
11476             /* establish postfix order */
11477             enter->op_next = (OP*)enter;
11478
11479             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11480             OpTYPE_set(o, OP_LEAVETRY);
11481             enter->op_other = o;
11482             return o;
11483         }
11484         else {
11485             scalar((OP*)kid);
11486             S_set_haseval(aTHX);
11487         }
11488     }
11489     else {
11490         const U8 priv = o->op_private;
11491         op_free(o);
11492         /* the newUNOP will recursively call ck_eval(), which will handle
11493          * all the stuff at the end of this function, like adding
11494          * OP_HINTSEVAL
11495          */
11496         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11497     }
11498     o->op_targ = (PADOFFSET)PL_hints;
11499     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11500     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11501      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11502         /* Store a copy of %^H that pp_entereval can pick up. */
11503         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11504                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11505         /* append hhop to only child  */
11506         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11507
11508         o->op_private |= OPpEVAL_HAS_HH;
11509     }
11510     if (!(o->op_private & OPpEVAL_BYTES)
11511          && FEATURE_UNIEVAL_IS_ENABLED)
11512             o->op_private |= OPpEVAL_UNICODE;
11513     return o;
11514 }
11515
11516 OP *
11517 Perl_ck_exec(pTHX_ OP *o)
11518 {
11519     PERL_ARGS_ASSERT_CK_EXEC;
11520
11521     if (o->op_flags & OPf_STACKED) {
11522         OP *kid;
11523         o = ck_fun(o);
11524         kid = OpSIBLING(cUNOPo->op_first);
11525         if (kid->op_type == OP_RV2GV)
11526             op_null(kid);
11527     }
11528     else
11529         o = listkids(o);
11530     return o;
11531 }
11532
11533 OP *
11534 Perl_ck_exists(pTHX_ OP *o)
11535 {
11536     PERL_ARGS_ASSERT_CK_EXISTS;
11537
11538     o = ck_fun(o);
11539     if (o->op_flags & OPf_KIDS) {
11540         OP * const kid = cUNOPo->op_first;
11541         if (kid->op_type == OP_ENTERSUB) {
11542             (void) ref(kid, o->op_type);
11543             if (kid->op_type != OP_RV2CV
11544                         && !(PL_parser && PL_parser->error_count))
11545                 Perl_croak(aTHX_
11546                           "exists argument is not a subroutine name");
11547             o->op_private |= OPpEXISTS_SUB;
11548         }
11549         else if (kid->op_type == OP_AELEM)
11550             o->op_flags |= OPf_SPECIAL;
11551         else if (kid->op_type != OP_HELEM)
11552             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11553                              "element or a subroutine");
11554         op_null(kid);
11555     }
11556     return o;
11557 }
11558
11559 OP *
11560 Perl_ck_rvconst(pTHX_ OP *o)
11561 {
11562     dVAR;
11563     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11564
11565     PERL_ARGS_ASSERT_CK_RVCONST;
11566
11567     if (o->op_type == OP_RV2HV)
11568         /* rv2hv steals the bottom bit for its own uses */
11569         o->op_private &= ~OPpARG1_MASK;
11570
11571     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11572
11573     if (kid->op_type == OP_CONST) {
11574         int iscv;
11575         GV *gv;
11576         SV * const kidsv = kid->op_sv;
11577
11578         /* Is it a constant from cv_const_sv()? */
11579         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11580             return o;
11581         }
11582         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11583         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11584             const char *badthing;
11585             switch (o->op_type) {
11586             case OP_RV2SV:
11587                 badthing = "a SCALAR";
11588                 break;
11589             case OP_RV2AV:
11590                 badthing = "an ARRAY";
11591                 break;
11592             case OP_RV2HV:
11593                 badthing = "a HASH";
11594                 break;
11595             default:
11596                 badthing = NULL;
11597                 break;
11598             }
11599             if (badthing)
11600                 Perl_croak(aTHX_
11601                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11602                            SVfARG(kidsv), badthing);
11603         }
11604         /*
11605          * This is a little tricky.  We only want to add the symbol if we
11606          * didn't add it in the lexer.  Otherwise we get duplicate strict
11607          * warnings.  But if we didn't add it in the lexer, we must at
11608          * least pretend like we wanted to add it even if it existed before,
11609          * or we get possible typo warnings.  OPpCONST_ENTERED says
11610          * whether the lexer already added THIS instance of this symbol.
11611          */
11612         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11613         gv = gv_fetchsv(kidsv,
11614                 o->op_type == OP_RV2CV
11615                         && o->op_private & OPpMAY_RETURN_CONSTANT
11616                     ? GV_NOEXPAND
11617                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11618                 iscv
11619                     ? SVt_PVCV
11620                     : o->op_type == OP_RV2SV
11621                         ? SVt_PV
11622                         : o->op_type == OP_RV2AV
11623                             ? SVt_PVAV
11624                             : o->op_type == OP_RV2HV
11625                                 ? SVt_PVHV
11626                                 : SVt_PVGV);
11627         if (gv) {
11628             if (!isGV(gv)) {
11629                 assert(iscv);
11630                 assert(SvROK(gv));
11631                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11632                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11633                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11634             }
11635             OpTYPE_set(kid, OP_GV);
11636             SvREFCNT_dec(kid->op_sv);
11637 #ifdef USE_ITHREADS
11638             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11639             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11640             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11641             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11642             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11643 #else
11644             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11645 #endif
11646             kid->op_private = 0;
11647             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11648             SvFAKE_off(gv);
11649         }
11650     }
11651     return o;
11652 }
11653
11654 OP *
11655 Perl_ck_ftst(pTHX_ OP *o)
11656 {
11657     dVAR;
11658     const I32 type = o->op_type;
11659
11660     PERL_ARGS_ASSERT_CK_FTST;
11661
11662     if (o->op_flags & OPf_REF) {
11663         NOOP;
11664     }
11665     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11666         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11667         const OPCODE kidtype = kid->op_type;
11668
11669         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11670          && !kid->op_folded) {
11671             OP * const newop = newGVOP(type, OPf_REF,
11672                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11673             op_free(o);
11674             return newop;
11675         }
11676
11677         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11678             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11679             if (name) {
11680                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11681                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11682                             array_passed_to_stat, name);
11683             }
11684             else {
11685                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11686                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11687             }
11688        }
11689         scalar((OP *) kid);
11690         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11691             o->op_private |= OPpFT_ACCESS;
11692         if (type != OP_STAT && type != OP_LSTAT
11693             && PL_check[kidtype] == Perl_ck_ftst
11694             && kidtype != OP_STAT && kidtype != OP_LSTAT
11695         ) {
11696             o->op_private |= OPpFT_STACKED;
11697             kid->op_private |= OPpFT_STACKING;
11698             if (kidtype == OP_FTTTY && (
11699                    !(kid->op_private & OPpFT_STACKED)
11700                 || kid->op_private & OPpFT_AFTER_t
11701                ))
11702                 o->op_private |= OPpFT_AFTER_t;
11703         }
11704     }
11705     else {
11706         op_free(o);
11707         if (type == OP_FTTTY)
11708             o = newGVOP(type, OPf_REF, PL_stdingv);
11709         else
11710             o = newUNOP(type, 0, newDEFSVOP());
11711     }
11712     return o;
11713 }
11714
11715 OP *
11716 Perl_ck_fun(pTHX_ OP *o)
11717 {
11718     const int type = o->op_type;
11719     I32 oa = PL_opargs[type] >> OASHIFT;
11720
11721     PERL_ARGS_ASSERT_CK_FUN;
11722
11723     if (o->op_flags & OPf_STACKED) {
11724         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11725             oa &= ~OA_OPTIONAL;
11726         else
11727             return no_fh_allowed(o);
11728     }
11729
11730     if (o->op_flags & OPf_KIDS) {
11731         OP *prev_kid = NULL;
11732         OP *kid = cLISTOPo->op_first;
11733         I32 numargs = 0;
11734         bool seen_optional = FALSE;
11735
11736         if (kid->op_type == OP_PUSHMARK ||
11737             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11738         {
11739             prev_kid = kid;
11740             kid = OpSIBLING(kid);
11741         }
11742         if (kid && kid->op_type == OP_COREARGS) {
11743             bool optional = FALSE;
11744             while (oa) {
11745                 numargs++;
11746                 if (oa & OA_OPTIONAL) optional = TRUE;
11747                 oa = oa >> 4;
11748             }
11749             if (optional) o->op_private |= numargs;
11750             return o;
11751         }
11752
11753         while (oa) {
11754             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11755                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11756                     kid = newDEFSVOP();
11757                     /* append kid to chain */
11758                     op_sibling_splice(o, prev_kid, 0, kid);
11759                 }
11760                 seen_optional = TRUE;
11761             }
11762             if (!kid) break;
11763
11764             numargs++;
11765             switch (oa & 7) {
11766             case OA_SCALAR:
11767                 /* list seen where single (scalar) arg expected? */
11768                 if (numargs == 1 && !(oa >> 4)
11769                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11770                 {
11771                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11772                 }
11773                 if (type != OP_DELETE) scalar(kid);
11774                 break;
11775             case OA_LIST:
11776                 if (oa < 16) {
11777                     kid = 0;
11778                     continue;
11779                 }
11780                 else
11781                     list(kid);
11782                 break;
11783             case OA_AVREF:
11784                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11785                     && !OpHAS_SIBLING(kid))
11786                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11787                                    "Useless use of %s with no values",
11788                                    PL_op_desc[type]);
11789
11790                 if (kid->op_type == OP_CONST
11791                       && (  !SvROK(cSVOPx_sv(kid))
11792                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11793                         )
11794                     bad_type_pv(numargs, "array", o, kid);
11795                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11796                          || kid->op_type == OP_RV2GV) {
11797                     bad_type_pv(1, "array", o, kid);
11798                 }
11799                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11800                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11801                                          PL_op_desc[type]), 0);
11802                 }
11803                 else {
11804                     op_lvalue(kid, type);
11805                 }
11806                 break;
11807             case OA_HVREF:
11808                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11809                     bad_type_pv(numargs, "hash", o, kid);
11810                 op_lvalue(kid, type);
11811                 break;
11812             case OA_CVREF:
11813                 {
11814                     /* replace kid with newop in chain */
11815                     OP * const newop =
11816                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11817                     newop->op_next = newop;
11818                     kid = newop;
11819                 }
11820                 break;
11821             case OA_FILEREF:
11822                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11823                     if (kid->op_type == OP_CONST &&
11824                         (kid->op_private & OPpCONST_BARE))
11825                     {
11826                         OP * const newop = newGVOP(OP_GV, 0,
11827                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11828                         /* replace kid with newop in chain */
11829                         op_sibling_splice(o, prev_kid, 1, newop);
11830                         op_free(kid);
11831                         kid = newop;
11832                     }
11833                     else if (kid->op_type == OP_READLINE) {
11834                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11835                         bad_type_pv(numargs, "HANDLE", o, kid);
11836                     }
11837                     else {
11838                         I32 flags = OPf_SPECIAL;
11839                         I32 priv = 0;
11840                         PADOFFSET targ = 0;
11841
11842                         /* is this op a FH constructor? */
11843                         if (is_handle_constructor(o,numargs)) {
11844                             const char *name = NULL;
11845                             STRLEN len = 0;
11846                             U32 name_utf8 = 0;
11847                             bool want_dollar = TRUE;
11848
11849                             flags = 0;
11850                             /* Set a flag to tell rv2gv to vivify
11851                              * need to "prove" flag does not mean something
11852                              * else already - NI-S 1999/05/07
11853                              */
11854                             priv = OPpDEREF;
11855                             if (kid->op_type == OP_PADSV) {
11856                                 PADNAME * const pn
11857                                     = PAD_COMPNAME_SV(kid->op_targ);
11858                                 name = PadnamePV (pn);
11859                                 len  = PadnameLEN(pn);
11860                                 name_utf8 = PadnameUTF8(pn);
11861                             }
11862                             else if (kid->op_type == OP_RV2SV
11863                                      && kUNOP->op_first->op_type == OP_GV)
11864                             {
11865                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11866                                 name = GvNAME(gv);
11867                                 len = GvNAMELEN(gv);
11868                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11869                             }
11870                             else if (kid->op_type == OP_AELEM
11871                                      || kid->op_type == OP_HELEM)
11872                             {
11873                                  OP *firstop;
11874                                  OP *op = ((BINOP*)kid)->op_first;
11875                                  name = NULL;
11876                                  if (op) {
11877                                       SV *tmpstr = NULL;
11878                                       const char * const a =
11879                                            kid->op_type == OP_AELEM ?
11880                                            "[]" : "{}";
11881                                       if (((op->op_type == OP_RV2AV) ||
11882                                            (op->op_type == OP_RV2HV)) &&
11883                                           (firstop = ((UNOP*)op)->op_first) &&
11884                                           (firstop->op_type == OP_GV)) {
11885                                            /* packagevar $a[] or $h{} */
11886                                            GV * const gv = cGVOPx_gv(firstop);
11887                                            if (gv)
11888                                                 tmpstr =
11889                                                      Perl_newSVpvf(aTHX_
11890                                                                    "%s%c...%c",
11891                                                                    GvNAME(gv),
11892                                                                    a[0], a[1]);
11893                                       }
11894                                       else if (op->op_type == OP_PADAV
11895                                                || op->op_type == OP_PADHV) {
11896                                            /* lexicalvar $a[] or $h{} */
11897                                            const char * const padname =
11898                                                 PAD_COMPNAME_PV(op->op_targ);
11899                                            if (padname)
11900                                                 tmpstr =
11901                                                      Perl_newSVpvf(aTHX_
11902                                                                    "%s%c...%c",
11903                                                                    padname + 1,
11904                                                                    a[0], a[1]);
11905                                       }
11906                                       if (tmpstr) {
11907                                            name = SvPV_const(tmpstr, len);
11908                                            name_utf8 = SvUTF8(tmpstr);
11909                                            sv_2mortal(tmpstr);
11910                                       }
11911                                  }
11912                                  if (!name) {
11913                                       name = "__ANONIO__";
11914                                       len = 10;
11915                                       want_dollar = FALSE;
11916                                  }
11917                                  op_lvalue(kid, type);
11918                             }
11919                             if (name) {
11920                                 SV *namesv;
11921                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11922                                 namesv = PAD_SVl(targ);
11923                                 if (want_dollar && *name != '$')
11924                                     sv_setpvs(namesv, "$");
11925                                 else
11926                                     SvPVCLEAR(namesv);
11927                                 sv_catpvn(namesv, name, len);
11928                                 if ( name_utf8 ) SvUTF8_on(namesv);
11929                             }
11930                         }
11931                         scalar(kid);
11932                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11933                                     OP_RV2GV, flags);
11934                         kid->op_targ = targ;
11935                         kid->op_private |= priv;
11936                     }
11937                 }
11938                 scalar(kid);
11939                 break;
11940             case OA_SCALARREF:
11941                 if ((type == OP_UNDEF || type == OP_POS)
11942                     && numargs == 1 && !(oa >> 4)
11943                     && kid->op_type == OP_LIST)
11944                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11945                 op_lvalue(scalar(kid), type);
11946                 break;
11947             }
11948             oa >>= 4;
11949             prev_kid = kid;
11950             kid = OpSIBLING(kid);
11951         }
11952         /* FIXME - should the numargs or-ing move after the too many
11953          * arguments check? */
11954         o->op_private |= numargs;
11955         if (kid)
11956             return too_many_arguments_pv(o,OP_DESC(o), 0);
11957         listkids(o);
11958     }
11959     else if (PL_opargs[type] & OA_DEFGV) {
11960         /* Ordering of these two is important to keep f_map.t passing.  */
11961         op_free(o);
11962         return newUNOP(type, 0, newDEFSVOP());
11963     }
11964
11965     if (oa) {
11966         while (oa & OA_OPTIONAL)
11967             oa >>= 4;
11968         if (oa && oa != OA_LIST)
11969             return too_few_arguments_pv(o,OP_DESC(o), 0);
11970     }
11971     return o;
11972 }
11973
11974 OP *
11975 Perl_ck_glob(pTHX_ OP *o)
11976 {
11977     GV *gv;
11978
11979     PERL_ARGS_ASSERT_CK_GLOB;
11980
11981     o = ck_fun(o);
11982     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11983         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11984
11985     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11986     {
11987         /* convert
11988          *     glob
11989          *       \ null - const(wildcard)
11990          * into
11991          *     null
11992          *       \ enter
11993          *            \ list
11994          *                 \ mark - glob - rv2cv
11995          *                             |        \ gv(CORE::GLOBAL::glob)
11996          *                             |
11997          *                              \ null - const(wildcard)
11998          */
11999         o->op_flags |= OPf_SPECIAL;
12000         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12001         o = S_new_entersubop(aTHX_ gv, o);
12002         o = newUNOP(OP_NULL, 0, o);
12003         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12004         return o;
12005     }
12006     else o->op_flags &= ~OPf_SPECIAL;
12007 #if !defined(PERL_EXTERNAL_GLOB)
12008     if (!PL_globhook) {
12009         ENTER;
12010         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12011                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12012         LEAVE;
12013     }
12014 #endif /* !PERL_EXTERNAL_GLOB */
12015     gv = (GV *)newSV(0);
12016     gv_init(gv, 0, "", 0, 0);
12017     gv_IOadd(gv);
12018     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12019     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12020     scalarkids(o);
12021     return o;
12022 }
12023
12024 OP *
12025 Perl_ck_grep(pTHX_ OP *o)
12026 {
12027     LOGOP *gwop;
12028     OP *kid;
12029     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12030
12031     PERL_ARGS_ASSERT_CK_GREP;
12032
12033     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12034
12035     if (o->op_flags & OPf_STACKED) {
12036         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12037         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12038             return no_fh_allowed(o);
12039         o->op_flags &= ~OPf_STACKED;
12040     }
12041     kid = OpSIBLING(cLISTOPo->op_first);
12042     if (type == OP_MAPWHILE)
12043         list(kid);
12044     else
12045         scalar(kid);
12046     o = ck_fun(o);
12047     if (PL_parser && PL_parser->error_count)
12048         return o;
12049     kid = OpSIBLING(cLISTOPo->op_first);
12050     if (kid->op_type != OP_NULL)
12051         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12052     kid = kUNOP->op_first;
12053
12054     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12055     kid->op_next = (OP*)gwop;
12056     o->op_private = gwop->op_private = 0;
12057     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12058
12059     kid = OpSIBLING(cLISTOPo->op_first);
12060     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12061         op_lvalue(kid, OP_GREPSTART);
12062
12063     return (OP*)gwop;
12064 }
12065
12066 OP *
12067 Perl_ck_index(pTHX_ OP *o)
12068 {
12069     PERL_ARGS_ASSERT_CK_INDEX;
12070
12071     if (o->op_flags & OPf_KIDS) {
12072         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12073         if (kid)
12074             kid = OpSIBLING(kid);                       /* get past "big" */
12075         if (kid && kid->op_type == OP_CONST) {
12076             const bool save_taint = TAINT_get;
12077             SV *sv = kSVOP->op_sv;
12078             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12079                 && SvOK(sv) && !SvROK(sv))
12080             {
12081                 sv = newSV(0);
12082                 sv_copypv(sv, kSVOP->op_sv);
12083                 SvREFCNT_dec_NN(kSVOP->op_sv);
12084                 kSVOP->op_sv = sv;
12085             }
12086             if (SvOK(sv)) fbm_compile(sv, 0);
12087             TAINT_set(save_taint);
12088 #ifdef NO_TAINT_SUPPORT
12089             PERL_UNUSED_VAR(save_taint);
12090 #endif
12091         }
12092     }
12093     return ck_fun(o);
12094 }
12095
12096 OP *
12097 Perl_ck_lfun(pTHX_ OP *o)
12098 {
12099     const OPCODE type = o->op_type;
12100
12101     PERL_ARGS_ASSERT_CK_LFUN;
12102
12103     return modkids(ck_fun(o), type);
12104 }
12105
12106 OP *
12107 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12108 {
12109     PERL_ARGS_ASSERT_CK_DEFINED;
12110
12111     if ((o->op_flags & OPf_KIDS)) {
12112         switch (cUNOPo->op_first->op_type) {
12113         case OP_RV2AV:
12114         case OP_PADAV:
12115             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12116                              " (Maybe you should just omit the defined()?)");
12117             NOT_REACHED; /* NOTREACHED */
12118             break;
12119         case OP_RV2HV:
12120         case OP_PADHV:
12121             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12122                              " (Maybe you should just omit the defined()?)");
12123             NOT_REACHED; /* NOTREACHED */
12124             break;
12125         default:
12126             /* no warning */
12127             break;
12128         }
12129     }
12130     return ck_rfun(o);
12131 }
12132
12133 OP *
12134 Perl_ck_readline(pTHX_ OP *o)
12135 {
12136     PERL_ARGS_ASSERT_CK_READLINE;
12137
12138     if (o->op_flags & OPf_KIDS) {
12139          OP *kid = cLISTOPo->op_first;
12140          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12141     }
12142     else {
12143         OP * const newop
12144             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12145         op_free(o);
12146         return newop;
12147     }
12148     return o;
12149 }
12150
12151 OP *
12152 Perl_ck_rfun(pTHX_ OP *o)
12153 {
12154     const OPCODE type = o->op_type;
12155
12156     PERL_ARGS_ASSERT_CK_RFUN;
12157
12158     return refkids(ck_fun(o), type);
12159 }
12160
12161 OP *
12162 Perl_ck_listiob(pTHX_ OP *o)
12163 {
12164     OP *kid;
12165
12166     PERL_ARGS_ASSERT_CK_LISTIOB;
12167
12168     kid = cLISTOPo->op_first;
12169     if (!kid) {
12170         o = force_list(o, 1);
12171         kid = cLISTOPo->op_first;
12172     }
12173     if (kid->op_type == OP_PUSHMARK)
12174         kid = OpSIBLING(kid);
12175     if (kid && o->op_flags & OPf_STACKED)
12176         kid = OpSIBLING(kid);
12177     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12178         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12179          && !kid->op_folded) {
12180             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12181             scalar(kid);
12182             /* replace old const op with new OP_RV2GV parent */
12183             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12184                                         OP_RV2GV, OPf_REF);
12185             kid = OpSIBLING(kid);
12186         }
12187     }
12188
12189     if (!kid)
12190         op_append_elem(o->op_type, o, newDEFSVOP());
12191
12192     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12193     return listkids(o);
12194 }
12195
12196 OP *
12197 Perl_ck_smartmatch(pTHX_ OP *o)
12198 {
12199     dVAR;
12200     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12201     if (0 == (o->op_flags & OPf_SPECIAL)) {
12202         OP *first  = cBINOPo->op_first;
12203         OP *second = OpSIBLING(first);
12204
12205         /* Implicitly take a reference to an array or hash */
12206
12207         /* remove the original two siblings, then add back the
12208          * (possibly different) first and second sibs.
12209          */
12210         op_sibling_splice(o, NULL, 1, NULL);
12211         op_sibling_splice(o, NULL, 1, NULL);
12212         first  = ref_array_or_hash(first);
12213         second = ref_array_or_hash(second);
12214         op_sibling_splice(o, NULL, 0, second);
12215         op_sibling_splice(o, NULL, 0, first);
12216
12217         /* Implicitly take a reference to a regular expression */
12218         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12219             OpTYPE_set(first, OP_QR);
12220         }
12221         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12222             OpTYPE_set(second, OP_QR);
12223         }
12224     }
12225
12226     return o;
12227 }
12228
12229
12230 static OP *
12231 S_maybe_targlex(pTHX_ OP *o)
12232 {
12233     OP * const kid = cLISTOPo->op_first;
12234     /* has a disposable target? */
12235     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12236         && !(kid->op_flags & OPf_STACKED)
12237         /* Cannot steal the second time! */
12238         && !(kid->op_private & OPpTARGET_MY)
12239         )
12240     {
12241         OP * const kkid = OpSIBLING(kid);
12242
12243         /* Can just relocate the target. */
12244         if (kkid && kkid->op_type == OP_PADSV
12245             && (!(kkid->op_private & OPpLVAL_INTRO)
12246                || kkid->op_private & OPpPAD_STATE))
12247         {
12248             kid->op_targ = kkid->op_targ;
12249             kkid->op_targ = 0;
12250             /* Now we do not need PADSV and SASSIGN.
12251              * Detach kid and free the rest. */
12252             op_sibling_splice(o, NULL, 1, NULL);
12253             op_free(o);
12254             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12255             return kid;
12256         }
12257     }
12258     return o;
12259 }
12260
12261 OP *
12262 Perl_ck_sassign(pTHX_ OP *o)
12263 {
12264     dVAR;
12265     OP * const kid = cBINOPo->op_first;
12266
12267     PERL_ARGS_ASSERT_CK_SASSIGN;
12268
12269     if (OpHAS_SIBLING(kid)) {
12270         OP *kkid = OpSIBLING(kid);
12271         /* For state variable assignment with attributes, kkid is a list op
12272            whose op_last is a padsv. */
12273         if ((kkid->op_type == OP_PADSV ||
12274              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12275               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12276              )
12277             )
12278                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12279                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12280             return S_newONCEOP(aTHX_ o, kkid);
12281         }
12282     }
12283     return S_maybe_targlex(aTHX_ o);
12284 }
12285
12286
12287 OP *
12288 Perl_ck_match(pTHX_ OP *o)
12289 {
12290     PERL_UNUSED_CONTEXT;
12291     PERL_ARGS_ASSERT_CK_MATCH;
12292
12293     return o;
12294 }
12295
12296 OP *
12297 Perl_ck_method(pTHX_ OP *o)
12298 {
12299     SV *sv, *methsv, *rclass;
12300     const char* method;
12301     char* compatptr;
12302     int utf8;
12303     STRLEN len, nsplit = 0, i;
12304     OP* new_op;
12305     OP * const kid = cUNOPo->op_first;
12306
12307     PERL_ARGS_ASSERT_CK_METHOD;
12308     if (kid->op_type != OP_CONST) return o;
12309
12310     sv = kSVOP->op_sv;
12311
12312     /* replace ' with :: */
12313     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12314                                         SvEND(sv) - SvPVX(sv) )))
12315     {
12316         *compatptr = ':';
12317         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12318     }
12319
12320     method = SvPVX_const(sv);
12321     len = SvCUR(sv);
12322     utf8 = SvUTF8(sv) ? -1 : 1;
12323
12324     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12325         nsplit = i+1;
12326         break;
12327     }
12328
12329     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12330
12331     if (!nsplit) { /* $proto->method() */
12332         op_free(o);
12333         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12334     }
12335
12336     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12337         op_free(o);
12338         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12339     }
12340
12341     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12342     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12343         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12344         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12345     } else {
12346         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12347         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12348     }
12349 #ifdef USE_ITHREADS
12350     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12351 #else
12352     cMETHOPx(new_op)->op_rclass_sv = rclass;
12353 #endif
12354     op_free(o);
12355     return new_op;
12356 }
12357
12358 OP *
12359 Perl_ck_null(pTHX_ OP *o)
12360 {
12361     PERL_ARGS_ASSERT_CK_NULL;
12362     PERL_UNUSED_CONTEXT;
12363     return o;
12364 }
12365
12366 OP *
12367 Perl_ck_open(pTHX_ OP *o)
12368 {
12369     PERL_ARGS_ASSERT_CK_OPEN;
12370
12371     S_io_hints(aTHX_ o);
12372     {
12373          /* In case of three-arg dup open remove strictness
12374           * from the last arg if it is a bareword. */
12375          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12376          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12377          OP *oa;
12378          const char *mode;
12379
12380          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12381              (last->op_private & OPpCONST_BARE) &&
12382              (last->op_private & OPpCONST_STRICT) &&
12383              (oa = OpSIBLING(first)) &&         /* The fh. */
12384              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12385              (oa->op_type == OP_CONST) &&
12386              SvPOK(((SVOP*)oa)->op_sv) &&
12387              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12388              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12389              (last == OpSIBLING(oa)))                   /* The bareword. */
12390               last->op_private &= ~OPpCONST_STRICT;
12391     }
12392     return ck_fun(o);
12393 }
12394
12395 OP *
12396 Perl_ck_prototype(pTHX_ OP *o)
12397 {
12398     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12399     if (!(o->op_flags & OPf_KIDS)) {
12400         op_free(o);
12401         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12402     }
12403     return o;
12404 }
12405
12406 OP *
12407 Perl_ck_refassign(pTHX_ OP *o)
12408 {
12409     OP * const right = cLISTOPo->op_first;
12410     OP * const left = OpSIBLING(right);
12411     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12412     bool stacked = 0;
12413
12414     PERL_ARGS_ASSERT_CK_REFASSIGN;
12415     assert (left);
12416     assert (left->op_type == OP_SREFGEN);
12417
12418     o->op_private = 0;
12419     /* we use OPpPAD_STATE in refassign to mean either of those things,
12420      * and the code assumes the two flags occupy the same bit position
12421      * in the various ops below */
12422     assert(OPpPAD_STATE == OPpOUR_INTRO);
12423
12424     switch (varop->op_type) {
12425     case OP_PADAV:
12426         o->op_private |= OPpLVREF_AV;
12427         goto settarg;
12428     case OP_PADHV:
12429         o->op_private |= OPpLVREF_HV;
12430         /* FALLTHROUGH */
12431     case OP_PADSV:
12432       settarg:
12433         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12434         o->op_targ = varop->op_targ;
12435         varop->op_targ = 0;
12436         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12437         break;
12438
12439     case OP_RV2AV:
12440         o->op_private |= OPpLVREF_AV;
12441         goto checkgv;
12442         NOT_REACHED; /* NOTREACHED */
12443     case OP_RV2HV:
12444         o->op_private |= OPpLVREF_HV;
12445         /* FALLTHROUGH */
12446     case OP_RV2SV:
12447       checkgv:
12448         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12449         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12450       detach_and_stack:
12451         /* Point varop to its GV kid, detached.  */
12452         varop = op_sibling_splice(varop, NULL, -1, NULL);
12453         stacked = TRUE;
12454         break;
12455     case OP_RV2CV: {
12456         OP * const kidparent =
12457             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12458         OP * const kid = cUNOPx(kidparent)->op_first;
12459         o->op_private |= OPpLVREF_CV;
12460         if (kid->op_type == OP_GV) {
12461             varop = kidparent;
12462             goto detach_and_stack;
12463         }
12464         if (kid->op_type != OP_PADCV)   goto bad;
12465         o->op_targ = kid->op_targ;
12466         kid->op_targ = 0;
12467         break;
12468     }
12469     case OP_AELEM:
12470     case OP_HELEM:
12471         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12472         o->op_private |= OPpLVREF_ELEM;
12473         op_null(varop);
12474         stacked = TRUE;
12475         /* Detach varop.  */
12476         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12477         break;
12478     default:
12479       bad:
12480         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12481         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12482                                 "assignment",
12483                                  OP_DESC(varop)));
12484         return o;
12485     }
12486     if (!FEATURE_REFALIASING_IS_ENABLED)
12487         Perl_croak(aTHX_
12488                   "Experimental aliasing via reference not enabled");
12489     Perl_ck_warner_d(aTHX_
12490                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12491                     "Aliasing via reference is experimental");
12492     if (stacked) {
12493         o->op_flags |= OPf_STACKED;
12494         op_sibling_splice(o, right, 1, varop);
12495     }
12496     else {
12497         o->op_flags &=~ OPf_STACKED;
12498         op_sibling_splice(o, right, 1, NULL);
12499     }
12500     op_free(left);
12501     return o;
12502 }
12503
12504 OP *
12505 Perl_ck_repeat(pTHX_ OP *o)
12506 {
12507     PERL_ARGS_ASSERT_CK_REPEAT;
12508
12509     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12510         OP* kids;
12511         o->op_private |= OPpREPEAT_DOLIST;
12512         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12513         kids = force_list(kids, 1); /* promote it to a list */
12514         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12515     }
12516     else
12517         scalar(o);
12518     return o;
12519 }
12520
12521 OP *
12522 Perl_ck_require(pTHX_ OP *o)
12523 {
12524     GV* gv;
12525
12526     PERL_ARGS_ASSERT_CK_REQUIRE;
12527
12528     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12529         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12530         U32 hash;
12531         char *s;
12532         STRLEN len;
12533         if (kid->op_type == OP_CONST) {
12534           SV * const sv = kid->op_sv;
12535           U32 const was_readonly = SvREADONLY(sv);
12536           if (kid->op_private & OPpCONST_BARE) {
12537             dVAR;
12538             const char *end;
12539             HEK *hek;
12540
12541             if (was_readonly) {
12542                     SvREADONLY_off(sv);
12543             }
12544             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12545
12546             s = SvPVX(sv);
12547             len = SvCUR(sv);
12548             end = s + len;
12549             /* treat ::foo::bar as foo::bar */
12550             if (len >= 2 && s[0] == ':' && s[1] == ':')
12551                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12552             if (s == end)
12553                 DIE(aTHX_ "Bareword in require maps to empty filename");
12554
12555             for (; s < end; s++) {
12556                 if (*s == ':' && s[1] == ':') {
12557                     *s = '/';
12558                     Move(s+2, s+1, end - s - 1, char);
12559                     --end;
12560                 }
12561             }
12562             SvEND_set(sv, end);
12563             sv_catpvs(sv, ".pm");
12564             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12565             hek = share_hek(SvPVX(sv),
12566                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12567                             hash);
12568             sv_sethek(sv, hek);
12569             unshare_hek(hek);
12570             SvFLAGS(sv) |= was_readonly;
12571           }
12572           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12573                 && !SvVOK(sv)) {
12574             s = SvPV(sv, len);
12575             if (SvREFCNT(sv) > 1) {
12576                 kid->op_sv = newSVpvn_share(
12577                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12578                 SvREFCNT_dec_NN(sv);
12579             }
12580             else {
12581                 dVAR;
12582                 HEK *hek;
12583                 if (was_readonly) SvREADONLY_off(sv);
12584                 PERL_HASH(hash, s, len);
12585                 hek = share_hek(s,
12586                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12587                                 hash);
12588                 sv_sethek(sv, hek);
12589                 unshare_hek(hek);
12590                 SvFLAGS(sv) |= was_readonly;
12591             }
12592           }
12593         }
12594     }
12595
12596     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12597         /* handle override, if any */
12598      && (gv = gv_override("require", 7))) {
12599         OP *kid, *newop;
12600         if (o->op_flags & OPf_KIDS) {
12601             kid = cUNOPo->op_first;
12602             op_sibling_splice(o, NULL, -1, NULL);
12603         }
12604         else {
12605             kid = newDEFSVOP();
12606         }
12607         op_free(o);
12608         newop = S_new_entersubop(aTHX_ gv, kid);
12609         return newop;
12610     }
12611
12612     return ck_fun(o);
12613 }
12614
12615 OP *
12616 Perl_ck_return(pTHX_ OP *o)
12617 {
12618     OP *kid;
12619
12620     PERL_ARGS_ASSERT_CK_RETURN;
12621
12622     kid = OpSIBLING(cLISTOPo->op_first);
12623     if (PL_compcv && CvLVALUE(PL_compcv)) {
12624         for (; kid; kid = OpSIBLING(kid))
12625             op_lvalue(kid, OP_LEAVESUBLV);
12626     }
12627
12628     return o;
12629 }
12630
12631 OP *
12632 Perl_ck_select(pTHX_ OP *o)
12633 {
12634     dVAR;
12635     OP* kid;
12636
12637     PERL_ARGS_ASSERT_CK_SELECT;
12638
12639     if (o->op_flags & OPf_KIDS) {
12640         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12641         if (kid && OpHAS_SIBLING(kid)) {
12642             OpTYPE_set(o, OP_SSELECT);
12643             o = ck_fun(o);
12644             return fold_constants(op_integerize(op_std_init(o)));
12645         }
12646     }
12647     o = ck_fun(o);
12648     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12649     if (kid && kid->op_type == OP_RV2GV)
12650         kid->op_private &= ~HINT_STRICT_REFS;
12651     return o;
12652 }
12653
12654 OP *
12655 Perl_ck_shift(pTHX_ OP *o)
12656 {
12657     const I32 type = o->op_type;
12658
12659     PERL_ARGS_ASSERT_CK_SHIFT;
12660
12661     if (!(o->op_flags & OPf_KIDS)) {
12662         OP *argop;
12663
12664         if (!CvUNIQUE(PL_compcv)) {
12665             o->op_flags |= OPf_SPECIAL;
12666             return o;
12667         }
12668
12669         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12670         op_free(o);
12671         return newUNOP(type, 0, scalar(argop));
12672     }
12673     return scalar(ck_fun(o));
12674 }
12675
12676 OP *
12677 Perl_ck_sort(pTHX_ OP *o)
12678 {
12679     OP *firstkid;
12680     OP *kid;
12681     HV * const hinthv =
12682         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12683     U8 stacked;
12684
12685     PERL_ARGS_ASSERT_CK_SORT;
12686
12687     if (hinthv) {
12688             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12689             if (svp) {
12690                 const I32 sorthints = (I32)SvIV(*svp);
12691                 if ((sorthints & HINT_SORT_STABLE) != 0)
12692                     o->op_private |= OPpSORT_STABLE;
12693                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12694                     o->op_private |= OPpSORT_UNSTABLE;
12695             }
12696     }
12697
12698     if (o->op_flags & OPf_STACKED)
12699         simplify_sort(o);
12700     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12701
12702     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12703         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12704
12705         /* if the first arg is a code block, process it and mark sort as
12706          * OPf_SPECIAL */
12707         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12708             LINKLIST(kid);
12709             if (kid->op_type == OP_LEAVE)
12710                     op_null(kid);                       /* wipe out leave */
12711             /* Prevent execution from escaping out of the sort block. */
12712             kid->op_next = 0;
12713
12714             /* provide scalar context for comparison function/block */
12715             kid = scalar(firstkid);
12716             kid->op_next = kid;
12717             o->op_flags |= OPf_SPECIAL;
12718         }
12719         else if (kid->op_type == OP_CONST
12720               && kid->op_private & OPpCONST_BARE) {
12721             char tmpbuf[256];
12722             STRLEN len;
12723             PADOFFSET off;
12724             const char * const name = SvPV(kSVOP_sv, len);
12725             *tmpbuf = '&';
12726             assert (len < 256);
12727             Copy(name, tmpbuf+1, len, char);
12728             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12729             if (off != NOT_IN_PAD) {
12730                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12731                     SV * const fq =
12732                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12733                     sv_catpvs(fq, "::");
12734                     sv_catsv(fq, kSVOP_sv);
12735                     SvREFCNT_dec_NN(kSVOP_sv);
12736                     kSVOP->op_sv = fq;
12737                 }
12738                 else {
12739                     OP * const padop = newOP(OP_PADCV, 0);
12740                     padop->op_targ = off;
12741                     /* replace the const op with the pad op */
12742                     op_sibling_splice(firstkid, NULL, 1, padop);
12743                     op_free(kid);
12744                 }
12745             }
12746         }
12747
12748         firstkid = OpSIBLING(firstkid);
12749     }
12750
12751     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12752         /* provide list context for arguments */
12753         list(kid);
12754         if (stacked)
12755             op_lvalue(kid, OP_GREPSTART);
12756     }
12757
12758     return o;
12759 }
12760
12761 /* for sort { X } ..., where X is one of
12762  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12763  * elide the second child of the sort (the one containing X),
12764  * and set these flags as appropriate
12765         OPpSORT_NUMERIC;
12766         OPpSORT_INTEGER;
12767         OPpSORT_DESCEND;
12768  * Also, check and warn on lexical $a, $b.
12769  */
12770
12771 STATIC void
12772 S_simplify_sort(pTHX_ OP *o)
12773 {
12774     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12775     OP *k;
12776     int descending;
12777     GV *gv;
12778     const char *gvname;
12779     bool have_scopeop;
12780
12781     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12782
12783     kid = kUNOP->op_first;                              /* get past null */
12784     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12785      && kid->op_type != OP_LEAVE)
12786         return;
12787     kid = kLISTOP->op_last;                             /* get past scope */
12788     switch(kid->op_type) {
12789         case OP_NCMP:
12790         case OP_I_NCMP:
12791         case OP_SCMP:
12792             if (!have_scopeop) goto padkids;
12793             break;
12794         default:
12795             return;
12796     }
12797     k = kid;                                            /* remember this node*/
12798     if (kBINOP->op_first->op_type != OP_RV2SV
12799      || kBINOP->op_last ->op_type != OP_RV2SV)
12800     {
12801         /*
12802            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12803            then used in a comparison.  This catches most, but not
12804            all cases.  For instance, it catches
12805                sort { my($a); $a <=> $b }
12806            but not
12807                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12808            (although why you'd do that is anyone's guess).
12809         */
12810
12811        padkids:
12812         if (!ckWARN(WARN_SYNTAX)) return;
12813         kid = kBINOP->op_first;
12814         do {
12815             if (kid->op_type == OP_PADSV) {
12816                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12817                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12818                  && (  PadnamePV(name)[1] == 'a'
12819                     || PadnamePV(name)[1] == 'b'  ))
12820                     /* diag_listed_as: "my %s" used in sort comparison */
12821                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12822                                      "\"%s %s\" used in sort comparison",
12823                                       PadnameIsSTATE(name)
12824                                         ? "state"
12825                                         : "my",
12826                                       PadnamePV(name));
12827             }
12828         } while ((kid = OpSIBLING(kid)));
12829         return;
12830     }
12831     kid = kBINOP->op_first;                             /* get past cmp */
12832     if (kUNOP->op_first->op_type != OP_GV)
12833         return;
12834     kid = kUNOP->op_first;                              /* get past rv2sv */
12835     gv = kGVOP_gv;
12836     if (GvSTASH(gv) != PL_curstash)
12837         return;
12838     gvname = GvNAME(gv);
12839     if (*gvname == 'a' && gvname[1] == '\0')
12840         descending = 0;
12841     else if (*gvname == 'b' && gvname[1] == '\0')
12842         descending = 1;
12843     else
12844         return;
12845
12846     kid = k;                                            /* back to cmp */
12847     /* already checked above that it is rv2sv */
12848     kid = kBINOP->op_last;                              /* down to 2nd arg */
12849     if (kUNOP->op_first->op_type != OP_GV)
12850         return;
12851     kid = kUNOP->op_first;                              /* get past rv2sv */
12852     gv = kGVOP_gv;
12853     if (GvSTASH(gv) != PL_curstash)
12854         return;
12855     gvname = GvNAME(gv);
12856     if ( descending
12857          ? !(*gvname == 'a' && gvname[1] == '\0')
12858          : !(*gvname == 'b' && gvname[1] == '\0'))
12859         return;
12860     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12861     if (descending)
12862         o->op_private |= OPpSORT_DESCEND;
12863     if (k->op_type == OP_NCMP)
12864         o->op_private |= OPpSORT_NUMERIC;
12865     if (k->op_type == OP_I_NCMP)
12866         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12867     kid = OpSIBLING(cLISTOPo->op_first);
12868     /* cut out and delete old block (second sibling) */
12869     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12870     op_free(kid);
12871 }
12872
12873 OP *
12874 Perl_ck_split(pTHX_ OP *o)
12875 {
12876     dVAR;
12877     OP *kid;
12878     OP *sibs;
12879
12880     PERL_ARGS_ASSERT_CK_SPLIT;
12881
12882     assert(o->op_type == OP_LIST);
12883
12884     if (o->op_flags & OPf_STACKED)
12885         return no_fh_allowed(o);
12886
12887     kid = cLISTOPo->op_first;
12888     /* delete leading NULL node, then add a CONST if no other nodes */
12889     assert(kid->op_type == OP_NULL);
12890     op_sibling_splice(o, NULL, 1,
12891         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12892     op_free(kid);
12893     kid = cLISTOPo->op_first;
12894
12895     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12896         /* remove match expression, and replace with new optree with
12897          * a match op at its head */
12898         op_sibling_splice(o, NULL, 1, NULL);
12899         /* pmruntime will handle split " " behavior with flag==2 */
12900         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12901         op_sibling_splice(o, NULL, 0, kid);
12902     }
12903
12904     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12905
12906     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12907       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12908                      "Use of /g modifier is meaningless in split");
12909     }
12910
12911     /* eliminate the split op, and move the match op (plus any children)
12912      * into its place, then convert the match op into a split op. i.e.
12913      *
12914      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12915      *    |                        |                     |
12916      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12917      *    |                        |                     |
12918      *    R                        X - Y                 X - Y
12919      *    |
12920      *    X - Y
12921      *
12922      * (R, if it exists, will be a regcomp op)
12923      */
12924
12925     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12926     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12927     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12928     OpTYPE_set(kid, OP_SPLIT);
12929     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12930     kid->op_private = o->op_private;
12931     op_free(o);
12932     o = kid;
12933     kid = sibs; /* kid is now the string arg of the split */
12934
12935     if (!kid) {
12936         kid = newDEFSVOP();
12937         op_append_elem(OP_SPLIT, o, kid);
12938     }
12939     scalar(kid);
12940
12941     kid = OpSIBLING(kid);
12942     if (!kid) {
12943         kid = newSVOP(OP_CONST, 0, newSViv(0));
12944         op_append_elem(OP_SPLIT, o, kid);
12945         o->op_private |= OPpSPLIT_IMPLIM;
12946     }
12947     scalar(kid);
12948
12949     if (OpHAS_SIBLING(kid))
12950         return too_many_arguments_pv(o,OP_DESC(o), 0);
12951
12952     return o;
12953 }
12954
12955 OP *
12956 Perl_ck_stringify(pTHX_ OP *o)
12957 {
12958     OP * const kid = OpSIBLING(cUNOPo->op_first);
12959     PERL_ARGS_ASSERT_CK_STRINGIFY;
12960     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12961          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12962          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12963         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12964     {
12965         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12966         op_free(o);
12967         return kid;
12968     }
12969     return ck_fun(o);
12970 }
12971
12972 OP *
12973 Perl_ck_join(pTHX_ OP *o)
12974 {
12975     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12976
12977     PERL_ARGS_ASSERT_CK_JOIN;
12978
12979     if (kid && kid->op_type == OP_MATCH) {
12980         if (ckWARN(WARN_SYNTAX)) {
12981             const REGEXP *re = PM_GETRE(kPMOP);
12982             const SV *msg = re
12983                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12984                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12985                     : newSVpvs_flags( "STRING", SVs_TEMP );
12986             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12987                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12988                         SVfARG(msg), SVfARG(msg));
12989         }
12990     }
12991     if (kid
12992      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12993         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12994         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12995            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12996     {
12997         const OP * const bairn = OpSIBLING(kid); /* the list */
12998         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12999          && OP_GIMME(bairn,0) == G_SCALAR)
13000         {
13001             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13002                                      op_sibling_splice(o, kid, 1, NULL));
13003             op_free(o);
13004             return ret;
13005         }
13006     }
13007
13008     return ck_fun(o);
13009 }
13010
13011 /*
13012 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
13013
13014 Examines an op, which is expected to identify a subroutine at runtime,
13015 and attempts to determine at compile time which subroutine it identifies.
13016 This is normally used during Perl compilation to determine whether
13017 a prototype can be applied to a function call.  C<cvop> is the op
13018 being considered, normally an C<rv2cv> op.  A pointer to the identified
13019 subroutine is returned, if it could be determined statically, and a null
13020 pointer is returned if it was not possible to determine statically.
13021
13022 Currently, the subroutine can be identified statically if the RV that the
13023 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13024 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13025 suitable if the constant value must be an RV pointing to a CV.  Details of
13026 this process may change in future versions of Perl.  If the C<rv2cv> op
13027 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13028 the subroutine statically: this flag is used to suppress compile-time
13029 magic on a subroutine call, forcing it to use default runtime behaviour.
13030
13031 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13032 of a GV reference is modified.  If a GV was examined and its CV slot was
13033 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13034 If the op is not optimised away, and the CV slot is later populated with
13035 a subroutine having a prototype, that flag eventually triggers the warning
13036 "called too early to check prototype".
13037
13038 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13039 of returning a pointer to the subroutine it returns a pointer to the
13040 GV giving the most appropriate name for the subroutine in this context.
13041 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13042 (C<CvANON>) subroutine that is referenced through a GV it will be the
13043 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13044 A null pointer is returned as usual if there is no statically-determinable
13045 subroutine.
13046
13047 =cut
13048 */
13049
13050 /* shared by toke.c:yylex */
13051 CV *
13052 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13053 {
13054     PADNAME *name = PAD_COMPNAME(off);
13055     CV *compcv = PL_compcv;
13056     while (PadnameOUTER(name)) {
13057         assert(PARENT_PAD_INDEX(name));
13058         compcv = CvOUTSIDE(compcv);
13059         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13060                 [off = PARENT_PAD_INDEX(name)];
13061     }
13062     assert(!PadnameIsOUR(name));
13063     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13064         return PadnamePROTOCV(name);
13065     }
13066     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13067 }
13068
13069 CV *
13070 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13071 {
13072     OP *rvop;
13073     CV *cv;
13074     GV *gv;
13075     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13076     if (flags & ~RV2CVOPCV_FLAG_MASK)
13077         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13078     if (cvop->op_type != OP_RV2CV)
13079         return NULL;
13080     if (cvop->op_private & OPpENTERSUB_AMPER)
13081         return NULL;
13082     if (!(cvop->op_flags & OPf_KIDS))
13083         return NULL;
13084     rvop = cUNOPx(cvop)->op_first;
13085     switch (rvop->op_type) {
13086         case OP_GV: {
13087             gv = cGVOPx_gv(rvop);
13088             if (!isGV(gv)) {
13089                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13090                     cv = MUTABLE_CV(SvRV(gv));
13091                     gv = NULL;
13092                     break;
13093                 }
13094                 if (flags & RV2CVOPCV_RETURN_STUB)
13095                     return (CV *)gv;
13096                 else return NULL;
13097             }
13098             cv = GvCVu(gv);
13099             if (!cv) {
13100                 if (flags & RV2CVOPCV_MARK_EARLY)
13101                     rvop->op_private |= OPpEARLY_CV;
13102                 return NULL;
13103             }
13104         } break;
13105         case OP_CONST: {
13106             SV *rv = cSVOPx_sv(rvop);
13107             if (!SvROK(rv))
13108                 return NULL;
13109             cv = (CV*)SvRV(rv);
13110             gv = NULL;
13111         } break;
13112         case OP_PADCV: {
13113             cv = find_lexical_cv(rvop->op_targ);
13114             gv = NULL;
13115         } break;
13116         default: {
13117             return NULL;
13118         } NOT_REACHED; /* NOTREACHED */
13119     }
13120     if (SvTYPE((SV*)cv) != SVt_PVCV)
13121         return NULL;
13122     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13123         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13124             gv = CvGV(cv);
13125         return (CV*)gv;
13126     }
13127     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13128         if (CvLEXICAL(cv) || CvNAMED(cv))
13129             return NULL;
13130         if (!CvANON(cv) || !gv)
13131             gv = CvGV(cv);
13132         return (CV*)gv;
13133
13134     } else {
13135         return cv;
13136     }
13137 }
13138
13139 /*
13140 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13141
13142 Performs the default fixup of the arguments part of an C<entersub>
13143 op tree.  This consists of applying list context to each of the
13144 argument ops.  This is the standard treatment used on a call marked
13145 with C<&>, or a method call, or a call through a subroutine reference,
13146 or any other call where the callee can't be identified at compile time,
13147 or a call where the callee has no prototype.
13148
13149 =cut
13150 */
13151
13152 OP *
13153 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13154 {
13155     OP *aop;
13156
13157     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13158
13159     aop = cUNOPx(entersubop)->op_first;
13160     if (!OpHAS_SIBLING(aop))
13161         aop = cUNOPx(aop)->op_first;
13162     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13163         /* skip the extra attributes->import() call implicitly added in
13164          * something like foo(my $x : bar)
13165          */
13166         if (   aop->op_type == OP_ENTERSUB
13167             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13168         )
13169             continue;
13170         list(aop);
13171         op_lvalue(aop, OP_ENTERSUB);
13172     }
13173     return entersubop;
13174 }
13175
13176 /*
13177 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13178
13179 Performs the fixup of the arguments part of an C<entersub> op tree
13180 based on a subroutine prototype.  This makes various modifications to
13181 the argument ops, from applying context up to inserting C<refgen> ops,
13182 and checking the number and syntactic types of arguments, as directed by
13183 the prototype.  This is the standard treatment used on a subroutine call,
13184 not marked with C<&>, where the callee can be identified at compile time
13185 and has a prototype.
13186
13187 C<protosv> supplies the subroutine prototype to be applied to the call.
13188 It may be a normal defined scalar, of which the string value will be used.
13189 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13190 that has been cast to C<SV*>) which has a prototype.  The prototype
13191 supplied, in whichever form, does not need to match the actual callee
13192 referenced by the op tree.
13193
13194 If the argument ops disagree with the prototype, for example by having
13195 an unacceptable number of arguments, a valid op tree is returned anyway.
13196 The error is reflected in the parser state, normally resulting in a single
13197 exception at the top level of parsing which covers all the compilation
13198 errors that occurred.  In the error message, the callee is referred to
13199 by the name defined by the C<namegv> parameter.
13200
13201 =cut
13202 */
13203
13204 OP *
13205 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13206 {
13207     STRLEN proto_len;
13208     const char *proto, *proto_end;
13209     OP *aop, *prev, *cvop, *parent;
13210     int optional = 0;
13211     I32 arg = 0;
13212     I32 contextclass = 0;
13213     const char *e = NULL;
13214     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13215     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13216         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13217                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13218     if (SvTYPE(protosv) == SVt_PVCV)
13219          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13220     else proto = SvPV(protosv, proto_len);
13221     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13222     proto_end = proto + proto_len;
13223     parent = entersubop;
13224     aop = cUNOPx(entersubop)->op_first;
13225     if (!OpHAS_SIBLING(aop)) {
13226         parent = aop;
13227         aop = cUNOPx(aop)->op_first;
13228     }
13229     prev = aop;
13230     aop = OpSIBLING(aop);
13231     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13232     while (aop != cvop) {
13233         OP* o3 = aop;
13234
13235         if (proto >= proto_end)
13236         {
13237             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13238             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13239                                         SVfARG(namesv)), SvUTF8(namesv));
13240             return entersubop;
13241         }
13242
13243         switch (*proto) {
13244             case ';':
13245                 optional = 1;
13246                 proto++;
13247                 continue;
13248             case '_':
13249                 /* _ must be at the end */
13250                 if (proto[1] && !strchr(";@%", proto[1]))
13251                     goto oops;
13252                 /* FALLTHROUGH */
13253             case '$':
13254                 proto++;
13255                 arg++;
13256                 scalar(aop);
13257                 break;
13258             case '%':
13259             case '@':
13260                 list(aop);
13261                 arg++;
13262                 break;
13263             case '&':
13264                 proto++;
13265                 arg++;
13266                 if (    o3->op_type != OP_UNDEF
13267                     && (o3->op_type != OP_SREFGEN
13268                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13269                                 != OP_ANONCODE
13270                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13271                                 != OP_RV2CV)))
13272                     bad_type_gv(arg, namegv, o3,
13273                             arg == 1 ? "block or sub {}" : "sub {}");
13274                 break;
13275             case '*':
13276                 /* '*' allows any scalar type, including bareword */
13277                 proto++;
13278                 arg++;
13279                 if (o3->op_type == OP_RV2GV)
13280                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13281                 else if (o3->op_type == OP_CONST)
13282                     o3->op_private &= ~OPpCONST_STRICT;
13283                 scalar(aop);
13284                 break;
13285             case '+':
13286                 proto++;
13287                 arg++;
13288                 if (o3->op_type == OP_RV2AV ||
13289                     o3->op_type == OP_PADAV ||
13290                     o3->op_type == OP_RV2HV ||
13291                     o3->op_type == OP_PADHV
13292                 ) {
13293                     goto wrapref;
13294                 }
13295                 scalar(aop);
13296                 break;
13297             case '[': case ']':
13298                 goto oops;
13299
13300             case '\\':
13301                 proto++;
13302                 arg++;
13303             again:
13304                 switch (*proto++) {
13305                     case '[':
13306                         if (contextclass++ == 0) {
13307                             e = (char *) memchr(proto, ']', proto_end - proto);
13308                             if (!e || e == proto)
13309                                 goto oops;
13310                         }
13311                         else
13312                             goto oops;
13313                         goto again;
13314
13315                     case ']':
13316                         if (contextclass) {
13317                             const char *p = proto;
13318                             const char *const end = proto;
13319                             contextclass = 0;
13320                             while (*--p != '[')
13321                                 /* \[$] accepts any scalar lvalue */
13322                                 if (*p == '$'
13323                                  && Perl_op_lvalue_flags(aTHX_
13324                                      scalar(o3),
13325                                      OP_READ, /* not entersub */
13326                                      OP_LVALUE_NO_CROAK
13327                                     )) goto wrapref;
13328                             bad_type_gv(arg, namegv, o3,
13329                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13330                         } else
13331                             goto oops;
13332                         break;
13333                     case '*':
13334                         if (o3->op_type == OP_RV2GV)
13335                             goto wrapref;
13336                         if (!contextclass)
13337                             bad_type_gv(arg, namegv, o3, "symbol");
13338                         break;
13339                     case '&':
13340                         if (o3->op_type == OP_ENTERSUB
13341                          && !(o3->op_flags & OPf_STACKED))
13342                             goto wrapref;
13343                         if (!contextclass)
13344                             bad_type_gv(arg, namegv, o3, "subroutine");
13345                         break;
13346                     case '$':
13347                         if (o3->op_type == OP_RV2SV ||
13348                                 o3->op_type == OP_PADSV ||
13349                                 o3->op_type == OP_HELEM ||
13350                                 o3->op_type == OP_AELEM)
13351                             goto wrapref;
13352                         if (!contextclass) {
13353                             /* \$ accepts any scalar lvalue */
13354                             if (Perl_op_lvalue_flags(aTHX_
13355                                     scalar(o3),
13356                                     OP_READ,  /* not entersub */
13357                                     OP_LVALUE_NO_CROAK
13358                                )) goto wrapref;
13359                             bad_type_gv(arg, namegv, o3, "scalar");
13360                         }
13361                         break;
13362                     case '@':
13363                         if (o3->op_type == OP_RV2AV ||
13364                                 o3->op_type == OP_PADAV)
13365                         {
13366                             o3->op_flags &=~ OPf_PARENS;
13367                             goto wrapref;
13368                         }
13369                         if (!contextclass)
13370                             bad_type_gv(arg, namegv, o3, "array");
13371                         break;
13372                     case '%':
13373                         if (o3->op_type == OP_RV2HV ||
13374                                 o3->op_type == OP_PADHV)
13375                         {
13376                             o3->op_flags &=~ OPf_PARENS;
13377                             goto wrapref;
13378                         }
13379                         if (!contextclass)
13380                             bad_type_gv(arg, namegv, o3, "hash");
13381                         break;
13382                     wrapref:
13383                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13384                                                 OP_REFGEN, 0);
13385                         if (contextclass && e) {
13386                             proto = e + 1;
13387                             contextclass = 0;
13388                         }
13389                         break;
13390                     default: goto oops;
13391                 }
13392                 if (contextclass)
13393                     goto again;
13394                 break;
13395             case ' ':
13396                 proto++;
13397                 continue;
13398             default:
13399             oops: {
13400                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13401                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13402                                   SVfARG(protosv));
13403             }
13404         }
13405
13406         op_lvalue(aop, OP_ENTERSUB);
13407         prev = aop;
13408         aop = OpSIBLING(aop);
13409     }
13410     if (aop == cvop && *proto == '_') {
13411         /* generate an access to $_ */
13412         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13413     }
13414     if (!optional && proto_end > proto &&
13415         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13416     {
13417         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13418         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13419                                     SVfARG(namesv)), SvUTF8(namesv));
13420     }
13421     return entersubop;
13422 }
13423
13424 /*
13425 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13426
13427 Performs the fixup of the arguments part of an C<entersub> op tree either
13428 based on a subroutine prototype or using default list-context processing.
13429 This is the standard treatment used on a subroutine call, not marked
13430 with C<&>, where the callee can be identified at compile time.
13431
13432 C<protosv> supplies the subroutine prototype to be applied to the call,
13433 or indicates that there is no prototype.  It may be a normal scalar,
13434 in which case if it is defined then the string value will be used
13435 as a prototype, and if it is undefined then there is no prototype.
13436 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13437 that has been cast to C<SV*>), of which the prototype will be used if it
13438 has one.  The prototype (or lack thereof) supplied, in whichever form,
13439 does not need to match the actual callee referenced by the op tree.
13440
13441 If the argument ops disagree with the prototype, for example by having
13442 an unacceptable number of arguments, a valid op tree is returned anyway.
13443 The error is reflected in the parser state, normally resulting in a single
13444 exception at the top level of parsing which covers all the compilation
13445 errors that occurred.  In the error message, the callee is referred to
13446 by the name defined by the C<namegv> parameter.
13447
13448 =cut
13449 */
13450
13451 OP *
13452 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13453         GV *namegv, SV *protosv)
13454 {
13455     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13456     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13457         return ck_entersub_args_proto(entersubop, namegv, protosv);
13458     else
13459         return ck_entersub_args_list(entersubop);
13460 }
13461
13462 OP *
13463 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13464 {
13465     IV cvflags = SvIVX(protosv);
13466     int opnum = cvflags & 0xffff;
13467     OP *aop = cUNOPx(entersubop)->op_first;
13468
13469     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13470
13471     if (!opnum) {
13472         OP *cvop;
13473         if (!OpHAS_SIBLING(aop))
13474             aop = cUNOPx(aop)->op_first;
13475         aop = OpSIBLING(aop);
13476         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13477         if (aop != cvop) {
13478             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13479             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13480                 SVfARG(namesv)), SvUTF8(namesv));
13481         }
13482
13483         op_free(entersubop);
13484         switch(cvflags >> 16) {
13485         case 'F': return newSVOP(OP_CONST, 0,
13486                                         newSVpv(CopFILE(PL_curcop),0));
13487         case 'L': return newSVOP(
13488                            OP_CONST, 0,
13489                            Perl_newSVpvf(aTHX_
13490                              "%" IVdf, (IV)CopLINE(PL_curcop)
13491                            )
13492                          );
13493         case 'P': return newSVOP(OP_CONST, 0,
13494                                    (PL_curstash
13495                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13496                                      : &PL_sv_undef
13497                                    )
13498                                 );
13499         }
13500         NOT_REACHED; /* NOTREACHED */
13501     }
13502     else {
13503         OP *prev, *cvop, *first, *parent;
13504         U32 flags = 0;
13505
13506         parent = entersubop;
13507         if (!OpHAS_SIBLING(aop)) {
13508             parent = aop;
13509             aop = cUNOPx(aop)->op_first;
13510         }
13511
13512         first = prev = aop;
13513         aop = OpSIBLING(aop);
13514         /* find last sibling */
13515         for (cvop = aop;
13516              OpHAS_SIBLING(cvop);
13517              prev = cvop, cvop = OpSIBLING(cvop))
13518             ;
13519         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13520             /* Usually, OPf_SPECIAL on an op with no args means that it had
13521              * parens, but these have their own meaning for that flag: */
13522             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13523             && opnum != OP_DELETE && opnum != OP_EXISTS)
13524                 flags |= OPf_SPECIAL;
13525         /* excise cvop from end of sibling chain */
13526         op_sibling_splice(parent, prev, 1, NULL);
13527         op_free(cvop);
13528         if (aop == cvop) aop = NULL;
13529
13530         /* detach remaining siblings from the first sibling, then
13531          * dispose of original optree */
13532
13533         if (aop)
13534             op_sibling_splice(parent, first, -1, NULL);
13535         op_free(entersubop);
13536
13537         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13538             flags |= OPpEVAL_BYTES <<8;
13539
13540         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13541         case OA_UNOP:
13542         case OA_BASEOP_OR_UNOP:
13543         case OA_FILESTATOP:
13544             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13545         case OA_BASEOP:
13546             if (aop) {
13547                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13548                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13549                     SVfARG(namesv)), SvUTF8(namesv));
13550                 op_free(aop);
13551             }
13552             return opnum == OP_RUNCV
13553                 ? newPVOP(OP_RUNCV,0,NULL)
13554                 : newOP(opnum,0);
13555         default:
13556             return op_convert_list(opnum,0,aop);
13557         }
13558     }
13559     NOT_REACHED; /* NOTREACHED */
13560     return entersubop;
13561 }
13562
13563 /*
13564 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13565
13566 Retrieves the function that will be used to fix up a call to C<cv>.
13567 Specifically, the function is applied to an C<entersub> op tree for a
13568 subroutine call, not marked with C<&>, where the callee can be identified
13569 at compile time as C<cv>.
13570
13571 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13572 for it is returned in C<*ckobj_p>, and control flags are returned in
13573 C<*ckflags_p>.  The function is intended to be called in this manner:
13574
13575  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13576
13577 In this call, C<entersubop> is a pointer to the C<entersub> op,
13578 which may be replaced by the check function, and C<namegv> supplies
13579 the name that should be used by the check function to refer
13580 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13581 It is permitted to apply the check function in non-standard situations,
13582 such as to a call to a different subroutine or to a method call.
13583
13584 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13585 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13586 instead, anything that can be used as the first argument to L</cv_name>.
13587 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13588 check function requires C<namegv> to be a genuine GV.
13589
13590 By default, the check function is
13591 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13592 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13593 flag is clear.  This implements standard prototype processing.  It can
13594 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13595
13596 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13597 indicates that the caller only knows about the genuine GV version of
13598 C<namegv>, and accordingly the corresponding bit will always be set in
13599 C<*ckflags_p>, regardless of the check function's recorded requirements.
13600 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13601 indicates the caller knows about the possibility of passing something
13602 other than a GV as C<namegv>, and accordingly the corresponding bit may
13603 be either set or clear in C<*ckflags_p>, indicating the check function's
13604 recorded requirements.
13605
13606 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13607 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13608 (for which see above).  All other bits should be clear.
13609
13610 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13611
13612 The original form of L</cv_get_call_checker_flags>, which does not return
13613 checker flags.  When using a checker function returned by this function,
13614 it is only safe to call it with a genuine GV as its C<namegv> argument.
13615
13616 =cut
13617 */
13618
13619 void
13620 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13621         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13622 {
13623     MAGIC *callmg;
13624     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13625     PERL_UNUSED_CONTEXT;
13626     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13627     if (callmg) {
13628         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13629         *ckobj_p = callmg->mg_obj;
13630         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13631     } else {
13632         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13633         *ckobj_p = (SV*)cv;
13634         *ckflags_p = gflags & MGf_REQUIRE_GV;
13635     }
13636 }
13637
13638 void
13639 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13640 {
13641     U32 ckflags;
13642     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13643     PERL_UNUSED_CONTEXT;
13644     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13645         &ckflags);
13646 }
13647
13648 /*
13649 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13650
13651 Sets the function that will be used to fix up a call to C<cv>.
13652 Specifically, the function is applied to an C<entersub> op tree for a
13653 subroutine call, not marked with C<&>, where the callee can be identified
13654 at compile time as C<cv>.
13655
13656 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13657 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13658 The function should be defined like this:
13659
13660     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13661
13662 It is intended to be called in this manner:
13663
13664     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13665
13666 In this call, C<entersubop> is a pointer to the C<entersub> op,
13667 which may be replaced by the check function, and C<namegv> supplies
13668 the name that should be used by the check function to refer
13669 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13670 It is permitted to apply the check function in non-standard situations,
13671 such as to a call to a different subroutine or to a method call.
13672
13673 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13674 CV or other SV instead.  Whatever is passed can be used as the first
13675 argument to L</cv_name>.  You can force perl to pass a GV by including
13676 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13677
13678 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13679 bit currently has a defined meaning (for which see above).  All other
13680 bits should be clear.
13681
13682 The current setting for a particular CV can be retrieved by
13683 L</cv_get_call_checker_flags>.
13684
13685 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13686
13687 The original form of L</cv_set_call_checker_flags>, which passes it the
13688 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13689 of that flag setting is that the check function is guaranteed to get a
13690 genuine GV as its C<namegv> argument.
13691
13692 =cut
13693 */
13694
13695 void
13696 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13697 {
13698     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13699     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13700 }
13701
13702 void
13703 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13704                                      SV *ckobj, U32 ckflags)
13705 {
13706     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13707     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13708         if (SvMAGICAL((SV*)cv))
13709             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13710     } else {
13711         MAGIC *callmg;
13712         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13713         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13714         assert(callmg);
13715         if (callmg->mg_flags & MGf_REFCOUNTED) {
13716             SvREFCNT_dec(callmg->mg_obj);
13717             callmg->mg_flags &= ~MGf_REFCOUNTED;
13718         }
13719         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13720         callmg->mg_obj = ckobj;
13721         if (ckobj != (SV*)cv) {
13722             SvREFCNT_inc_simple_void_NN(ckobj);
13723             callmg->mg_flags |= MGf_REFCOUNTED;
13724         }
13725         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13726                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13727     }
13728 }
13729
13730 static void
13731 S_entersub_alloc_targ(pTHX_ OP * const o)
13732 {
13733     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13734     o->op_private |= OPpENTERSUB_HASTARG;
13735 }
13736
13737 OP *
13738 Perl_ck_subr(pTHX_ OP *o)
13739 {
13740     OP *aop, *cvop;
13741     CV *cv;
13742     GV *namegv;
13743     SV **const_class = NULL;
13744
13745     PERL_ARGS_ASSERT_CK_SUBR;
13746
13747     aop = cUNOPx(o)->op_first;
13748     if (!OpHAS_SIBLING(aop))
13749         aop = cUNOPx(aop)->op_first;
13750     aop = OpSIBLING(aop);
13751     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13752     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13753     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13754
13755     o->op_private &= ~1;
13756     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13757     if (PERLDB_SUB && PL_curstash != PL_debstash)
13758         o->op_private |= OPpENTERSUB_DB;
13759     switch (cvop->op_type) {
13760         case OP_RV2CV:
13761             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13762             op_null(cvop);
13763             break;
13764         case OP_METHOD:
13765         case OP_METHOD_NAMED:
13766         case OP_METHOD_SUPER:
13767         case OP_METHOD_REDIR:
13768         case OP_METHOD_REDIR_SUPER:
13769             o->op_flags |= OPf_REF;
13770             if (aop->op_type == OP_CONST) {
13771                 aop->op_private &= ~OPpCONST_STRICT;
13772                 const_class = &cSVOPx(aop)->op_sv;
13773             }
13774             else if (aop->op_type == OP_LIST) {
13775                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13776                 if (sib && sib->op_type == OP_CONST) {
13777                     sib->op_private &= ~OPpCONST_STRICT;
13778                     const_class = &cSVOPx(sib)->op_sv;
13779                 }
13780             }
13781             /* make class name a shared cow string to speedup method calls */
13782             /* constant string might be replaced with object, f.e. bigint */
13783             if (const_class && SvPOK(*const_class)) {
13784                 STRLEN len;
13785                 const char* str = SvPV(*const_class, len);
13786                 if (len) {
13787                     SV* const shared = newSVpvn_share(
13788                         str, SvUTF8(*const_class)
13789                                     ? -(SSize_t)len : (SSize_t)len,
13790                         0
13791                     );
13792                     if (SvREADONLY(*const_class))
13793                         SvREADONLY_on(shared);
13794                     SvREFCNT_dec(*const_class);
13795                     *const_class = shared;
13796                 }
13797             }
13798             break;
13799     }
13800
13801     if (!cv) {
13802         S_entersub_alloc_targ(aTHX_ o);
13803         return ck_entersub_args_list(o);
13804     } else {
13805         Perl_call_checker ckfun;
13806         SV *ckobj;
13807         U32 ckflags;
13808         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13809         if (CvISXSUB(cv) || !CvROOT(cv))
13810             S_entersub_alloc_targ(aTHX_ o);
13811         if (!namegv) {
13812             /* The original call checker API guarantees that a GV will be
13813                be provided with the right name.  So, if the old API was
13814                used (or the REQUIRE_GV flag was passed), we have to reify
13815                the CV’s GV, unless this is an anonymous sub.  This is not
13816                ideal for lexical subs, as its stringification will include
13817                the package.  But it is the best we can do.  */
13818             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13819                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13820                     namegv = CvGV(cv);
13821             }
13822             else namegv = MUTABLE_GV(cv);
13823             /* After a syntax error in a lexical sub, the cv that
13824                rv2cv_op_cv returns may be a nameless stub. */
13825             if (!namegv) return ck_entersub_args_list(o);
13826
13827         }
13828         return ckfun(aTHX_ o, namegv, ckobj);
13829     }
13830 }
13831
13832 OP *
13833 Perl_ck_svconst(pTHX_ OP *o)
13834 {
13835     SV * const sv = cSVOPo->op_sv;
13836     PERL_ARGS_ASSERT_CK_SVCONST;
13837     PERL_UNUSED_CONTEXT;
13838 #ifdef PERL_COPY_ON_WRITE
13839     /* Since the read-only flag may be used to protect a string buffer, we
13840        cannot do copy-on-write with existing read-only scalars that are not
13841        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13842        that constant, mark the constant as COWable here, if it is not
13843        already read-only. */
13844     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13845         SvIsCOW_on(sv);
13846         CowREFCNT(sv) = 0;
13847 # ifdef PERL_DEBUG_READONLY_COW
13848         sv_buf_to_ro(sv);
13849 # endif
13850     }
13851 #endif
13852     SvREADONLY_on(sv);
13853     return o;
13854 }
13855
13856 OP *
13857 Perl_ck_trunc(pTHX_ OP *o)
13858 {
13859     PERL_ARGS_ASSERT_CK_TRUNC;
13860
13861     if (o->op_flags & OPf_KIDS) {
13862         SVOP *kid = (SVOP*)cUNOPo->op_first;
13863
13864         if (kid->op_type == OP_NULL)
13865             kid = (SVOP*)OpSIBLING(kid);
13866         if (kid && kid->op_type == OP_CONST &&
13867             (kid->op_private & OPpCONST_BARE) &&
13868             !kid->op_folded)
13869         {
13870             o->op_flags |= OPf_SPECIAL;
13871             kid->op_private &= ~OPpCONST_STRICT;
13872         }
13873     }
13874     return ck_fun(o);
13875 }
13876
13877 OP *
13878 Perl_ck_substr(pTHX_ OP *o)
13879 {
13880     PERL_ARGS_ASSERT_CK_SUBSTR;
13881
13882     o = ck_fun(o);
13883     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13884         OP *kid = cLISTOPo->op_first;
13885
13886         if (kid->op_type == OP_NULL)
13887             kid = OpSIBLING(kid);
13888         if (kid)
13889             /* Historically, substr(delete $foo{bar},...) has been allowed
13890                with 4-arg substr.  Keep it working by applying entersub
13891                lvalue context.  */
13892             op_lvalue(kid, OP_ENTERSUB);
13893
13894     }
13895     return o;
13896 }
13897
13898 OP *
13899 Perl_ck_tell(pTHX_ OP *o)
13900 {
13901     PERL_ARGS_ASSERT_CK_TELL;
13902     o = ck_fun(o);
13903     if (o->op_flags & OPf_KIDS) {
13904      OP *kid = cLISTOPo->op_first;
13905      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13906      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13907     }
13908     return o;
13909 }
13910
13911 OP *
13912 Perl_ck_each(pTHX_ OP *o)
13913 {
13914     dVAR;
13915     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13916     const unsigned orig_type  = o->op_type;
13917
13918     PERL_ARGS_ASSERT_CK_EACH;
13919
13920     if (kid) {
13921         switch (kid->op_type) {
13922             case OP_PADHV:
13923             case OP_RV2HV:
13924                 break;
13925             case OP_PADAV:
13926             case OP_RV2AV:
13927                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13928                             : orig_type == OP_KEYS ? OP_AKEYS
13929                             :                        OP_AVALUES);
13930                 break;
13931             case OP_CONST:
13932                 if (kid->op_private == OPpCONST_BARE
13933                  || !SvROK(cSVOPx_sv(kid))
13934                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13935                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13936                    )
13937                     goto bad;
13938                 /* FALLTHROUGH */
13939             default:
13940                 qerror(Perl_mess(aTHX_
13941                     "Experimental %s on scalar is now forbidden",
13942                      PL_op_desc[orig_type]));
13943                bad:
13944                 bad_type_pv(1, "hash or array", o, kid);
13945                 return o;
13946         }
13947     }
13948     return ck_fun(o);
13949 }
13950
13951 OP *
13952 Perl_ck_length(pTHX_ OP *o)
13953 {
13954     PERL_ARGS_ASSERT_CK_LENGTH;
13955
13956     o = ck_fun(o);
13957
13958     if (ckWARN(WARN_SYNTAX)) {
13959         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13960
13961         if (kid) {
13962             SV *name = NULL;
13963             const bool hash = kid->op_type == OP_PADHV
13964                            || kid->op_type == OP_RV2HV;
13965             switch (kid->op_type) {
13966                 case OP_PADHV:
13967                 case OP_PADAV:
13968                 case OP_RV2HV:
13969                 case OP_RV2AV:
13970                     name = S_op_varname(aTHX_ kid);
13971                     break;
13972                 default:
13973                     return o;
13974             }
13975             if (name)
13976                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13977                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13978                     ")\"?)",
13979                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13980                 );
13981             else if (hash)
13982      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13983                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13984                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13985             else
13986      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13987                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13988                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13989         }
13990     }
13991
13992     return o;
13993 }
13994
13995
13996
13997 /*
13998    ---------------------------------------------------------
13999
14000    Common vars in list assignment
14001
14002    There now follows some enums and static functions for detecting
14003    common variables in list assignments. Here is a little essay I wrote
14004    for myself when trying to get my head around this. DAPM.
14005
14006    ----
14007
14008    First some random observations:
14009
14010    * If a lexical var is an alias of something else, e.g.
14011        for my $x ($lex, $pkg, $a[0]) {...}
14012      then the act of aliasing will increase the reference count of the SV
14013
14014    * If a package var is an alias of something else, it may still have a
14015      reference count of 1, depending on how the alias was created, e.g.
14016      in *a = *b, $a may have a refcount of 1 since the GP is shared
14017      with a single GvSV pointer to the SV. So If it's an alias of another
14018      package var, then RC may be 1; if it's an alias of another scalar, e.g.
14019      a lexical var or an array element, then it will have RC > 1.
14020
14021    * There are many ways to create a package alias; ultimately, XS code
14022      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14023      run-time tracing mechanisms are unlikely to be able to catch all cases.
14024
14025    * When the LHS is all my declarations, the same vars can't appear directly
14026      on the RHS, but they can indirectly via closures, aliasing and lvalue
14027      subs. But those techniques all involve an increase in the lexical
14028      scalar's ref count.
14029
14030    * When the LHS is all lexical vars (but not necessarily my declarations),
14031      it is possible for the same lexicals to appear directly on the RHS, and
14032      without an increased ref count, since the stack isn't refcounted.
14033      This case can be detected at compile time by scanning for common lex
14034      vars with PL_generation.
14035
14036    * lvalue subs defeat common var detection, but they do at least
14037      return vars with a temporary ref count increment. Also, you can't
14038      tell at compile time whether a sub call is lvalue.
14039
14040
14041    So...
14042
14043    A: There are a few circumstances where there definitely can't be any
14044      commonality:
14045
14046        LHS empty:  () = (...);
14047        RHS empty:  (....) = ();
14048        RHS contains only constants or other 'can't possibly be shared'
14049            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
14050            i.e. they only contain ops not marked as dangerous, whose children
14051            are also not dangerous;
14052        LHS ditto;
14053        LHS contains a single scalar element: e.g. ($x) = (....); because
14054            after $x has been modified, it won't be used again on the RHS;
14055        RHS contains a single element with no aggregate on LHS: e.g.
14056            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
14057            won't be used again.
14058
14059    B: If LHS are all 'my' lexical var declarations (or safe ops, which
14060      we can ignore):
14061
14062        my ($a, $b, @c) = ...;
14063
14064        Due to closure and goto tricks, these vars may already have content.
14065        For the same reason, an element on the RHS may be a lexical or package
14066        alias of one of the vars on the left, or share common elements, for
14067        example:
14068
14069            my ($x,$y) = f(); # $x and $y on both sides
14070            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14071
14072        and
14073
14074            my $ra = f();
14075            my @a = @$ra;  # elements of @a on both sides
14076            sub f { @a = 1..4; \@a }
14077
14078
14079        First, just consider scalar vars on LHS:
14080
14081            RHS is safe only if (A), or in addition,
14082                * contains only lexical *scalar* vars, where neither side's
14083                  lexicals have been flagged as aliases
14084
14085            If RHS is not safe, then it's always legal to check LHS vars for
14086            RC==1, since the only RHS aliases will always be associated
14087            with an RC bump.
14088
14089            Note that in particular, RHS is not safe if:
14090
14091                * it contains package scalar vars; e.g.:
14092
14093                    f();
14094                    my ($x, $y) = (2, $x_alias);
14095                    sub f { $x = 1; *x_alias = \$x; }
14096
14097                * It contains other general elements, such as flattened or
14098                * spliced or single array or hash elements, e.g.
14099
14100                    f();
14101                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14102
14103                    sub f {
14104                        ($x, $y) = (1,2);
14105                        use feature 'refaliasing';
14106                        \($a[0], $a[1]) = \($y,$x);
14107                    }
14108
14109                  It doesn't matter if the array/hash is lexical or package.
14110
14111                * it contains a function call that happens to be an lvalue
14112                  sub which returns one or more of the above, e.g.
14113
14114                    f();
14115                    my ($x,$y) = f();
14116
14117                    sub f : lvalue {
14118                        ($x, $y) = (1,2);
14119                        *x1 = \$x;
14120                        $y, $x1;
14121                    }
14122
14123                    (so a sub call on the RHS should be treated the same
14124                    as having a package var on the RHS).
14125
14126                * any other "dangerous" thing, such an op or built-in that
14127                  returns one of the above, e.g. pp_preinc
14128
14129
14130            If RHS is not safe, what we can do however is at compile time flag
14131            that the LHS are all my declarations, and at run time check whether
14132            all the LHS have RC == 1, and if so skip the full scan.
14133
14134        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14135
14136            Here the issue is whether there can be elements of @a on the RHS
14137            which will get prematurely freed when @a is cleared prior to
14138            assignment. This is only a problem if the aliasing mechanism
14139            is one which doesn't increase the refcount - only if RC == 1
14140            will the RHS element be prematurely freed.
14141
14142            Because the array/hash is being INTROed, it or its elements
14143            can't directly appear on the RHS:
14144
14145                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14146
14147            but can indirectly, e.g.:
14148
14149                my $r = f();
14150                my (@a) = @$r;
14151                sub f { @a = 1..3; \@a }
14152
14153            So if the RHS isn't safe as defined by (A), we must always
14154            mortalise and bump the ref count of any remaining RHS elements
14155            when assigning to a non-empty LHS aggregate.
14156
14157            Lexical scalars on the RHS aren't safe if they've been involved in
14158            aliasing, e.g.
14159
14160                use feature 'refaliasing';
14161
14162                f();
14163                \(my $lex) = \$pkg;
14164                my @a = ($lex,3); # equivalent to ($a[0],3)
14165
14166                sub f {
14167                    @a = (1,2);
14168                    \$pkg = \$a[0];
14169                }
14170
14171            Similarly with lexical arrays and hashes on the RHS:
14172
14173                f();
14174                my @b;
14175                my @a = (@b);
14176
14177                sub f {
14178                    @a = (1,2);
14179                    \$b[0] = \$a[1];
14180                    \$b[1] = \$a[0];
14181                }
14182
14183
14184
14185    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14186        my $a; ($a, my $b) = (....);
14187
14188        The difference between (B) and (C) is that it is now physically
14189        possible for the LHS vars to appear on the RHS too, where they
14190        are not reference counted; but in this case, the compile-time
14191        PL_generation sweep will detect such common vars.
14192
14193        So the rules for (C) differ from (B) in that if common vars are
14194        detected, the runtime "test RC==1" optimisation can no longer be used,
14195        and a full mark and sweep is required
14196
14197    D: As (C), but in addition the LHS may contain package vars.
14198
14199        Since package vars can be aliased without a corresponding refcount
14200        increase, all bets are off. It's only safe if (A). E.g.
14201
14202            my ($x, $y) = (1,2);
14203
14204            for $x_alias ($x) {
14205                ($x_alias, $y) = (3, $x); # whoops
14206            }
14207
14208        Ditto for LHS aggregate package vars.
14209
14210    E: Any other dangerous ops on LHS, e.g.
14211            (f(), $a[0], @$r) = (...);
14212
14213        this is similar to (E) in that all bets are off. In addition, it's
14214        impossible to determine at compile time whether the LHS
14215        contains a scalar or an aggregate, e.g.
14216
14217            sub f : lvalue { @a }
14218            (f()) = 1..3;
14219
14220 * ---------------------------------------------------------
14221 */
14222
14223
14224 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14225  * that at least one of the things flagged was seen.
14226  */
14227
14228 enum {
14229     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14230     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14231     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14232     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14233     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14234     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14235     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14236     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14237                                          that's flagged OA_DANGEROUS */
14238     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14239                                         not in any of the categories above */
14240     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14241 };
14242
14243
14244
14245 /* helper function for S_aassign_scan().
14246  * check a PAD-related op for commonality and/or set its generation number.
14247  * Returns a boolean indicating whether its shared */
14248
14249 static bool
14250 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14251 {
14252     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14253         /* lexical used in aliasing */
14254         return TRUE;
14255
14256     if (rhs)
14257         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14258     else
14259         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14260
14261     return FALSE;
14262 }
14263
14264
14265 /*
14266   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14267   It scans the left or right hand subtree of the aassign op, and returns a
14268   set of flags indicating what sorts of things it found there.
14269   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14270   set PL_generation on lexical vars; if the latter, we see if
14271   PL_generation matches.
14272   'top' indicates whether we're recursing or at the top level.
14273   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14274   This fn will increment it by the number seen. It's not intended to
14275   be an accurate count (especially as many ops can push a variable
14276   number of SVs onto the stack); rather it's used as to test whether there
14277   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14278 */
14279
14280 static int
14281 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14282 {
14283     int flags = 0;
14284     bool kid_top = FALSE;
14285
14286     /* first, look for a solitary @_ on the RHS */
14287     if (   rhs
14288         && top
14289         && (o->op_flags & OPf_KIDS)
14290         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14291     ) {
14292         OP *kid = cUNOPo->op_first;
14293         if (   (   kid->op_type == OP_PUSHMARK
14294                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14295             && ((kid = OpSIBLING(kid)))
14296             && !OpHAS_SIBLING(kid)
14297             && kid->op_type == OP_RV2AV
14298             && !(kid->op_flags & OPf_REF)
14299             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14300             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14301             && ((kid = cUNOPx(kid)->op_first))
14302             && kid->op_type == OP_GV
14303             && cGVOPx_gv(kid) == PL_defgv
14304         )
14305             flags |= AAS_DEFAV;
14306     }
14307
14308     switch (o->op_type) {
14309     case OP_GVSV:
14310         (*scalars_p)++;
14311         return AAS_PKG_SCALAR;
14312
14313     case OP_PADAV:
14314     case OP_PADHV:
14315         (*scalars_p) += 2;
14316         /* if !top, could be e.g. @a[0,1] */
14317         if (top && (o->op_flags & OPf_REF))
14318             return (o->op_private & OPpLVAL_INTRO)
14319                 ? AAS_MY_AGG : AAS_LEX_AGG;
14320         return AAS_DANGEROUS;
14321
14322     case OP_PADSV:
14323         {
14324             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14325                         ?  AAS_LEX_SCALAR_COMM : 0;
14326             (*scalars_p)++;
14327             return (o->op_private & OPpLVAL_INTRO)
14328                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14329         }
14330
14331     case OP_RV2AV:
14332     case OP_RV2HV:
14333         (*scalars_p) += 2;
14334         if (cUNOPx(o)->op_first->op_type != OP_GV)
14335             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14336         /* @pkg, %pkg */
14337         /* if !top, could be e.g. @a[0,1] */
14338         if (top && (o->op_flags & OPf_REF))
14339             return AAS_PKG_AGG;
14340         return AAS_DANGEROUS;
14341
14342     case OP_RV2SV:
14343         (*scalars_p)++;
14344         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14345             (*scalars_p) += 2;
14346             return AAS_DANGEROUS; /* ${expr} */
14347         }
14348         return AAS_PKG_SCALAR; /* $pkg */
14349
14350     case OP_SPLIT:
14351         if (o->op_private & OPpSPLIT_ASSIGN) {
14352             /* the assign in @a = split() has been optimised away
14353              * and the @a attached directly to the split op
14354              * Treat the array as appearing on the RHS, i.e.
14355              *    ... = (@a = split)
14356              * is treated like
14357              *    ... = @a;
14358              */
14359
14360             if (o->op_flags & OPf_STACKED)
14361                 /* @{expr} = split() - the array expression is tacked
14362                  * on as an extra child to split - process kid */
14363                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14364                                         top, scalars_p);
14365
14366             /* ... else array is directly attached to split op */
14367             (*scalars_p) += 2;
14368             if (PL_op->op_private & OPpSPLIT_LEX)
14369                 return (o->op_private & OPpLVAL_INTRO)
14370                     ? AAS_MY_AGG : AAS_LEX_AGG;
14371             else
14372                 return AAS_PKG_AGG;
14373         }
14374         (*scalars_p)++;
14375         /* other args of split can't be returned */
14376         return AAS_SAFE_SCALAR;
14377
14378     case OP_UNDEF:
14379         /* undef counts as a scalar on the RHS:
14380          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14381          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14382          */
14383         if (rhs)
14384             (*scalars_p)++;
14385         flags = AAS_SAFE_SCALAR;
14386         break;
14387
14388     case OP_PUSHMARK:
14389     case OP_STUB:
14390         /* these are all no-ops; they don't push a potentially common SV
14391          * onto the stack, so they are neither AAS_DANGEROUS nor
14392          * AAS_SAFE_SCALAR */
14393         return 0;
14394
14395     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14396         break;
14397
14398     case OP_NULL:
14399     case OP_LIST:
14400         /* these do nothing but may have children; but their children
14401          * should also be treated as top-level */
14402         kid_top = top;
14403         break;
14404
14405     default:
14406         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14407             (*scalars_p) += 2;
14408             flags = AAS_DANGEROUS;
14409             break;
14410         }
14411
14412         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14413             && (o->op_private & OPpTARGET_MY))
14414         {
14415             (*scalars_p)++;
14416             return S_aassign_padcheck(aTHX_ o, rhs)
14417                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14418         }
14419
14420         /* if its an unrecognised, non-dangerous op, assume that it
14421          * it the cause of at least one safe scalar */
14422         (*scalars_p)++;
14423         flags = AAS_SAFE_SCALAR;
14424         break;
14425     }
14426
14427     /* XXX this assumes that all other ops are "transparent" - i.e. that
14428      * they can return some of their children. While this true for e.g.
14429      * sort and grep, it's not true for e.g. map. We really need a
14430      * 'transparent' flag added to regen/opcodes
14431      */
14432     if (o->op_flags & OPf_KIDS) {
14433         OP *kid;
14434         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14435             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14436     }
14437     return flags;
14438 }
14439
14440
14441 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14442    and modify the optree to make them work inplace */
14443
14444 STATIC void
14445 S_inplace_aassign(pTHX_ OP *o) {
14446
14447     OP *modop, *modop_pushmark;
14448     OP *oright;
14449     OP *oleft, *oleft_pushmark;
14450
14451     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14452
14453     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14454
14455     assert(cUNOPo->op_first->op_type == OP_NULL);
14456     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14457     assert(modop_pushmark->op_type == OP_PUSHMARK);
14458     modop = OpSIBLING(modop_pushmark);
14459
14460     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14461         return;
14462
14463     /* no other operation except sort/reverse */
14464     if (OpHAS_SIBLING(modop))
14465         return;
14466
14467     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14468     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14469
14470     if (modop->op_flags & OPf_STACKED) {
14471         /* skip sort subroutine/block */
14472         assert(oright->op_type == OP_NULL);
14473         oright = OpSIBLING(oright);
14474     }
14475
14476     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14477     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14478     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14479     oleft = OpSIBLING(oleft_pushmark);
14480
14481     /* Check the lhs is an array */
14482     if (!oleft ||
14483         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14484         || OpHAS_SIBLING(oleft)
14485         || (oleft->op_private & OPpLVAL_INTRO)
14486     )
14487         return;
14488
14489     /* Only one thing on the rhs */
14490     if (OpHAS_SIBLING(oright))
14491         return;
14492
14493     /* check the array is the same on both sides */
14494     if (oleft->op_type == OP_RV2AV) {
14495         if (oright->op_type != OP_RV2AV
14496             || !cUNOPx(oright)->op_first
14497             || cUNOPx(oright)->op_first->op_type != OP_GV
14498             || cUNOPx(oleft )->op_first->op_type != OP_GV
14499             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14500                cGVOPx_gv(cUNOPx(oright)->op_first)
14501         )
14502             return;
14503     }
14504     else if (oright->op_type != OP_PADAV
14505         || oright->op_targ != oleft->op_targ
14506     )
14507         return;
14508
14509     /* This actually is an inplace assignment */
14510
14511     modop->op_private |= OPpSORT_INPLACE;
14512
14513     /* transfer MODishness etc from LHS arg to RHS arg */
14514     oright->op_flags = oleft->op_flags;
14515
14516     /* remove the aassign op and the lhs */
14517     op_null(o);
14518     op_null(oleft_pushmark);
14519     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14520         op_null(cUNOPx(oleft)->op_first);
14521     op_null(oleft);
14522 }
14523
14524
14525
14526 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14527  * that potentially represent a series of one or more aggregate derefs
14528  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14529  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14530  * additional ops left in too).
14531  *
14532  * The caller will have already verified that the first few ops in the
14533  * chain following 'start' indicate a multideref candidate, and will have
14534  * set 'orig_o' to the point further on in the chain where the first index
14535  * expression (if any) begins.  'orig_action' specifies what type of
14536  * beginning has already been determined by the ops between start..orig_o
14537  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14538  *
14539  * 'hints' contains any hints flags that need adding (currently just
14540  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14541  */
14542
14543 STATIC void
14544 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14545 {
14546     dVAR;
14547     int pass;
14548     UNOP_AUX_item *arg_buf = NULL;
14549     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14550     int index_skip         = -1;    /* don't output index arg on this action */
14551
14552     /* similar to regex compiling, do two passes; the first pass
14553      * determines whether the op chain is convertible and calculates the
14554      * buffer size; the second pass populates the buffer and makes any
14555      * changes necessary to ops (such as moving consts to the pad on
14556      * threaded builds).
14557      *
14558      * NB: for things like Coverity, note that both passes take the same
14559      * path through the logic tree (except for 'if (pass)' bits), since
14560      * both passes are following the same op_next chain; and in
14561      * particular, if it would return early on the second pass, it would
14562      * already have returned early on the first pass.
14563      */
14564     for (pass = 0; pass < 2; pass++) {
14565         OP *o                = orig_o;
14566         UV action            = orig_action;
14567         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14568         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14569         int action_count     = 0;     /* number of actions seen so far */
14570         int action_ix        = 0;     /* action_count % (actions per IV) */
14571         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14572         bool is_last         = FALSE; /* no more derefs to follow */
14573         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14574         UNOP_AUX_item *arg     = arg_buf;
14575         UNOP_AUX_item *action_ptr = arg_buf;
14576
14577         if (pass)
14578             action_ptr->uv = 0;
14579         arg++;
14580
14581         switch (action) {
14582         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14583         case MDEREF_HV_gvhv_helem:
14584             next_is_hash = TRUE;
14585             /* FALLTHROUGH */
14586         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14587         case MDEREF_AV_gvav_aelem:
14588             if (pass) {
14589 #ifdef USE_ITHREADS
14590                 arg->pad_offset = cPADOPx(start)->op_padix;
14591                 /* stop it being swiped when nulled */
14592                 cPADOPx(start)->op_padix = 0;
14593 #else
14594                 arg->sv = cSVOPx(start)->op_sv;
14595                 cSVOPx(start)->op_sv = NULL;
14596 #endif
14597             }
14598             arg++;
14599             break;
14600
14601         case MDEREF_HV_padhv_helem:
14602         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14603             next_is_hash = TRUE;
14604             /* FALLTHROUGH */
14605         case MDEREF_AV_padav_aelem:
14606         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14607             if (pass) {
14608                 arg->pad_offset = start->op_targ;
14609                 /* we skip setting op_targ = 0 for now, since the intact
14610                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14611                 reset_start_targ = TRUE;
14612             }
14613             arg++;
14614             break;
14615
14616         case MDEREF_HV_pop_rv2hv_helem:
14617             next_is_hash = TRUE;
14618             /* FALLTHROUGH */
14619         case MDEREF_AV_pop_rv2av_aelem:
14620             break;
14621
14622         default:
14623             NOT_REACHED; /* NOTREACHED */
14624             return;
14625         }
14626
14627         while (!is_last) {
14628             /* look for another (rv2av/hv; get index;
14629              * aelem/helem/exists/delele) sequence */
14630
14631             OP *kid;
14632             bool is_deref;
14633             bool ok;
14634             UV index_type = MDEREF_INDEX_none;
14635
14636             if (action_count) {
14637                 /* if this is not the first lookup, consume the rv2av/hv  */
14638
14639                 /* for N levels of aggregate lookup, we normally expect
14640                  * that the first N-1 [ah]elem ops will be flagged as
14641                  * /DEREF (so they autovivifiy if necessary), and the last
14642                  * lookup op not to be.
14643                  * For other things (like @{$h{k1}{k2}}) extra scope or
14644                  * leave ops can appear, so abandon the effort in that
14645                  * case */
14646                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14647                     return;
14648
14649                 /* rv2av or rv2hv sKR/1 */
14650
14651                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14652                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14653                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14654                     return;
14655
14656                 /* at this point, we wouldn't expect any of these
14657                  * possible private flags:
14658                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14659                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14660                  */
14661                 ASSUME(!(o->op_private &
14662                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14663
14664                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14665
14666                 /* make sure the type of the previous /DEREF matches the
14667                  * type of the next lookup */
14668                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14669                 top_op = o;
14670
14671                 action = next_is_hash
14672                             ? MDEREF_HV_vivify_rv2hv_helem
14673                             : MDEREF_AV_vivify_rv2av_aelem;
14674                 o = o->op_next;
14675             }
14676
14677             /* if this is the second pass, and we're at the depth where
14678              * previously we encountered a non-simple index expression,
14679              * stop processing the index at this point */
14680             if (action_count != index_skip) {
14681
14682                 /* look for one or more simple ops that return an array
14683                  * index or hash key */
14684
14685                 switch (o->op_type) {
14686                 case OP_PADSV:
14687                     /* it may be a lexical var index */
14688                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14689                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14690                     ASSUME(!(o->op_private &
14691                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14692
14693                     if (   OP_GIMME(o,0) == G_SCALAR
14694                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14695                         && o->op_private == 0)
14696                     {
14697                         if (pass)
14698                             arg->pad_offset = o->op_targ;
14699                         arg++;
14700                         index_type = MDEREF_INDEX_padsv;
14701                         o = o->op_next;
14702                     }
14703                     break;
14704
14705                 case OP_CONST:
14706                     if (next_is_hash) {
14707                         /* it's a constant hash index */
14708                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14709                             /* "use constant foo => FOO; $h{+foo}" for
14710                              * some weird FOO, can leave you with constants
14711                              * that aren't simple strings. It's not worth
14712                              * the extra hassle for those edge cases */
14713                             break;
14714
14715                         {
14716                             UNOP *rop = NULL;
14717                             OP * helem_op = o->op_next;
14718
14719                             ASSUME(   helem_op->op_type == OP_HELEM
14720                                    || helem_op->op_type == OP_NULL
14721                                    || pass == 0);
14722                             if (helem_op->op_type == OP_HELEM) {
14723                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14724                                 if (   helem_op->op_private & OPpLVAL_INTRO
14725                                     || rop->op_type != OP_RV2HV
14726                                 )
14727                                     rop = NULL;
14728                             }
14729                             /* on first pass just check; on second pass
14730                              * hekify */
14731                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
14732                                                             pass);
14733                         }
14734
14735                         if (pass) {
14736 #ifdef USE_ITHREADS
14737                             /* Relocate sv to the pad for thread safety */
14738                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14739                             arg->pad_offset = o->op_targ;
14740                             o->op_targ = 0;
14741 #else
14742                             arg->sv = cSVOPx_sv(o);
14743 #endif
14744                         }
14745                     }
14746                     else {
14747                         /* it's a constant array index */
14748                         IV iv;
14749                         SV *ix_sv = cSVOPo->op_sv;
14750                         if (!SvIOK(ix_sv))
14751                             break;
14752                         iv = SvIV(ix_sv);
14753
14754                         if (   action_count == 0
14755                             && iv >= -128
14756                             && iv <= 127
14757                             && (   action == MDEREF_AV_padav_aelem
14758                                 || action == MDEREF_AV_gvav_aelem)
14759                         )
14760                             maybe_aelemfast = TRUE;
14761
14762                         if (pass) {
14763                             arg->iv = iv;
14764                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14765                         }
14766                     }
14767                     if (pass)
14768                         /* we've taken ownership of the SV */
14769                         cSVOPo->op_sv = NULL;
14770                     arg++;
14771                     index_type = MDEREF_INDEX_const;
14772                     o = o->op_next;
14773                     break;
14774
14775                 case OP_GV:
14776                     /* it may be a package var index */
14777
14778                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14779                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14780                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14781                         || o->op_private != 0
14782                     )
14783                         break;
14784
14785                     kid = o->op_next;
14786                     if (kid->op_type != OP_RV2SV)
14787                         break;
14788
14789                     ASSUME(!(kid->op_flags &
14790                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14791                              |OPf_SPECIAL|OPf_PARENS)));
14792                     ASSUME(!(kid->op_private &
14793                                     ~(OPpARG1_MASK
14794                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14795                                      |OPpDEREF|OPpLVAL_INTRO)));
14796                     if(   (kid->op_flags &~ OPf_PARENS)
14797                             != (OPf_WANT_SCALAR|OPf_KIDS)
14798                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14799                     )
14800                         break;
14801
14802                     if (pass) {
14803 #ifdef USE_ITHREADS
14804                         arg->pad_offset = cPADOPx(o)->op_padix;
14805                         /* stop it being swiped when nulled */
14806                         cPADOPx(o)->op_padix = 0;
14807 #else
14808                         arg->sv = cSVOPx(o)->op_sv;
14809                         cSVOPo->op_sv = NULL;
14810 #endif
14811                     }
14812                     arg++;
14813                     index_type = MDEREF_INDEX_gvsv;
14814                     o = kid->op_next;
14815                     break;
14816
14817                 } /* switch */
14818             } /* action_count != index_skip */
14819
14820             action |= index_type;
14821
14822
14823             /* at this point we have either:
14824              *   * detected what looks like a simple index expression,
14825              *     and expect the next op to be an [ah]elem, or
14826              *     an nulled  [ah]elem followed by a delete or exists;
14827              *  * found a more complex expression, so something other
14828              *    than the above follows.
14829              */
14830
14831             /* possibly an optimised away [ah]elem (where op_next is
14832              * exists or delete) */
14833             if (o->op_type == OP_NULL)
14834                 o = o->op_next;
14835
14836             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14837              * OP_EXISTS or OP_DELETE */
14838
14839             /* if a custom array/hash access checker is in scope,
14840              * abandon optimisation attempt */
14841             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14842                && PL_check[o->op_type] != Perl_ck_null)
14843                 return;
14844             /* similarly for customised exists and delete */
14845             if (  (o->op_type == OP_EXISTS)
14846                && PL_check[o->op_type] != Perl_ck_exists)
14847                 return;
14848             if (  (o->op_type == OP_DELETE)
14849                && PL_check[o->op_type] != Perl_ck_delete)
14850                 return;
14851
14852             if (   o->op_type != OP_AELEM
14853                 || (o->op_private &
14854                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14855                 )
14856                 maybe_aelemfast = FALSE;
14857
14858             /* look for aelem/helem/exists/delete. If it's not the last elem
14859              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14860              * flags; if it's the last, then it mustn't have
14861              * OPpDEREF_AV/HV, but may have lots of other flags, like
14862              * OPpLVAL_INTRO etc
14863              */
14864
14865             if (   index_type == MDEREF_INDEX_none
14866                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14867                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14868             )
14869                 ok = FALSE;
14870             else {
14871                 /* we have aelem/helem/exists/delete with valid simple index */
14872
14873                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14874                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14875                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14876
14877                 /* This doesn't make much sense but is legal:
14878                  *    @{ local $x[0][0] } = 1
14879                  * Since scope exit will undo the autovivification,
14880                  * don't bother in the first place. The OP_LEAVE
14881                  * assertion is in case there are other cases of both
14882                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14883                  * exit that would undo the local - in which case this
14884                  * block of code would need rethinking.
14885                  */
14886                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14887 #ifdef DEBUGGING
14888                     OP *n = o->op_next;
14889                     while (n && (  n->op_type == OP_NULL
14890                                 || n->op_type == OP_LIST))
14891                         n = n->op_next;
14892                     assert(n && n->op_type == OP_LEAVE);
14893 #endif
14894                     o->op_private &= ~OPpDEREF;
14895                     is_deref = FALSE;
14896                 }
14897
14898                 if (is_deref) {
14899                     ASSUME(!(o->op_flags &
14900                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14901                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14902
14903                     ok =    (o->op_flags &~ OPf_PARENS)
14904                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14905                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14906                 }
14907                 else if (o->op_type == OP_EXISTS) {
14908                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14909                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14910                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14911                     ok =  !(o->op_private & ~OPpARG1_MASK);
14912                 }
14913                 else if (o->op_type == OP_DELETE) {
14914                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14915                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14916                     ASSUME(!(o->op_private &
14917                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14918                     /* don't handle slices or 'local delete'; the latter
14919                      * is fairly rare, and has a complex runtime */
14920                     ok =  !(o->op_private & ~OPpARG1_MASK);
14921                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14922                         /* skip handling run-tome error */
14923                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14924                 }
14925                 else {
14926                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14927                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14928                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14929                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14930                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14931                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14932                 }
14933             }
14934
14935             if (ok) {
14936                 if (!first_elem_op)
14937                     first_elem_op = o;
14938                 top_op = o;
14939                 if (is_deref) {
14940                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14941                     o = o->op_next;
14942                 }
14943                 else {
14944                     is_last = TRUE;
14945                     action |= MDEREF_FLAG_last;
14946                 }
14947             }
14948             else {
14949                 /* at this point we have something that started
14950                  * promisingly enough (with rv2av or whatever), but failed
14951                  * to find a simple index followed by an
14952                  * aelem/helem/exists/delete. If this is the first action,
14953                  * give up; but if we've already seen at least one
14954                  * aelem/helem, then keep them and add a new action with
14955                  * MDEREF_INDEX_none, which causes it to do the vivify
14956                  * from the end of the previous lookup, and do the deref,
14957                  * but stop at that point. So $a[0][expr] will do one
14958                  * av_fetch, vivify and deref, then continue executing at
14959                  * expr */
14960                 if (!action_count)
14961                     return;
14962                 is_last = TRUE;
14963                 index_skip = action_count;
14964                 action |= MDEREF_FLAG_last;
14965                 if (index_type != MDEREF_INDEX_none)
14966                     arg--;
14967             }
14968
14969             if (pass)
14970                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14971             action_ix++;
14972             action_count++;
14973             /* if there's no space for the next action, create a new slot
14974              * for it *before* we start adding args for that action */
14975             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14976                 action_ptr = arg;
14977                 if (pass)
14978                     arg->uv = 0;
14979                 arg++;
14980                 action_ix = 0;
14981             }
14982         } /* while !is_last */
14983
14984         /* success! */
14985
14986         if (pass) {
14987             OP *mderef;
14988             OP *p, *q;
14989
14990             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14991             if (index_skip == -1) {
14992                 mderef->op_flags = o->op_flags
14993                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14994                 if (o->op_type == OP_EXISTS)
14995                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14996                 else if (o->op_type == OP_DELETE)
14997                     mderef->op_private = OPpMULTIDEREF_DELETE;
14998                 else
14999                     mderef->op_private = o->op_private
15000                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15001             }
15002             /* accumulate strictness from every level (although I don't think
15003              * they can actually vary) */
15004             mderef->op_private |= hints;
15005
15006             /* integrate the new multideref op into the optree and the
15007              * op_next chain.
15008              *
15009              * In general an op like aelem or helem has two child
15010              * sub-trees: the aggregate expression (a_expr) and the
15011              * index expression (i_expr):
15012              *
15013              *     aelem
15014              *       |
15015              *     a_expr - i_expr
15016              *
15017              * The a_expr returns an AV or HV, while the i-expr returns an
15018              * index. In general a multideref replaces most or all of a
15019              * multi-level tree, e.g.
15020              *
15021              *     exists
15022              *       |
15023              *     ex-aelem
15024              *       |
15025              *     rv2av  - i_expr1
15026              *       |
15027              *     helem
15028              *       |
15029              *     rv2hv  - i_expr2
15030              *       |
15031              *     aelem
15032              *       |
15033              *     a_expr - i_expr3
15034              *
15035              * With multideref, all the i_exprs will be simple vars or
15036              * constants, except that i_expr1 may be arbitrary in the case
15037              * of MDEREF_INDEX_none.
15038              *
15039              * The bottom-most a_expr will be either:
15040              *   1) a simple var (so padXv or gv+rv2Xv);
15041              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
15042              *      so a simple var with an extra rv2Xv;
15043              *   3) or an arbitrary expression.
15044              *
15045              * 'start', the first op in the execution chain, will point to
15046              *   1),2): the padXv or gv op;
15047              *   3):    the rv2Xv which forms the last op in the a_expr
15048              *          execution chain, and the top-most op in the a_expr
15049              *          subtree.
15050              *
15051              * For all cases, the 'start' node is no longer required,
15052              * but we can't free it since one or more external nodes
15053              * may point to it. E.g. consider
15054              *     $h{foo} = $a ? $b : $c
15055              * Here, both the op_next and op_other branches of the
15056              * cond_expr point to the gv[*h] of the hash expression, so
15057              * we can't free the 'start' op.
15058              *
15059              * For expr->[...], we need to save the subtree containing the
15060              * expression; for the other cases, we just need to save the
15061              * start node.
15062              * So in all cases, we null the start op and keep it around by
15063              * making it the child of the multideref op; for the expr->
15064              * case, the expr will be a subtree of the start node.
15065              *
15066              * So in the simple 1,2 case the  optree above changes to
15067              *
15068              *     ex-exists
15069              *       |
15070              *     multideref
15071              *       |
15072              *     ex-gv (or ex-padxv)
15073              *
15074              *  with the op_next chain being
15075              *
15076              *  -> ex-gv -> multideref -> op-following-ex-exists ->
15077              *
15078              *  In the 3 case, we have
15079              *
15080              *     ex-exists
15081              *       |
15082              *     multideref
15083              *       |
15084              *     ex-rv2xv
15085              *       |
15086              *    rest-of-a_expr
15087              *      subtree
15088              *
15089              *  and
15090              *
15091              *  -> rest-of-a_expr subtree ->
15092              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15093              *
15094              *
15095              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15096              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15097              * multideref attached as the child, e.g.
15098              *
15099              *     exists
15100              *       |
15101              *     ex-aelem
15102              *       |
15103              *     ex-rv2av  - i_expr1
15104              *       |
15105              *     multideref
15106              *       |
15107              *     ex-whatever
15108              *
15109              */
15110
15111             /* if we free this op, don't free the pad entry */
15112             if (reset_start_targ)
15113                 start->op_targ = 0;
15114
15115
15116             /* Cut the bit we need to save out of the tree and attach to
15117              * the multideref op, then free the rest of the tree */
15118
15119             /* find parent of node to be detached (for use by splice) */
15120             p = first_elem_op;
15121             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15122                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15123             {
15124                 /* there is an arbitrary expression preceding us, e.g.
15125                  * expr->[..]? so we need to save the 'expr' subtree */
15126                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15127                     p = cUNOPx(p)->op_first;
15128                 ASSUME(   start->op_type == OP_RV2AV
15129                        || start->op_type == OP_RV2HV);
15130             }
15131             else {
15132                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15133                  * above for exists/delete. */
15134                 while (   (p->op_flags & OPf_KIDS)
15135                        && cUNOPx(p)->op_first != start
15136                 )
15137                     p = cUNOPx(p)->op_first;
15138             }
15139             ASSUME(cUNOPx(p)->op_first == start);
15140
15141             /* detach from main tree, and re-attach under the multideref */
15142             op_sibling_splice(mderef, NULL, 0,
15143                     op_sibling_splice(p, NULL, 1, NULL));
15144             op_null(start);
15145
15146             start->op_next = mderef;
15147
15148             mderef->op_next = index_skip == -1 ? o->op_next : o;
15149
15150             /* excise and free the original tree, and replace with
15151              * the multideref op */
15152             p = op_sibling_splice(top_op, NULL, -1, mderef);
15153             while (p) {
15154                 q = OpSIBLING(p);
15155                 op_free(p);
15156                 p = q;
15157             }
15158             op_null(top_op);
15159         }
15160         else {
15161             Size_t size = arg - arg_buf;
15162
15163             if (maybe_aelemfast && action_count == 1)
15164                 return;
15165
15166             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15167                                 sizeof(UNOP_AUX_item) * (size + 1));
15168             /* for dumping etc: store the length in a hidden first slot;
15169              * we set the op_aux pointer to the second slot */
15170             arg_buf->uv = size;
15171             arg_buf++;
15172         }
15173     } /* for (pass = ...) */
15174 }
15175
15176 /* See if the ops following o are such that o will always be executed in
15177  * boolean context: that is, the SV which o pushes onto the stack will
15178  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15179  * If so, set a suitable private flag on o. Normally this will be
15180  * bool_flag; but see below why maybe_flag is needed too.
15181  *
15182  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15183  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15184  * already be taken, so you'll have to give that op two different flags.
15185  *
15186  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15187  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15188  * those underlying ops) short-circuit, which means that rather than
15189  * necessarily returning a truth value, they may return the LH argument,
15190  * which may not be boolean. For example in $x = (keys %h || -1), keys
15191  * should return a key count rather than a boolean, even though its
15192  * sort-of being used in boolean context.
15193  *
15194  * So we only consider such logical ops to provide boolean context to
15195  * their LH argument if they themselves are in void or boolean context.
15196  * However, sometimes the context isn't known until run-time. In this
15197  * case the op is marked with the maybe_flag flag it.
15198  *
15199  * Consider the following.
15200  *
15201  *     sub f { ....;  if (%h) { .... } }
15202  *
15203  * This is actually compiled as
15204  *
15205  *     sub f { ....;  %h && do { .... } }
15206  *
15207  * Here we won't know until runtime whether the final statement (and hence
15208  * the &&) is in void context and so is safe to return a boolean value.
15209  * So mark o with maybe_flag rather than the bool_flag.
15210  * Note that there is cost associated with determining context at runtime
15211  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15212  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15213  * boolean costs savings are marginal.
15214  *
15215  * However, we can do slightly better with && (compared to || and //):
15216  * this op only returns its LH argument when that argument is false. In
15217  * this case, as long as the op promises to return a false value which is
15218  * valid in both boolean and scalar contexts, we can mark an op consumed
15219  * by && with bool_flag rather than maybe_flag.
15220  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15221  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15222  * op which promises to handle this case is indicated by setting safe_and
15223  * to true.
15224  */
15225
15226 static void
15227 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15228 {
15229     OP *lop;
15230     U8 flag = 0;
15231
15232     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15233
15234     /* OPpTARGET_MY and boolean context probably don't mix well.
15235      * If someone finds a valid use case, maybe add an extra flag to this
15236      * function which indicates its safe to do so for this op? */
15237     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15238              && (o->op_private & OPpTARGET_MY)));
15239
15240     lop = o->op_next;
15241
15242     while (lop) {
15243         switch (lop->op_type) {
15244         case OP_NULL:
15245         case OP_SCALAR:
15246             break;
15247
15248         /* these two consume the stack argument in the scalar case,
15249          * and treat it as a boolean in the non linenumber case */
15250         case OP_FLIP:
15251         case OP_FLOP:
15252             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15253                 || (lop->op_private & OPpFLIP_LINENUM))
15254             {
15255                 lop = NULL;
15256                 break;
15257             }
15258             /* FALLTHROUGH */
15259         /* these never leave the original value on the stack */
15260         case OP_NOT:
15261         case OP_XOR:
15262         case OP_COND_EXPR:
15263         case OP_GREPWHILE:
15264             flag = bool_flag;
15265             lop = NULL;
15266             break;
15267
15268         /* OR DOR and AND evaluate their arg as a boolean, but then may
15269          * leave the original scalar value on the stack when following the
15270          * op_next route. If not in void context, we need to ensure
15271          * that whatever follows consumes the arg only in boolean context
15272          * too.
15273          */
15274         case OP_AND:
15275             if (safe_and) {
15276                 flag = bool_flag;
15277                 lop = NULL;
15278                 break;
15279             }
15280             /* FALLTHROUGH */
15281         case OP_OR:
15282         case OP_DOR:
15283             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15284                 flag = bool_flag;
15285                 lop = NULL;
15286             }
15287             else if (!(lop->op_flags & OPf_WANT)) {
15288                 /* unknown context - decide at runtime */
15289                 flag = maybe_flag;
15290                 lop = NULL;
15291             }
15292             break;
15293
15294         default:
15295             lop = NULL;
15296             break;
15297         }
15298
15299         if (lop)
15300             lop = lop->op_next;
15301     }
15302
15303     o->op_private |= flag;
15304 }
15305
15306
15307
15308 /* mechanism for deferring recursion in rpeep() */
15309
15310 #define MAX_DEFERRED 4
15311
15312 #define DEFER(o) \
15313   STMT_START { \
15314     if (defer_ix == (MAX_DEFERRED-1)) { \
15315         OP **defer = defer_queue[defer_base]; \
15316         CALL_RPEEP(*defer); \
15317         S_prune_chain_head(defer); \
15318         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15319         defer_ix--; \
15320     } \
15321     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15322   } STMT_END
15323
15324 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15325 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15326
15327
15328 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15329  * See the comments at the top of this file for more details about when
15330  * peep() is called */
15331
15332 void
15333 Perl_rpeep(pTHX_ OP *o)
15334 {
15335     dVAR;
15336     OP* oldop = NULL;
15337     OP* oldoldop = NULL;
15338     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15339     int defer_base = 0;
15340     int defer_ix = -1;
15341
15342     if (!o || o->op_opt)
15343         return;
15344
15345     assert(o->op_type != OP_FREED);
15346
15347     ENTER;
15348     SAVEOP();
15349     SAVEVPTR(PL_curcop);
15350     for (;; o = o->op_next) {
15351         if (o && o->op_opt)
15352             o = NULL;
15353         if (!o) {
15354             while (defer_ix >= 0) {
15355                 OP **defer =
15356                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15357                 CALL_RPEEP(*defer);
15358                 S_prune_chain_head(defer);
15359             }
15360             break;
15361         }
15362
15363       redo:
15364
15365         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15366         assert(!oldoldop || oldoldop->op_next == oldop);
15367         assert(!oldop    || oldop->op_next    == o);
15368
15369         /* By default, this op has now been optimised. A couple of cases below
15370            clear this again.  */
15371         o->op_opt = 1;
15372         PL_op = o;
15373
15374         /* look for a series of 1 or more aggregate derefs, e.g.
15375          *   $a[1]{foo}[$i]{$k}
15376          * and replace with a single OP_MULTIDEREF op.
15377          * Each index must be either a const, or a simple variable,
15378          *
15379          * First, look for likely combinations of starting ops,
15380          * corresponding to (global and lexical variants of)
15381          *     $a[...]   $h{...}
15382          *     $r->[...] $r->{...}
15383          *     (preceding expression)->[...]
15384          *     (preceding expression)->{...}
15385          * and if so, call maybe_multideref() to do a full inspection
15386          * of the op chain and if appropriate, replace with an
15387          * OP_MULTIDEREF
15388          */
15389         {
15390             UV action;
15391             OP *o2 = o;
15392             U8 hints = 0;
15393
15394             switch (o2->op_type) {
15395             case OP_GV:
15396                 /* $pkg[..]   :   gv[*pkg]
15397                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15398
15399                 /* Fail if there are new op flag combinations that we're
15400                  * not aware of, rather than:
15401                  *  * silently failing to optimise, or
15402                  *  * silently optimising the flag away.
15403                  * If this ASSUME starts failing, examine what new flag
15404                  * has been added to the op, and decide whether the
15405                  * optimisation should still occur with that flag, then
15406                  * update the code accordingly. This applies to all the
15407                  * other ASSUMEs in the block of code too.
15408                  */
15409                 ASSUME(!(o2->op_flags &
15410                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15411                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15412
15413                 o2 = o2->op_next;
15414
15415                 if (o2->op_type == OP_RV2AV) {
15416                     action = MDEREF_AV_gvav_aelem;
15417                     goto do_deref;
15418                 }
15419
15420                 if (o2->op_type == OP_RV2HV) {
15421                     action = MDEREF_HV_gvhv_helem;
15422                     goto do_deref;
15423                 }
15424
15425                 if (o2->op_type != OP_RV2SV)
15426                     break;
15427
15428                 /* at this point we've seen gv,rv2sv, so the only valid
15429                  * construct left is $pkg->[] or $pkg->{} */
15430
15431                 ASSUME(!(o2->op_flags & OPf_STACKED));
15432                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15433                             != (OPf_WANT_SCALAR|OPf_MOD))
15434                     break;
15435
15436                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15437                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15438                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15439                     break;
15440                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15441                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15442                     break;
15443
15444                 o2 = o2->op_next;
15445                 if (o2->op_type == OP_RV2AV) {
15446                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15447                     goto do_deref;
15448                 }
15449                 if (o2->op_type == OP_RV2HV) {
15450                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15451                     goto do_deref;
15452                 }
15453                 break;
15454
15455             case OP_PADSV:
15456                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15457
15458                 ASSUME(!(o2->op_flags &
15459                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15460                 if ((o2->op_flags &
15461                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15462                      != (OPf_WANT_SCALAR|OPf_MOD))
15463                     break;
15464
15465                 ASSUME(!(o2->op_private &
15466                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15467                 /* skip if state or intro, or not a deref */
15468                 if (      o2->op_private != OPpDEREF_AV
15469                        && o2->op_private != OPpDEREF_HV)
15470                     break;
15471
15472                 o2 = o2->op_next;
15473                 if (o2->op_type == OP_RV2AV) {
15474                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15475                     goto do_deref;
15476                 }
15477                 if (o2->op_type == OP_RV2HV) {
15478                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15479                     goto do_deref;
15480                 }
15481                 break;
15482
15483             case OP_PADAV:
15484             case OP_PADHV:
15485                 /*    $lex[..]:  padav[@lex:1,2] sR *
15486                  * or $lex{..}:  padhv[%lex:1,2] sR */
15487                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15488                                             OPf_REF|OPf_SPECIAL)));
15489                 if ((o2->op_flags &
15490                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15491                      != (OPf_WANT_SCALAR|OPf_REF))
15492                     break;
15493                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15494                     break;
15495                 /* OPf_PARENS isn't currently used in this case;
15496                  * if that changes, let us know! */
15497                 ASSUME(!(o2->op_flags & OPf_PARENS));
15498
15499                 /* at this point, we wouldn't expect any of the remaining
15500                  * possible private flags:
15501                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15502                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15503                  *
15504                  * OPpSLICEWARNING shouldn't affect runtime
15505                  */
15506                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15507
15508                 action = o2->op_type == OP_PADAV
15509                             ? MDEREF_AV_padav_aelem
15510                             : MDEREF_HV_padhv_helem;
15511                 o2 = o2->op_next;
15512                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15513                 break;
15514
15515
15516             case OP_RV2AV:
15517             case OP_RV2HV:
15518                 action = o2->op_type == OP_RV2AV
15519                             ? MDEREF_AV_pop_rv2av_aelem
15520                             : MDEREF_HV_pop_rv2hv_helem;
15521                 /* FALLTHROUGH */
15522             do_deref:
15523                 /* (expr)->[...]:  rv2av sKR/1;
15524                  * (expr)->{...}:  rv2hv sKR/1; */
15525
15526                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15527
15528                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15529                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15530                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15531                     break;
15532
15533                 /* at this point, we wouldn't expect any of these
15534                  * possible private flags:
15535                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15536                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15537                  */
15538                 ASSUME(!(o2->op_private &
15539                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15540                      |OPpOUR_INTRO)));
15541                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15542
15543                 o2 = o2->op_next;
15544
15545                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15546                 break;
15547
15548             default:
15549                 break;
15550             }
15551         }
15552
15553
15554         switch (o->op_type) {
15555         case OP_DBSTATE:
15556             PL_curcop = ((COP*)o);              /* for warnings */
15557             break;
15558         case OP_NEXTSTATE:
15559             PL_curcop = ((COP*)o);              /* for warnings */
15560
15561             /* Optimise a "return ..." at the end of a sub to just be "...".
15562              * This saves 2 ops. Before:
15563              * 1  <;> nextstate(main 1 -e:1) v ->2
15564              * 4  <@> return K ->5
15565              * 2    <0> pushmark s ->3
15566              * -    <1> ex-rv2sv sK/1 ->4
15567              * 3      <#> gvsv[*cat] s ->4
15568              *
15569              * After:
15570              * -  <@> return K ->-
15571              * -    <0> pushmark s ->2
15572              * -    <1> ex-rv2sv sK/1 ->-
15573              * 2      <$> gvsv(*cat) s ->3
15574              */
15575             {
15576                 OP *next = o->op_next;
15577                 OP *sibling = OpSIBLING(o);
15578                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15579                     && OP_TYPE_IS(sibling, OP_RETURN)
15580                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15581                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15582                        ||OP_TYPE_IS(sibling->op_next->op_next,
15583                                     OP_LEAVESUBLV))
15584                     && cUNOPx(sibling)->op_first == next
15585                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15586                     && next->op_next
15587                 ) {
15588                     /* Look through the PUSHMARK's siblings for one that
15589                      * points to the RETURN */
15590                     OP *top = OpSIBLING(next);
15591                     while (top && top->op_next) {
15592                         if (top->op_next == sibling) {
15593                             top->op_next = sibling->op_next;
15594                             o->op_next = next->op_next;
15595                             break;
15596                         }
15597                         top = OpSIBLING(top);
15598                     }
15599                 }
15600             }
15601
15602             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15603              *
15604              * This latter form is then suitable for conversion into padrange
15605              * later on. Convert:
15606              *
15607              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15608              *
15609              * into:
15610              *
15611              *   nextstate1 ->     listop     -> nextstate3
15612              *                 /            \
15613              *         pushmark -> padop1 -> padop2
15614              */
15615             if (o->op_next && (
15616                     o->op_next->op_type == OP_PADSV
15617                  || o->op_next->op_type == OP_PADAV
15618                  || o->op_next->op_type == OP_PADHV
15619                 )
15620                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15621                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15622                 && o->op_next->op_next->op_next && (
15623                     o->op_next->op_next->op_next->op_type == OP_PADSV
15624                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15625                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15626                 )
15627                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15628                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15629                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15630                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15631             ) {
15632                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15633
15634                 pad1 =    o->op_next;
15635                 ns2  = pad1->op_next;
15636                 pad2 =  ns2->op_next;
15637                 ns3  = pad2->op_next;
15638
15639                 /* we assume here that the op_next chain is the same as
15640                  * the op_sibling chain */
15641                 assert(OpSIBLING(o)    == pad1);
15642                 assert(OpSIBLING(pad1) == ns2);
15643                 assert(OpSIBLING(ns2)  == pad2);
15644                 assert(OpSIBLING(pad2) == ns3);
15645
15646                 /* excise and delete ns2 */
15647                 op_sibling_splice(NULL, pad1, 1, NULL);
15648                 op_free(ns2);
15649
15650                 /* excise pad1 and pad2 */
15651                 op_sibling_splice(NULL, o, 2, NULL);
15652
15653                 /* create new listop, with children consisting of:
15654                  * a new pushmark, pad1, pad2. */
15655                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15656                 newop->op_flags |= OPf_PARENS;
15657                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15658
15659                 /* insert newop between o and ns3 */
15660                 op_sibling_splice(NULL, o, 0, newop);
15661
15662                 /*fixup op_next chain */
15663                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15664                 o    ->op_next = newpm;
15665                 newpm->op_next = pad1;
15666                 pad1 ->op_next = pad2;
15667                 pad2 ->op_next = newop; /* listop */
15668                 newop->op_next = ns3;
15669
15670                 /* Ensure pushmark has this flag if padops do */
15671                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15672                     newpm->op_flags |= OPf_MOD;
15673                 }
15674
15675                 break;
15676             }
15677
15678             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15679                to carry two labels. For now, take the easier option, and skip
15680                this optimisation if the first NEXTSTATE has a label.  */
15681             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15682                 OP *nextop = o->op_next;
15683                 while (nextop && nextop->op_type == OP_NULL)
15684                     nextop = nextop->op_next;
15685
15686                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15687                     op_null(o);
15688                     if (oldop)
15689                         oldop->op_next = nextop;
15690                     o = nextop;
15691                     /* Skip (old)oldop assignment since the current oldop's
15692                        op_next already points to the next op.  */
15693                     goto redo;
15694                 }
15695             }
15696             break;
15697
15698         case OP_CONCAT:
15699             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15700                 if (o->op_next->op_private & OPpTARGET_MY) {
15701                     if (o->op_flags & OPf_STACKED) /* chained concats */
15702                         break; /* ignore_optimization */
15703                     else {
15704                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15705                         o->op_targ = o->op_next->op_targ;
15706                         o->op_next->op_targ = 0;
15707                         o->op_private |= OPpTARGET_MY;
15708                     }
15709                 }
15710                 op_null(o->op_next);
15711             }
15712             break;
15713         case OP_STUB:
15714             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15715                 break; /* Scalar stub must produce undef.  List stub is noop */
15716             }
15717             goto nothin;
15718         case OP_NULL:
15719             if (o->op_targ == OP_NEXTSTATE
15720                 || o->op_targ == OP_DBSTATE)
15721             {
15722                 PL_curcop = ((COP*)o);
15723             }
15724             /* XXX: We avoid setting op_seq here to prevent later calls
15725                to rpeep() from mistakenly concluding that optimisation
15726                has already occurred. This doesn't fix the real problem,
15727                though (See 20010220.007 (#5874)). AMS 20010719 */
15728             /* op_seq functionality is now replaced by op_opt */
15729             o->op_opt = 0;
15730             /* FALLTHROUGH */
15731         case OP_SCALAR:
15732         case OP_LINESEQ:
15733         case OP_SCOPE:
15734         nothin:
15735             if (oldop) {
15736                 oldop->op_next = o->op_next;
15737                 o->op_opt = 0;
15738                 continue;
15739             }
15740             break;
15741
15742         case OP_PUSHMARK:
15743
15744             /* Given
15745                  5 repeat/DOLIST
15746                  3   ex-list
15747                  1     pushmark
15748                  2     scalar or const
15749                  4   const[0]
15750                convert repeat into a stub with no kids.
15751              */
15752             if (o->op_next->op_type == OP_CONST
15753              || (  o->op_next->op_type == OP_PADSV
15754                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15755              || (  o->op_next->op_type == OP_GV
15756                 && o->op_next->op_next->op_type == OP_RV2SV
15757                 && !(o->op_next->op_next->op_private
15758                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15759             {
15760                 const OP *kid = o->op_next->op_next;
15761                 if (o->op_next->op_type == OP_GV)
15762                    kid = kid->op_next;
15763                 /* kid is now the ex-list.  */
15764                 if (kid->op_type == OP_NULL
15765                  && (kid = kid->op_next)->op_type == OP_CONST
15766                     /* kid is now the repeat count.  */
15767                  && kid->op_next->op_type == OP_REPEAT
15768                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15769                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15770                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15771                  && oldop)
15772                 {
15773                     o = kid->op_next; /* repeat */
15774                     oldop->op_next = o;
15775                     op_free(cBINOPo->op_first);
15776                     op_free(cBINOPo->op_last );
15777                     o->op_flags &=~ OPf_KIDS;
15778                     /* stub is a baseop; repeat is a binop */
15779                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15780                     OpTYPE_set(o, OP_STUB);
15781                     o->op_private = 0;
15782                     break;
15783                 }
15784             }
15785
15786             /* Convert a series of PAD ops for my vars plus support into a
15787              * single padrange op. Basically
15788              *
15789              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15790              *
15791              * becomes, depending on circumstances, one of
15792              *
15793              *    padrange  ----------------------------------> (list) -> rest
15794              *    padrange  --------------------------------------------> rest
15795              *
15796              * where all the pad indexes are sequential and of the same type
15797              * (INTRO or not).
15798              * We convert the pushmark into a padrange op, then skip
15799              * any other pad ops, and possibly some trailing ops.
15800              * Note that we don't null() the skipped ops, to make it
15801              * easier for Deparse to undo this optimisation (and none of
15802              * the skipped ops are holding any resourses). It also makes
15803              * it easier for find_uninit_var(), as it can just ignore
15804              * padrange, and examine the original pad ops.
15805              */
15806         {
15807             OP *p;
15808             OP *followop = NULL; /* the op that will follow the padrange op */
15809             U8 count = 0;
15810             U8 intro = 0;
15811             PADOFFSET base = 0; /* init only to stop compiler whining */
15812             bool gvoid = 0;     /* init only to stop compiler whining */
15813             bool defav = 0;  /* seen (...) = @_ */
15814             bool reuse = 0;  /* reuse an existing padrange op */
15815
15816             /* look for a pushmark -> gv[_] -> rv2av */
15817
15818             {
15819                 OP *rv2av, *q;
15820                 p = o->op_next;
15821                 if (   p->op_type == OP_GV
15822                     && cGVOPx_gv(p) == PL_defgv
15823                     && (rv2av = p->op_next)
15824                     && rv2av->op_type == OP_RV2AV
15825                     && !(rv2av->op_flags & OPf_REF)
15826                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15827                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15828                 ) {
15829                     q = rv2av->op_next;
15830                     if (q->op_type == OP_NULL)
15831                         q = q->op_next;
15832                     if (q->op_type == OP_PUSHMARK) {
15833                         defav = 1;
15834                         p = q;
15835                     }
15836                 }
15837             }
15838             if (!defav) {
15839                 p = o;
15840             }
15841
15842             /* scan for PAD ops */
15843
15844             for (p = p->op_next; p; p = p->op_next) {
15845                 if (p->op_type == OP_NULL)
15846                     continue;
15847
15848                 if ((     p->op_type != OP_PADSV
15849                        && p->op_type != OP_PADAV
15850                        && p->op_type != OP_PADHV
15851                     )
15852                       /* any private flag other than INTRO? e.g. STATE */
15853                    || (p->op_private & ~OPpLVAL_INTRO)
15854                 )
15855                     break;
15856
15857                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15858                  * instead */
15859                 if (   p->op_type == OP_PADAV
15860                     && p->op_next
15861                     && p->op_next->op_type == OP_CONST
15862                     && p->op_next->op_next
15863                     && p->op_next->op_next->op_type == OP_AELEM
15864                 )
15865                     break;
15866
15867                 /* for 1st padop, note what type it is and the range
15868                  * start; for the others, check that it's the same type
15869                  * and that the targs are contiguous */
15870                 if (count == 0) {
15871                     intro = (p->op_private & OPpLVAL_INTRO);
15872                     base = p->op_targ;
15873                     gvoid = OP_GIMME(p,0) == G_VOID;
15874                 }
15875                 else {
15876                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15877                         break;
15878                     /* Note that you'd normally  expect targs to be
15879                      * contiguous in my($a,$b,$c), but that's not the case
15880                      * when external modules start doing things, e.g.
15881                      * Function::Parameters */
15882                     if (p->op_targ != base + count)
15883                         break;
15884                     assert(p->op_targ == base + count);
15885                     /* Either all the padops or none of the padops should
15886                        be in void context.  Since we only do the optimisa-
15887                        tion for av/hv when the aggregate itself is pushed
15888                        on to the stack (one item), there is no need to dis-
15889                        tinguish list from scalar context.  */
15890                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15891                         break;
15892                 }
15893
15894                 /* for AV, HV, only when we're not flattening */
15895                 if (   p->op_type != OP_PADSV
15896                     && !gvoid
15897                     && !(p->op_flags & OPf_REF)
15898                 )
15899                     break;
15900
15901                 if (count >= OPpPADRANGE_COUNTMASK)
15902                     break;
15903
15904                 /* there's a biggest base we can fit into a
15905                  * SAVEt_CLEARPADRANGE in pp_padrange.
15906                  * (The sizeof() stuff will be constant-folded, and is
15907                  * intended to avoid getting "comparison is always false"
15908                  * compiler warnings. See the comments above
15909                  * MEM_WRAP_CHECK for more explanation on why we do this
15910                  * in a weird way to avoid compiler warnings.)
15911                  */
15912                 if (   intro
15913                     && (8*sizeof(base) >
15914                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15915                         ? (Size_t)base
15916                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15917                         ) >
15918                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15919                 )
15920                     break;
15921
15922                 /* Success! We've got another valid pad op to optimise away */
15923                 count++;
15924                 followop = p->op_next;
15925             }
15926
15927             if (count < 1 || (count == 1 && !defav))
15928                 break;
15929
15930             /* pp_padrange in specifically compile-time void context
15931              * skips pushing a mark and lexicals; in all other contexts
15932              * (including unknown till runtime) it pushes a mark and the
15933              * lexicals. We must be very careful then, that the ops we
15934              * optimise away would have exactly the same effect as the
15935              * padrange.
15936              * In particular in void context, we can only optimise to
15937              * a padrange if we see the complete sequence
15938              *     pushmark, pad*v, ...., list
15939              * which has the net effect of leaving the markstack as it
15940              * was.  Not pushing onto the stack (whereas padsv does touch
15941              * the stack) makes no difference in void context.
15942              */
15943             assert(followop);
15944             if (gvoid) {
15945                 if (followop->op_type == OP_LIST
15946                         && OP_GIMME(followop,0) == G_VOID
15947                    )
15948                 {
15949                     followop = followop->op_next; /* skip OP_LIST */
15950
15951                     /* consolidate two successive my(...);'s */
15952
15953                     if (   oldoldop
15954                         && oldoldop->op_type == OP_PADRANGE
15955                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15956                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15957                         && !(oldoldop->op_flags & OPf_SPECIAL)
15958                     ) {
15959                         U8 old_count;
15960                         assert(oldoldop->op_next == oldop);
15961                         assert(   oldop->op_type == OP_NEXTSTATE
15962                                || oldop->op_type == OP_DBSTATE);
15963                         assert(oldop->op_next == o);
15964
15965                         old_count
15966                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15967
15968                        /* Do not assume pad offsets for $c and $d are con-
15969                           tiguous in
15970                             my ($a,$b,$c);
15971                             my ($d,$e,$f);
15972                         */
15973                         if (  oldoldop->op_targ + old_count == base
15974                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15975                             base = oldoldop->op_targ;
15976                             count += old_count;
15977                             reuse = 1;
15978                         }
15979                     }
15980
15981                     /* if there's any immediately following singleton
15982                      * my var's; then swallow them and the associated
15983                      * nextstates; i.e.
15984                      *    my ($a,$b); my $c; my $d;
15985                      * is treated as
15986                      *    my ($a,$b,$c,$d);
15987                      */
15988
15989                     while (    ((p = followop->op_next))
15990                             && (  p->op_type == OP_PADSV
15991                                || p->op_type == OP_PADAV
15992                                || p->op_type == OP_PADHV)
15993                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15994                             && (p->op_private & OPpLVAL_INTRO) == intro
15995                             && !(p->op_private & ~OPpLVAL_INTRO)
15996                             && p->op_next
15997                             && (   p->op_next->op_type == OP_NEXTSTATE
15998                                 || p->op_next->op_type == OP_DBSTATE)
15999                             && count < OPpPADRANGE_COUNTMASK
16000                             && base + count == p->op_targ
16001                     ) {
16002                         count++;
16003                         followop = p->op_next;
16004                     }
16005                 }
16006                 else
16007                     break;
16008             }
16009
16010             if (reuse) {
16011                 assert(oldoldop->op_type == OP_PADRANGE);
16012                 oldoldop->op_next = followop;
16013                 oldoldop->op_private = (intro | count);
16014                 o = oldoldop;
16015                 oldop = NULL;
16016                 oldoldop = NULL;
16017             }
16018             else {
16019                 /* Convert the pushmark into a padrange.
16020                  * To make Deparse easier, we guarantee that a padrange was
16021                  * *always* formerly a pushmark */
16022                 assert(o->op_type == OP_PUSHMARK);
16023                 o->op_next = followop;
16024                 OpTYPE_set(o, OP_PADRANGE);
16025                 o->op_targ = base;
16026                 /* bit 7: INTRO; bit 6..0: count */
16027                 o->op_private = (intro | count);
16028                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16029                               | gvoid * OPf_WANT_VOID
16030                               | (defav ? OPf_SPECIAL : 0));
16031             }
16032             break;
16033         }
16034
16035         case OP_RV2AV:
16036             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16037                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16038             break;
16039
16040         case OP_RV2HV:
16041         case OP_PADHV:
16042             /*'keys %h' in void or scalar context: skip the OP_KEYS
16043              * and perform the functionality directly in the RV2HV/PADHV
16044              * op
16045              */
16046             if (o->op_flags & OPf_REF) {
16047                 OP *k = o->op_next;
16048                 U8 want = (k->op_flags & OPf_WANT);
16049                 if (   k
16050                     && k->op_type == OP_KEYS
16051                     && (   want == OPf_WANT_VOID
16052                         || want == OPf_WANT_SCALAR)
16053                     && !(k->op_private & OPpMAYBE_LVSUB)
16054                     && !(k->op_flags & OPf_MOD)
16055                 ) {
16056                     o->op_next     = k->op_next;
16057                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
16058                     o->op_flags   |= want;
16059                     o->op_private |= (o->op_type == OP_PADHV ?
16060                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16061                     /* for keys(%lex), hold onto the OP_KEYS's targ
16062                      * since padhv doesn't have its own targ to return
16063                      * an int with */
16064                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16065                         op_null(k);
16066                 }
16067             }
16068
16069             /* see if %h is used in boolean context */
16070             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16071                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16072
16073
16074             if (o->op_type != OP_PADHV)
16075                 break;
16076             /* FALLTHROUGH */
16077         case OP_PADAV:
16078             if (   o->op_type == OP_PADAV
16079                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16080             )
16081                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16082             /* FALLTHROUGH */
16083         case OP_PADSV:
16084             /* Skip over state($x) in void context.  */
16085             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16086              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16087             {
16088                 oldop->op_next = o->op_next;
16089                 goto redo_nextstate;
16090             }
16091             if (o->op_type != OP_PADAV)
16092                 break;
16093             /* FALLTHROUGH */
16094         case OP_GV:
16095             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16096                 OP* const pop = (o->op_type == OP_PADAV) ?
16097                             o->op_next : o->op_next->op_next;
16098                 IV i;
16099                 if (pop && pop->op_type == OP_CONST &&
16100                     ((PL_op = pop->op_next)) &&
16101                     pop->op_next->op_type == OP_AELEM &&
16102                     !(pop->op_next->op_private &
16103                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16104                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16105                 {
16106                     GV *gv;
16107                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16108                         no_bareword_allowed(pop);
16109                     if (o->op_type == OP_GV)
16110                         op_null(o->op_next);
16111                     op_null(pop->op_next);
16112                     op_null(pop);
16113                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16114                     o->op_next = pop->op_next->op_next;
16115                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16116                     o->op_private = (U8)i;
16117                     if (o->op_type == OP_GV) {
16118                         gv = cGVOPo_gv;
16119                         GvAVn(gv);
16120                         o->op_type = OP_AELEMFAST;
16121                     }
16122                     else
16123                         o->op_type = OP_AELEMFAST_LEX;
16124                 }
16125                 if (o->op_type != OP_GV)
16126                     break;
16127             }
16128
16129             /* Remove $foo from the op_next chain in void context.  */
16130             if (oldop
16131              && (  o->op_next->op_type == OP_RV2SV
16132                 || o->op_next->op_type == OP_RV2AV
16133                 || o->op_next->op_type == OP_RV2HV  )
16134              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16135              && !(o->op_next->op_private & OPpLVAL_INTRO))
16136             {
16137                 oldop->op_next = o->op_next->op_next;
16138                 /* Reprocess the previous op if it is a nextstate, to
16139                    allow double-nextstate optimisation.  */
16140               redo_nextstate:
16141                 if (oldop->op_type == OP_NEXTSTATE) {
16142                     oldop->op_opt = 0;
16143                     o = oldop;
16144                     oldop = oldoldop;
16145                     oldoldop = NULL;
16146                     goto redo;
16147                 }
16148                 o = oldop->op_next;
16149                 goto redo;
16150             }
16151             else if (o->op_next->op_type == OP_RV2SV) {
16152                 if (!(o->op_next->op_private & OPpDEREF)) {
16153                     op_null(o->op_next);
16154                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16155                                                                | OPpOUR_INTRO);
16156                     o->op_next = o->op_next->op_next;
16157                     OpTYPE_set(o, OP_GVSV);
16158                 }
16159             }
16160             else if (o->op_next->op_type == OP_READLINE
16161                     && o->op_next->op_next->op_type == OP_CONCAT
16162                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16163             {
16164                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16165                 OpTYPE_set(o, OP_RCATLINE);
16166                 o->op_flags |= OPf_STACKED;
16167                 op_null(o->op_next->op_next);
16168                 op_null(o->op_next);
16169             }
16170
16171             break;
16172
16173         case OP_NOT:
16174             break;
16175
16176         case OP_AND:
16177         case OP_OR:
16178         case OP_DOR:
16179             while (cLOGOP->op_other->op_type == OP_NULL)
16180                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16181             while (o->op_next && (   o->op_type == o->op_next->op_type
16182                                   || o->op_next->op_type == OP_NULL))
16183                 o->op_next = o->op_next->op_next;
16184
16185             /* If we're an OR and our next is an AND in void context, we'll
16186                follow its op_other on short circuit, same for reverse.
16187                We can't do this with OP_DOR since if it's true, its return
16188                value is the underlying value which must be evaluated
16189                by the next op. */
16190             if (o->op_next &&
16191                 (
16192                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16193                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16194                 )
16195                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16196             ) {
16197                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16198             }
16199             DEFER(cLOGOP->op_other);
16200             o->op_opt = 1;
16201             break;
16202
16203         case OP_GREPWHILE:
16204             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16205                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16206             /* FALLTHROUGH */
16207         case OP_COND_EXPR:
16208         case OP_MAPWHILE:
16209         case OP_ANDASSIGN:
16210         case OP_ORASSIGN:
16211         case OP_DORASSIGN:
16212         case OP_RANGE:
16213         case OP_ONCE:
16214         case OP_ARGDEFELEM:
16215             while (cLOGOP->op_other->op_type == OP_NULL)
16216                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16217             DEFER(cLOGOP->op_other);
16218             break;
16219
16220         case OP_ENTERLOOP:
16221         case OP_ENTERITER:
16222             while (cLOOP->op_redoop->op_type == OP_NULL)
16223                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16224             while (cLOOP->op_nextop->op_type == OP_NULL)
16225                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16226             while (cLOOP->op_lastop->op_type == OP_NULL)
16227                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16228             /* a while(1) loop doesn't have an op_next that escapes the
16229              * loop, so we have to explicitly follow the op_lastop to
16230              * process the rest of the code */
16231             DEFER(cLOOP->op_lastop);
16232             break;
16233
16234         case OP_ENTERTRY:
16235             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16236             DEFER(cLOGOPo->op_other);
16237             break;
16238
16239         case OP_SUBST:
16240             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16241                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16242             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16243             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16244                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16245                 cPMOP->op_pmstashstartu.op_pmreplstart
16246                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16247             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16248             break;
16249
16250         case OP_SORT: {
16251             OP *oright;
16252
16253             if (o->op_flags & OPf_SPECIAL) {
16254                 /* first arg is a code block */
16255                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16256                 OP * kid          = cUNOPx(nullop)->op_first;
16257
16258                 assert(nullop->op_type == OP_NULL);
16259                 assert(kid->op_type == OP_SCOPE
16260                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16261                 /* since OP_SORT doesn't have a handy op_other-style
16262                  * field that can point directly to the start of the code
16263                  * block, store it in the otherwise-unused op_next field
16264                  * of the top-level OP_NULL. This will be quicker at
16265                  * run-time, and it will also allow us to remove leading
16266                  * OP_NULLs by just messing with op_nexts without
16267                  * altering the basic op_first/op_sibling layout. */
16268                 kid = kLISTOP->op_first;
16269                 assert(
16270                       (kid->op_type == OP_NULL
16271                       && (  kid->op_targ == OP_NEXTSTATE
16272                          || kid->op_targ == OP_DBSTATE  ))
16273                     || kid->op_type == OP_STUB
16274                     || kid->op_type == OP_ENTER
16275                     || (PL_parser && PL_parser->error_count));
16276                 nullop->op_next = kid->op_next;
16277                 DEFER(nullop->op_next);
16278             }
16279
16280             /* check that RHS of sort is a single plain array */
16281             oright = cUNOPo->op_first;
16282             if (!oright || oright->op_type != OP_PUSHMARK)
16283                 break;
16284
16285             if (o->op_private & OPpSORT_INPLACE)
16286                 break;
16287
16288             /* reverse sort ... can be optimised.  */
16289             if (!OpHAS_SIBLING(cUNOPo)) {
16290                 /* Nothing follows us on the list. */
16291                 OP * const reverse = o->op_next;
16292
16293                 if (reverse->op_type == OP_REVERSE &&
16294                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16295                     OP * const pushmark = cUNOPx(reverse)->op_first;
16296                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16297                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16298                         /* reverse -> pushmark -> sort */
16299                         o->op_private |= OPpSORT_REVERSE;
16300                         op_null(reverse);
16301                         pushmark->op_next = oright->op_next;
16302                         op_null(oright);
16303                     }
16304                 }
16305             }
16306
16307             break;
16308         }
16309
16310         case OP_REVERSE: {
16311             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16312             OP *gvop = NULL;
16313             LISTOP *enter, *exlist;
16314
16315             if (o->op_private & OPpSORT_INPLACE)
16316                 break;
16317
16318             enter = (LISTOP *) o->op_next;
16319             if (!enter)
16320                 break;
16321             if (enter->op_type == OP_NULL) {
16322                 enter = (LISTOP *) enter->op_next;
16323                 if (!enter)
16324                     break;
16325             }
16326             /* for $a (...) will have OP_GV then OP_RV2GV here.
16327                for (...) just has an OP_GV.  */
16328             if (enter->op_type == OP_GV) {
16329                 gvop = (OP *) enter;
16330                 enter = (LISTOP *) enter->op_next;
16331                 if (!enter)
16332                     break;
16333                 if (enter->op_type == OP_RV2GV) {
16334                   enter = (LISTOP *) enter->op_next;
16335                   if (!enter)
16336                     break;
16337                 }
16338             }
16339
16340             if (enter->op_type != OP_ENTERITER)
16341                 break;
16342
16343             iter = enter->op_next;
16344             if (!iter || iter->op_type != OP_ITER)
16345                 break;
16346
16347             expushmark = enter->op_first;
16348             if (!expushmark || expushmark->op_type != OP_NULL
16349                 || expushmark->op_targ != OP_PUSHMARK)
16350                 break;
16351
16352             exlist = (LISTOP *) OpSIBLING(expushmark);
16353             if (!exlist || exlist->op_type != OP_NULL
16354                 || exlist->op_targ != OP_LIST)
16355                 break;
16356
16357             if (exlist->op_last != o) {
16358                 /* Mmm. Was expecting to point back to this op.  */
16359                 break;
16360             }
16361             theirmark = exlist->op_first;
16362             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16363                 break;
16364
16365             if (OpSIBLING(theirmark) != o) {
16366                 /* There's something between the mark and the reverse, eg
16367                    for (1, reverse (...))
16368                    so no go.  */
16369                 break;
16370             }
16371
16372             ourmark = ((LISTOP *)o)->op_first;
16373             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16374                 break;
16375
16376             ourlast = ((LISTOP *)o)->op_last;
16377             if (!ourlast || ourlast->op_next != o)
16378                 break;
16379
16380             rv2av = OpSIBLING(ourmark);
16381             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16382                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16383                 /* We're just reversing a single array.  */
16384                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16385                 enter->op_flags |= OPf_STACKED;
16386             }
16387
16388             /* We don't have control over who points to theirmark, so sacrifice
16389                ours.  */
16390             theirmark->op_next = ourmark->op_next;
16391             theirmark->op_flags = ourmark->op_flags;
16392             ourlast->op_next = gvop ? gvop : (OP *) enter;
16393             op_null(ourmark);
16394             op_null(o);
16395             enter->op_private |= OPpITER_REVERSED;
16396             iter->op_private |= OPpITER_REVERSED;
16397
16398             oldoldop = NULL;
16399             oldop    = ourlast;
16400             o        = oldop->op_next;
16401             goto redo;
16402             NOT_REACHED; /* NOTREACHED */
16403             break;
16404         }
16405
16406         case OP_QR:
16407         case OP_MATCH:
16408             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16409                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16410             }
16411             break;
16412
16413         case OP_RUNCV:
16414             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16415              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16416             {
16417                 SV *sv;
16418                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16419                 else {
16420                     sv = newRV((SV *)PL_compcv);
16421                     sv_rvweaken(sv);
16422                     SvREADONLY_on(sv);
16423                 }
16424                 OpTYPE_set(o, OP_CONST);
16425                 o->op_flags |= OPf_SPECIAL;
16426                 cSVOPo->op_sv = sv;
16427             }
16428             break;
16429
16430         case OP_SASSIGN:
16431             if (OP_GIMME(o,0) == G_VOID
16432              || (  o->op_next->op_type == OP_LINESEQ
16433                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16434                    || (  o->op_next->op_next->op_type == OP_RETURN
16435                       && !CvLVALUE(PL_compcv)))))
16436             {
16437                 OP *right = cBINOP->op_first;
16438                 if (right) {
16439                     /*   sassign
16440                     *      RIGHT
16441                     *      substr
16442                     *         pushmark
16443                     *         arg1
16444                     *         arg2
16445                     *         ...
16446                     * becomes
16447                     *
16448                     *  ex-sassign
16449                     *     substr
16450                     *        pushmark
16451                     *        RIGHT
16452                     *        arg1
16453                     *        arg2
16454                     *        ...
16455                     */
16456                     OP *left = OpSIBLING(right);
16457                     if (left->op_type == OP_SUBSTR
16458                          && (left->op_private & 7) < 4) {
16459                         op_null(o);
16460                         /* cut out right */
16461                         op_sibling_splice(o, NULL, 1, NULL);
16462                         /* and insert it as second child of OP_SUBSTR */
16463                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16464                                     right);
16465                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16466                         left->op_flags =
16467                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16468                     }
16469                 }
16470             }
16471             break;
16472
16473         case OP_AASSIGN: {
16474             int l, r, lr, lscalars, rscalars;
16475
16476             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16477                Note that we do this now rather than in newASSIGNOP(),
16478                since only by now are aliased lexicals flagged as such
16479
16480                See the essay "Common vars in list assignment" above for
16481                the full details of the rationale behind all the conditions
16482                below.
16483
16484                PL_generation sorcery:
16485                To detect whether there are common vars, the global var
16486                PL_generation is incremented for each assign op we scan.
16487                Then we run through all the lexical variables on the LHS,
16488                of the assignment, setting a spare slot in each of them to
16489                PL_generation.  Then we scan the RHS, and if any lexicals
16490                already have that value, we know we've got commonality.
16491                Also, if the generation number is already set to
16492                PERL_INT_MAX, then the variable is involved in aliasing, so
16493                we also have potential commonality in that case.
16494              */
16495
16496             PL_generation++;
16497             /* scan LHS */
16498             lscalars = 0;
16499             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16500             /* scan RHS */
16501             rscalars = 0;
16502             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16503             lr = (l|r);
16504
16505
16506             /* After looking for things which are *always* safe, this main
16507              * if/else chain selects primarily based on the type of the
16508              * LHS, gradually working its way down from the more dangerous
16509              * to the more restrictive and thus safer cases */
16510
16511             if (   !l                      /* () = ....; */
16512                 || !r                      /* .... = (); */
16513                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16514                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16515                 || (lscalars < 2)          /* ($x, undef) = ... */
16516             ) {
16517                 NOOP; /* always safe */
16518             }
16519             else if (l & AAS_DANGEROUS) {
16520                 /* always dangerous */
16521                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16522                 o->op_private |= OPpASSIGN_COMMON_AGG;
16523             }
16524             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16525                 /* package vars are always dangerous - too many
16526                  * aliasing possibilities */
16527                 if (l & AAS_PKG_SCALAR)
16528                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16529                 if (l & AAS_PKG_AGG)
16530                     o->op_private |= OPpASSIGN_COMMON_AGG;
16531             }
16532             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16533                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16534             {
16535                 /* LHS contains only lexicals and safe ops */
16536
16537                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16538                     o->op_private |= OPpASSIGN_COMMON_AGG;
16539
16540                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16541                     if (lr & AAS_LEX_SCALAR_COMM)
16542                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16543                     else if (   !(l & AAS_LEX_SCALAR)
16544                              && (r & AAS_DEFAV))
16545                     {
16546                         /* falsely mark
16547                          *    my (...) = @_
16548                          * as scalar-safe for performance reasons.
16549                          * (it will still have been marked _AGG if necessary */
16550                         NOOP;
16551                     }
16552                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16553                         /* if there are only lexicals on the LHS and no
16554                          * common ones on the RHS, then we assume that the
16555                          * only way those lexicals could also get
16556                          * on the RHS is via some sort of dereffing or
16557                          * closure, e.g.
16558                          *    $r = \$lex;
16559                          *    ($lex, $x) = (1, $$r)
16560                          * and in this case we assume the var must have
16561                          *  a bumped ref count. So if its ref count is 1,
16562                          *  it must only be on the LHS.
16563                          */
16564                         o->op_private |= OPpASSIGN_COMMON_RC1;
16565                 }
16566             }
16567
16568             /* ... = ($x)
16569              * may have to handle aggregate on LHS, but we can't
16570              * have common scalars. */
16571             if (rscalars < 2)
16572                 o->op_private &=
16573                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16574
16575             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16576                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16577             break;
16578         }
16579
16580         case OP_REF:
16581             /* see if ref() is used in boolean context */
16582             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16583                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16584             break;
16585
16586         case OP_LENGTH:
16587             /* see if the op is used in known boolean context,
16588              * but not if OA_TARGLEX optimisation is enabled */
16589             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16590                 && !(o->op_private & OPpTARGET_MY)
16591             )
16592                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16593             break;
16594
16595         case OP_POS:
16596             /* see if the op is used in known boolean context */
16597             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16598                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16599             break;
16600
16601         case OP_CUSTOM: {
16602             Perl_cpeep_t cpeep =
16603                 XopENTRYCUSTOM(o, xop_peep);
16604             if (cpeep)
16605                 cpeep(aTHX_ o, oldop);
16606             break;
16607         }
16608
16609         }
16610         /* did we just null the current op? If so, re-process it to handle
16611          * eliding "empty" ops from the chain */
16612         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16613             o->op_opt = 0;
16614             o = oldop;
16615         }
16616         else {
16617             oldoldop = oldop;
16618             oldop = o;
16619         }
16620     }
16621     LEAVE;
16622 }
16623
16624 void
16625 Perl_peep(pTHX_ OP *o)
16626 {
16627     CALL_RPEEP(o);
16628 }
16629
16630 /*
16631 =head1 Custom Operators
16632
16633 =for apidoc Ao||custom_op_xop
16634 Return the XOP structure for a given custom op.  This macro should be
16635 considered internal to C<OP_NAME> and the other access macros: use them instead.
16636 This macro does call a function.  Prior
16637 to 5.19.6, this was implemented as a
16638 function.
16639
16640 =cut
16641 */
16642
16643
16644 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16645  * freeing PL_custom_ops */
16646
16647 static int
16648 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16649 {
16650     XOP *xop;
16651
16652     PERL_UNUSED_ARG(mg);
16653     xop = INT2PTR(XOP *, SvIV(sv));
16654     safefree((void*)xop->xop_name);
16655     safefree((void*)xop->xop_desc);
16656     safefree(xop);
16657     return 0;
16658 }
16659
16660
16661 static const MGVTBL custom_op_register_vtbl = {
16662     0,                          /* get */
16663     0,                          /* set */
16664     0,                          /* len */
16665     0,                          /* clear */
16666     custom_op_register_free,     /* free */
16667     0,                          /* copy */
16668     0,                          /* dup */
16669 #ifdef MGf_LOCAL
16670     0,                          /* local */
16671 #endif
16672 };
16673
16674
16675 XOPRETANY
16676 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16677 {
16678     SV *keysv;
16679     HE *he = NULL;
16680     XOP *xop;
16681
16682     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16683
16684     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16685     assert(o->op_type == OP_CUSTOM);
16686
16687     /* This is wrong. It assumes a function pointer can be cast to IV,
16688      * which isn't guaranteed, but this is what the old custom OP code
16689      * did. In principle it should be safer to Copy the bytes of the
16690      * pointer into a PV: since the new interface is hidden behind
16691      * functions, this can be changed later if necessary.  */
16692     /* Change custom_op_xop if this ever happens */
16693     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16694
16695     if (PL_custom_ops)
16696         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16697
16698     /* See if the op isn't registered, but its name *is* registered.
16699      * That implies someone is using the pre-5.14 API,where only name and
16700      * description could be registered. If so, fake up a real
16701      * registration.
16702      * We only check for an existing name, and assume no one will have
16703      * just registered a desc */
16704     if (!he && PL_custom_op_names &&
16705         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16706     ) {
16707         const char *pv;
16708         STRLEN l;
16709
16710         /* XXX does all this need to be shared mem? */
16711         Newxz(xop, 1, XOP);
16712         pv = SvPV(HeVAL(he), l);
16713         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16714         if (PL_custom_op_descs &&
16715             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16716         ) {
16717             pv = SvPV(HeVAL(he), l);
16718             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16719         }
16720         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16721         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16722         /* add magic to the SV so that the xop struct (pointed to by
16723          * SvIV(sv)) is freed. Normally a static xop is registered, but
16724          * for this backcompat hack, we've alloced one */
16725         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
16726                 &custom_op_register_vtbl, NULL, 0);
16727
16728     }
16729     else {
16730         if (!he)
16731             xop = (XOP *)&xop_null;
16732         else
16733             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16734     }
16735     {
16736         XOPRETANY any;
16737         if(field == XOPe_xop_ptr) {
16738             any.xop_ptr = xop;
16739         } else {
16740             const U32 flags = XopFLAGS(xop);
16741             if(flags & field) {
16742                 switch(field) {
16743                 case XOPe_xop_name:
16744                     any.xop_name = xop->xop_name;
16745                     break;
16746                 case XOPe_xop_desc:
16747                     any.xop_desc = xop->xop_desc;
16748                     break;
16749                 case XOPe_xop_class:
16750                     any.xop_class = xop->xop_class;
16751                     break;
16752                 case XOPe_xop_peep:
16753                     any.xop_peep = xop->xop_peep;
16754                     break;
16755                 default:
16756                     NOT_REACHED; /* NOTREACHED */
16757                     break;
16758                 }
16759             } else {
16760                 switch(field) {
16761                 case XOPe_xop_name:
16762                     any.xop_name = XOPd_xop_name;
16763                     break;
16764                 case XOPe_xop_desc:
16765                     any.xop_desc = XOPd_xop_desc;
16766                     break;
16767                 case XOPe_xop_class:
16768                     any.xop_class = XOPd_xop_class;
16769                     break;
16770                 case XOPe_xop_peep:
16771                     any.xop_peep = XOPd_xop_peep;
16772                     break;
16773                 default:
16774                     NOT_REACHED; /* NOTREACHED */
16775                     break;
16776                 }
16777             }
16778         }
16779         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16780          * op.c: In function 'Perl_custom_op_get_field':
16781          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16782          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16783          * expands to assert(0), which expands to ((0) ? (void)0 :
16784          * __assert(...)), and gcc doesn't know that __assert can never return. */
16785         return any;
16786     }
16787 }
16788
16789 /*
16790 =for apidoc Ao||custom_op_register
16791 Register a custom op.  See L<perlguts/"Custom Operators">.
16792
16793 =cut
16794 */
16795
16796 void
16797 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16798 {
16799     SV *keysv;
16800
16801     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16802
16803     /* see the comment in custom_op_xop */
16804     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16805
16806     if (!PL_custom_ops)
16807         PL_custom_ops = newHV();
16808
16809     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16810         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16811 }
16812
16813 /*
16814
16815 =for apidoc core_prototype
16816
16817 This function assigns the prototype of the named core function to C<sv>, or
16818 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16819 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16820 by C<keyword()>.  It must not be equal to 0.
16821
16822 =cut
16823 */
16824
16825 SV *
16826 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16827                           int * const opnum)
16828 {
16829     int i = 0, n = 0, seen_question = 0, defgv = 0;
16830     I32 oa;
16831 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16832     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16833     bool nullret = FALSE;
16834
16835     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16836
16837     assert (code);
16838
16839     if (!sv) sv = sv_newmortal();
16840
16841 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16842
16843     switch (code < 0 ? -code : code) {
16844     case KEY_and   : case KEY_chop: case KEY_chomp:
16845     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16846     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16847     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16848     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16849     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16850     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16851     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16852     case KEY_x     : case KEY_xor    :
16853         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16854     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16855     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16856     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16857     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16858     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16859     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16860         retsetpvs("", 0);
16861     case KEY_evalbytes:
16862         name = "entereval"; break;
16863     case KEY_readpipe:
16864         name = "backtick";
16865     }
16866
16867 #undef retsetpvs
16868
16869   findopnum:
16870     while (i < MAXO) {  /* The slow way. */
16871         if (strEQ(name, PL_op_name[i])
16872             || strEQ(name, PL_op_desc[i]))
16873         {
16874             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16875             goto found;
16876         }
16877         i++;
16878     }
16879     return NULL;
16880   found:
16881     defgv = PL_opargs[i] & OA_DEFGV;
16882     oa = PL_opargs[i] >> OASHIFT;
16883     while (oa) {
16884         if (oa & OA_OPTIONAL && !seen_question && (
16885               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16886         )) {
16887             seen_question = 1;
16888             str[n++] = ';';
16889         }
16890         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16891             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16892             /* But globs are already references (kinda) */
16893             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16894         ) {
16895             str[n++] = '\\';
16896         }
16897         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16898          && !scalar_mod_type(NULL, i)) {
16899             str[n++] = '[';
16900             str[n++] = '$';
16901             str[n++] = '@';
16902             str[n++] = '%';
16903             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16904             str[n++] = '*';
16905             str[n++] = ']';
16906         }
16907         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16908         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16909             str[n-1] = '_'; defgv = 0;
16910         }
16911         oa = oa >> 4;
16912     }
16913     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16914     str[n++] = '\0';
16915     sv_setpvn(sv, str, n - 1);
16916     if (opnum) *opnum = i;
16917     return sv;
16918 }
16919
16920 OP *
16921 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16922                       const int opnum)
16923 {
16924     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16925     OP *o;
16926
16927     PERL_ARGS_ASSERT_CORESUB_OP;
16928
16929     switch(opnum) {
16930     case 0:
16931         return op_append_elem(OP_LINESEQ,
16932                        argop,
16933                        newSLICEOP(0,
16934                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16935                                   newOP(OP_CALLER,0)
16936                        )
16937                );
16938     case OP_EACH:
16939     case OP_KEYS:
16940     case OP_VALUES:
16941         o = newUNOP(OP_AVHVSWITCH,0,argop);
16942         o->op_private = opnum-OP_EACH;
16943         return o;
16944     case OP_SELECT: /* which represents OP_SSELECT as well */
16945         if (code)
16946             return newCONDOP(
16947                          0,
16948                          newBINOP(OP_GT, 0,
16949                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16950                                   newSVOP(OP_CONST, 0, newSVuv(1))
16951                                  ),
16952                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16953                                     OP_SSELECT),
16954                          coresub_op(coreargssv, 0, OP_SELECT)
16955                    );
16956         /* FALLTHROUGH */
16957     default:
16958         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16959         case OA_BASEOP:
16960             return op_append_elem(
16961                         OP_LINESEQ, argop,
16962                         newOP(opnum,
16963                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16964                                 ? OPpOFFBYONE << 8 : 0)
16965                    );
16966         case OA_BASEOP_OR_UNOP:
16967             if (opnum == OP_ENTEREVAL) {
16968                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16969                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16970             }
16971             else o = newUNOP(opnum,0,argop);
16972             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16973             else {
16974           onearg:
16975               if (is_handle_constructor(o, 1))
16976                 argop->op_private |= OPpCOREARGS_DEREF1;
16977               if (scalar_mod_type(NULL, opnum))
16978                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16979             }
16980             return o;
16981         default:
16982             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16983             if (is_handle_constructor(o, 2))
16984                 argop->op_private |= OPpCOREARGS_DEREF2;
16985             if (opnum == OP_SUBSTR) {
16986                 o->op_private |= OPpMAYBE_LVSUB;
16987                 return o;
16988             }
16989             else goto onearg;
16990         }
16991     }
16992 }
16993
16994 void
16995 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16996                                SV * const *new_const_svp)
16997 {
16998     const char *hvname;
16999     bool is_const = !!CvCONST(old_cv);
17000     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17001
17002     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17003
17004     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17005         return;
17006         /* They are 2 constant subroutines generated from
17007            the same constant. This probably means that
17008            they are really the "same" proxy subroutine
17009            instantiated in 2 places. Most likely this is
17010            when a constant is exported twice.  Don't warn.
17011         */
17012     if (
17013         (ckWARN(WARN_REDEFINE)
17014          && !(
17015                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17016              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17017              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17018                  strEQ(hvname, "autouse"))
17019              )
17020         )
17021      || (is_const
17022          && ckWARN_d(WARN_REDEFINE)
17023          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17024         )
17025     )
17026         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17027                           is_const
17028                             ? "Constant subroutine %" SVf " redefined"
17029                             : "Subroutine %" SVf " redefined",
17030                           SVfARG(name));
17031 }
17032
17033 /*
17034 =head1 Hook manipulation
17035
17036 These functions provide convenient and thread-safe means of manipulating
17037 hook variables.
17038
17039 =cut
17040 */
17041
17042 /*
17043 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
17044
17045 Puts a C function into the chain of check functions for a specified op
17046 type.  This is the preferred way to manipulate the L</PL_check> array.
17047 C<opcode> specifies which type of op is to be affected.  C<new_checker>
17048 is a pointer to the C function that is to be added to that opcode's
17049 check chain, and C<old_checker_p> points to the storage location where a
17050 pointer to the next function in the chain will be stored.  The value of
17051 C<new_checker> is written into the L</PL_check> array, while the value
17052 previously stored there is written to C<*old_checker_p>.
17053
17054 L</PL_check> is global to an entire process, and a module wishing to
17055 hook op checking may find itself invoked more than once per process,
17056 typically in different threads.  To handle that situation, this function
17057 is idempotent.  The location C<*old_checker_p> must initially (once
17058 per process) contain a null pointer.  A C variable of static duration
17059 (declared at file scope, typically also marked C<static> to give
17060 it internal linkage) will be implicitly initialised appropriately,
17061 if it does not have an explicit initialiser.  This function will only
17062 actually modify the check chain if it finds C<*old_checker_p> to be null.
17063 This function is also thread safe on the small scale.  It uses appropriate
17064 locking to avoid race conditions in accessing L</PL_check>.
17065
17066 When this function is called, the function referenced by C<new_checker>
17067 must be ready to be called, except for C<*old_checker_p> being unfilled.
17068 In a threading situation, C<new_checker> may be called immediately,
17069 even before this function has returned.  C<*old_checker_p> will always
17070 be appropriately set before C<new_checker> is called.  If C<new_checker>
17071 decides not to do anything special with an op that it is given (which
17072 is the usual case for most uses of op check hooking), it must chain the
17073 check function referenced by C<*old_checker_p>.
17074
17075 Taken all together, XS code to hook an op checker should typically look
17076 something like this:
17077
17078     static Perl_check_t nxck_frob;
17079     static OP *myck_frob(pTHX_ OP *op) {
17080         ...
17081         op = nxck_frob(aTHX_ op);
17082         ...
17083         return op;
17084     }
17085     BOOT:
17086         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17087
17088 If you want to influence compilation of calls to a specific subroutine,
17089 then use L</cv_set_call_checker_flags> rather than hooking checking of
17090 all C<entersub> ops.
17091
17092 =cut
17093 */
17094
17095 void
17096 Perl_wrap_op_checker(pTHX_ Optype opcode,
17097     Perl_check_t new_checker, Perl_check_t *old_checker_p)
17098 {
17099     dVAR;
17100
17101     PERL_UNUSED_CONTEXT;
17102     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17103     if (*old_checker_p) return;
17104     OP_CHECK_MUTEX_LOCK;
17105     if (!*old_checker_p) {
17106         *old_checker_p = PL_check[opcode];
17107         PL_check[opcode] = new_checker;
17108     }
17109     OP_CHECK_MUTEX_UNLOCK;
17110 }
17111
17112 #include "XSUB.h"
17113
17114 /* Efficient sub that returns a constant scalar value. */
17115 static void
17116 const_sv_xsub(pTHX_ CV* cv)
17117 {
17118     dXSARGS;
17119     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17120     PERL_UNUSED_ARG(items);
17121     if (!sv) {
17122         XSRETURN(0);
17123     }
17124     EXTEND(sp, 1);
17125     ST(0) = sv;
17126     XSRETURN(1);
17127 }
17128
17129 static void
17130 const_av_xsub(pTHX_ CV* cv)
17131 {
17132     dXSARGS;
17133     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17134     SP -= items;
17135     assert(av);
17136 #ifndef DEBUGGING
17137     if (!av) {
17138         XSRETURN(0);
17139     }
17140 #endif
17141     if (SvRMAGICAL(av))
17142         Perl_croak(aTHX_ "Magical list constants are not supported");
17143     if (GIMME_V != G_ARRAY) {
17144         EXTEND(SP, 1);
17145         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17146         XSRETURN(1);
17147     }
17148     EXTEND(SP, AvFILLp(av)+1);
17149     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17150     XSRETURN(AvFILLp(av)+1);
17151 }
17152
17153 /* Copy an existing cop->cop_warnings field.
17154  * If it's one of the standard addresses, just re-use the address.
17155  * This is the e implementation for the DUP_WARNINGS() macro
17156  */
17157
17158 STRLEN*
17159 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17160 {
17161     Size_t size;
17162     STRLEN *new_warnings;
17163
17164     if (warnings == NULL || specialWARN(warnings))
17165         return warnings;
17166
17167     size = sizeof(*warnings) + *warnings;
17168
17169     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17170     Copy(warnings, new_warnings, size, char);
17171     return new_warnings;
17172 }
17173
17174 /*
17175  * ex: set ts=8 sts=4 sw=4 et:
17176  */