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     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6105      * pushmark is banned. So do it now while existing ops are in a
6106      * consistent state, in case they suddenly get freed */
6107     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6108
6109     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6110         || type == OP_CUSTOM);
6111
6112     NewOp(1101, listop, 1, LISTOP);
6113     OpTYPE_set(listop, type);
6114     if (first || last)
6115         flags |= OPf_KIDS;
6116     listop->op_flags = (U8)flags;
6117
6118     if (!last && first)
6119         last = first;
6120     else if (!first && last)
6121         first = last;
6122     else if (first)
6123         OpMORESIB_set(first, last);
6124     listop->op_first = first;
6125     listop->op_last = last;
6126
6127     if (pushop) {
6128         OpMORESIB_set(pushop, first);
6129         listop->op_first = pushop;
6130         listop->op_flags |= OPf_KIDS;
6131         if (!last)
6132             listop->op_last = pushop;
6133     }
6134     if (listop->op_last)
6135         OpLASTSIB_set(listop->op_last, (OP*)listop);
6136
6137     return CHECKOP(type, listop);
6138 }
6139
6140 /*
6141 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6142
6143 Constructs, checks, and returns an op of any base type (any type that
6144 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6145 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6146 of C<op_private>.
6147
6148 =cut
6149 */
6150
6151 OP *
6152 Perl_newOP(pTHX_ I32 type, I32 flags)
6153 {
6154     dVAR;
6155     OP *o;
6156
6157     if (type == -OP_ENTEREVAL) {
6158         type = OP_ENTEREVAL;
6159         flags |= OPpEVAL_BYTES<<8;
6160     }
6161
6162     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6163         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6164         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6165         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6166
6167     NewOp(1101, o, 1, OP);
6168     OpTYPE_set(o, type);
6169     o->op_flags = (U8)flags;
6170
6171     o->op_next = o;
6172     o->op_private = (U8)(0 | (flags >> 8));
6173     if (PL_opargs[type] & OA_RETSCALAR)
6174         scalar(o);
6175     if (PL_opargs[type] & OA_TARGET)
6176         o->op_targ = pad_alloc(type, SVs_PADTMP);
6177     return CHECKOP(type, o);
6178 }
6179
6180 /*
6181 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6182
6183 Constructs, checks, and returns an op of any unary type.  C<type> is
6184 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6185 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6186 bits, the eight bits of C<op_private>, except that the bit with value 1
6187 is automatically set.  C<first> supplies an optional op to be the direct
6188 child of the unary op; it is consumed by this function and become part
6189 of the constructed op tree.
6190
6191 =cut
6192 */
6193
6194 OP *
6195 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6196 {
6197     dVAR;
6198     UNOP *unop;
6199
6200     if (type == -OP_ENTEREVAL) {
6201         type = OP_ENTEREVAL;
6202         flags |= OPpEVAL_BYTES<<8;
6203     }
6204
6205     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6206         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6207         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6208         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6209         || type == OP_SASSIGN
6210         || type == OP_ENTERTRY
6211         || type == OP_CUSTOM
6212         || type == OP_NULL );
6213
6214     if (!first)
6215         first = newOP(OP_STUB, 0);
6216     if (PL_opargs[type] & OA_MARK)
6217         first = force_list(first, 1);
6218
6219     NewOp(1101, unop, 1, UNOP);
6220     OpTYPE_set(unop, type);
6221     unop->op_first = first;
6222     unop->op_flags = (U8)(flags | OPf_KIDS);
6223     unop->op_private = (U8)(1 | (flags >> 8));
6224
6225     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6226         OpLASTSIB_set(first, (OP*)unop);
6227
6228     unop = (UNOP*) CHECKOP(type, unop);
6229     if (unop->op_next)
6230         return (OP*)unop;
6231
6232     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6233 }
6234
6235 /*
6236 =for apidoc newUNOP_AUX
6237
6238 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6239 initialised to C<aux>
6240
6241 =cut
6242 */
6243
6244 OP *
6245 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6246 {
6247     dVAR;
6248     UNOP_AUX *unop;
6249
6250     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6251         || type == OP_CUSTOM);
6252
6253     NewOp(1101, unop, 1, UNOP_AUX);
6254     unop->op_type = (OPCODE)type;
6255     unop->op_ppaddr = PL_ppaddr[type];
6256     unop->op_first = first;
6257     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6258     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6259     unop->op_aux = aux;
6260
6261     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6262         OpLASTSIB_set(first, (OP*)unop);
6263
6264     unop = (UNOP_AUX*) CHECKOP(type, unop);
6265
6266     return op_std_init((OP *) unop);
6267 }
6268
6269 /*
6270 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6271
6272 Constructs, checks, and returns an op of method type with a method name
6273 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6274 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6275 and, shifted up eight bits, the eight bits of C<op_private>, except that
6276 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6277 op which evaluates method name; it is consumed by this function and
6278 become part of the constructed op tree.
6279 Supported optypes: C<OP_METHOD>.
6280
6281 =cut
6282 */
6283
6284 static OP*
6285 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6286     dVAR;
6287     METHOP *methop;
6288
6289     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6290         || type == OP_CUSTOM);
6291
6292     NewOp(1101, methop, 1, METHOP);
6293     if (dynamic_meth) {
6294         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6295         methop->op_flags = (U8)(flags | OPf_KIDS);
6296         methop->op_u.op_first = dynamic_meth;
6297         methop->op_private = (U8)(1 | (flags >> 8));
6298
6299         if (!OpHAS_SIBLING(dynamic_meth))
6300             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6301     }
6302     else {
6303         assert(const_meth);
6304         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6305         methop->op_u.op_meth_sv = const_meth;
6306         methop->op_private = (U8)(0 | (flags >> 8));
6307         methop->op_next = (OP*)methop;
6308     }
6309
6310 #ifdef USE_ITHREADS
6311     methop->op_rclass_targ = 0;
6312 #else
6313     methop->op_rclass_sv = NULL;
6314 #endif
6315
6316     OpTYPE_set(methop, type);
6317     return CHECKOP(type, methop);
6318 }
6319
6320 OP *
6321 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6322     PERL_ARGS_ASSERT_NEWMETHOP;
6323     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6324 }
6325
6326 /*
6327 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6328
6329 Constructs, checks, and returns an op of method type with a constant
6330 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6331 C<op_flags>, and, shifted up eight bits, the eight bits of
6332 C<op_private>.  C<const_meth> supplies a constant method name;
6333 it must be a shared COW string.
6334 Supported optypes: C<OP_METHOD_NAMED>.
6335
6336 =cut
6337 */
6338
6339 OP *
6340 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6341     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6342     return newMETHOP_internal(type, flags, NULL, const_meth);
6343 }
6344
6345 /*
6346 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6347
6348 Constructs, checks, and returns an op of any binary type.  C<type>
6349 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6350 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6351 the eight bits of C<op_private>, except that the bit with value 1 or
6352 2 is automatically set as required.  C<first> and C<last> supply up to
6353 two ops to be the direct children of the binary op; they are consumed
6354 by this function and become part of the constructed op tree.
6355
6356 =cut
6357 */
6358
6359 OP *
6360 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6361 {
6362     dVAR;
6363     BINOP *binop;
6364
6365     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6366         || type == OP_NULL || type == OP_CUSTOM);
6367
6368     NewOp(1101, binop, 1, BINOP);
6369
6370     if (!first)
6371         first = newOP(OP_NULL, 0);
6372
6373     OpTYPE_set(binop, type);
6374     binop->op_first = first;
6375     binop->op_flags = (U8)(flags | OPf_KIDS);
6376     if (!last) {
6377         last = first;
6378         binop->op_private = (U8)(1 | (flags >> 8));
6379     }
6380     else {
6381         binop->op_private = (U8)(2 | (flags >> 8));
6382         OpMORESIB_set(first, last);
6383     }
6384
6385     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6386         OpLASTSIB_set(last, (OP*)binop);
6387
6388     binop->op_last = OpSIBLING(binop->op_first);
6389     if (binop->op_last)
6390         OpLASTSIB_set(binop->op_last, (OP*)binop);
6391
6392     binop = (BINOP*)CHECKOP(type, binop);
6393     if (binop->op_next || binop->op_type != (OPCODE)type)
6394         return (OP*)binop;
6395
6396     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6397 }
6398
6399 /* Helper function for S_pmtrans(): comparison function to sort an array
6400  * of codepoint range pairs. Sorts by start point, or if equal, by end
6401  * point */
6402
6403 static int uvcompare(const void *a, const void *b)
6404     __attribute__nonnull__(1)
6405     __attribute__nonnull__(2)
6406     __attribute__pure__;
6407 static int uvcompare(const void *a, const void *b)
6408 {
6409     if (*((const UV *)a) < (*(const UV *)b))
6410         return -1;
6411     if (*((const UV *)a) > (*(const UV *)b))
6412         return 1;
6413     if (*((const UV *)a+1) < (*(const UV *)b+1))
6414         return -1;
6415     if (*((const UV *)a+1) > (*(const UV *)b+1))
6416         return 1;
6417     return 0;
6418 }
6419
6420 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6421  * containing the search and replacement strings, assemble into
6422  * a translation table attached as o->op_pv.
6423  * Free expr and repl.
6424  * It expects the toker to have already set the
6425  *   OPpTRANS_COMPLEMENT
6426  *   OPpTRANS_SQUASH
6427  *   OPpTRANS_DELETE
6428  * flags as appropriate; this function may add
6429  *   OPpTRANS_FROM_UTF
6430  *   OPpTRANS_TO_UTF
6431  *   OPpTRANS_IDENTICAL
6432  *   OPpTRANS_GROWS
6433  * flags
6434  */
6435
6436 static OP *
6437 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6438 {
6439     SV * const tstr = ((SVOP*)expr)->op_sv;
6440     SV * const rstr = ((SVOP*)repl)->op_sv;
6441     STRLEN tlen;
6442     STRLEN rlen;
6443     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6444     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6445     Size_t i, j;
6446     bool grows = FALSE;
6447     OPtrans_map *tbl;
6448     SSize_t struct_size; /* malloced size of table struct */
6449
6450     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6451     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6452     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6453     SV* swash;
6454
6455     PERL_ARGS_ASSERT_PMTRANS;
6456
6457     PL_hints |= HINT_BLOCK_SCOPE;
6458
6459     if (SvUTF8(tstr))
6460         o->op_private |= OPpTRANS_FROM_UTF;
6461
6462     if (SvUTF8(rstr))
6463         o->op_private |= OPpTRANS_TO_UTF;
6464
6465     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6466
6467         /* for utf8 translations, op_sv will be set to point to a swash
6468          * containing codepoint ranges. This is done by first assembling
6469          * a textual representation of the ranges in listsv then compiling
6470          * it using swash_init(). For more details of the textual format,
6471          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6472          */
6473
6474         SV* const listsv = newSVpvs("# comment\n");
6475         SV* transv = NULL;
6476         const U8* tend = t + tlen;
6477         const U8* rend = r + rlen;
6478         STRLEN ulen;
6479         UV tfirst = 1;
6480         UV tlast = 0;
6481         IV tdiff;
6482         STRLEN tcount = 0;
6483         UV rfirst = 1;
6484         UV rlast = 0;
6485         IV rdiff;
6486         STRLEN rcount = 0;
6487         IV diff;
6488         I32 none = 0;
6489         U32 max = 0;
6490         I32 bits;
6491         I32 havefinal = 0;
6492         U32 final = 0;
6493         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6494         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6495         U8* tsave = NULL;
6496         U8* rsave = NULL;
6497         const U32 flags = UTF8_ALLOW_DEFAULT;
6498
6499         if (!from_utf) {
6500             STRLEN len = tlen;
6501             t = tsave = bytes_to_utf8(t, &len);
6502             tend = t + len;
6503         }
6504         if (!to_utf && rlen) {
6505             STRLEN len = rlen;
6506             r = rsave = bytes_to_utf8(r, &len);
6507             rend = r + len;
6508         }
6509
6510 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6511  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6512  * odd.  */
6513
6514         if (complement) {
6515             /* utf8 and /c:
6516              * replace t/tlen/tend with a version that has the ranges
6517              * complemented
6518              */
6519             U8 tmpbuf[UTF8_MAXBYTES+1];
6520             UV *cp;
6521             UV nextmin = 0;
6522             Newx(cp, 2*tlen, UV);
6523             i = 0;
6524             transv = newSVpvs("");
6525
6526             /* convert search string into array of (start,end) range
6527              * codepoint pairs stored in cp[]. Most "ranges" will start
6528              * and end at the same char */
6529             while (t < tend) {
6530                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6531                 t += ulen;
6532                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6533                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6534                     t++;
6535                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6536                     t += ulen;
6537                 }
6538                 else {
6539                  cp[2*i+1] = cp[2*i];
6540                 }
6541                 i++;
6542             }
6543
6544             /* sort the ranges */
6545             qsort(cp, i, 2*sizeof(UV), uvcompare);
6546
6547             /* Create a utf8 string containing the complement of the
6548              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6549              * then transv will contain the equivalent of:
6550              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6551              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6552              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6553              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6554              * end cp.
6555              */
6556             for (j = 0; j < i; j++) {
6557                 UV  val = cp[2*j];
6558                 diff = val - nextmin;
6559                 if (diff > 0) {
6560                     t = uvchr_to_utf8(tmpbuf,nextmin);
6561                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6562                     if (diff > 1) {
6563                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6564                         t = uvchr_to_utf8(tmpbuf, val - 1);
6565                         sv_catpvn(transv, (char *)&range_mark, 1);
6566                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6567                     }
6568                 }
6569                 val = cp[2*j+1];
6570                 if (val >= nextmin)
6571                     nextmin = val + 1;
6572             }
6573
6574             t = uvchr_to_utf8(tmpbuf,nextmin);
6575             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6576             {
6577                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6578                 sv_catpvn(transv, (char *)&range_mark, 1);
6579             }
6580             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6581             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6582             t = (const U8*)SvPVX_const(transv);
6583             tlen = SvCUR(transv);
6584             tend = t + tlen;
6585             Safefree(cp);
6586         }
6587         else if (!rlen && !del) {
6588             r = t; rlen = tlen; rend = tend;
6589         }
6590
6591         if (!squash) {
6592                 if ((!rlen && !del) || t == r ||
6593                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6594                 {
6595                     o->op_private |= OPpTRANS_IDENTICAL;
6596                 }
6597         }
6598
6599         /* extract char ranges from t and r and append them to listsv */
6600
6601         while (t < tend || tfirst <= tlast) {
6602             /* see if we need more "t" chars */
6603             if (tfirst > tlast) {
6604                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6605                 t += ulen;
6606                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6607                     t++;
6608                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6609                     t += ulen;
6610                 }
6611                 else
6612                     tlast = tfirst;
6613             }
6614
6615             /* now see if we need more "r" chars */
6616             if (rfirst > rlast) {
6617                 if (r < rend) {
6618                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6619                     r += ulen;
6620                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6621                         r++;
6622                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6623                         r += ulen;
6624                     }
6625                     else
6626                         rlast = rfirst;
6627                 }
6628                 else {
6629                     if (!havefinal++)
6630                         final = rlast;
6631                     rfirst = rlast = 0xffffffff;
6632                 }
6633             }
6634
6635             /* now see which range will peter out first, if either. */
6636             tdiff = tlast - tfirst;
6637             rdiff = rlast - rfirst;
6638             tcount += tdiff + 1;
6639             rcount += rdiff + 1;
6640
6641             if (tdiff <= rdiff)
6642                 diff = tdiff;
6643             else
6644                 diff = rdiff;
6645
6646             if (rfirst == 0xffffffff) {
6647                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6648                 if (diff > 0)
6649                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6650                                    (long)tfirst, (long)tlast);
6651                 else
6652                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6653             }
6654             else {
6655                 if (diff > 0)
6656                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6657                                    (long)tfirst, (long)(tfirst + diff),
6658                                    (long)rfirst);
6659                 else
6660                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6661                                    (long)tfirst, (long)rfirst);
6662
6663                 if (rfirst + diff > max)
6664                     max = rfirst + diff;
6665                 if (!grows)
6666                     grows = (tfirst < rfirst &&
6667                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6668                 rfirst += diff + 1;
6669             }
6670             tfirst += diff + 1;
6671         }
6672
6673         /* compile listsv into a swash and attach to o */
6674
6675         none = ++max;
6676         if (del)
6677             ++max;
6678
6679         if (max > 0xffff)
6680             bits = 32;
6681         else if (max > 0xff)
6682             bits = 16;
6683         else
6684             bits = 8;
6685
6686         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6687 #ifdef USE_ITHREADS
6688         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6689         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6690         PAD_SETSV(cPADOPo->op_padix, swash);
6691         SvPADTMP_on(swash);
6692         SvREADONLY_on(swash);
6693 #else
6694         cSVOPo->op_sv = swash;
6695 #endif
6696         SvREFCNT_dec(listsv);
6697         SvREFCNT_dec(transv);
6698
6699         if (!del && havefinal && rlen)
6700             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6701                            newSVuv((UV)final), 0);
6702
6703         Safefree(tsave);
6704         Safefree(rsave);
6705
6706         tlen = tcount;
6707         rlen = rcount;
6708         if (r < rend)
6709             rlen++;
6710         else if (rlast == 0xffffffff)
6711             rlen = 0;
6712
6713         goto warnins;
6714     }
6715
6716     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6717      * table. Entries with the value -1 indicate chars not to be
6718      * translated, while -2 indicates a search char without a
6719      * corresponding replacement char under /d.
6720      *
6721      * Normally, the table has 256 slots. However, in the presence of
6722      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6723      * added, and if there are enough replacement chars to start pairing
6724      * with the \x{100},... search chars, then a larger (> 256) table
6725      * is allocated.
6726      *
6727      * In addition, regardless of whether under /c, an extra slot at the
6728      * end is used to store the final repeating char, or -3 under an empty
6729      * replacement list, or -2 under /d; which makes the runtime code
6730      * easier.
6731      *
6732      * The toker will have already expanded char ranges in t and r.
6733      */
6734
6735     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6736      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6737      * The OPtrans_map struct already contains one slot; hence the -1.
6738      */
6739     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6740     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6741     tbl->size = 256;
6742     cPVOPo->op_pv = (char*)tbl;
6743
6744     if (complement) {
6745         Size_t excess;
6746
6747         /* in this branch, j is a count of 'consumed' (i.e. paired off
6748          * with a search char) replacement chars (so j <= rlen always)
6749          */
6750         for (i = 0; i < tlen; i++)
6751             tbl->map[t[i]] = -1;
6752
6753         for (i = 0, j = 0; i < 256; i++) {
6754             if (!tbl->map[i]) {
6755                 if (j == rlen) {
6756                     if (del)
6757                         tbl->map[i] = -2;
6758                     else if (rlen)
6759                         tbl->map[i] = r[j-1];
6760                     else
6761                         tbl->map[i] = (short)i;
6762                 }
6763                 else {
6764                     tbl->map[i] = r[j++];
6765                 }
6766                 if (   tbl->map[i] >= 0
6767                     &&  UVCHR_IS_INVARIANT((UV)i)
6768                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6769                 )
6770                     grows = TRUE;
6771             }
6772         }
6773
6774         ASSUME(j <= rlen);
6775         excess = rlen - j;
6776
6777         if (excess) {
6778             /* More replacement chars than search chars:
6779              * store excess replacement chars at end of main table.
6780              */
6781
6782             struct_size += excess;
6783             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6784                         struct_size + excess * sizeof(short));
6785             tbl->size += excess;
6786             cPVOPo->op_pv = (char*)tbl;
6787
6788             for (i = 0; i < excess; i++)
6789                 tbl->map[i + 256] = r[j+i];
6790         }
6791         else {
6792             /* no more replacement chars than search chars */
6793             if (!rlen && !del && !squash)
6794                 o->op_private |= OPpTRANS_IDENTICAL;
6795         }
6796
6797         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6798     }
6799     else {
6800         if (!rlen && !del) {
6801             r = t; rlen = tlen;
6802             if (!squash)
6803                 o->op_private |= OPpTRANS_IDENTICAL;
6804         }
6805         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6806             o->op_private |= OPpTRANS_IDENTICAL;
6807         }
6808
6809         for (i = 0; i < 256; i++)
6810             tbl->map[i] = -1;
6811         for (i = 0, j = 0; i < tlen; i++,j++) {
6812             if (j >= rlen) {
6813                 if (del) {
6814                     if (tbl->map[t[i]] == -1)
6815                         tbl->map[t[i]] = -2;
6816                     continue;
6817                 }
6818                 --j;
6819             }
6820             if (tbl->map[t[i]] == -1) {
6821                 if (     UVCHR_IS_INVARIANT(t[i])
6822                     && ! UVCHR_IS_INVARIANT(r[j]))
6823                     grows = TRUE;
6824                 tbl->map[t[i]] = r[j];
6825             }
6826         }
6827         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6828     }
6829
6830     /* both non-utf8 and utf8 code paths end up here */
6831
6832   warnins:
6833     if(del && rlen == tlen) {
6834         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6835     } else if(rlen > tlen && !complement) {
6836         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6837     }
6838
6839     if (grows)
6840         o->op_private |= OPpTRANS_GROWS;
6841     op_free(expr);
6842     op_free(repl);
6843
6844     return o;
6845 }
6846
6847
6848 /*
6849 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6850
6851 Constructs, checks, and returns an op of any pattern matching type.
6852 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6853 and, shifted up eight bits, the eight bits of C<op_private>.
6854
6855 =cut
6856 */
6857
6858 OP *
6859 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6860 {
6861     dVAR;
6862     PMOP *pmop;
6863
6864     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6865         || type == OP_CUSTOM);
6866
6867     NewOp(1101, pmop, 1, PMOP);
6868     OpTYPE_set(pmop, type);
6869     pmop->op_flags = (U8)flags;
6870     pmop->op_private = (U8)(0 | (flags >> 8));
6871     if (PL_opargs[type] & OA_RETSCALAR)
6872         scalar((OP *)pmop);
6873
6874     if (PL_hints & HINT_RE_TAINT)
6875         pmop->op_pmflags |= PMf_RETAINT;
6876 #ifdef USE_LOCALE_CTYPE
6877     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6878         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6879     }
6880     else
6881 #endif
6882          if (IN_UNI_8_BIT) {
6883         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6884     }
6885     if (PL_hints & HINT_RE_FLAGS) {
6886         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6887          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6888         );
6889         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6890         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6891          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6892         );
6893         if (reflags && SvOK(reflags)) {
6894             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6895         }
6896     }
6897
6898
6899 #ifdef USE_ITHREADS
6900     assert(SvPOK(PL_regex_pad[0]));
6901     if (SvCUR(PL_regex_pad[0])) {
6902         /* Pop off the "packed" IV from the end.  */
6903         SV *const repointer_list = PL_regex_pad[0];
6904         const char *p = SvEND(repointer_list) - sizeof(IV);
6905         const IV offset = *((IV*)p);
6906
6907         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6908
6909         SvEND_set(repointer_list, p);
6910
6911         pmop->op_pmoffset = offset;
6912         /* This slot should be free, so assert this:  */
6913         assert(PL_regex_pad[offset] == &PL_sv_undef);
6914     } else {
6915         SV * const repointer = &PL_sv_undef;
6916         av_push(PL_regex_padav, repointer);
6917         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6918         PL_regex_pad = AvARRAY(PL_regex_padav);
6919     }
6920 #endif
6921
6922     return CHECKOP(type, pmop);
6923 }
6924
6925 static void
6926 S_set_haseval(pTHX)
6927 {
6928     PADOFFSET i = 1;
6929     PL_cv_has_eval = 1;
6930     /* Any pad names in scope are potentially lvalues.  */
6931     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6932         PADNAME *pn = PAD_COMPNAME_SV(i);
6933         if (!pn || !PadnameLEN(pn))
6934             continue;
6935         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6936             S_mark_padname_lvalue(aTHX_ pn);
6937     }
6938 }
6939
6940 /* Given some sort of match op o, and an expression expr containing a
6941  * pattern, either compile expr into a regex and attach it to o (if it's
6942  * constant), or convert expr into a runtime regcomp op sequence (if it's
6943  * not)
6944  *
6945  * Flags currently has 2 bits of meaning:
6946  * 1: isreg indicates that the pattern is part of a regex construct, eg
6947  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6948  * split "pattern", which aren't. In the former case, expr will be a list
6949  * if the pattern contains more than one term (eg /a$b/).
6950  * 2: The pattern is for a split.
6951  *
6952  * When the pattern has been compiled within a new anon CV (for
6953  * qr/(?{...})/ ), then floor indicates the savestack level just before
6954  * the new sub was created
6955  */
6956
6957 OP *
6958 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6959 {
6960     PMOP *pm;
6961     LOGOP *rcop;
6962     I32 repl_has_vars = 0;
6963     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6964     bool is_compiletime;
6965     bool has_code;
6966     bool isreg    = cBOOL(flags & 1);
6967     bool is_split = cBOOL(flags & 2);
6968
6969     PERL_ARGS_ASSERT_PMRUNTIME;
6970
6971     if (is_trans) {
6972         return pmtrans(o, expr, repl);
6973     }
6974
6975     /* find whether we have any runtime or code elements;
6976      * at the same time, temporarily set the op_next of each DO block;
6977      * then when we LINKLIST, this will cause the DO blocks to be excluded
6978      * from the op_next chain (and from having LINKLIST recursively
6979      * applied to them). We fix up the DOs specially later */
6980
6981     is_compiletime = 1;
6982     has_code = 0;
6983     if (expr->op_type == OP_LIST) {
6984         OP *o;
6985         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6986             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6987                 has_code = 1;
6988                 assert(!o->op_next);
6989                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6990                     assert(PL_parser && PL_parser->error_count);
6991                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6992                        the op we were expecting to see, to avoid crashing
6993                        elsewhere.  */
6994                     op_sibling_splice(expr, o, 0,
6995                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6996                 }
6997                 o->op_next = OpSIBLING(o);
6998             }
6999             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7000                 is_compiletime = 0;
7001         }
7002     }
7003     else if (expr->op_type != OP_CONST)
7004         is_compiletime = 0;
7005
7006     LINKLIST(expr);
7007
7008     /* fix up DO blocks; treat each one as a separate little sub;
7009      * also, mark any arrays as LIST/REF */
7010
7011     if (expr->op_type == OP_LIST) {
7012         OP *o;
7013         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7014
7015             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7016                 assert( !(o->op_flags  & OPf_WANT));
7017                 /* push the array rather than its contents. The regex
7018                  * engine will retrieve and join the elements later */
7019                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7020                 continue;
7021             }
7022
7023             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7024                 continue;
7025             o->op_next = NULL; /* undo temporary hack from above */
7026             scalar(o);
7027             LINKLIST(o);
7028             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7029                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7030                 /* skip ENTER */
7031                 assert(leaveop->op_first->op_type == OP_ENTER);
7032                 assert(OpHAS_SIBLING(leaveop->op_first));
7033                 o->op_next = OpSIBLING(leaveop->op_first);
7034                 /* skip leave */
7035                 assert(leaveop->op_flags & OPf_KIDS);
7036                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7037                 leaveop->op_next = NULL; /* stop on last op */
7038                 op_null((OP*)leaveop);
7039             }
7040             else {
7041                 /* skip SCOPE */
7042                 OP *scope = cLISTOPo->op_first;
7043                 assert(scope->op_type == OP_SCOPE);
7044                 assert(scope->op_flags & OPf_KIDS);
7045                 scope->op_next = NULL; /* stop on last op */
7046                 op_null(scope);
7047             }
7048
7049             /* XXX optimize_optree() must be called on o before
7050              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7051              * currently cope with a peephole-optimised optree.
7052              * Calling optimize_optree() here ensures that condition
7053              * is met, but may mean optimize_optree() is applied
7054              * to the same optree later (where hopefully it won't do any
7055              * harm as it can't convert an op to multiconcat if it's
7056              * already been converted */
7057             optimize_optree(o);
7058
7059             /* have to peep the DOs individually as we've removed it from
7060              * the op_next chain */
7061             CALL_PEEP(o);
7062             S_prune_chain_head(&(o->op_next));
7063             if (is_compiletime)
7064                 /* runtime finalizes as part of finalizing whole tree */
7065                 finalize_optree(o);
7066         }
7067     }
7068     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7069         assert( !(expr->op_flags  & OPf_WANT));
7070         /* push the array rather than its contents. The regex
7071          * engine will retrieve and join the elements later */
7072         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7073     }
7074
7075     PL_hints |= HINT_BLOCK_SCOPE;
7076     pm = (PMOP*)o;
7077     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7078
7079     if (is_compiletime) {
7080         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7081         regexp_engine const *eng = current_re_engine();
7082
7083         if (is_split) {
7084             /* make engine handle split ' ' specially */
7085             pm->op_pmflags |= PMf_SPLIT;
7086             rx_flags |= RXf_SPLIT;
7087         }
7088
7089         if (!has_code || !eng->op_comp) {
7090             /* compile-time simple constant pattern */
7091
7092             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7093                 /* whoops! we guessed that a qr// had a code block, but we
7094                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7095                  * that isn't required now. Note that we have to be pretty
7096                  * confident that nothing used that CV's pad while the
7097                  * regex was parsed, except maybe op targets for \Q etc.
7098                  * If there were any op targets, though, they should have
7099                  * been stolen by constant folding.
7100                  */
7101 #ifdef DEBUGGING
7102                 SSize_t i = 0;
7103                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7104                 while (++i <= AvFILLp(PL_comppad)) {
7105 #  ifdef USE_PAD_RESET
7106                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7107                      * folded constant with a fresh padtmp */
7108                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7109 #  else
7110                     assert(!PL_curpad[i]);
7111 #  endif
7112                 }
7113 #endif
7114                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7115                  * outer CV (the one whose slab holds the pm op). The
7116                  * inner CV (which holds expr) will be freed later, once
7117                  * all the entries on the parse stack have been popped on
7118                  * return from this function. Which is why its safe to
7119                  * call op_free(expr) below.
7120                  */
7121                 LEAVE_SCOPE(floor);
7122                 pm->op_pmflags &= ~PMf_HAS_CV;
7123             }
7124
7125             /* Skip compiling if parser found an error for this pattern */
7126             if (pm->op_pmflags & PMf_HAS_ERROR) {
7127                 return o;
7128             }
7129
7130             PM_SETRE(pm,
7131                 eng->op_comp
7132                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7133                                         rx_flags, pm->op_pmflags)
7134                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7135                                         rx_flags, pm->op_pmflags)
7136             );
7137             op_free(expr);
7138         }
7139         else {
7140             /* compile-time pattern that includes literal code blocks */
7141
7142             REGEXP* re;
7143
7144             /* Skip compiling if parser found an error for this pattern */
7145             if (pm->op_pmflags & PMf_HAS_ERROR) {
7146                 return o;
7147             }
7148
7149             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7150                         rx_flags,
7151                         (pm->op_pmflags |
7152                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7153                     );
7154             PM_SETRE(pm, re);
7155             if (pm->op_pmflags & PMf_HAS_CV) {
7156                 CV *cv;
7157                 /* this QR op (and the anon sub we embed it in) is never
7158                  * actually executed. It's just a placeholder where we can
7159                  * squirrel away expr in op_code_list without the peephole
7160                  * optimiser etc processing it for a second time */
7161                 OP *qr = newPMOP(OP_QR, 0);
7162                 ((PMOP*)qr)->op_code_list = expr;
7163
7164                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7165                 SvREFCNT_inc_simple_void(PL_compcv);
7166                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7167                 ReANY(re)->qr_anoncv = cv;
7168
7169                 /* attach the anon CV to the pad so that
7170                  * pad_fixup_inner_anons() can find it */
7171                 (void)pad_add_anon(cv, o->op_type);
7172                 SvREFCNT_inc_simple_void(cv);
7173             }
7174             else {
7175                 pm->op_code_list = expr;
7176             }
7177         }
7178     }
7179     else {
7180         /* runtime pattern: build chain of regcomp etc ops */
7181         bool reglist;
7182         PADOFFSET cv_targ = 0;
7183
7184         reglist = isreg && expr->op_type == OP_LIST;
7185         if (reglist)
7186             op_null(expr);
7187
7188         if (has_code) {
7189             pm->op_code_list = expr;
7190             /* don't free op_code_list; its ops are embedded elsewhere too */
7191             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7192         }
7193
7194         if (is_split)
7195             /* make engine handle split ' ' specially */
7196             pm->op_pmflags |= PMf_SPLIT;
7197
7198         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7199          * to allow its op_next to be pointed past the regcomp and
7200          * preceding stacking ops;
7201          * OP_REGCRESET is there to reset taint before executing the
7202          * stacking ops */
7203         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7204             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7205
7206         if (pm->op_pmflags & PMf_HAS_CV) {
7207             /* we have a runtime qr with literal code. This means
7208              * that the qr// has been wrapped in a new CV, which
7209              * means that runtime consts, vars etc will have been compiled
7210              * against a new pad. So... we need to execute those ops
7211              * within the environment of the new CV. So wrap them in a call
7212              * to a new anon sub. i.e. for
7213              *
7214              *     qr/a$b(?{...})/,
7215              *
7216              * we build an anon sub that looks like
7217              *
7218              *     sub { "a", $b, '(?{...})' }
7219              *
7220              * and call it, passing the returned list to regcomp.
7221              * Or to put it another way, the list of ops that get executed
7222              * are:
7223              *
7224              *     normal              PMf_HAS_CV
7225              *     ------              -------------------
7226              *                         pushmark (for regcomp)
7227              *                         pushmark (for entersub)
7228              *                         anoncode
7229              *                         srefgen
7230              *                         entersub
7231              *     regcreset                  regcreset
7232              *     pushmark                   pushmark
7233              *     const("a")                 const("a")
7234              *     gvsv(b)                    gvsv(b)
7235              *     const("(?{...})")          const("(?{...})")
7236              *                                leavesub
7237              *     regcomp             regcomp
7238              */
7239
7240             SvREFCNT_inc_simple_void(PL_compcv);
7241             CvLVALUE_on(PL_compcv);
7242             /* these lines are just an unrolled newANONATTRSUB */
7243             expr = newSVOP(OP_ANONCODE, 0,
7244                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7245             cv_targ = expr->op_targ;
7246             expr = newUNOP(OP_REFGEN, 0, expr);
7247
7248             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7249         }
7250
7251         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7252         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7253                            | (reglist ? OPf_STACKED : 0);
7254         rcop->op_targ = cv_targ;
7255
7256         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7257         if (PL_hints & HINT_RE_EVAL)
7258             S_set_haseval(aTHX);
7259
7260         /* establish postfix order */
7261         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7262             LINKLIST(expr);
7263             rcop->op_next = expr;
7264             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7265         }
7266         else {
7267             rcop->op_next = LINKLIST(expr);
7268             expr->op_next = (OP*)rcop;
7269         }
7270
7271         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7272     }
7273
7274     if (repl) {
7275         OP *curop = repl;
7276         bool konst;
7277         /* If we are looking at s//.../e with a single statement, get past
7278            the implicit do{}. */
7279         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7280              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7281              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7282          {
7283             OP *sib;
7284             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7285             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7286              && !OpHAS_SIBLING(sib))
7287                 curop = sib;
7288         }
7289         if (curop->op_type == OP_CONST)
7290             konst = TRUE;
7291         else if (( (curop->op_type == OP_RV2SV ||
7292                     curop->op_type == OP_RV2AV ||
7293                     curop->op_type == OP_RV2HV ||
7294                     curop->op_type == OP_RV2GV)
7295                    && cUNOPx(curop)->op_first
7296                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7297                 || curop->op_type == OP_PADSV
7298                 || curop->op_type == OP_PADAV
7299                 || curop->op_type == OP_PADHV
7300                 || curop->op_type == OP_PADANY) {
7301             repl_has_vars = 1;
7302             konst = TRUE;
7303         }
7304         else konst = FALSE;
7305         if (konst
7306             && !(repl_has_vars
7307                  && (!PM_GETRE(pm)
7308                      || !RX_PRELEN(PM_GETRE(pm))
7309                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7310         {
7311             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7312             op_prepend_elem(o->op_type, scalar(repl), o);
7313         }
7314         else {
7315             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7316             rcop->op_private = 1;
7317
7318             /* establish postfix order */
7319             rcop->op_next = LINKLIST(repl);
7320             repl->op_next = (OP*)rcop;
7321
7322             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7323             assert(!(pm->op_pmflags & PMf_ONCE));
7324             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7325             rcop->op_next = 0;
7326         }
7327     }
7328
7329     return (OP*)pm;
7330 }
7331
7332 /*
7333 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7334
7335 Constructs, checks, and returns an op of any type that involves an
7336 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7337 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7338 takes ownership of one reference to it.
7339
7340 =cut
7341 */
7342
7343 OP *
7344 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7345 {
7346     dVAR;
7347     SVOP *svop;
7348
7349     PERL_ARGS_ASSERT_NEWSVOP;
7350
7351     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7352         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7353         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7354         || type == OP_CUSTOM);
7355
7356     NewOp(1101, svop, 1, SVOP);
7357     OpTYPE_set(svop, type);
7358     svop->op_sv = sv;
7359     svop->op_next = (OP*)svop;
7360     svop->op_flags = (U8)flags;
7361     svop->op_private = (U8)(0 | (flags >> 8));
7362     if (PL_opargs[type] & OA_RETSCALAR)
7363         scalar((OP*)svop);
7364     if (PL_opargs[type] & OA_TARGET)
7365         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7366     return CHECKOP(type, svop);
7367 }
7368
7369 /*
7370 =for apidoc Am|OP *|newDEFSVOP|
7371
7372 Constructs and returns an op to access C<$_>.
7373
7374 =cut
7375 */
7376
7377 OP *
7378 Perl_newDEFSVOP(pTHX)
7379 {
7380         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7381 }
7382
7383 #ifdef USE_ITHREADS
7384
7385 /*
7386 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7387
7388 Constructs, checks, and returns an op of any type that involves a
7389 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7390 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7391 is populated with C<sv>; this function takes ownership of one reference
7392 to it.
7393
7394 This function only exists if Perl has been compiled to use ithreads.
7395
7396 =cut
7397 */
7398
7399 OP *
7400 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7401 {
7402     dVAR;
7403     PADOP *padop;
7404
7405     PERL_ARGS_ASSERT_NEWPADOP;
7406
7407     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7408         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7409         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7410         || type == OP_CUSTOM);
7411
7412     NewOp(1101, padop, 1, PADOP);
7413     OpTYPE_set(padop, type);
7414     padop->op_padix =
7415         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7416     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7417     PAD_SETSV(padop->op_padix, sv);
7418     assert(sv);
7419     padop->op_next = (OP*)padop;
7420     padop->op_flags = (U8)flags;
7421     if (PL_opargs[type] & OA_RETSCALAR)
7422         scalar((OP*)padop);
7423     if (PL_opargs[type] & OA_TARGET)
7424         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7425     return CHECKOP(type, padop);
7426 }
7427
7428 #endif /* USE_ITHREADS */
7429
7430 /*
7431 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7432
7433 Constructs, checks, and returns an op of any type that involves an
7434 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7435 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7436 reference; calling this function does not transfer ownership of any
7437 reference to it.
7438
7439 =cut
7440 */
7441
7442 OP *
7443 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7444 {
7445     PERL_ARGS_ASSERT_NEWGVOP;
7446
7447 #ifdef USE_ITHREADS
7448     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7449 #else
7450     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7451 #endif
7452 }
7453
7454 /*
7455 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7456
7457 Constructs, checks, and returns an op of any type that involves an
7458 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7459 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7460 Depending on the op type, the memory referenced by C<pv> may be freed
7461 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7462 have been allocated using C<PerlMemShared_malloc>.
7463
7464 =cut
7465 */
7466
7467 OP *
7468 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7469 {
7470     dVAR;
7471     const bool utf8 = cBOOL(flags & SVf_UTF8);
7472     PVOP *pvop;
7473
7474     flags &= ~SVf_UTF8;
7475
7476     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7477         || type == OP_RUNCV || type == OP_CUSTOM
7478         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7479
7480     NewOp(1101, pvop, 1, PVOP);
7481     OpTYPE_set(pvop, type);
7482     pvop->op_pv = pv;
7483     pvop->op_next = (OP*)pvop;
7484     pvop->op_flags = (U8)flags;
7485     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7486     if (PL_opargs[type] & OA_RETSCALAR)
7487         scalar((OP*)pvop);
7488     if (PL_opargs[type] & OA_TARGET)
7489         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7490     return CHECKOP(type, pvop);
7491 }
7492
7493 void
7494 Perl_package(pTHX_ OP *o)
7495 {
7496     SV *const sv = cSVOPo->op_sv;
7497
7498     PERL_ARGS_ASSERT_PACKAGE;
7499
7500     SAVEGENERICSV(PL_curstash);
7501     save_item(PL_curstname);
7502
7503     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7504
7505     sv_setsv(PL_curstname, sv);
7506
7507     PL_hints |= HINT_BLOCK_SCOPE;
7508     PL_parser->copline = NOLINE;
7509
7510     op_free(o);
7511 }
7512
7513 void
7514 Perl_package_version( pTHX_ OP *v )
7515 {
7516     U32 savehints = PL_hints;
7517     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7518     PL_hints &= ~HINT_STRICT_VARS;
7519     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7520     PL_hints = savehints;
7521     op_free(v);
7522 }
7523
7524 void
7525 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7526 {
7527     OP *pack;
7528     OP *imop;
7529     OP *veop;
7530     SV *use_version = NULL;
7531
7532     PERL_ARGS_ASSERT_UTILIZE;
7533
7534     if (idop->op_type != OP_CONST)
7535         Perl_croak(aTHX_ "Module name must be constant");
7536
7537     veop = NULL;
7538
7539     if (version) {
7540         SV * const vesv = ((SVOP*)version)->op_sv;
7541
7542         if (!arg && !SvNIOKp(vesv)) {
7543             arg = version;
7544         }
7545         else {
7546             OP *pack;
7547             SV *meth;
7548
7549             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7550                 Perl_croak(aTHX_ "Version number must be a constant number");
7551
7552             /* Make copy of idop so we don't free it twice */
7553             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7554
7555             /* Fake up a method call to VERSION */
7556             meth = newSVpvs_share("VERSION");
7557             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7558                             op_append_elem(OP_LIST,
7559                                         op_prepend_elem(OP_LIST, pack, version),
7560                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7561         }
7562     }
7563
7564     /* Fake up an import/unimport */
7565     if (arg && arg->op_type == OP_STUB) {
7566         imop = arg;             /* no import on explicit () */
7567     }
7568     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7569         imop = NULL;            /* use 5.0; */
7570         if (aver)
7571             use_version = ((SVOP*)idop)->op_sv;
7572         else
7573             idop->op_private |= OPpCONST_NOVER;
7574     }
7575     else {
7576         SV *meth;
7577
7578         /* Make copy of idop so we don't free it twice */
7579         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7580
7581         /* Fake up a method call to import/unimport */
7582         meth = aver
7583             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7584         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7585                        op_append_elem(OP_LIST,
7586                                    op_prepend_elem(OP_LIST, pack, arg),
7587                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7588                        ));
7589     }
7590
7591     /* Fake up the BEGIN {}, which does its thing immediately. */
7592     newATTRSUB(floor,
7593         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7594         NULL,
7595         NULL,
7596         op_append_elem(OP_LINESEQ,
7597             op_append_elem(OP_LINESEQ,
7598                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7599                 newSTATEOP(0, NULL, veop)),
7600             newSTATEOP(0, NULL, imop) ));
7601
7602     if (use_version) {
7603         /* Enable the
7604          * feature bundle that corresponds to the required version. */
7605         use_version = sv_2mortal(new_version(use_version));
7606         S_enable_feature_bundle(aTHX_ use_version);
7607
7608         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7609         if (vcmp(use_version,
7610                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7611             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7612                 PL_hints |= HINT_STRICT_REFS;
7613             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7614                 PL_hints |= HINT_STRICT_SUBS;
7615             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7616                 PL_hints |= HINT_STRICT_VARS;
7617         }
7618         /* otherwise they are off */
7619         else {
7620             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7621                 PL_hints &= ~HINT_STRICT_REFS;
7622             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7623                 PL_hints &= ~HINT_STRICT_SUBS;
7624             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7625                 PL_hints &= ~HINT_STRICT_VARS;
7626         }
7627     }
7628
7629     /* The "did you use incorrect case?" warning used to be here.
7630      * The problem is that on case-insensitive filesystems one
7631      * might get false positives for "use" (and "require"):
7632      * "use Strict" or "require CARP" will work.  This causes
7633      * portability problems for the script: in case-strict
7634      * filesystems the script will stop working.
7635      *
7636      * The "incorrect case" warning checked whether "use Foo"
7637      * imported "Foo" to your namespace, but that is wrong, too:
7638      * there is no requirement nor promise in the language that
7639      * a Foo.pm should or would contain anything in package "Foo".
7640      *
7641      * There is very little Configure-wise that can be done, either:
7642      * the case-sensitivity of the build filesystem of Perl does not
7643      * help in guessing the case-sensitivity of the runtime environment.
7644      */
7645
7646     PL_hints |= HINT_BLOCK_SCOPE;
7647     PL_parser->copline = NOLINE;
7648     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7649 }
7650
7651 /*
7652 =head1 Embedding Functions
7653
7654 =for apidoc load_module
7655
7656 Loads the module whose name is pointed to by the string part of C<name>.
7657 Note that the actual module name, not its filename, should be given.
7658 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7659 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7660 trailing arguments can be used to specify arguments to the module's C<import()>
7661 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7662 on the flags. The flags argument is a bitwise-ORed collection of any of
7663 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7664 (or 0 for no flags).
7665
7666 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7667 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7668 the trailing optional arguments may be omitted entirely. Otherwise, if
7669 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7670 exactly one C<OP*>, containing the op tree that produces the relevant import
7671 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7672 will be used as import arguments; and the list must be terminated with C<(SV*)
7673 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7674 set, the trailing C<NULL> pointer is needed even if no import arguments are
7675 desired. The reference count for each specified C<SV*> argument is
7676 decremented. In addition, the C<name> argument is modified.
7677
7678 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7679 than C<use>.
7680
7681 =cut */
7682
7683 void
7684 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7685 {
7686     va_list args;
7687
7688     PERL_ARGS_ASSERT_LOAD_MODULE;
7689
7690     va_start(args, ver);
7691     vload_module(flags, name, ver, &args);
7692     va_end(args);
7693 }
7694
7695 #ifdef PERL_IMPLICIT_CONTEXT
7696 void
7697 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7698 {
7699     dTHX;
7700     va_list args;
7701     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7702     va_start(args, ver);
7703     vload_module(flags, name, ver, &args);
7704     va_end(args);
7705 }
7706 #endif
7707
7708 void
7709 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7710 {
7711     OP *veop, *imop;
7712     OP * modname;
7713     I32 floor;
7714
7715     PERL_ARGS_ASSERT_VLOAD_MODULE;
7716
7717     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7718      * that it has a PL_parser to play with while doing that, and also
7719      * that it doesn't mess with any existing parser, by creating a tmp
7720      * new parser with lex_start(). This won't actually be used for much,
7721      * since pp_require() will create another parser for the real work.
7722      * The ENTER/LEAVE pair protect callers from any side effects of use.
7723      *
7724      * start_subparse() creates a new PL_compcv. This means that any ops
7725      * allocated below will be allocated from that CV's op slab, and so
7726      * will be automatically freed if the utilise() fails
7727      */
7728
7729     ENTER;
7730     SAVEVPTR(PL_curcop);
7731     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7732     floor = start_subparse(FALSE, 0);
7733
7734     modname = newSVOP(OP_CONST, 0, name);
7735     modname->op_private |= OPpCONST_BARE;
7736     if (ver) {
7737         veop = newSVOP(OP_CONST, 0, ver);
7738     }
7739     else
7740         veop = NULL;
7741     if (flags & PERL_LOADMOD_NOIMPORT) {
7742         imop = sawparens(newNULLLIST());
7743     }
7744     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7745         imop = va_arg(*args, OP*);
7746     }
7747     else {
7748         SV *sv;
7749         imop = NULL;
7750         sv = va_arg(*args, SV*);
7751         while (sv) {
7752             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7753             sv = va_arg(*args, SV*);
7754         }
7755     }
7756
7757     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7758     LEAVE;
7759 }
7760
7761 PERL_STATIC_INLINE OP *
7762 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7763 {
7764     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7765                    newLISTOP(OP_LIST, 0, arg,
7766                              newUNOP(OP_RV2CV, 0,
7767                                      newGVOP(OP_GV, 0, gv))));
7768 }
7769
7770 OP *
7771 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7772 {
7773     OP *doop;
7774     GV *gv;
7775
7776     PERL_ARGS_ASSERT_DOFILE;
7777
7778     if (!force_builtin && (gv = gv_override("do", 2))) {
7779         doop = S_new_entersubop(aTHX_ gv, term);
7780     }
7781     else {
7782         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7783     }
7784     return doop;
7785 }
7786
7787 /*
7788 =head1 Optree construction
7789
7790 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7791
7792 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7793 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7794 be set automatically, and, shifted up eight bits, the eight bits of
7795 C<op_private>, except that the bit with value 1 or 2 is automatically
7796 set as required.  C<listval> and C<subscript> supply the parameters of
7797 the slice; they are consumed by this function and become part of the
7798 constructed op tree.
7799
7800 =cut
7801 */
7802
7803 OP *
7804 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7805 {
7806     return newBINOP(OP_LSLICE, flags,
7807             list(force_list(subscript, 1)),
7808             list(force_list(listval,   1)) );
7809 }
7810
7811 #define ASSIGN_LIST   1
7812 #define ASSIGN_REF    2
7813
7814 STATIC I32
7815 S_assignment_type(pTHX_ const OP *o)
7816 {
7817     unsigned type;
7818     U8 flags;
7819     U8 ret;
7820
7821     if (!o)
7822         return TRUE;
7823
7824     if (o->op_type == OP_SREFGEN)
7825     {
7826         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7827         type = kid->op_type;
7828         flags = o->op_flags | kid->op_flags;
7829         if (!(flags & OPf_PARENS)
7830           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7831               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7832             return ASSIGN_REF;
7833         ret = ASSIGN_REF;
7834     } else {
7835         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7836             o = cUNOPo->op_first;
7837         flags = o->op_flags;
7838         type = o->op_type;
7839         ret = 0;
7840     }
7841
7842     if (type == OP_COND_EXPR) {
7843         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7844         const I32 t = assignment_type(sib);
7845         const I32 f = assignment_type(OpSIBLING(sib));
7846
7847         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7848             return ASSIGN_LIST;
7849         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7850             yyerror("Assignment to both a list and a scalar");
7851         return FALSE;
7852     }
7853
7854     if (type == OP_LIST &&
7855         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7856         o->op_private & OPpLVAL_INTRO)
7857         return ret;
7858
7859     if (type == OP_LIST || flags & OPf_PARENS ||
7860         type == OP_RV2AV || type == OP_RV2HV ||
7861         type == OP_ASLICE || type == OP_HSLICE ||
7862         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7863         return TRUE;
7864
7865     if (type == OP_PADAV || type == OP_PADHV)
7866         return TRUE;
7867
7868     if (type == OP_RV2SV)
7869         return ret;
7870
7871     return ret;
7872 }
7873
7874 static OP *
7875 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7876 {
7877     dVAR;
7878     const PADOFFSET target = padop->op_targ;
7879     OP *const other = newOP(OP_PADSV,
7880                             padop->op_flags
7881                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7882     OP *const first = newOP(OP_NULL, 0);
7883     OP *const nullop = newCONDOP(0, first, initop, other);
7884     /* XXX targlex disabled for now; see ticket #124160
7885         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7886      */
7887     OP *const condop = first->op_next;
7888
7889     OpTYPE_set(condop, OP_ONCE);
7890     other->op_targ = target;
7891     nullop->op_flags |= OPf_WANT_SCALAR;
7892
7893     /* Store the initializedness of state vars in a separate
7894        pad entry.  */
7895     condop->op_targ =
7896       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7897     /* hijacking PADSTALE for uninitialized state variables */
7898     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7899
7900     return nullop;
7901 }
7902
7903 /*
7904 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7905
7906 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7907 supply the parameters of the assignment; they are consumed by this
7908 function and become part of the constructed op tree.
7909
7910 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7911 a suitable conditional optree is constructed.  If C<optype> is the opcode
7912 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7913 performs the binary operation and assigns the result to the left argument.
7914 Either way, if C<optype> is non-zero then C<flags> has no effect.
7915
7916 If C<optype> is zero, then a plain scalar or list assignment is
7917 constructed.  Which type of assignment it is is automatically determined.
7918 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7919 will be set automatically, and, shifted up eight bits, the eight bits
7920 of C<op_private>, except that the bit with value 1 or 2 is automatically
7921 set as required.
7922
7923 =cut
7924 */
7925
7926 OP *
7927 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7928 {
7929     OP *o;
7930     I32 assign_type;
7931
7932     if (optype) {
7933         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7934             right = scalar(right);
7935             return newLOGOP(optype, 0,
7936                 op_lvalue(scalar(left), optype),
7937                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7938         }
7939         else {
7940             return newBINOP(optype, OPf_STACKED,
7941                 op_lvalue(scalar(left), optype), scalar(right));
7942         }
7943     }
7944
7945     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7946         OP *state_var_op = NULL;
7947         static const char no_list_state[] = "Initialization of state variables"
7948             " in list currently forbidden";
7949         OP *curop;
7950
7951         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7952             left->op_private &= ~ OPpSLICEWARNING;
7953
7954         PL_modcount = 0;
7955         left = op_lvalue(left, OP_AASSIGN);
7956         curop = list(force_list(left, 1));
7957         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7958         o->op_private = (U8)(0 | (flags >> 8));
7959
7960         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7961         {
7962             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7963             if (!(left->op_flags & OPf_PARENS) &&
7964                     lop->op_type == OP_PUSHMARK &&
7965                     (vop = OpSIBLING(lop)) &&
7966                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7967                     !(vop->op_flags & OPf_PARENS) &&
7968                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7969                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7970                     (eop = OpSIBLING(vop)) &&
7971                     eop->op_type == OP_ENTERSUB &&
7972                     !OpHAS_SIBLING(eop)) {
7973                 state_var_op = vop;
7974             } else {
7975                 while (lop) {
7976                     if ((lop->op_type == OP_PADSV ||
7977                          lop->op_type == OP_PADAV ||
7978                          lop->op_type == OP_PADHV ||
7979                          lop->op_type == OP_PADANY)
7980                       && (lop->op_private & OPpPAD_STATE)
7981                     )
7982                         yyerror(no_list_state);
7983                     lop = OpSIBLING(lop);
7984                 }
7985             }
7986         }
7987         else if (  (left->op_private & OPpLVAL_INTRO)
7988                 && (left->op_private & OPpPAD_STATE)
7989                 && (   left->op_type == OP_PADSV
7990                     || left->op_type == OP_PADAV
7991                     || left->op_type == OP_PADHV
7992                     || left->op_type == OP_PADANY)
7993         ) {
7994                 /* All single variable list context state assignments, hence
7995                    state ($a) = ...
7996                    (state $a) = ...
7997                    state @a = ...
7998                    state (@a) = ...
7999                    (state @a) = ...
8000                    state %a = ...
8001                    state (%a) = ...
8002                    (state %a) = ...
8003                 */
8004                 if (left->op_flags & OPf_PARENS)
8005                     yyerror(no_list_state);
8006                 else
8007                     state_var_op = left;
8008         }
8009
8010         /* optimise @a = split(...) into:
8011         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8012         * @a, my @a, local @a:  split(...)          (where @a is attached to
8013         *                                            the split op itself)
8014         */
8015
8016         if (   right
8017             && right->op_type == OP_SPLIT
8018             /* don't do twice, e.g. @b = (@a = split) */
8019             && !(right->op_private & OPpSPLIT_ASSIGN))
8020         {
8021             OP *gvop = NULL;
8022
8023             if (   (  left->op_type == OP_RV2AV
8024                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8025                 || left->op_type == OP_PADAV)
8026             {
8027                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8028                 OP *tmpop;
8029                 if (gvop) {
8030 #ifdef USE_ITHREADS
8031                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8032                         = cPADOPx(gvop)->op_padix;
8033                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
8034 #else
8035                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8036                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8037                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
8038 #endif
8039                     right->op_private |=
8040                         left->op_private & OPpOUR_INTRO;
8041                 }
8042                 else {
8043                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8044                     left->op_targ = 0;  /* steal it */
8045                     right->op_private |= OPpSPLIT_LEX;
8046                 }
8047                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8048
8049               detach_split:
8050                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8051                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8052                 assert(OpSIBLING(tmpop) == right);
8053                 assert(!OpHAS_SIBLING(right));
8054                 /* detach the split subtreee from the o tree,
8055                  * then free the residual o tree */
8056                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8057                 op_free(o);                     /* blow off assign */
8058                 right->op_private |= OPpSPLIT_ASSIGN;
8059                 right->op_flags &= ~OPf_WANT;
8060                         /* "I don't know and I don't care." */
8061                 return right;
8062             }
8063             else if (left->op_type == OP_RV2AV) {
8064                 /* @{expr} */
8065
8066                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8067                 assert(OpSIBLING(pushop) == left);
8068                 /* Detach the array ...  */
8069                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8070                 /* ... and attach it to the split.  */
8071                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8072                                   0, left);
8073                 right->op_flags |= OPf_STACKED;
8074                 /* Detach split and expunge aassign as above.  */
8075                 goto detach_split;
8076             }
8077             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8078                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8079             {
8080                 /* convert split(...,0) to split(..., PL_modcount+1) */
8081                 SV ** const svp =
8082                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8083                 SV * const sv = *svp;
8084                 if (SvIOK(sv) && SvIVX(sv) == 0)
8085                 {
8086                   if (right->op_private & OPpSPLIT_IMPLIM) {
8087                     /* our own SV, created in ck_split */
8088                     SvREADONLY_off(sv);
8089                     sv_setiv(sv, PL_modcount+1);
8090                   }
8091                   else {
8092                     /* SV may belong to someone else */
8093                     SvREFCNT_dec(sv);
8094                     *svp = newSViv(PL_modcount+1);
8095                   }
8096                 }
8097             }
8098         }
8099
8100         if (state_var_op)
8101             o = S_newONCEOP(aTHX_ o, state_var_op);
8102         return o;
8103     }
8104     if (assign_type == ASSIGN_REF)
8105         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8106     if (!right)
8107         right = newOP(OP_UNDEF, 0);
8108     if (right->op_type == OP_READLINE) {
8109         right->op_flags |= OPf_STACKED;
8110         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8111                 scalar(right));
8112     }
8113     else {
8114         o = newBINOP(OP_SASSIGN, flags,
8115             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8116     }
8117     return o;
8118 }
8119
8120 /*
8121 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8122
8123 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8124 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8125 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8126 If C<label> is non-null, it supplies the name of a label to attach to
8127 the state op; this function takes ownership of the memory pointed at by
8128 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8129 for the state op.
8130
8131 If C<o> is null, the state op is returned.  Otherwise the state op is
8132 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8133 is consumed by this function and becomes part of the returned op tree.
8134
8135 =cut
8136 */
8137
8138 OP *
8139 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8140 {
8141     dVAR;
8142     const U32 seq = intro_my();
8143     const U32 utf8 = flags & SVf_UTF8;
8144     COP *cop;
8145
8146     PL_parser->parsed_sub = 0;
8147
8148     flags &= ~SVf_UTF8;
8149
8150     NewOp(1101, cop, 1, COP);
8151     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8152         OpTYPE_set(cop, OP_DBSTATE);
8153     }
8154     else {
8155         OpTYPE_set(cop, OP_NEXTSTATE);
8156     }
8157     cop->op_flags = (U8)flags;
8158     CopHINTS_set(cop, PL_hints);
8159 #ifdef VMS
8160     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8161 #endif
8162     cop->op_next = (OP*)cop;
8163
8164     cop->cop_seq = seq;
8165     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8166     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8167     if (label) {
8168         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8169
8170         PL_hints |= HINT_BLOCK_SCOPE;
8171         /* It seems that we need to defer freeing this pointer, as other parts
8172            of the grammar end up wanting to copy it after this op has been
8173            created. */
8174         SAVEFREEPV(label);
8175     }
8176
8177     if (PL_parser->preambling != NOLINE) {
8178         CopLINE_set(cop, PL_parser->preambling);
8179         PL_parser->copline = NOLINE;
8180     }
8181     else if (PL_parser->copline == NOLINE)
8182         CopLINE_set(cop, CopLINE(PL_curcop));
8183     else {
8184         CopLINE_set(cop, PL_parser->copline);
8185         PL_parser->copline = NOLINE;
8186     }
8187 #ifdef USE_ITHREADS
8188     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8189 #else
8190     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8191 #endif
8192     CopSTASH_set(cop, PL_curstash);
8193
8194     if (cop->op_type == OP_DBSTATE) {
8195         /* this line can have a breakpoint - store the cop in IV */
8196         AV *av = CopFILEAVx(PL_curcop);
8197         if (av) {
8198             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8199             if (svp && *svp != &PL_sv_undef ) {
8200                 (void)SvIOK_on(*svp);
8201                 SvIV_set(*svp, PTR2IV(cop));
8202             }
8203         }
8204     }
8205
8206     if (flags & OPf_SPECIAL)
8207         op_null((OP*)cop);
8208     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8209 }
8210
8211 /*
8212 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8213
8214 Constructs, checks, and returns a logical (flow control) op.  C<type>
8215 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8216 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8217 the eight bits of C<op_private>, except that the bit with value 1 is
8218 automatically set.  C<first> supplies the expression controlling the
8219 flow, and C<other> supplies the side (alternate) chain of ops; they are
8220 consumed by this function and become part of the constructed op tree.
8221
8222 =cut
8223 */
8224
8225 OP *
8226 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8227 {
8228     PERL_ARGS_ASSERT_NEWLOGOP;
8229
8230     return new_logop(type, flags, &first, &other);
8231 }
8232
8233 STATIC OP *
8234 S_search_const(pTHX_ OP *o)
8235 {
8236     PERL_ARGS_ASSERT_SEARCH_CONST;
8237
8238     switch (o->op_type) {
8239         case OP_CONST:
8240             return o;
8241         case OP_NULL:
8242             if (o->op_flags & OPf_KIDS)
8243                 return search_const(cUNOPo->op_first);
8244             break;
8245         case OP_LEAVE:
8246         case OP_SCOPE:
8247         case OP_LINESEQ:
8248         {
8249             OP *kid;
8250             if (!(o->op_flags & OPf_KIDS))
8251                 return NULL;
8252             kid = cLISTOPo->op_first;
8253             do {
8254                 switch (kid->op_type) {
8255                     case OP_ENTER:
8256                     case OP_NULL:
8257                     case OP_NEXTSTATE:
8258                         kid = OpSIBLING(kid);
8259                         break;
8260                     default:
8261                         if (kid != cLISTOPo->op_last)
8262                             return NULL;
8263                         goto last;
8264                 }
8265             } while (kid);
8266             if (!kid)
8267                 kid = cLISTOPo->op_last;
8268           last:
8269             return search_const(kid);
8270         }
8271     }
8272
8273     return NULL;
8274 }
8275
8276 STATIC OP *
8277 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8278 {
8279     dVAR;
8280     LOGOP *logop;
8281     OP *o;
8282     OP *first;
8283     OP *other;
8284     OP *cstop = NULL;
8285     int prepend_not = 0;
8286
8287     PERL_ARGS_ASSERT_NEW_LOGOP;
8288
8289     first = *firstp;
8290     other = *otherp;
8291
8292     /* [perl #59802]: Warn about things like "return $a or $b", which
8293        is parsed as "(return $a) or $b" rather than "return ($a or
8294        $b)".  NB: This also applies to xor, which is why we do it
8295        here.
8296      */
8297     switch (first->op_type) {
8298     case OP_NEXT:
8299     case OP_LAST:
8300     case OP_REDO:
8301         /* XXX: Perhaps we should emit a stronger warning for these.
8302            Even with the high-precedence operator they don't seem to do
8303            anything sensible.
8304
8305            But until we do, fall through here.
8306          */
8307     case OP_RETURN:
8308     case OP_EXIT:
8309     case OP_DIE:
8310     case OP_GOTO:
8311         /* XXX: Currently we allow people to "shoot themselves in the
8312            foot" by explicitly writing "(return $a) or $b".
8313
8314            Warn unless we are looking at the result from folding or if
8315            the programmer explicitly grouped the operators like this.
8316            The former can occur with e.g.
8317
8318                 use constant FEATURE => ( $] >= ... );
8319                 sub { not FEATURE and return or do_stuff(); }
8320          */
8321         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8322             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8323                            "Possible precedence issue with control flow operator");
8324         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8325            the "or $b" part)?
8326         */
8327         break;
8328     }
8329
8330     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8331         return newBINOP(type, flags, scalar(first), scalar(other));
8332
8333     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8334         || type == OP_CUSTOM);
8335
8336     scalarboolean(first);
8337
8338     /* search for a constant op that could let us fold the test */
8339     if ((cstop = search_const(first))) {
8340         if (cstop->op_private & OPpCONST_STRICT)
8341             no_bareword_allowed(cstop);
8342         else if ((cstop->op_private & OPpCONST_BARE))
8343                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8344         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8345             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8346             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8347             /* Elide the (constant) lhs, since it can't affect the outcome */
8348             *firstp = NULL;
8349             if (other->op_type == OP_CONST)
8350                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8351             op_free(first);
8352             if (other->op_type == OP_LEAVE)
8353                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8354             else if (other->op_type == OP_MATCH
8355                   || other->op_type == OP_SUBST
8356                   || other->op_type == OP_TRANSR
8357                   || other->op_type == OP_TRANS)
8358                 /* Mark the op as being unbindable with =~ */
8359                 other->op_flags |= OPf_SPECIAL;
8360
8361             other->op_folded = 1;
8362             return other;
8363         }
8364         else {
8365             /* Elide the rhs, since the outcome is entirely determined by
8366              * the (constant) lhs */
8367
8368             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8369             const OP *o2 = other;
8370             if ( ! (o2->op_type == OP_LIST
8371                     && (( o2 = cUNOPx(o2)->op_first))
8372                     && o2->op_type == OP_PUSHMARK
8373                     && (( o2 = OpSIBLING(o2))) )
8374             )
8375                 o2 = other;
8376             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8377                         || o2->op_type == OP_PADHV)
8378                 && o2->op_private & OPpLVAL_INTRO
8379                 && !(o2->op_private & OPpPAD_STATE))
8380             {
8381         Perl_croak(aTHX_ "This use of my() in false conditional is "
8382                           "no longer allowed");
8383             }
8384
8385             *otherp = NULL;
8386             if (cstop->op_type == OP_CONST)
8387                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8388             op_free(other);
8389             return first;
8390         }
8391     }
8392     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8393         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8394     {
8395         const OP * const k1 = ((UNOP*)first)->op_first;
8396         const OP * const k2 = OpSIBLING(k1);
8397         OPCODE warnop = 0;
8398         switch (first->op_type)
8399         {
8400         case OP_NULL:
8401             if (k2 && k2->op_type == OP_READLINE
8402                   && (k2->op_flags & OPf_STACKED)
8403                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8404             {
8405                 warnop = k2->op_type;
8406             }
8407             break;
8408
8409         case OP_SASSIGN:
8410             if (k1->op_type == OP_READDIR
8411                   || k1->op_type == OP_GLOB
8412                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8413                  || k1->op_type == OP_EACH
8414                  || k1->op_type == OP_AEACH)
8415             {
8416                 warnop = ((k1->op_type == OP_NULL)
8417                           ? (OPCODE)k1->op_targ : k1->op_type);
8418             }
8419             break;
8420         }
8421         if (warnop) {
8422             const line_t oldline = CopLINE(PL_curcop);
8423             /* This ensures that warnings are reported at the first line
8424                of the construction, not the last.  */
8425             CopLINE_set(PL_curcop, PL_parser->copline);
8426             Perl_warner(aTHX_ packWARN(WARN_MISC),
8427                  "Value of %s%s can be \"0\"; test with defined()",
8428                  PL_op_desc[warnop],
8429                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8430                   ? " construct" : "() operator"));
8431             CopLINE_set(PL_curcop, oldline);
8432         }
8433     }
8434
8435     /* optimize AND and OR ops that have NOTs as children */
8436     if (first->op_type == OP_NOT
8437         && (first->op_flags & OPf_KIDS)
8438         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8439             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8440         ) {
8441         if (type == OP_AND || type == OP_OR) {
8442             if (type == OP_AND)
8443                 type = OP_OR;
8444             else
8445                 type = OP_AND;
8446             op_null(first);
8447             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8448                 op_null(other);
8449                 prepend_not = 1; /* prepend a NOT op later */
8450             }
8451         }
8452     }
8453
8454     logop = alloc_LOGOP(type, first, LINKLIST(other));
8455     logop->op_flags |= (U8)flags;
8456     logop->op_private = (U8)(1 | (flags >> 8));
8457
8458     /* establish postfix order */
8459     logop->op_next = LINKLIST(first);
8460     first->op_next = (OP*)logop;
8461     assert(!OpHAS_SIBLING(first));
8462     op_sibling_splice((OP*)logop, first, 0, other);
8463
8464     CHECKOP(type,logop);
8465
8466     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8467                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8468                 (OP*)logop);
8469     other->op_next = o;
8470
8471     return o;
8472 }
8473
8474 /*
8475 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8476
8477 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8478 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8479 will be set automatically, and, shifted up eight bits, the eight bits of
8480 C<op_private>, except that the bit with value 1 is automatically set.
8481 C<first> supplies the expression selecting between the two branches,
8482 and C<trueop> and C<falseop> supply the branches; they are consumed by
8483 this function and become part of the constructed op tree.
8484
8485 =cut
8486 */
8487
8488 OP *
8489 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8490 {
8491     dVAR;
8492     LOGOP *logop;
8493     OP *start;
8494     OP *o;
8495     OP *cstop;
8496
8497     PERL_ARGS_ASSERT_NEWCONDOP;
8498
8499     if (!falseop)
8500         return newLOGOP(OP_AND, 0, first, trueop);
8501     if (!trueop)
8502         return newLOGOP(OP_OR, 0, first, falseop);
8503
8504     scalarboolean(first);
8505     if ((cstop = search_const(first))) {
8506         /* Left or right arm of the conditional?  */
8507         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8508         OP *live = left ? trueop : falseop;
8509         OP *const dead = left ? falseop : trueop;
8510         if (cstop->op_private & OPpCONST_BARE &&
8511             cstop->op_private & OPpCONST_STRICT) {
8512             no_bareword_allowed(cstop);
8513         }
8514         op_free(first);
8515         op_free(dead);
8516         if (live->op_type == OP_LEAVE)
8517             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8518         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8519               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8520             /* Mark the op as being unbindable with =~ */
8521             live->op_flags |= OPf_SPECIAL;
8522         live->op_folded = 1;
8523         return live;
8524     }
8525     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8526     logop->op_flags |= (U8)flags;
8527     logop->op_private = (U8)(1 | (flags >> 8));
8528     logop->op_next = LINKLIST(falseop);
8529
8530     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8531             logop);
8532
8533     /* establish postfix order */
8534     start = LINKLIST(first);
8535     first->op_next = (OP*)logop;
8536
8537     /* make first, trueop, falseop siblings */
8538     op_sibling_splice((OP*)logop, first,  0, trueop);
8539     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8540
8541     o = newUNOP(OP_NULL, 0, (OP*)logop);
8542
8543     trueop->op_next = falseop->op_next = o;
8544
8545     o->op_next = start;
8546     return o;
8547 }
8548
8549 /*
8550 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8551
8552 Constructs and returns a C<range> op, with subordinate C<flip> and
8553 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8554 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8555 for both the C<flip> and C<range> ops, except that the bit with value
8556 1 is automatically set.  C<left> and C<right> supply the expressions
8557 controlling the endpoints of the range; they are consumed by this function
8558 and become part of the constructed op tree.
8559
8560 =cut
8561 */
8562
8563 OP *
8564 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8565 {
8566     LOGOP *range;
8567     OP *flip;
8568     OP *flop;
8569     OP *leftstart;
8570     OP *o;
8571
8572     PERL_ARGS_ASSERT_NEWRANGE;
8573
8574     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8575     range->op_flags = OPf_KIDS;
8576     leftstart = LINKLIST(left);
8577     range->op_private = (U8)(1 | (flags >> 8));
8578
8579     /* make left and right siblings */
8580     op_sibling_splice((OP*)range, left, 0, right);
8581
8582     range->op_next = (OP*)range;
8583     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8584     flop = newUNOP(OP_FLOP, 0, flip);
8585     o = newUNOP(OP_NULL, 0, flop);
8586     LINKLIST(flop);
8587     range->op_next = leftstart;
8588
8589     left->op_next = flip;
8590     right->op_next = flop;
8591
8592     range->op_targ =
8593         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8594     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8595     flip->op_targ =
8596         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8597     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8598     SvPADTMP_on(PAD_SV(flip->op_targ));
8599
8600     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8601     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8602
8603     /* check barewords before they might be optimized aways */
8604     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8605         no_bareword_allowed(left);
8606     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8607         no_bareword_allowed(right);
8608
8609     flip->op_next = o;
8610     if (!flip->op_private || !flop->op_private)
8611         LINKLIST(o);            /* blow off optimizer unless constant */
8612
8613     return o;
8614 }
8615
8616 /*
8617 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8618
8619 Constructs, checks, and returns an op tree expressing a loop.  This is
8620 only a loop in the control flow through the op tree; it does not have
8621 the heavyweight loop structure that allows exiting the loop by C<last>
8622 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8623 top-level op, except that some bits will be set automatically as required.
8624 C<expr> supplies the expression controlling loop iteration, and C<block>
8625 supplies the body of the loop; they are consumed by this function and
8626 become part of the constructed op tree.  C<debuggable> is currently
8627 unused and should always be 1.
8628
8629 =cut
8630 */
8631
8632 OP *
8633 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8634 {
8635     OP* listop;
8636     OP* o;
8637     const bool once = block && block->op_flags & OPf_SPECIAL &&
8638                       block->op_type == OP_NULL;
8639
8640     PERL_UNUSED_ARG(debuggable);
8641
8642     if (expr) {
8643         if (once && (
8644               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8645            || (  expr->op_type == OP_NOT
8646               && cUNOPx(expr)->op_first->op_type == OP_CONST
8647               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8648               )
8649            ))
8650             /* Return the block now, so that S_new_logop does not try to
8651                fold it away. */
8652         {
8653             op_free(expr);
8654             return block;       /* do {} while 0 does once */
8655         }
8656
8657         if (expr->op_type == OP_READLINE
8658             || expr->op_type == OP_READDIR
8659             || expr->op_type == OP_GLOB
8660             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8661             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8662             expr = newUNOP(OP_DEFINED, 0,
8663                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8664         } else if (expr->op_flags & OPf_KIDS) {
8665             const OP * const k1 = ((UNOP*)expr)->op_first;
8666             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8667             switch (expr->op_type) {
8668               case OP_NULL:
8669                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8670                       && (k2->op_flags & OPf_STACKED)
8671                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8672                     expr = newUNOP(OP_DEFINED, 0, expr);
8673                 break;
8674
8675               case OP_SASSIGN:
8676                 if (k1 && (k1->op_type == OP_READDIR
8677                       || k1->op_type == OP_GLOB
8678                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8679                      || k1->op_type == OP_EACH
8680                      || k1->op_type == OP_AEACH))
8681                     expr = newUNOP(OP_DEFINED, 0, expr);
8682                 break;
8683             }
8684         }
8685     }
8686
8687     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8688      * op, in listop. This is wrong. [perl #27024] */
8689     if (!block)
8690         block = newOP(OP_NULL, 0);
8691     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8692     o = new_logop(OP_AND, 0, &expr, &listop);
8693
8694     if (once) {
8695         ASSUME(listop);
8696     }
8697
8698     if (listop)
8699         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8700
8701     if (once && o != listop)
8702     {
8703         assert(cUNOPo->op_first->op_type == OP_AND
8704             || cUNOPo->op_first->op_type == OP_OR);
8705         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8706     }
8707
8708     if (o == listop)
8709         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8710
8711     o->op_flags |= flags;
8712     o = op_scope(o);
8713     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8714     return o;
8715 }
8716
8717 /*
8718 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8719
8720 Constructs, checks, and returns an op tree expressing a C<while> loop.
8721 This is a heavyweight loop, with structure that allows exiting the loop
8722 by C<last> and suchlike.
8723
8724 C<loop> is an optional preconstructed C<enterloop> op to use in the
8725 loop; if it is null then a suitable op will be constructed automatically.
8726 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8727 main body of the loop, and C<cont> optionally supplies a C<continue> block
8728 that operates as a second half of the body.  All of these optree inputs
8729 are consumed by this function and become part of the constructed op tree.
8730
8731 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8732 op and, shifted up eight bits, the eight bits of C<op_private> for
8733 the C<leaveloop> op, except that (in both cases) some bits will be set
8734 automatically.  C<debuggable> is currently unused and should always be 1.
8735 C<has_my> can be supplied as true to force the
8736 loop body to be enclosed in its own scope.
8737
8738 =cut
8739 */
8740
8741 OP *
8742 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8743         OP *expr, OP *block, OP *cont, I32 has_my)
8744 {
8745     dVAR;
8746     OP *redo;
8747     OP *next = NULL;
8748     OP *listop;
8749     OP *o;
8750     U8 loopflags = 0;
8751
8752     PERL_UNUSED_ARG(debuggable);
8753
8754     if (expr) {
8755         if (expr->op_type == OP_READLINE
8756          || expr->op_type == OP_READDIR
8757          || expr->op_type == OP_GLOB
8758          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8759                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8760             expr = newUNOP(OP_DEFINED, 0,
8761                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8762         } else if (expr->op_flags & OPf_KIDS) {
8763             const OP * const k1 = ((UNOP*)expr)->op_first;
8764             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8765             switch (expr->op_type) {
8766               case OP_NULL:
8767                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8768                       && (k2->op_flags & OPf_STACKED)
8769                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8770                     expr = newUNOP(OP_DEFINED, 0, expr);
8771                 break;
8772
8773               case OP_SASSIGN:
8774                 if (k1 && (k1->op_type == OP_READDIR
8775                       || k1->op_type == OP_GLOB
8776                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8777                      || k1->op_type == OP_EACH
8778                      || k1->op_type == OP_AEACH))
8779                     expr = newUNOP(OP_DEFINED, 0, expr);
8780                 break;
8781             }
8782         }
8783     }
8784
8785     if (!block)
8786         block = newOP(OP_NULL, 0);
8787     else if (cont || has_my) {
8788         block = op_scope(block);
8789     }
8790
8791     if (cont) {
8792         next = LINKLIST(cont);
8793     }
8794     if (expr) {
8795         OP * const unstack = newOP(OP_UNSTACK, 0);
8796         if (!next)
8797             next = unstack;
8798         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8799     }
8800
8801     assert(block);
8802     listop = op_append_list(OP_LINESEQ, block, cont);
8803     assert(listop);
8804     redo = LINKLIST(listop);
8805
8806     if (expr) {
8807         scalar(listop);
8808         o = new_logop(OP_AND, 0, &expr, &listop);
8809         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8810             op_free((OP*)loop);
8811             return expr;                /* listop already freed by new_logop */
8812         }
8813         if (listop)
8814             ((LISTOP*)listop)->op_last->op_next =
8815                 (o == listop ? redo : LINKLIST(o));
8816     }
8817     else
8818         o = listop;
8819
8820     if (!loop) {
8821         NewOp(1101,loop,1,LOOP);
8822         OpTYPE_set(loop, OP_ENTERLOOP);
8823         loop->op_private = 0;
8824         loop->op_next = (OP*)loop;
8825     }
8826
8827     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8828
8829     loop->op_redoop = redo;
8830     loop->op_lastop = o;
8831     o->op_private |= loopflags;
8832
8833     if (next)
8834         loop->op_nextop = next;
8835     else
8836         loop->op_nextop = o;
8837
8838     o->op_flags |= flags;
8839     o->op_private |= (flags >> 8);
8840     return o;
8841 }
8842
8843 /*
8844 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8845
8846 Constructs, checks, and returns an op tree expressing a C<foreach>
8847 loop (iteration through a list of values).  This is a heavyweight loop,
8848 with structure that allows exiting the loop by C<last> and suchlike.
8849
8850 C<sv> optionally supplies the variable that will be aliased to each
8851 item in turn; if null, it defaults to C<$_>.
8852 C<expr> supplies the list of values to iterate over.  C<block> supplies
8853 the main body of the loop, and C<cont> optionally supplies a C<continue>
8854 block that operates as a second half of the body.  All of these optree
8855 inputs are consumed by this function and become part of the constructed
8856 op tree.
8857
8858 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8859 op and, shifted up eight bits, the eight bits of C<op_private> for
8860 the C<leaveloop> op, except that (in both cases) some bits will be set
8861 automatically.
8862
8863 =cut
8864 */
8865
8866 OP *
8867 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8868 {
8869     dVAR;
8870     LOOP *loop;
8871     OP *wop;
8872     PADOFFSET padoff = 0;
8873     I32 iterflags = 0;
8874     I32 iterpflags = 0;
8875
8876     PERL_ARGS_ASSERT_NEWFOROP;
8877
8878     if (sv) {
8879         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8880             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8881             OpTYPE_set(sv, OP_RV2GV);
8882
8883             /* The op_type check is needed to prevent a possible segfault
8884              * if the loop variable is undeclared and 'strict vars' is in
8885              * effect. This is illegal but is nonetheless parsed, so we
8886              * may reach this point with an OP_CONST where we're expecting
8887              * an OP_GV.
8888              */
8889             if (cUNOPx(sv)->op_first->op_type == OP_GV
8890              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8891                 iterpflags |= OPpITER_DEF;
8892         }
8893         else if (sv->op_type == OP_PADSV) { /* private variable */
8894             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8895             padoff = sv->op_targ;
8896             sv->op_targ = 0;
8897             op_free(sv);
8898             sv = NULL;
8899             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8900         }
8901         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8902             NOOP;
8903         else
8904             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8905         if (padoff) {
8906             PADNAME * const pn = PAD_COMPNAME(padoff);
8907             const char * const name = PadnamePV(pn);
8908
8909             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8910                 iterpflags |= OPpITER_DEF;
8911         }
8912     }
8913     else {
8914         sv = newGVOP(OP_GV, 0, PL_defgv);
8915         iterpflags |= OPpITER_DEF;
8916     }
8917
8918     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8919         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8920         iterflags |= OPf_STACKED;
8921     }
8922     else if (expr->op_type == OP_NULL &&
8923              (expr->op_flags & OPf_KIDS) &&
8924              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8925     {
8926         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8927          * set the STACKED flag to indicate that these values are to be
8928          * treated as min/max values by 'pp_enteriter'.
8929          */
8930         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8931         LOGOP* const range = (LOGOP*) flip->op_first;
8932         OP* const left  = range->op_first;
8933         OP* const right = OpSIBLING(left);
8934         LISTOP* listop;
8935
8936         range->op_flags &= ~OPf_KIDS;
8937         /* detach range's children */
8938         op_sibling_splice((OP*)range, NULL, -1, NULL);
8939
8940         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8941         listop->op_first->op_next = range->op_next;
8942         left->op_next = range->op_other;
8943         right->op_next = (OP*)listop;
8944         listop->op_next = listop->op_first;
8945
8946         op_free(expr);
8947         expr = (OP*)(listop);
8948         op_null(expr);
8949         iterflags |= OPf_STACKED;
8950     }
8951     else {
8952         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8953     }
8954
8955     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8956                                   op_append_elem(OP_LIST, list(expr),
8957                                                  scalar(sv)));
8958     assert(!loop->op_next);
8959     /* for my  $x () sets OPpLVAL_INTRO;
8960      * for our $x () sets OPpOUR_INTRO */
8961     loop->op_private = (U8)iterpflags;
8962     if (loop->op_slabbed
8963      && DIFF(loop, OpSLOT(loop)->opslot_next)
8964          < SIZE_TO_PSIZE(sizeof(LOOP)))
8965     {
8966         LOOP *tmp;
8967         NewOp(1234,tmp,1,LOOP);
8968         Copy(loop,tmp,1,LISTOP);
8969         assert(loop->op_last->op_sibparent == (OP*)loop);
8970         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8971         S_op_destroy(aTHX_ (OP*)loop);
8972         loop = tmp;
8973     }
8974     else if (!loop->op_slabbed)
8975     {
8976         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8977         OpLASTSIB_set(loop->op_last, (OP*)loop);
8978     }
8979     loop->op_targ = padoff;
8980     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8981     return wop;
8982 }
8983
8984 /*
8985 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8986
8987 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8988 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8989 determining the target of the op; it is consumed by this function and
8990 becomes part of the constructed op tree.
8991
8992 =cut
8993 */
8994
8995 OP*
8996 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8997 {
8998     OP *o = NULL;
8999
9000     PERL_ARGS_ASSERT_NEWLOOPEX;
9001
9002     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9003         || type == OP_CUSTOM);
9004
9005     if (type != OP_GOTO) {
9006         /* "last()" means "last" */
9007         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9008             o = newOP(type, OPf_SPECIAL);
9009         }
9010     }
9011     else {
9012         /* Check whether it's going to be a goto &function */
9013         if (label->op_type == OP_ENTERSUB
9014                 && !(label->op_flags & OPf_STACKED))
9015             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9016     }
9017
9018     /* Check for a constant argument */
9019     if (label->op_type == OP_CONST) {
9020             SV * const sv = ((SVOP *)label)->op_sv;
9021             STRLEN l;
9022             const char *s = SvPV_const(sv,l);
9023             if (l == strlen(s)) {
9024                 o = newPVOP(type,
9025                             SvUTF8(((SVOP*)label)->op_sv),
9026                             savesharedpv(
9027                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9028             }
9029     }
9030
9031     /* If we have already created an op, we do not need the label. */
9032     if (o)
9033                 op_free(label);
9034     else o = newUNOP(type, OPf_STACKED, label);
9035
9036     PL_hints |= HINT_BLOCK_SCOPE;
9037     return o;
9038 }
9039
9040 /* if the condition is a literal array or hash
9041    (or @{ ... } etc), make a reference to it.
9042  */
9043 STATIC OP *
9044 S_ref_array_or_hash(pTHX_ OP *cond)
9045 {
9046     if (cond
9047     && (cond->op_type == OP_RV2AV
9048     ||  cond->op_type == OP_PADAV
9049     ||  cond->op_type == OP_RV2HV
9050     ||  cond->op_type == OP_PADHV))
9051
9052         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9053
9054     else if(cond
9055     && (cond->op_type == OP_ASLICE
9056     ||  cond->op_type == OP_KVASLICE
9057     ||  cond->op_type == OP_HSLICE
9058     ||  cond->op_type == OP_KVHSLICE)) {
9059
9060         /* anonlist now needs a list from this op, was previously used in
9061          * scalar context */
9062         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9063         cond->op_flags |= OPf_WANT_LIST;
9064
9065         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9066     }
9067
9068     else
9069         return cond;
9070 }
9071
9072 /* These construct the optree fragments representing given()
9073    and when() blocks.
9074
9075    entergiven and enterwhen are LOGOPs; the op_other pointer
9076    points up to the associated leave op. We need this so we
9077    can put it in the context and make break/continue work.
9078    (Also, of course, pp_enterwhen will jump straight to
9079    op_other if the match fails.)
9080  */
9081
9082 STATIC OP *
9083 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9084                    I32 enter_opcode, I32 leave_opcode,
9085                    PADOFFSET entertarg)
9086 {
9087     dVAR;
9088     LOGOP *enterop;
9089     OP *o;
9090
9091     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9092     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9093
9094     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9095     enterop->op_targ = 0;
9096     enterop->op_private = 0;
9097
9098     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9099
9100     if (cond) {
9101         /* prepend cond if we have one */
9102         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9103
9104         o->op_next = LINKLIST(cond);
9105         cond->op_next = (OP *) enterop;
9106     }
9107     else {
9108         /* This is a default {} block */
9109         enterop->op_flags |= OPf_SPECIAL;
9110         o      ->op_flags |= OPf_SPECIAL;
9111
9112         o->op_next = (OP *) enterop;
9113     }
9114
9115     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9116                                        entergiven and enterwhen both
9117                                        use ck_null() */
9118
9119     enterop->op_next = LINKLIST(block);
9120     block->op_next = enterop->op_other = o;
9121
9122     return o;
9123 }
9124
9125 /* Does this look like a boolean operation? For these purposes
9126    a boolean operation is:
9127      - a subroutine call [*]
9128      - a logical connective
9129      - a comparison operator
9130      - a filetest operator, with the exception of -s -M -A -C
9131      - defined(), exists() or eof()
9132      - /$re/ or $foo =~ /$re/
9133
9134    [*] possibly surprising
9135  */
9136 STATIC bool
9137 S_looks_like_bool(pTHX_ const OP *o)
9138 {
9139     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9140
9141     switch(o->op_type) {
9142         case OP_OR:
9143         case OP_DOR:
9144             return looks_like_bool(cLOGOPo->op_first);
9145
9146         case OP_AND:
9147         {
9148             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9149             ASSUME(sibl);
9150             return (
9151                 looks_like_bool(cLOGOPo->op_first)
9152              && looks_like_bool(sibl));
9153         }
9154
9155         case OP_NULL:
9156         case OP_SCALAR:
9157             return (
9158                 o->op_flags & OPf_KIDS
9159             && looks_like_bool(cUNOPo->op_first));
9160
9161         case OP_ENTERSUB:
9162
9163         case OP_NOT:    case OP_XOR:
9164
9165         case OP_EQ:     case OP_NE:     case OP_LT:
9166         case OP_GT:     case OP_LE:     case OP_GE:
9167
9168         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9169         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9170
9171         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9172         case OP_SGT:    case OP_SLE:    case OP_SGE:
9173
9174         case OP_SMARTMATCH:
9175
9176         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9177         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9178         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9179         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9180         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9181         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9182         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9183         case OP_FTTEXT:   case OP_FTBINARY:
9184
9185         case OP_DEFINED: case OP_EXISTS:
9186         case OP_MATCH:   case OP_EOF:
9187
9188         case OP_FLOP:
9189
9190             return TRUE;
9191
9192         case OP_INDEX:
9193         case OP_RINDEX:
9194             /* optimised-away (index() != -1) or similar comparison */
9195             if (o->op_private & OPpTRUEBOOL)
9196                 return TRUE;
9197             return FALSE;
9198
9199         case OP_CONST:
9200             /* Detect comparisons that have been optimized away */
9201             if (cSVOPo->op_sv == &PL_sv_yes
9202             ||  cSVOPo->op_sv == &PL_sv_no)
9203
9204                 return TRUE;
9205             else
9206                 return FALSE;
9207         /* FALLTHROUGH */
9208         default:
9209             return FALSE;
9210     }
9211 }
9212
9213 /*
9214 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9215
9216 Constructs, checks, and returns an op tree expressing a C<given> block.
9217 C<cond> supplies the expression to whose value C<$_> will be locally
9218 aliased, and C<block> supplies the body of the C<given> construct; they
9219 are consumed by this function and become part of the constructed op tree.
9220 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9221
9222 =cut
9223 */
9224
9225 OP *
9226 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9227 {
9228     PERL_ARGS_ASSERT_NEWGIVENOP;
9229     PERL_UNUSED_ARG(defsv_off);
9230
9231     assert(!defsv_off);
9232     return newGIVWHENOP(
9233         ref_array_or_hash(cond),
9234         block,
9235         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9236         0);
9237 }
9238
9239 /*
9240 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9241
9242 Constructs, checks, and returns an op tree expressing a C<when> block.
9243 C<cond> supplies the test expression, and C<block> supplies the block
9244 that will be executed if the test evaluates to true; they are consumed
9245 by this function and become part of the constructed op tree.  C<cond>
9246 will be interpreted DWIMically, often as a comparison against C<$_>,
9247 and may be null to generate a C<default> block.
9248
9249 =cut
9250 */
9251
9252 OP *
9253 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9254 {
9255     const bool cond_llb = (!cond || looks_like_bool(cond));
9256     OP *cond_op;
9257
9258     PERL_ARGS_ASSERT_NEWWHENOP;
9259
9260     if (cond_llb)
9261         cond_op = cond;
9262     else {
9263         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9264                 newDEFSVOP(),
9265                 scalar(ref_array_or_hash(cond)));
9266     }
9267
9268     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9269 }
9270
9271 /* must not conflict with SVf_UTF8 */
9272 #define CV_CKPROTO_CURSTASH     0x1
9273
9274 void
9275 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9276                     const STRLEN len, const U32 flags)
9277 {
9278     SV *name = NULL, *msg;
9279     const char * cvp = SvROK(cv)
9280                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9281                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9282                            : ""
9283                         : CvPROTO(cv);
9284     STRLEN clen = CvPROTOLEN(cv), plen = len;
9285
9286     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9287
9288     if (p == NULL && cvp == NULL)
9289         return;
9290
9291     if (!ckWARN_d(WARN_PROTOTYPE))
9292         return;
9293
9294     if (p && cvp) {
9295         p = S_strip_spaces(aTHX_ p, &plen);
9296         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9297         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9298             if (plen == clen && memEQ(cvp, p, plen))
9299                 return;
9300         } else {
9301             if (flags & SVf_UTF8) {
9302                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9303                     return;
9304             }
9305             else {
9306                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9307                     return;
9308             }
9309         }
9310     }
9311
9312     msg = sv_newmortal();
9313
9314     if (gv)
9315     {
9316         if (isGV(gv))
9317             gv_efullname3(name = sv_newmortal(), gv, NULL);
9318         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9319             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9320         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9321             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9322             sv_catpvs(name, "::");
9323             if (SvROK(gv)) {
9324                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9325                 assert (CvNAMED(SvRV_const(gv)));
9326                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9327             }
9328             else sv_catsv(name, (SV *)gv);
9329         }
9330         else name = (SV *)gv;
9331     }
9332     sv_setpvs(msg, "Prototype mismatch:");
9333     if (name)
9334         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9335     if (cvp)
9336         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9337             UTF8fARG(SvUTF8(cv),clen,cvp)
9338         );
9339     else
9340         sv_catpvs(msg, ": none");
9341     sv_catpvs(msg, " vs ");
9342     if (p)
9343         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9344     else
9345         sv_catpvs(msg, "none");
9346     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9347 }
9348
9349 static void const_sv_xsub(pTHX_ CV* cv);
9350 static void const_av_xsub(pTHX_ CV* cv);
9351
9352 /*
9353
9354 =head1 Optree Manipulation Functions
9355
9356 =for apidoc cv_const_sv
9357
9358 If C<cv> is a constant sub eligible for inlining, returns the constant
9359 value returned by the sub.  Otherwise, returns C<NULL>.
9360
9361 Constant subs can be created with C<newCONSTSUB> or as described in
9362 L<perlsub/"Constant Functions">.
9363
9364 =cut
9365 */
9366 SV *
9367 Perl_cv_const_sv(const CV *const cv)
9368 {
9369     SV *sv;
9370     if (!cv)
9371         return NULL;
9372     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9373         return NULL;
9374     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9375     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9376     return sv;
9377 }
9378
9379 SV *
9380 Perl_cv_const_sv_or_av(const CV * const cv)
9381 {
9382     if (!cv)
9383         return NULL;
9384     if (SvROK(cv)) return SvRV((SV *)cv);
9385     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9386     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9387 }
9388
9389 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9390  * Can be called in 2 ways:
9391  *
9392  * !allow_lex
9393  *      look for a single OP_CONST with attached value: return the value
9394  *
9395  * allow_lex && !CvCONST(cv);
9396  *
9397  *      examine the clone prototype, and if contains only a single
9398  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9399  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9400  *      a candidate for "constizing" at clone time, and return NULL.
9401  */
9402
9403 static SV *
9404 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9405 {
9406     SV *sv = NULL;
9407     bool padsv = FALSE;
9408
9409     assert(o);
9410     assert(cv);
9411
9412     for (; o; o = o->op_next) {
9413         const OPCODE type = o->op_type;
9414
9415         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9416              || type == OP_NULL
9417              || type == OP_PUSHMARK)
9418                 continue;
9419         if (type == OP_DBSTATE)
9420                 continue;
9421         if (type == OP_LEAVESUB)
9422             break;
9423         if (sv)
9424             return NULL;
9425         if (type == OP_CONST && cSVOPo->op_sv)
9426             sv = cSVOPo->op_sv;
9427         else if (type == OP_UNDEF && !o->op_private) {
9428             sv = newSV(0);
9429             SAVEFREESV(sv);
9430         }
9431         else if (allow_lex && type == OP_PADSV) {
9432                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9433                 {
9434                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9435                     padsv = TRUE;
9436                 }
9437                 else
9438                     return NULL;
9439         }
9440         else {
9441             return NULL;
9442         }
9443     }
9444     if (padsv) {
9445         CvCONST_on(cv);
9446         return NULL;
9447     }
9448     return sv;
9449 }
9450
9451 static void
9452 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9453                         PADNAME * const name, SV ** const const_svp)
9454 {
9455     assert (cv);
9456     assert (o || name);
9457     assert (const_svp);
9458     if (!block) {
9459         if (CvFLAGS(PL_compcv)) {
9460             /* might have had built-in attrs applied */
9461             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9462             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9463              && ckWARN(WARN_MISC))
9464             {
9465                 /* protect against fatal warnings leaking compcv */
9466                 SAVEFREESV(PL_compcv);
9467                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9468                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9469             }
9470             CvFLAGS(cv) |=
9471                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9472                   & ~(CVf_LVALUE * pureperl));
9473         }
9474         return;
9475     }
9476
9477     /* redundant check for speed: */
9478     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9479         const line_t oldline = CopLINE(PL_curcop);
9480         SV *namesv = o
9481             ? cSVOPo->op_sv
9482             : sv_2mortal(newSVpvn_utf8(
9483                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9484               ));
9485         if (PL_parser && PL_parser->copline != NOLINE)
9486             /* This ensures that warnings are reported at the first
9487                line of a redefinition, not the last.  */
9488             CopLINE_set(PL_curcop, PL_parser->copline);
9489         /* protect against fatal warnings leaking compcv */
9490         SAVEFREESV(PL_compcv);
9491         report_redefined_cv(namesv, cv, const_svp);
9492         SvREFCNT_inc_simple_void_NN(PL_compcv);
9493         CopLINE_set(PL_curcop, oldline);
9494     }
9495     SAVEFREESV(cv);
9496     return;
9497 }
9498
9499 CV *
9500 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9501 {
9502     CV **spot;
9503     SV **svspot;
9504     const char *ps;
9505     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9506     U32 ps_utf8 = 0;
9507     CV *cv = NULL;
9508     CV *compcv = PL_compcv;
9509     SV *const_sv;
9510     PADNAME *name;
9511     PADOFFSET pax = o->op_targ;
9512     CV *outcv = CvOUTSIDE(PL_compcv);
9513     CV *clonee = NULL;
9514     HEK *hek = NULL;
9515     bool reusable = FALSE;
9516     OP *start = NULL;
9517 #ifdef PERL_DEBUG_READONLY_OPS
9518     OPSLAB *slab = NULL;
9519 #endif
9520
9521     PERL_ARGS_ASSERT_NEWMYSUB;
9522
9523     PL_hints |= HINT_BLOCK_SCOPE;
9524
9525     /* Find the pad slot for storing the new sub.
9526        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9527        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9528        ing sub.  And then we need to dig deeper if this is a lexical from
9529        outside, as in:
9530            my sub foo; sub { sub foo { } }
9531      */
9532   redo:
9533     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9534     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9535         pax = PARENT_PAD_INDEX(name);
9536         outcv = CvOUTSIDE(outcv);
9537         assert(outcv);
9538         goto redo;
9539     }
9540     svspot =
9541         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9542                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9543     spot = (CV **)svspot;
9544
9545     if (!(PL_parser && PL_parser->error_count))
9546         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9547
9548     if (proto) {
9549         assert(proto->op_type == OP_CONST);
9550         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9551         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9552     }
9553     else
9554         ps = NULL;
9555
9556     if (proto)
9557         SAVEFREEOP(proto);
9558     if (attrs)
9559         SAVEFREEOP(attrs);
9560
9561     if (PL_parser && PL_parser->error_count) {
9562         op_free(block);
9563         SvREFCNT_dec(PL_compcv);
9564         PL_compcv = 0;
9565         goto done;
9566     }
9567
9568     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9569         cv = *spot;
9570         svspot = (SV **)(spot = &clonee);
9571     }
9572     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9573         cv = *spot;
9574     else {
9575         assert (SvTYPE(*spot) == SVt_PVCV);
9576         if (CvNAMED(*spot))
9577             hek = CvNAME_HEK(*spot);
9578         else {
9579             dVAR;
9580             U32 hash;
9581             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9582             CvNAME_HEK_set(*spot, hek =
9583                 share_hek(
9584                     PadnamePV(name)+1,
9585                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9586                     hash
9587                 )
9588             );
9589             CvLEXICAL_on(*spot);
9590         }
9591         cv = PadnamePROTOCV(name);
9592         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9593     }
9594
9595     if (block) {
9596         /* This makes sub {}; work as expected.  */
9597         if (block->op_type == OP_STUB) {
9598             const line_t l = PL_parser->copline;
9599             op_free(block);
9600             block = newSTATEOP(0, NULL, 0);
9601             PL_parser->copline = l;
9602         }
9603         block = CvLVALUE(compcv)
9604              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9605                    ? newUNOP(OP_LEAVESUBLV, 0,
9606                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9607                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9608         start = LINKLIST(block);
9609         block->op_next = 0;
9610         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9611             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9612         else
9613             const_sv = NULL;
9614     }
9615     else
9616         const_sv = NULL;
9617
9618     if (cv) {
9619         const bool exists = CvROOT(cv) || CvXSUB(cv);
9620
9621         /* if the subroutine doesn't exist and wasn't pre-declared
9622          * with a prototype, assume it will be AUTOLOADed,
9623          * skipping the prototype check
9624          */
9625         if (exists || SvPOK(cv))
9626             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9627                                  ps_utf8);
9628         /* already defined? */
9629         if (exists) {
9630             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9631             if (block)
9632                 cv = NULL;
9633             else {
9634                 if (attrs)
9635                     goto attrs;
9636                 /* just a "sub foo;" when &foo is already defined */
9637                 SAVEFREESV(compcv);
9638                 goto done;
9639             }
9640         }
9641         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9642             cv = NULL;
9643             reusable = TRUE;
9644         }
9645     }
9646
9647     if (const_sv) {
9648         SvREFCNT_inc_simple_void_NN(const_sv);
9649         SvFLAGS(const_sv) |= SVs_PADTMP;
9650         if (cv) {
9651             assert(!CvROOT(cv) && !CvCONST(cv));
9652             cv_forget_slab(cv);
9653         }
9654         else {
9655             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9656             CvFILE_set_from_cop(cv, PL_curcop);
9657             CvSTASH_set(cv, PL_curstash);
9658             *spot = cv;
9659         }
9660         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9661         CvXSUBANY(cv).any_ptr = const_sv;
9662         CvXSUB(cv) = const_sv_xsub;
9663         CvCONST_on(cv);
9664         CvISXSUB_on(cv);
9665         PoisonPADLIST(cv);
9666         CvFLAGS(cv) |= CvMETHOD(compcv);
9667         op_free(block);
9668         SvREFCNT_dec(compcv);
9669         PL_compcv = NULL;
9670         goto setname;
9671     }
9672
9673     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9674        determine whether this sub definition is in the same scope as its
9675        declaration.  If this sub definition is inside an inner named pack-
9676        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9677        the package sub.  So check PadnameOUTER(name) too.
9678      */
9679     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9680         assert(!CvWEAKOUTSIDE(compcv));
9681         SvREFCNT_dec(CvOUTSIDE(compcv));
9682         CvWEAKOUTSIDE_on(compcv);
9683     }
9684     /* XXX else do we have a circular reference? */
9685
9686     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9687         /* transfer PL_compcv to cv */
9688         if (block) {
9689             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9690             cv_flags_t preserved_flags =
9691                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9692             PADLIST *const temp_padl = CvPADLIST(cv);
9693             CV *const temp_cv = CvOUTSIDE(cv);
9694             const cv_flags_t other_flags =
9695                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9696             OP * const cvstart = CvSTART(cv);
9697
9698             SvPOK_off(cv);
9699             CvFLAGS(cv) =
9700                 CvFLAGS(compcv) | preserved_flags;
9701             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9702             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9703             CvPADLIST_set(cv, CvPADLIST(compcv));
9704             CvOUTSIDE(compcv) = temp_cv;
9705             CvPADLIST_set(compcv, temp_padl);
9706             CvSTART(cv) = CvSTART(compcv);
9707             CvSTART(compcv) = cvstart;
9708             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9709             CvFLAGS(compcv) |= other_flags;
9710
9711             if (free_file) {
9712                 Safefree(CvFILE(cv));
9713                 CvFILE(cv) = NULL;
9714             }
9715
9716             /* inner references to compcv must be fixed up ... */
9717             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9718             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9719                 ++PL_sub_generation;
9720         }
9721         else {
9722             /* Might have had built-in attributes applied -- propagate them. */
9723             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9724         }
9725         /* ... before we throw it away */
9726         SvREFCNT_dec(compcv);
9727         PL_compcv = compcv = cv;
9728     }
9729     else {
9730         cv = compcv;
9731         *spot = cv;
9732     }
9733
9734   setname:
9735     CvLEXICAL_on(cv);
9736     if (!CvNAME_HEK(cv)) {
9737         if (hek) (void)share_hek_hek(hek);
9738         else {
9739             dVAR;
9740             U32 hash;
9741             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9742             hek = share_hek(PadnamePV(name)+1,
9743                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9744                       hash);
9745         }
9746         CvNAME_HEK_set(cv, hek);
9747     }
9748
9749     if (const_sv)
9750         goto clone;
9751
9752     if (CvFILE(cv) && CvDYNFILE(cv))
9753         Safefree(CvFILE(cv));
9754     CvFILE_set_from_cop(cv, PL_curcop);
9755     CvSTASH_set(cv, PL_curstash);
9756
9757     if (ps) {
9758         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9759         if (ps_utf8)
9760             SvUTF8_on(MUTABLE_SV(cv));
9761     }
9762
9763     if (block) {
9764         /* If we assign an optree to a PVCV, then we've defined a
9765          * subroutine that the debugger could be able to set a breakpoint
9766          * in, so signal to pp_entereval that it should not throw away any
9767          * saved lines at scope exit.  */
9768
9769         PL_breakable_sub_gen++;
9770         CvROOT(cv) = block;
9771         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9772            itself has a refcount. */
9773         CvSLABBED_off(cv);
9774         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9775 #ifdef PERL_DEBUG_READONLY_OPS
9776         slab = (OPSLAB *)CvSTART(cv);
9777 #endif
9778         S_process_optree(aTHX_ cv, block, start);
9779     }
9780
9781   attrs:
9782     if (attrs) {
9783         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9784         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9785     }
9786
9787     if (block) {
9788         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9789             SV * const tmpstr = sv_newmortal();
9790             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9791                                                   GV_ADDMULTI, SVt_PVHV);
9792             HV *hv;
9793             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9794                                           CopFILE(PL_curcop),
9795                                           (long)PL_subline,
9796                                           (long)CopLINE(PL_curcop));
9797             if (HvNAME_HEK(PL_curstash)) {
9798                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9799                 sv_catpvs(tmpstr, "::");
9800             }
9801             else
9802                 sv_setpvs(tmpstr, "__ANON__::");
9803
9804             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9805                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9806             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9807                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9808             hv = GvHVn(db_postponed);
9809             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9810                 CV * const pcv = GvCV(db_postponed);
9811                 if (pcv) {
9812                     dSP;
9813                     PUSHMARK(SP);
9814                     XPUSHs(tmpstr);
9815                     PUTBACK;
9816                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9817                 }
9818             }
9819         }
9820     }
9821
9822   clone:
9823     if (clonee) {
9824         assert(CvDEPTH(outcv));
9825         spot = (CV **)
9826             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9827         if (reusable)
9828             cv_clone_into(clonee, *spot);
9829         else *spot = cv_clone(clonee);
9830         SvREFCNT_dec_NN(clonee);
9831         cv = *spot;
9832     }
9833
9834     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9835         PADOFFSET depth = CvDEPTH(outcv);
9836         while (--depth) {
9837             SV *oldcv;
9838             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9839             oldcv = *svspot;
9840             *svspot = SvREFCNT_inc_simple_NN(cv);
9841             SvREFCNT_dec(oldcv);
9842         }
9843     }
9844
9845   done:
9846     if (PL_parser)
9847         PL_parser->copline = NOLINE;
9848     LEAVE_SCOPE(floor);
9849 #ifdef PERL_DEBUG_READONLY_OPS
9850     if (slab)
9851         Slab_to_ro(slab);
9852 #endif
9853     op_free(o);
9854     return cv;
9855 }
9856
9857 /*
9858 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9859
9860 Construct a Perl subroutine, also performing some surrounding jobs.
9861
9862 This function is expected to be called in a Perl compilation context,
9863 and some aspects of the subroutine are taken from global variables
9864 associated with compilation.  In particular, C<PL_compcv> represents
9865 the subroutine that is currently being compiled.  It must be non-null
9866 when this function is called, and some aspects of the subroutine being
9867 constructed are taken from it.  The constructed subroutine may actually
9868 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9869
9870 If C<block> is null then the subroutine will have no body, and for the
9871 time being it will be an error to call it.  This represents a forward
9872 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9873 non-null then it provides the Perl code of the subroutine body, which
9874 will be executed when the subroutine is called.  This body includes
9875 any argument unwrapping code resulting from a subroutine signature or
9876 similar.  The pad use of the code must correspond to the pad attached
9877 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9878 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9879 by this function and will become part of the constructed subroutine.
9880
9881 C<proto> specifies the subroutine's prototype, unless one is supplied
9882 as an attribute (see below).  If C<proto> is null, then the subroutine
9883 will not have a prototype.  If C<proto> is non-null, it must point to a
9884 C<const> op whose value is a string, and the subroutine will have that
9885 string as its prototype.  If a prototype is supplied as an attribute, the
9886 attribute takes precedence over C<proto>, but in that case C<proto> should
9887 preferably be null.  In any case, C<proto> is consumed by this function.
9888
9889 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9890 attributes take effect by built-in means, being applied to C<PL_compcv>
9891 immediately when seen.  Other attributes are collected up and attached
9892 to the subroutine by this route.  C<attrs> may be null to supply no
9893 attributes, or point to a C<const> op for a single attribute, or point
9894 to a C<list> op whose children apart from the C<pushmark> are C<const>
9895 ops for one or more attributes.  Each C<const> op must be a string,
9896 giving the attribute name optionally followed by parenthesised arguments,
9897 in the manner in which attributes appear in Perl source.  The attributes
9898 will be applied to the sub by this function.  C<attrs> is consumed by
9899 this function.
9900
9901 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9902 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9903 must point to a C<const> op, which will be consumed by this function,
9904 and its string value supplies a name for the subroutine.  The name may
9905 be qualified or unqualified, and if it is unqualified then a default
9906 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9907 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9908 by which the subroutine will be named.
9909
9910 If there is already a subroutine of the specified name, then the new
9911 sub will either replace the existing one in the glob or be merged with
9912 the existing one.  A warning may be generated about redefinition.
9913
9914 If the subroutine has one of a few special names, such as C<BEGIN> or
9915 C<END>, then it will be claimed by the appropriate queue for automatic
9916 running of phase-related subroutines.  In this case the relevant glob will
9917 be left not containing any subroutine, even if it did contain one before.
9918 In the case of C<BEGIN>, the subroutine will be executed and the reference
9919 to it disposed of before this function returns.
9920
9921 The function returns a pointer to the constructed subroutine.  If the sub
9922 is anonymous then ownership of one counted reference to the subroutine
9923 is transferred to the caller.  If the sub is named then the caller does
9924 not get ownership of a reference.  In most such cases, where the sub
9925 has a non-phase name, the sub will be alive at the point it is returned
9926 by virtue of being contained in the glob that names it.  A phase-named
9927 subroutine will usually be alive by virtue of the reference owned by the
9928 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9929 been executed, will quite likely have been destroyed already by the
9930 time this function returns, making it erroneous for the caller to make
9931 any use of the returned pointer.  It is the caller's responsibility to
9932 ensure that it knows which of these situations applies.
9933
9934 =cut
9935 */
9936
9937 /* _x = extended */
9938 CV *
9939 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9940                             OP *block, bool o_is_gv)
9941 {
9942     GV *gv;
9943     const char *ps;
9944     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9945     U32 ps_utf8 = 0;
9946     CV *cv = NULL;     /* the previous CV with this name, if any */
9947     SV *const_sv;
9948     const bool ec = PL_parser && PL_parser->error_count;
9949     /* If the subroutine has no body, no attributes, and no builtin attributes
9950        then it's just a sub declaration, and we may be able to get away with
9951        storing with a placeholder scalar in the symbol table, rather than a
9952        full CV.  If anything is present then it will take a full CV to
9953        store it.  */
9954     const I32 gv_fetch_flags
9955         = ec ? GV_NOADD_NOINIT :
9956         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9957         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9958     STRLEN namlen = 0;
9959     const char * const name =
9960          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9961     bool has_name;
9962     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9963     bool evanescent = FALSE;
9964     OP *start = NULL;
9965 #ifdef PERL_DEBUG_READONLY_OPS
9966     OPSLAB *slab = NULL;
9967 #endif
9968
9969     if (o_is_gv) {
9970         gv = (GV*)o;
9971         o = NULL;
9972         has_name = TRUE;
9973     } else if (name) {
9974         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9975            hek and CvSTASH pointer together can imply the GV.  If the name
9976            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9977            CvSTASH, so forego the optimisation if we find any.
9978            Also, we may be called from load_module at run time, so
9979            PL_curstash (which sets CvSTASH) may not point to the stash the
9980            sub is stored in.  */
9981         /* XXX This optimization is currently disabled for packages other
9982                than main, since there was too much CPAN breakage.  */
9983         const I32 flags =
9984            ec ? GV_NOADD_NOINIT
9985               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9986                || PL_curstash != PL_defstash
9987                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9988                     ? gv_fetch_flags
9989                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9990         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9991         has_name = TRUE;
9992     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9993         SV * const sv = sv_newmortal();
9994         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9995                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9996                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9997         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9998         has_name = TRUE;
9999     } else if (PL_curstash) {
10000         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10001         has_name = FALSE;
10002     } else {
10003         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10004         has_name = FALSE;
10005     }
10006
10007     if (!ec) {
10008         if (isGV(gv)) {
10009             move_proto_attr(&proto, &attrs, gv, 0);
10010         } else {
10011             assert(cSVOPo);
10012             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10013         }
10014     }
10015
10016     if (proto) {
10017         assert(proto->op_type == OP_CONST);
10018         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10019         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10020     }
10021     else
10022         ps = NULL;
10023
10024     if (o)
10025         SAVEFREEOP(o);
10026     if (proto)
10027         SAVEFREEOP(proto);
10028     if (attrs)
10029         SAVEFREEOP(attrs);
10030
10031     if (ec) {
10032         op_free(block);
10033
10034         if (name)
10035             SvREFCNT_dec(PL_compcv);
10036         else
10037             cv = PL_compcv;
10038
10039         PL_compcv = 0;
10040         if (name && block) {
10041             const char *s = (char *) my_memrchr(name, ':', namlen);
10042             s = s ? s+1 : name;
10043             if (strEQ(s, "BEGIN")) {
10044                 if (PL_in_eval & EVAL_KEEPERR)
10045                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10046                 else {
10047                     SV * const errsv = ERRSV;
10048                     /* force display of errors found but not reported */
10049                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10050                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10051                 }
10052             }
10053         }
10054         goto done;
10055     }
10056
10057     if (!block && SvTYPE(gv) != SVt_PVGV) {
10058         /* If we are not defining a new sub and the existing one is not a
10059            full GV + CV... */
10060         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10061             /* We are applying attributes to an existing sub, so we need it
10062                upgraded if it is a constant.  */
10063             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10064                 gv_init_pvn(gv, PL_curstash, name, namlen,
10065                             SVf_UTF8 * name_is_utf8);
10066         }
10067         else {                  /* Maybe prototype now, and had at maximum
10068                                    a prototype or const/sub ref before.  */
10069             if (SvTYPE(gv) > SVt_NULL) {
10070                 cv_ckproto_len_flags((const CV *)gv,
10071                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10072                                     ps_len, ps_utf8);
10073             }
10074
10075             if (!SvROK(gv)) {
10076                 if (ps) {
10077                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10078                     if (ps_utf8)
10079                         SvUTF8_on(MUTABLE_SV(gv));
10080                 }
10081                 else
10082                     sv_setiv(MUTABLE_SV(gv), -1);
10083             }
10084
10085             SvREFCNT_dec(PL_compcv);
10086             cv = PL_compcv = NULL;
10087             goto done;
10088         }
10089     }
10090
10091     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10092         ? NULL
10093         : isGV(gv)
10094             ? GvCV(gv)
10095             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10096                 ? (CV *)SvRV(gv)
10097                 : NULL;
10098
10099     if (block) {
10100         assert(PL_parser);
10101         /* This makes sub {}; work as expected.  */
10102         if (block->op_type == OP_STUB) {
10103             const line_t l = PL_parser->copline;
10104             op_free(block);
10105             block = newSTATEOP(0, NULL, 0);
10106             PL_parser->copline = l;
10107         }
10108         block = CvLVALUE(PL_compcv)
10109              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10110                     && (!isGV(gv) || !GvASSUMECV(gv)))
10111                    ? newUNOP(OP_LEAVESUBLV, 0,
10112                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10113                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10114         start = LINKLIST(block);
10115         block->op_next = 0;
10116         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10117             const_sv =
10118                 S_op_const_sv(aTHX_ start, PL_compcv,
10119                                         cBOOL(CvCLONE(PL_compcv)));
10120         else
10121             const_sv = NULL;
10122     }
10123     else
10124         const_sv = NULL;
10125
10126     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10127         cv_ckproto_len_flags((const CV *)gv,
10128                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10129                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10130         if (SvROK(gv)) {
10131             /* All the other code for sub redefinition warnings expects the
10132                clobbered sub to be a CV.  Instead of making all those code
10133                paths more complex, just inline the RV version here.  */
10134             const line_t oldline = CopLINE(PL_curcop);
10135             assert(IN_PERL_COMPILETIME);
10136             if (PL_parser && PL_parser->copline != NOLINE)
10137                 /* This ensures that warnings are reported at the first
10138                    line of a redefinition, not the last.  */
10139                 CopLINE_set(PL_curcop, PL_parser->copline);
10140             /* protect against fatal warnings leaking compcv */
10141             SAVEFREESV(PL_compcv);
10142
10143             if (ckWARN(WARN_REDEFINE)
10144              || (  ckWARN_d(WARN_REDEFINE)
10145                 && (  !const_sv || SvRV(gv) == const_sv
10146                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10147                 assert(cSVOPo);
10148                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10149                           "Constant subroutine %" SVf " redefined",
10150                           SVfARG(cSVOPo->op_sv));
10151             }
10152
10153             SvREFCNT_inc_simple_void_NN(PL_compcv);
10154             CopLINE_set(PL_curcop, oldline);
10155             SvREFCNT_dec(SvRV(gv));
10156         }
10157     }
10158
10159     if (cv) {
10160         const bool exists = CvROOT(cv) || CvXSUB(cv);
10161
10162         /* if the subroutine doesn't exist and wasn't pre-declared
10163          * with a prototype, assume it will be AUTOLOADed,
10164          * skipping the prototype check
10165          */
10166         if (exists || SvPOK(cv))
10167             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10168         /* already defined (or promised)? */
10169         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10170             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10171             if (block)
10172                 cv = NULL;
10173             else {
10174                 if (attrs)
10175                     goto attrs;
10176                 /* just a "sub foo;" when &foo is already defined */
10177                 SAVEFREESV(PL_compcv);
10178                 goto done;
10179             }
10180         }
10181     }
10182
10183     if (const_sv) {
10184         SvREFCNT_inc_simple_void_NN(const_sv);
10185         SvFLAGS(const_sv) |= SVs_PADTMP;
10186         if (cv) {
10187             assert(!CvROOT(cv) && !CvCONST(cv));
10188             cv_forget_slab(cv);
10189             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10190             CvXSUBANY(cv).any_ptr = const_sv;
10191             CvXSUB(cv) = const_sv_xsub;
10192             CvCONST_on(cv);
10193             CvISXSUB_on(cv);
10194             PoisonPADLIST(cv);
10195             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10196         }
10197         else {
10198             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10199                 if (name && isGV(gv))
10200                     GvCV_set(gv, NULL);
10201                 cv = newCONSTSUB_flags(
10202                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10203                     const_sv
10204                 );
10205                 assert(cv);
10206                 assert(SvREFCNT((SV*)cv) != 0);
10207                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10208             }
10209             else {
10210                 if (!SvROK(gv)) {
10211                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10212                     prepare_SV_for_RV((SV *)gv);
10213                     SvOK_off((SV *)gv);
10214                     SvROK_on(gv);
10215                 }
10216                 SvRV_set(gv, const_sv);
10217             }
10218         }
10219         op_free(block);
10220         SvREFCNT_dec(PL_compcv);
10221         PL_compcv = NULL;
10222         goto done;
10223     }
10224
10225     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10226     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10227         cv = NULL;
10228
10229     if (cv) {                           /* must reuse cv if autoloaded */
10230         /* transfer PL_compcv to cv */
10231         if (block) {
10232             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10233             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10234             PADLIST *const temp_av = CvPADLIST(cv);
10235             CV *const temp_cv = CvOUTSIDE(cv);
10236             const cv_flags_t other_flags =
10237                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10238             OP * const cvstart = CvSTART(cv);
10239
10240             if (isGV(gv)) {
10241                 CvGV_set(cv,gv);
10242                 assert(!CvCVGV_RC(cv));
10243                 assert(CvGV(cv) == gv);
10244             }
10245             else {
10246                 dVAR;
10247                 U32 hash;
10248                 PERL_HASH(hash, name, namlen);
10249                 CvNAME_HEK_set(cv,
10250                                share_hek(name,
10251                                          name_is_utf8
10252                                             ? -(SSize_t)namlen
10253                                             :  (SSize_t)namlen,
10254                                          hash));
10255             }
10256
10257             SvPOK_off(cv);
10258             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10259                                              | CvNAMED(cv);
10260             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10261             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10262             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10263             CvOUTSIDE(PL_compcv) = temp_cv;
10264             CvPADLIST_set(PL_compcv, temp_av);
10265             CvSTART(cv) = CvSTART(PL_compcv);
10266             CvSTART(PL_compcv) = cvstart;
10267             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10268             CvFLAGS(PL_compcv) |= other_flags;
10269
10270             if (free_file) {
10271                 Safefree(CvFILE(cv));
10272             }
10273             CvFILE_set_from_cop(cv, PL_curcop);
10274             CvSTASH_set(cv, PL_curstash);
10275
10276             /* inner references to PL_compcv must be fixed up ... */
10277             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10278             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10279                 ++PL_sub_generation;
10280         }
10281         else {
10282             /* Might have had built-in attributes applied -- propagate them. */
10283             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10284         }
10285         /* ... before we throw it away */
10286         SvREFCNT_dec(PL_compcv);
10287         PL_compcv = cv;
10288     }
10289     else {
10290         cv = PL_compcv;
10291         if (name && isGV(gv)) {
10292             GvCV_set(gv, cv);
10293             GvCVGEN(gv) = 0;
10294             if (HvENAME_HEK(GvSTASH(gv)))
10295                 /* sub Foo::bar { (shift)+1 } */
10296                 gv_method_changed(gv);
10297         }
10298         else if (name) {
10299             if (!SvROK(gv)) {
10300                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10301                 prepare_SV_for_RV((SV *)gv);
10302                 SvOK_off((SV *)gv);
10303                 SvROK_on(gv);
10304             }
10305             SvRV_set(gv, (SV *)cv);
10306             if (HvENAME_HEK(PL_curstash))
10307                 mro_method_changed_in(PL_curstash);
10308         }
10309     }
10310     assert(cv);
10311     assert(SvREFCNT((SV*)cv) != 0);
10312
10313     if (!CvHASGV(cv)) {
10314         if (isGV(gv))
10315             CvGV_set(cv, gv);
10316         else {
10317             dVAR;
10318             U32 hash;
10319             PERL_HASH(hash, name, namlen);
10320             CvNAME_HEK_set(cv, share_hek(name,
10321                                          name_is_utf8
10322                                             ? -(SSize_t)namlen
10323                                             :  (SSize_t)namlen,
10324                                          hash));
10325         }
10326         CvFILE_set_from_cop(cv, PL_curcop);
10327         CvSTASH_set(cv, PL_curstash);
10328     }
10329
10330     if (ps) {
10331         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10332         if ( ps_utf8 )
10333             SvUTF8_on(MUTABLE_SV(cv));
10334     }
10335
10336     if (block) {
10337         /* If we assign an optree to a PVCV, then we've defined a
10338          * subroutine that the debugger could be able to set a breakpoint
10339          * in, so signal to pp_entereval that it should not throw away any
10340          * saved lines at scope exit.  */
10341
10342         PL_breakable_sub_gen++;
10343         CvROOT(cv) = block;
10344         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10345            itself has a refcount. */
10346         CvSLABBED_off(cv);
10347         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10348 #ifdef PERL_DEBUG_READONLY_OPS
10349         slab = (OPSLAB *)CvSTART(cv);
10350 #endif
10351         S_process_optree(aTHX_ cv, block, start);
10352     }
10353
10354   attrs:
10355     if (attrs) {
10356         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10357         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10358                         ? GvSTASH(CvGV(cv))
10359                         : PL_curstash;
10360         if (!name)
10361             SAVEFREESV(cv);
10362         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10363         if (!name)
10364             SvREFCNT_inc_simple_void_NN(cv);
10365     }
10366
10367     if (block && has_name) {
10368         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10369             SV * const tmpstr = cv_name(cv,NULL,0);
10370             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10371                                                   GV_ADDMULTI, SVt_PVHV);
10372             HV *hv;
10373             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10374                                           CopFILE(PL_curcop),
10375                                           (long)PL_subline,
10376                                           (long)CopLINE(PL_curcop));
10377             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10378                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10379             hv = GvHVn(db_postponed);
10380             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10381                 CV * const pcv = GvCV(db_postponed);
10382                 if (pcv) {
10383                     dSP;
10384                     PUSHMARK(SP);
10385                     XPUSHs(tmpstr);
10386                     PUTBACK;
10387                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10388                 }
10389             }
10390         }
10391
10392         if (name) {
10393             if (PL_parser && PL_parser->error_count)
10394                 clear_special_blocks(name, gv, cv);
10395             else
10396                 evanescent =
10397                     process_special_blocks(floor, name, gv, cv);
10398         }
10399     }
10400     assert(cv);
10401
10402   done:
10403     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10404     if (PL_parser)
10405         PL_parser->copline = NOLINE;
10406     LEAVE_SCOPE(floor);
10407
10408     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10409     if (!evanescent) {
10410 #ifdef PERL_DEBUG_READONLY_OPS
10411     if (slab)
10412         Slab_to_ro(slab);
10413 #endif
10414     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10415         pad_add_weakref(cv);
10416     }
10417     return cv;
10418 }
10419
10420 STATIC void
10421 S_clear_special_blocks(pTHX_ const char *const fullname,
10422                        GV *const gv, CV *const cv) {
10423     const char *colon;
10424     const char *name;
10425
10426     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10427
10428     colon = strrchr(fullname,':');
10429     name = colon ? colon + 1 : fullname;
10430
10431     if ((*name == 'B' && strEQ(name, "BEGIN"))
10432         || (*name == 'E' && strEQ(name, "END"))
10433         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10434         || (*name == 'C' && strEQ(name, "CHECK"))
10435         || (*name == 'I' && strEQ(name, "INIT"))) {
10436         if (!isGV(gv)) {
10437             (void)CvGV(cv);
10438             assert(isGV(gv));
10439         }
10440         GvCV_set(gv, NULL);
10441         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10442     }
10443 }
10444
10445 /* Returns true if the sub has been freed.  */
10446 STATIC bool
10447 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10448                          GV *const gv,
10449                          CV *const cv)
10450 {
10451     const char *const colon = strrchr(fullname,':');
10452     const char *const name = colon ? colon + 1 : fullname;
10453
10454     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10455
10456     if (*name == 'B') {
10457         if (strEQ(name, "BEGIN")) {
10458             const I32 oldscope = PL_scopestack_ix;
10459             dSP;
10460             (void)CvGV(cv);
10461             if (floor) LEAVE_SCOPE(floor);
10462             ENTER;
10463             PUSHSTACKi(PERLSI_REQUIRE);
10464             SAVECOPFILE(&PL_compiling);
10465             SAVECOPLINE(&PL_compiling);
10466             SAVEVPTR(PL_curcop);
10467
10468             DEBUG_x( dump_sub(gv) );
10469             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10470             GvCV_set(gv,0);             /* cv has been hijacked */
10471             call_list(oldscope, PL_beginav);
10472
10473             POPSTACK;
10474             LEAVE;
10475             return !PL_savebegin;
10476         }
10477         else
10478             return FALSE;
10479     } else {
10480         if (*name == 'E') {
10481             if strEQ(name, "END") {
10482                 DEBUG_x( dump_sub(gv) );
10483                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10484             } else
10485                 return FALSE;
10486         } else if (*name == 'U') {
10487             if (strEQ(name, "UNITCHECK")) {
10488                 /* It's never too late to run a unitcheck block */
10489                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10490             }
10491             else
10492                 return FALSE;
10493         } else if (*name == 'C') {
10494             if (strEQ(name, "CHECK")) {
10495                 if (PL_main_start)
10496                     /* diag_listed_as: Too late to run %s block */
10497                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10498                                    "Too late to run CHECK block");
10499                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10500             }
10501             else
10502                 return FALSE;
10503         } else if (*name == 'I') {
10504             if (strEQ(name, "INIT")) {
10505                 if (PL_main_start)
10506                     /* diag_listed_as: Too late to run %s block */
10507                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10508                                    "Too late to run INIT block");
10509                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10510             }
10511             else
10512                 return FALSE;
10513         } else
10514             return FALSE;
10515         DEBUG_x( dump_sub(gv) );
10516         (void)CvGV(cv);
10517         GvCV_set(gv,0);         /* cv has been hijacked */
10518         return FALSE;
10519     }
10520 }
10521
10522 /*
10523 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10524
10525 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10526 rather than of counted length, and no flags are set.  (This means that
10527 C<name> is always interpreted as Latin-1.)
10528
10529 =cut
10530 */
10531
10532 CV *
10533 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10534 {
10535     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10536 }
10537
10538 /*
10539 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10540
10541 Construct a constant subroutine, also performing some surrounding
10542 jobs.  A scalar constant-valued subroutine is eligible for inlining
10543 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10544 123 }>>.  Other kinds of constant subroutine have other treatment.
10545
10546 The subroutine will have an empty prototype and will ignore any arguments
10547 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10548 is null, the subroutine will yield an empty list.  If C<sv> points to a
10549 scalar, the subroutine will always yield that scalar.  If C<sv> points
10550 to an array, the subroutine will always yield a list of the elements of
10551 that array in list context, or the number of elements in the array in
10552 scalar context.  This function takes ownership of one counted reference
10553 to the scalar or array, and will arrange for the object to live as long
10554 as the subroutine does.  If C<sv> points to a scalar then the inlining
10555 assumes that the value of the scalar will never change, so the caller
10556 must ensure that the scalar is not subsequently written to.  If C<sv>
10557 points to an array then no such assumption is made, so it is ostensibly
10558 safe to mutate the array or its elements, but whether this is really
10559 supported has not been determined.
10560
10561 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10562 Other aspects of the subroutine will be left in their default state.
10563 The caller is free to mutate the subroutine beyond its initial state
10564 after this function has returned.
10565
10566 If C<name> is null then the subroutine will be anonymous, with its
10567 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10568 subroutine will be named accordingly, referenced by the appropriate glob.
10569 C<name> is a string of length C<len> bytes giving a sigilless symbol
10570 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10571 otherwise.  The name may be either qualified or unqualified.  If the
10572 name is unqualified then it defaults to being in the stash specified by
10573 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10574 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10575 semantics.
10576
10577 C<flags> should not have bits set other than C<SVf_UTF8>.
10578
10579 If there is already a subroutine of the specified name, then the new sub
10580 will replace the existing one in the glob.  A warning may be generated
10581 about the redefinition.
10582
10583 If the subroutine has one of a few special names, such as C<BEGIN> or
10584 C<END>, then it will be claimed by the appropriate queue for automatic
10585 running of phase-related subroutines.  In this case the relevant glob will
10586 be left not containing any subroutine, even if it did contain one before.
10587 Execution of the subroutine will likely be a no-op, unless C<sv> was
10588 a tied array or the caller modified the subroutine in some interesting
10589 way before it was executed.  In the case of C<BEGIN>, the treatment is
10590 buggy: the sub will be executed when only half built, and may be deleted
10591 prematurely, possibly causing a crash.
10592
10593 The function returns a pointer to the constructed subroutine.  If the sub
10594 is anonymous then ownership of one counted reference to the subroutine
10595 is transferred to the caller.  If the sub is named then the caller does
10596 not get ownership of a reference.  In most such cases, where the sub
10597 has a non-phase name, the sub will be alive at the point it is returned
10598 by virtue of being contained in the glob that names it.  A phase-named
10599 subroutine will usually be alive by virtue of the reference owned by
10600 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10601 destroyed already by the time this function returns, but currently bugs
10602 occur in that case before the caller gets control.  It is the caller's
10603 responsibility to ensure that it knows which of these situations applies.
10604
10605 =cut
10606 */
10607
10608 CV *
10609 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10610                              U32 flags, SV *sv)
10611 {
10612     CV* cv;
10613     const char *const file = CopFILE(PL_curcop);
10614
10615     ENTER;
10616
10617     if (IN_PERL_RUNTIME) {
10618         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10619          * an op shared between threads. Use a non-shared COP for our
10620          * dirty work */
10621          SAVEVPTR(PL_curcop);
10622          SAVECOMPILEWARNINGS();
10623          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10624          PL_curcop = &PL_compiling;
10625     }
10626     SAVECOPLINE(PL_curcop);
10627     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10628
10629     SAVEHINTS();
10630     PL_hints &= ~HINT_BLOCK_SCOPE;
10631
10632     if (stash) {
10633         SAVEGENERICSV(PL_curstash);
10634         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10635     }
10636
10637     /* Protect sv against leakage caused by fatal warnings. */
10638     if (sv) SAVEFREESV(sv);
10639
10640     /* file becomes the CvFILE. For an XS, it's usually static storage,
10641        and so doesn't get free()d.  (It's expected to be from the C pre-
10642        processor __FILE__ directive). But we need a dynamically allocated one,
10643        and we need it to get freed.  */
10644     cv = newXS_len_flags(name, len,
10645                          sv && SvTYPE(sv) == SVt_PVAV
10646                              ? const_av_xsub
10647                              : const_sv_xsub,
10648                          file ? file : "", "",
10649                          &sv, XS_DYNAMIC_FILENAME | flags);
10650     assert(cv);
10651     assert(SvREFCNT((SV*)cv) != 0);
10652     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10653     CvCONST_on(cv);
10654
10655     LEAVE;
10656
10657     return cv;
10658 }
10659
10660 /*
10661 =for apidoc U||newXS
10662
10663 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10664 static storage, as it is used directly as CvFILE(), without a copy being made.
10665
10666 =cut
10667 */
10668
10669 CV *
10670 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10671 {
10672     PERL_ARGS_ASSERT_NEWXS;
10673     return newXS_len_flags(
10674         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10675     );
10676 }
10677
10678 CV *
10679 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10680                  const char *const filename, const char *const proto,
10681                  U32 flags)
10682 {
10683     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10684     return newXS_len_flags(
10685        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10686     );
10687 }
10688
10689 CV *
10690 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10691 {
10692     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10693     return newXS_len_flags(
10694         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10695     );
10696 }
10697
10698 /*
10699 =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
10700
10701 Construct an XS subroutine, also performing some surrounding jobs.
10702
10703 The subroutine will have the entry point C<subaddr>.  It will have
10704 the prototype specified by the nul-terminated string C<proto>, or
10705 no prototype if C<proto> is null.  The prototype string is copied;
10706 the caller can mutate the supplied string afterwards.  If C<filename>
10707 is non-null, it must be a nul-terminated filename, and the subroutine
10708 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10709 point directly to the supplied string, which must be static.  If C<flags>
10710 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10711 be taken instead.
10712
10713 Other aspects of the subroutine will be left in their default state.
10714 If anything else needs to be done to the subroutine for it to function
10715 correctly, it is the caller's responsibility to do that after this
10716 function has constructed it.  However, beware of the subroutine
10717 potentially being destroyed before this function returns, as described
10718 below.
10719
10720 If C<name> is null then the subroutine will be anonymous, with its
10721 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10722 subroutine will be named accordingly, referenced by the appropriate glob.
10723 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10724 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10725 The name may be either qualified or unqualified, with the stash defaulting
10726 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10727 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10728 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10729 the stash if necessary, with C<GV_ADDMULTI> semantics.
10730
10731 If there is already a subroutine of the specified name, then the new sub
10732 will replace the existing one in the glob.  A warning may be generated
10733 about the redefinition.  If the old subroutine was C<CvCONST> then the
10734 decision about whether to warn is influenced by an expectation about
10735 whether the new subroutine will become a constant of similar value.
10736 That expectation is determined by C<const_svp>.  (Note that the call to
10737 this function doesn't make the new subroutine C<CvCONST> in any case;
10738 that is left to the caller.)  If C<const_svp> is null then it indicates
10739 that the new subroutine will not become a constant.  If C<const_svp>
10740 is non-null then it indicates that the new subroutine will become a
10741 constant, and it points to an C<SV*> that provides the constant value
10742 that the subroutine will have.
10743
10744 If the subroutine has one of a few special names, such as C<BEGIN> or
10745 C<END>, then it will be claimed by the appropriate queue for automatic
10746 running of phase-related subroutines.  In this case the relevant glob will
10747 be left not containing any subroutine, even if it did contain one before.
10748 In the case of C<BEGIN>, the subroutine will be executed and the reference
10749 to it disposed of before this function returns, and also before its
10750 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10751 constructed by this function to be ready for execution then the caller
10752 must prevent this happening by giving the subroutine a different name.
10753
10754 The function returns a pointer to the constructed subroutine.  If the sub
10755 is anonymous then ownership of one counted reference to the subroutine
10756 is transferred to the caller.  If the sub is named then the caller does
10757 not get ownership of a reference.  In most such cases, where the sub
10758 has a non-phase name, the sub will be alive at the point it is returned
10759 by virtue of being contained in the glob that names it.  A phase-named
10760 subroutine will usually be alive by virtue of the reference owned by the
10761 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10762 been executed, will quite likely have been destroyed already by the
10763 time this function returns, making it erroneous for the caller to make
10764 any use of the returned pointer.  It is the caller's responsibility to
10765 ensure that it knows which of these situations applies.
10766
10767 =cut
10768 */
10769
10770 CV *
10771 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10772                            XSUBADDR_t subaddr, const char *const filename,
10773                            const char *const proto, SV **const_svp,
10774                            U32 flags)
10775 {
10776     CV *cv;
10777     bool interleave = FALSE;
10778     bool evanescent = FALSE;
10779
10780     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10781
10782     {
10783         GV * const gv = gv_fetchpvn(
10784                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10785                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10786                                 sizeof("__ANON__::__ANON__") - 1,
10787                             GV_ADDMULTI | flags, SVt_PVCV);
10788
10789         if ((cv = (name ? GvCV(gv) : NULL))) {
10790             if (GvCVGEN(gv)) {
10791                 /* just a cached method */
10792                 SvREFCNT_dec(cv);
10793                 cv = NULL;
10794             }
10795             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10796                 /* already defined (or promised) */
10797                 /* Redundant check that allows us to avoid creating an SV
10798                    most of the time: */
10799                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10800                     report_redefined_cv(newSVpvn_flags(
10801                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10802                                         ),
10803                                         cv, const_svp);
10804                 }
10805                 interleave = TRUE;
10806                 ENTER;
10807                 SAVEFREESV(cv);
10808                 cv = NULL;
10809             }
10810         }
10811
10812         if (cv)                         /* must reuse cv if autoloaded */
10813             cv_undef(cv);
10814         else {
10815             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10816             if (name) {
10817                 GvCV_set(gv,cv);
10818                 GvCVGEN(gv) = 0;
10819                 if (HvENAME_HEK(GvSTASH(gv)))
10820                     gv_method_changed(gv); /* newXS */
10821             }
10822         }
10823         assert(cv);
10824         assert(SvREFCNT((SV*)cv) != 0);
10825
10826         CvGV_set(cv, gv);
10827         if(filename) {
10828             /* XSUBs can't be perl lang/perl5db.pl debugged
10829             if (PERLDB_LINE_OR_SAVESRC)
10830                 (void)gv_fetchfile(filename); */
10831             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10832             if (flags & XS_DYNAMIC_FILENAME) {
10833                 CvDYNFILE_on(cv);
10834                 CvFILE(cv) = savepv(filename);
10835             } else {
10836             /* NOTE: not copied, as it is expected to be an external constant string */
10837                 CvFILE(cv) = (char *)filename;
10838             }
10839         } else {
10840             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10841             CvFILE(cv) = (char*)PL_xsubfilename;
10842         }
10843         CvISXSUB_on(cv);
10844         CvXSUB(cv) = subaddr;
10845 #ifndef PERL_IMPLICIT_CONTEXT
10846         CvHSCXT(cv) = &PL_stack_sp;
10847 #else
10848         PoisonPADLIST(cv);
10849 #endif
10850
10851         if (name)
10852             evanescent = process_special_blocks(0, name, gv, cv);
10853         else
10854             CvANON_on(cv);
10855     } /* <- not a conditional branch */
10856
10857     assert(cv);
10858     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10859
10860     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10861     if (interleave) LEAVE;
10862     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10863     return cv;
10864 }
10865
10866 /* Add a stub CV to a typeglob.
10867  * This is the implementation of a forward declaration, 'sub foo';'
10868  */
10869
10870 CV *
10871 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10872 {
10873     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10874     GV *cvgv;
10875     PERL_ARGS_ASSERT_NEWSTUB;
10876     assert(!GvCVu(gv));
10877     GvCV_set(gv, cv);
10878     GvCVGEN(gv) = 0;
10879     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10880         gv_method_changed(gv);
10881     if (SvFAKE(gv)) {
10882         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10883         SvFAKE_off(cvgv);
10884     }
10885     else cvgv = gv;
10886     CvGV_set(cv, cvgv);
10887     CvFILE_set_from_cop(cv, PL_curcop);
10888     CvSTASH_set(cv, PL_curstash);
10889     GvMULTI_on(gv);
10890     return cv;
10891 }
10892
10893 void
10894 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10895 {
10896     CV *cv;
10897     GV *gv;
10898     OP *root;
10899     OP *start;
10900
10901     if (PL_parser && PL_parser->error_count) {
10902         op_free(block);
10903         goto finish;
10904     }
10905
10906     gv = o
10907         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10908         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10909
10910     GvMULTI_on(gv);
10911     if ((cv = GvFORM(gv))) {
10912         if (ckWARN(WARN_REDEFINE)) {
10913             const line_t oldline = CopLINE(PL_curcop);
10914             if (PL_parser && PL_parser->copline != NOLINE)
10915                 CopLINE_set(PL_curcop, PL_parser->copline);
10916             if (o) {
10917                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10918                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10919             } else {
10920                 /* diag_listed_as: Format %s redefined */
10921                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10922                             "Format STDOUT redefined");
10923             }
10924             CopLINE_set(PL_curcop, oldline);
10925         }
10926         SvREFCNT_dec(cv);
10927     }
10928     cv = PL_compcv;
10929     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10930     CvGV_set(cv, gv);
10931     CvFILE_set_from_cop(cv, PL_curcop);
10932
10933
10934     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10935     CvROOT(cv) = root;
10936     start = LINKLIST(root);
10937     root->op_next = 0;
10938     S_process_optree(aTHX_ cv, root, start);
10939     cv_forget_slab(cv);
10940
10941   finish:
10942     op_free(o);
10943     if (PL_parser)
10944         PL_parser->copline = NOLINE;
10945     LEAVE_SCOPE(floor);
10946     PL_compiling.cop_seq = 0;
10947 }
10948
10949 OP *
10950 Perl_newANONLIST(pTHX_ OP *o)
10951 {
10952     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10953 }
10954
10955 OP *
10956 Perl_newANONHASH(pTHX_ OP *o)
10957 {
10958     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10959 }
10960
10961 OP *
10962 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10963 {
10964     return newANONATTRSUB(floor, proto, NULL, block);
10965 }
10966
10967 OP *
10968 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10969 {
10970     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10971     OP * anoncode =
10972         newSVOP(OP_ANONCODE, 0,
10973                 cv);
10974     if (CvANONCONST(cv))
10975         anoncode = newUNOP(OP_ANONCONST, 0,
10976                            op_convert_list(OP_ENTERSUB,
10977                                            OPf_STACKED|OPf_WANT_SCALAR,
10978                                            anoncode));
10979     return newUNOP(OP_REFGEN, 0, anoncode);
10980 }
10981
10982 OP *
10983 Perl_oopsAV(pTHX_ OP *o)
10984 {
10985     dVAR;
10986
10987     PERL_ARGS_ASSERT_OOPSAV;
10988
10989     switch (o->op_type) {
10990     case OP_PADSV:
10991     case OP_PADHV:
10992         OpTYPE_set(o, OP_PADAV);
10993         return ref(o, OP_RV2AV);
10994
10995     case OP_RV2SV:
10996     case OP_RV2HV:
10997         OpTYPE_set(o, OP_RV2AV);
10998         ref(o, OP_RV2AV);
10999         break;
11000
11001     default:
11002         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11003         break;
11004     }
11005     return o;
11006 }
11007
11008 OP *
11009 Perl_oopsHV(pTHX_ OP *o)
11010 {
11011     dVAR;
11012
11013     PERL_ARGS_ASSERT_OOPSHV;
11014
11015     switch (o->op_type) {
11016     case OP_PADSV:
11017     case OP_PADAV:
11018         OpTYPE_set(o, OP_PADHV);
11019         return ref(o, OP_RV2HV);
11020
11021     case OP_RV2SV:
11022     case OP_RV2AV:
11023         OpTYPE_set(o, OP_RV2HV);
11024         /* rv2hv steals the bottom bit for its own uses */
11025         o->op_private &= ~OPpARG1_MASK;
11026         ref(o, OP_RV2HV);
11027         break;
11028
11029     default:
11030         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11031         break;
11032     }
11033     return o;
11034 }
11035
11036 OP *
11037 Perl_newAVREF(pTHX_ OP *o)
11038 {
11039     dVAR;
11040
11041     PERL_ARGS_ASSERT_NEWAVREF;
11042
11043     if (o->op_type == OP_PADANY) {
11044         OpTYPE_set(o, OP_PADAV);
11045         return o;
11046     }
11047     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11048         Perl_croak(aTHX_ "Can't use an array as a reference");
11049     }
11050     return newUNOP(OP_RV2AV, 0, scalar(o));
11051 }
11052
11053 OP *
11054 Perl_newGVREF(pTHX_ I32 type, OP *o)
11055 {
11056     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11057         return newUNOP(OP_NULL, 0, o);
11058     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11059 }
11060
11061 OP *
11062 Perl_newHVREF(pTHX_ OP *o)
11063 {
11064     dVAR;
11065
11066     PERL_ARGS_ASSERT_NEWHVREF;
11067
11068     if (o->op_type == OP_PADANY) {
11069         OpTYPE_set(o, OP_PADHV);
11070         return o;
11071     }
11072     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11073         Perl_croak(aTHX_ "Can't use a hash as a reference");
11074     }
11075     return newUNOP(OP_RV2HV, 0, scalar(o));
11076 }
11077
11078 OP *
11079 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11080 {
11081     if (o->op_type == OP_PADANY) {
11082         dVAR;
11083         OpTYPE_set(o, OP_PADCV);
11084     }
11085     return newUNOP(OP_RV2CV, flags, scalar(o));
11086 }
11087
11088 OP *
11089 Perl_newSVREF(pTHX_ OP *o)
11090 {
11091     dVAR;
11092
11093     PERL_ARGS_ASSERT_NEWSVREF;
11094
11095     if (o->op_type == OP_PADANY) {
11096         OpTYPE_set(o, OP_PADSV);
11097         scalar(o);
11098         return o;
11099     }
11100     return newUNOP(OP_RV2SV, 0, scalar(o));
11101 }
11102
11103 /* Check routines. See the comments at the top of this file for details
11104  * on when these are called */
11105
11106 OP *
11107 Perl_ck_anoncode(pTHX_ OP *o)
11108 {
11109     PERL_ARGS_ASSERT_CK_ANONCODE;
11110
11111     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11112     cSVOPo->op_sv = NULL;
11113     return o;
11114 }
11115
11116 static void
11117 S_io_hints(pTHX_ OP *o)
11118 {
11119 #if O_BINARY != 0 || O_TEXT != 0
11120     HV * const table =
11121         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11122     if (table) {
11123         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11124         if (svp && *svp) {
11125             STRLEN len = 0;
11126             const char *d = SvPV_const(*svp, len);
11127             const I32 mode = mode_from_discipline(d, len);
11128             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11129 #  if O_BINARY != 0
11130             if (mode & O_BINARY)
11131                 o->op_private |= OPpOPEN_IN_RAW;
11132 #  endif
11133 #  if O_TEXT != 0
11134             if (mode & O_TEXT)
11135                 o->op_private |= OPpOPEN_IN_CRLF;
11136 #  endif
11137         }
11138
11139         svp = hv_fetchs(table, "open_OUT", FALSE);
11140         if (svp && *svp) {
11141             STRLEN len = 0;
11142             const char *d = SvPV_const(*svp, len);
11143             const I32 mode = mode_from_discipline(d, len);
11144             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11145 #  if O_BINARY != 0
11146             if (mode & O_BINARY)
11147                 o->op_private |= OPpOPEN_OUT_RAW;
11148 #  endif
11149 #  if O_TEXT != 0
11150             if (mode & O_TEXT)
11151                 o->op_private |= OPpOPEN_OUT_CRLF;
11152 #  endif
11153         }
11154     }
11155 #else
11156     PERL_UNUSED_CONTEXT;
11157     PERL_UNUSED_ARG(o);
11158 #endif
11159 }
11160
11161 OP *
11162 Perl_ck_backtick(pTHX_ OP *o)
11163 {
11164     GV *gv;
11165     OP *newop = NULL;
11166     OP *sibl;
11167     PERL_ARGS_ASSERT_CK_BACKTICK;
11168     o = ck_fun(o);
11169     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11170     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11171      && (gv = gv_override("readpipe",8)))
11172     {
11173         /* detach rest of siblings from o and its first child */
11174         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11175         newop = S_new_entersubop(aTHX_ gv, sibl);
11176     }
11177     else if (!(o->op_flags & OPf_KIDS))
11178         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11179     if (newop) {
11180         op_free(o);
11181         return newop;
11182     }
11183     S_io_hints(aTHX_ o);
11184     return o;
11185 }
11186
11187 OP *
11188 Perl_ck_bitop(pTHX_ OP *o)
11189 {
11190     PERL_ARGS_ASSERT_CK_BITOP;
11191
11192     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11193
11194     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11195             && OP_IS_INFIX_BIT(o->op_type))
11196     {
11197         const OP * const left = cBINOPo->op_first;
11198         const OP * const right = OpSIBLING(left);
11199         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11200                 (left->op_flags & OPf_PARENS) == 0) ||
11201             (OP_IS_NUMCOMPARE(right->op_type) &&
11202                 (right->op_flags & OPf_PARENS) == 0))
11203             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11204                           "Possible precedence problem on bitwise %s operator",
11205                            o->op_type ==  OP_BIT_OR
11206                          ||o->op_type == OP_NBIT_OR  ? "|"
11207                         :  o->op_type ==  OP_BIT_AND
11208                          ||o->op_type == OP_NBIT_AND ? "&"
11209                         :  o->op_type ==  OP_BIT_XOR
11210                          ||o->op_type == OP_NBIT_XOR ? "^"
11211                         :  o->op_type == OP_SBIT_OR  ? "|."
11212                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11213                            );
11214     }
11215     return o;
11216 }
11217
11218 PERL_STATIC_INLINE bool
11219 is_dollar_bracket(pTHX_ const OP * const o)
11220 {
11221     const OP *kid;
11222     PERL_UNUSED_CONTEXT;
11223     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11224         && (kid = cUNOPx(o)->op_first)
11225         && kid->op_type == OP_GV
11226         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11227 }
11228
11229 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11230
11231 OP *
11232 Perl_ck_cmp(pTHX_ OP *o)
11233 {
11234     bool is_eq;
11235     bool neg;
11236     bool reverse;
11237     bool iv0;
11238     OP *indexop, *constop, *start;
11239     SV *sv;
11240     IV iv;
11241
11242     PERL_ARGS_ASSERT_CK_CMP;
11243
11244     is_eq = (   o->op_type == OP_EQ
11245              || o->op_type == OP_NE
11246              || o->op_type == OP_I_EQ
11247              || o->op_type == OP_I_NE);
11248
11249     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11250         const OP *kid = cUNOPo->op_first;
11251         if (kid &&
11252             (
11253                 (   is_dollar_bracket(aTHX_ kid)
11254                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11255                 )
11256              || (   kid->op_type == OP_CONST
11257                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11258                 )
11259            )
11260         )
11261             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11262                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11263     }
11264
11265     /* convert (index(...) == -1) and variations into
11266      *   (r)index/BOOL(,NEG)
11267      */
11268
11269     reverse = FALSE;
11270
11271     indexop = cUNOPo->op_first;
11272     constop = OpSIBLING(indexop);
11273     start = NULL;
11274     if (indexop->op_type == OP_CONST) {
11275         constop = indexop;
11276         indexop = OpSIBLING(constop);
11277         start = constop;
11278         reverse = TRUE;
11279     }
11280
11281     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11282         return o;
11283
11284     /* ($lex = index(....)) == -1 */
11285     if (indexop->op_private & OPpTARGET_MY)
11286         return o;
11287
11288     if (constop->op_type != OP_CONST)
11289         return o;
11290
11291     sv = cSVOPx_sv(constop);
11292     if (!(sv && SvIOK_notUV(sv)))
11293         return o;
11294
11295     iv = SvIVX(sv);
11296     if (iv != -1 && iv != 0)
11297         return o;
11298     iv0 = (iv == 0);
11299
11300     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11301         if (!(iv0 ^ reverse))
11302             return o;
11303         neg = iv0;
11304     }
11305     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11306         if (iv0 ^ reverse)
11307             return o;
11308         neg = !iv0;
11309     }
11310     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11311         if (!(iv0 ^ reverse))
11312             return o;
11313         neg = !iv0;
11314     }
11315     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11316         if (iv0 ^ reverse)
11317             return o;
11318         neg = iv0;
11319     }
11320     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11321         if (iv0)
11322             return o;
11323         neg = TRUE;
11324     }
11325     else {
11326         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11327         if (iv0)
11328             return o;
11329         neg = FALSE;
11330     }
11331
11332     indexop->op_flags &= ~OPf_PARENS;
11333     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11334     indexop->op_private |= OPpTRUEBOOL;
11335     if (neg)
11336         indexop->op_private |= OPpINDEX_BOOLNEG;
11337     /* cut out the index op and free the eq,const ops */
11338     (void)op_sibling_splice(o, start, 1, NULL);
11339     op_free(o);
11340
11341     return indexop;
11342 }
11343
11344
11345 OP *
11346 Perl_ck_concat(pTHX_ OP *o)
11347 {
11348     const OP * const kid = cUNOPo->op_first;
11349
11350     PERL_ARGS_ASSERT_CK_CONCAT;
11351     PERL_UNUSED_CONTEXT;
11352
11353     /* reuse the padtmp returned by the concat child */
11354     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11355             !(kUNOP->op_first->op_flags & OPf_MOD))
11356     {
11357         o->op_flags |= OPf_STACKED;
11358         o->op_private |= OPpCONCAT_NESTED;
11359     }
11360     return o;
11361 }
11362
11363 OP *
11364 Perl_ck_spair(pTHX_ OP *o)
11365 {
11366     dVAR;
11367
11368     PERL_ARGS_ASSERT_CK_SPAIR;
11369
11370     if (o->op_flags & OPf_KIDS) {
11371         OP* newop;
11372         OP* kid;
11373         OP* kidkid;
11374         const OPCODE type = o->op_type;
11375         o = modkids(ck_fun(o), type);
11376         kid    = cUNOPo->op_first;
11377         kidkid = kUNOP->op_first;
11378         newop = OpSIBLING(kidkid);
11379         if (newop) {
11380             const OPCODE type = newop->op_type;
11381             if (OpHAS_SIBLING(newop))
11382                 return o;
11383             if (o->op_type == OP_REFGEN
11384              && (  type == OP_RV2CV
11385                 || (  !(newop->op_flags & OPf_PARENS)
11386                    && (  type == OP_RV2AV || type == OP_PADAV
11387                       || type == OP_RV2HV || type == OP_PADHV))))
11388                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11389             else if (OP_GIMME(newop,0) != G_SCALAR)
11390                 return o;
11391         }
11392         /* excise first sibling */
11393         op_sibling_splice(kid, NULL, 1, NULL);
11394         op_free(kidkid);
11395     }
11396     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11397      * and OP_CHOMP into OP_SCHOMP */
11398     o->op_ppaddr = PL_ppaddr[++o->op_type];
11399     return ck_fun(o);
11400 }
11401
11402 OP *
11403 Perl_ck_delete(pTHX_ OP *o)
11404 {
11405     PERL_ARGS_ASSERT_CK_DELETE;
11406
11407     o = ck_fun(o);
11408     o->op_private = 0;
11409     if (o->op_flags & OPf_KIDS) {
11410         OP * const kid = cUNOPo->op_first;
11411         switch (kid->op_type) {
11412         case OP_ASLICE:
11413             o->op_flags |= OPf_SPECIAL;
11414             /* FALLTHROUGH */
11415         case OP_HSLICE:
11416             o->op_private |= OPpSLICE;
11417             break;
11418         case OP_AELEM:
11419             o->op_flags |= OPf_SPECIAL;
11420             /* FALLTHROUGH */
11421         case OP_HELEM:
11422             break;
11423         case OP_KVASLICE:
11424             o->op_flags |= OPf_SPECIAL;
11425             /* FALLTHROUGH */
11426         case OP_KVHSLICE:
11427             o->op_private |= OPpKVSLICE;
11428             break;
11429         default:
11430             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11431                              "element or slice");
11432         }
11433         if (kid->op_private & OPpLVAL_INTRO)
11434             o->op_private |= OPpLVAL_INTRO;
11435         op_null(kid);
11436     }
11437     return o;
11438 }
11439
11440 OP *
11441 Perl_ck_eof(pTHX_ OP *o)
11442 {
11443     PERL_ARGS_ASSERT_CK_EOF;
11444
11445     if (o->op_flags & OPf_KIDS) {
11446         OP *kid;
11447         if (cLISTOPo->op_first->op_type == OP_STUB) {
11448             OP * const newop
11449                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11450             op_free(o);
11451             o = newop;
11452         }
11453         o = ck_fun(o);
11454         kid = cLISTOPo->op_first;
11455         if (kid->op_type == OP_RV2GV)
11456             kid->op_private |= OPpALLOW_FAKE;
11457     }
11458     return o;
11459 }
11460
11461
11462 OP *
11463 Perl_ck_eval(pTHX_ OP *o)
11464 {
11465     dVAR;
11466
11467     PERL_ARGS_ASSERT_CK_EVAL;
11468
11469     PL_hints |= HINT_BLOCK_SCOPE;
11470     if (o->op_flags & OPf_KIDS) {
11471         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11472         assert(kid);
11473
11474         if (o->op_type == OP_ENTERTRY) {
11475             LOGOP *enter;
11476
11477             /* cut whole sibling chain free from o */
11478             op_sibling_splice(o, NULL, -1, NULL);
11479             op_free(o);
11480
11481             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11482
11483             /* establish postfix order */
11484             enter->op_next = (OP*)enter;
11485
11486             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11487             OpTYPE_set(o, OP_LEAVETRY);
11488             enter->op_other = o;
11489             return o;
11490         }
11491         else {
11492             scalar((OP*)kid);
11493             S_set_haseval(aTHX);
11494         }
11495     }
11496     else {
11497         const U8 priv = o->op_private;
11498         op_free(o);
11499         /* the newUNOP will recursively call ck_eval(), which will handle
11500          * all the stuff at the end of this function, like adding
11501          * OP_HINTSEVAL
11502          */
11503         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11504     }
11505     o->op_targ = (PADOFFSET)PL_hints;
11506     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11507     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11508      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11509         /* Store a copy of %^H that pp_entereval can pick up. */
11510         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11511                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11512         /* append hhop to only child  */
11513         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11514
11515         o->op_private |= OPpEVAL_HAS_HH;
11516     }
11517     if (!(o->op_private & OPpEVAL_BYTES)
11518          && FEATURE_UNIEVAL_IS_ENABLED)
11519             o->op_private |= OPpEVAL_UNICODE;
11520     return o;
11521 }
11522
11523 OP *
11524 Perl_ck_exec(pTHX_ OP *o)
11525 {
11526     PERL_ARGS_ASSERT_CK_EXEC;
11527
11528     if (o->op_flags & OPf_STACKED) {
11529         OP *kid;
11530         o = ck_fun(o);
11531         kid = OpSIBLING(cUNOPo->op_first);
11532         if (kid->op_type == OP_RV2GV)
11533             op_null(kid);
11534     }
11535     else
11536         o = listkids(o);
11537     return o;
11538 }
11539
11540 OP *
11541 Perl_ck_exists(pTHX_ OP *o)
11542 {
11543     PERL_ARGS_ASSERT_CK_EXISTS;
11544
11545     o = ck_fun(o);
11546     if (o->op_flags & OPf_KIDS) {
11547         OP * const kid = cUNOPo->op_first;
11548         if (kid->op_type == OP_ENTERSUB) {
11549             (void) ref(kid, o->op_type);
11550             if (kid->op_type != OP_RV2CV
11551                         && !(PL_parser && PL_parser->error_count))
11552                 Perl_croak(aTHX_
11553                           "exists argument is not a subroutine name");
11554             o->op_private |= OPpEXISTS_SUB;
11555         }
11556         else if (kid->op_type == OP_AELEM)
11557             o->op_flags |= OPf_SPECIAL;
11558         else if (kid->op_type != OP_HELEM)
11559             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11560                              "element or a subroutine");
11561         op_null(kid);
11562     }
11563     return o;
11564 }
11565
11566 OP *
11567 Perl_ck_rvconst(pTHX_ OP *o)
11568 {
11569     dVAR;
11570     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11571
11572     PERL_ARGS_ASSERT_CK_RVCONST;
11573
11574     if (o->op_type == OP_RV2HV)
11575         /* rv2hv steals the bottom bit for its own uses */
11576         o->op_private &= ~OPpARG1_MASK;
11577
11578     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11579
11580     if (kid->op_type == OP_CONST) {
11581         int iscv;
11582         GV *gv;
11583         SV * const kidsv = kid->op_sv;
11584
11585         /* Is it a constant from cv_const_sv()? */
11586         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11587             return o;
11588         }
11589         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11590         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11591             const char *badthing;
11592             switch (o->op_type) {
11593             case OP_RV2SV:
11594                 badthing = "a SCALAR";
11595                 break;
11596             case OP_RV2AV:
11597                 badthing = "an ARRAY";
11598                 break;
11599             case OP_RV2HV:
11600                 badthing = "a HASH";
11601                 break;
11602             default:
11603                 badthing = NULL;
11604                 break;
11605             }
11606             if (badthing)
11607                 Perl_croak(aTHX_
11608                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11609                            SVfARG(kidsv), badthing);
11610         }
11611         /*
11612          * This is a little tricky.  We only want to add the symbol if we
11613          * didn't add it in the lexer.  Otherwise we get duplicate strict
11614          * warnings.  But if we didn't add it in the lexer, we must at
11615          * least pretend like we wanted to add it even if it existed before,
11616          * or we get possible typo warnings.  OPpCONST_ENTERED says
11617          * whether the lexer already added THIS instance of this symbol.
11618          */
11619         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11620         gv = gv_fetchsv(kidsv,
11621                 o->op_type == OP_RV2CV
11622                         && o->op_private & OPpMAY_RETURN_CONSTANT
11623                     ? GV_NOEXPAND
11624                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11625                 iscv
11626                     ? SVt_PVCV
11627                     : o->op_type == OP_RV2SV
11628                         ? SVt_PV
11629                         : o->op_type == OP_RV2AV
11630                             ? SVt_PVAV
11631                             : o->op_type == OP_RV2HV
11632                                 ? SVt_PVHV
11633                                 : SVt_PVGV);
11634         if (gv) {
11635             if (!isGV(gv)) {
11636                 assert(iscv);
11637                 assert(SvROK(gv));
11638                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11639                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11640                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11641             }
11642             OpTYPE_set(kid, OP_GV);
11643             SvREFCNT_dec(kid->op_sv);
11644 #ifdef USE_ITHREADS
11645             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11646             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11647             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11648             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11649             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11650 #else
11651             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11652 #endif
11653             kid->op_private = 0;
11654             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11655             SvFAKE_off(gv);
11656         }
11657     }
11658     return o;
11659 }
11660
11661 OP *
11662 Perl_ck_ftst(pTHX_ OP *o)
11663 {
11664     dVAR;
11665     const I32 type = o->op_type;
11666
11667     PERL_ARGS_ASSERT_CK_FTST;
11668
11669     if (o->op_flags & OPf_REF) {
11670         NOOP;
11671     }
11672     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11673         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11674         const OPCODE kidtype = kid->op_type;
11675
11676         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11677          && !kid->op_folded) {
11678             OP * const newop = newGVOP(type, OPf_REF,
11679                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11680             op_free(o);
11681             return newop;
11682         }
11683
11684         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11685             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11686             if (name) {
11687                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11688                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11689                             array_passed_to_stat, name);
11690             }
11691             else {
11692                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11693                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11694             }
11695        }
11696         scalar((OP *) kid);
11697         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11698             o->op_private |= OPpFT_ACCESS;
11699         if (type != OP_STAT && type != OP_LSTAT
11700             && PL_check[kidtype] == Perl_ck_ftst
11701             && kidtype != OP_STAT && kidtype != OP_LSTAT
11702         ) {
11703             o->op_private |= OPpFT_STACKED;
11704             kid->op_private |= OPpFT_STACKING;
11705             if (kidtype == OP_FTTTY && (
11706                    !(kid->op_private & OPpFT_STACKED)
11707                 || kid->op_private & OPpFT_AFTER_t
11708                ))
11709                 o->op_private |= OPpFT_AFTER_t;
11710         }
11711     }
11712     else {
11713         op_free(o);
11714         if (type == OP_FTTTY)
11715             o = newGVOP(type, OPf_REF, PL_stdingv);
11716         else
11717             o = newUNOP(type, 0, newDEFSVOP());
11718     }
11719     return o;
11720 }
11721
11722 OP *
11723 Perl_ck_fun(pTHX_ OP *o)
11724 {
11725     const int type = o->op_type;
11726     I32 oa = PL_opargs[type] >> OASHIFT;
11727
11728     PERL_ARGS_ASSERT_CK_FUN;
11729
11730     if (o->op_flags & OPf_STACKED) {
11731         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11732             oa &= ~OA_OPTIONAL;
11733         else
11734             return no_fh_allowed(o);
11735     }
11736
11737     if (o->op_flags & OPf_KIDS) {
11738         OP *prev_kid = NULL;
11739         OP *kid = cLISTOPo->op_first;
11740         I32 numargs = 0;
11741         bool seen_optional = FALSE;
11742
11743         if (kid->op_type == OP_PUSHMARK ||
11744             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11745         {
11746             prev_kid = kid;
11747             kid = OpSIBLING(kid);
11748         }
11749         if (kid && kid->op_type == OP_COREARGS) {
11750             bool optional = FALSE;
11751             while (oa) {
11752                 numargs++;
11753                 if (oa & OA_OPTIONAL) optional = TRUE;
11754                 oa = oa >> 4;
11755             }
11756             if (optional) o->op_private |= numargs;
11757             return o;
11758         }
11759
11760         while (oa) {
11761             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11762                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11763                     kid = newDEFSVOP();
11764                     /* append kid to chain */
11765                     op_sibling_splice(o, prev_kid, 0, kid);
11766                 }
11767                 seen_optional = TRUE;
11768             }
11769             if (!kid) break;
11770
11771             numargs++;
11772             switch (oa & 7) {
11773             case OA_SCALAR:
11774                 /* list seen where single (scalar) arg expected? */
11775                 if (numargs == 1 && !(oa >> 4)
11776                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11777                 {
11778                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11779                 }
11780                 if (type != OP_DELETE) scalar(kid);
11781                 break;
11782             case OA_LIST:
11783                 if (oa < 16) {
11784                     kid = 0;
11785                     continue;
11786                 }
11787                 else
11788                     list(kid);
11789                 break;
11790             case OA_AVREF:
11791                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11792                     && !OpHAS_SIBLING(kid))
11793                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11794                                    "Useless use of %s with no values",
11795                                    PL_op_desc[type]);
11796
11797                 if (kid->op_type == OP_CONST
11798                       && (  !SvROK(cSVOPx_sv(kid))
11799                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11800                         )
11801                     bad_type_pv(numargs, "array", o, kid);
11802                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11803                          || kid->op_type == OP_RV2GV) {
11804                     bad_type_pv(1, "array", o, kid);
11805                 }
11806                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11807                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11808                                          PL_op_desc[type]), 0);
11809                 }
11810                 else {
11811                     op_lvalue(kid, type);
11812                 }
11813                 break;
11814             case OA_HVREF:
11815                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11816                     bad_type_pv(numargs, "hash", o, kid);
11817                 op_lvalue(kid, type);
11818                 break;
11819             case OA_CVREF:
11820                 {
11821                     /* replace kid with newop in chain */
11822                     OP * const newop =
11823                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11824                     newop->op_next = newop;
11825                     kid = newop;
11826                 }
11827                 break;
11828             case OA_FILEREF:
11829                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11830                     if (kid->op_type == OP_CONST &&
11831                         (kid->op_private & OPpCONST_BARE))
11832                     {
11833                         OP * const newop = newGVOP(OP_GV, 0,
11834                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11835                         /* replace kid with newop in chain */
11836                         op_sibling_splice(o, prev_kid, 1, newop);
11837                         op_free(kid);
11838                         kid = newop;
11839                     }
11840                     else if (kid->op_type == OP_READLINE) {
11841                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11842                         bad_type_pv(numargs, "HANDLE", o, kid);
11843                     }
11844                     else {
11845                         I32 flags = OPf_SPECIAL;
11846                         I32 priv = 0;
11847                         PADOFFSET targ = 0;
11848
11849                         /* is this op a FH constructor? */
11850                         if (is_handle_constructor(o,numargs)) {
11851                             const char *name = NULL;
11852                             STRLEN len = 0;
11853                             U32 name_utf8 = 0;
11854                             bool want_dollar = TRUE;
11855
11856                             flags = 0;
11857                             /* Set a flag to tell rv2gv to vivify
11858                              * need to "prove" flag does not mean something
11859                              * else already - NI-S 1999/05/07
11860                              */
11861                             priv = OPpDEREF;
11862                             if (kid->op_type == OP_PADSV) {
11863                                 PADNAME * const pn
11864                                     = PAD_COMPNAME_SV(kid->op_targ);
11865                                 name = PadnamePV (pn);
11866                                 len  = PadnameLEN(pn);
11867                                 name_utf8 = PadnameUTF8(pn);
11868                             }
11869                             else if (kid->op_type == OP_RV2SV
11870                                      && kUNOP->op_first->op_type == OP_GV)
11871                             {
11872                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11873                                 name = GvNAME(gv);
11874                                 len = GvNAMELEN(gv);
11875                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11876                             }
11877                             else if (kid->op_type == OP_AELEM
11878                                      || kid->op_type == OP_HELEM)
11879                             {
11880                                  OP *firstop;
11881                                  OP *op = ((BINOP*)kid)->op_first;
11882                                  name = NULL;
11883                                  if (op) {
11884                                       SV *tmpstr = NULL;
11885                                       const char * const a =
11886                                            kid->op_type == OP_AELEM ?
11887                                            "[]" : "{}";
11888                                       if (((op->op_type == OP_RV2AV) ||
11889                                            (op->op_type == OP_RV2HV)) &&
11890                                           (firstop = ((UNOP*)op)->op_first) &&
11891                                           (firstop->op_type == OP_GV)) {
11892                                            /* packagevar $a[] or $h{} */
11893                                            GV * const gv = cGVOPx_gv(firstop);
11894                                            if (gv)
11895                                                 tmpstr =
11896                                                      Perl_newSVpvf(aTHX_
11897                                                                    "%s%c...%c",
11898                                                                    GvNAME(gv),
11899                                                                    a[0], a[1]);
11900                                       }
11901                                       else if (op->op_type == OP_PADAV
11902                                                || op->op_type == OP_PADHV) {
11903                                            /* lexicalvar $a[] or $h{} */
11904                                            const char * const padname =
11905                                                 PAD_COMPNAME_PV(op->op_targ);
11906                                            if (padname)
11907                                                 tmpstr =
11908                                                      Perl_newSVpvf(aTHX_
11909                                                                    "%s%c...%c",
11910                                                                    padname + 1,
11911                                                                    a[0], a[1]);
11912                                       }
11913                                       if (tmpstr) {
11914                                            name = SvPV_const(tmpstr, len);
11915                                            name_utf8 = SvUTF8(tmpstr);
11916                                            sv_2mortal(tmpstr);
11917                                       }
11918                                  }
11919                                  if (!name) {
11920                                       name = "__ANONIO__";
11921                                       len = 10;
11922                                       want_dollar = FALSE;
11923                                  }
11924                                  op_lvalue(kid, type);
11925                             }
11926                             if (name) {
11927                                 SV *namesv;
11928                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11929                                 namesv = PAD_SVl(targ);
11930                                 if (want_dollar && *name != '$')
11931                                     sv_setpvs(namesv, "$");
11932                                 else
11933                                     SvPVCLEAR(namesv);
11934                                 sv_catpvn(namesv, name, len);
11935                                 if ( name_utf8 ) SvUTF8_on(namesv);
11936                             }
11937                         }
11938                         scalar(kid);
11939                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11940                                     OP_RV2GV, flags);
11941                         kid->op_targ = targ;
11942                         kid->op_private |= priv;
11943                     }
11944                 }
11945                 scalar(kid);
11946                 break;
11947             case OA_SCALARREF:
11948                 if ((type == OP_UNDEF || type == OP_POS)
11949                     && numargs == 1 && !(oa >> 4)
11950                     && kid->op_type == OP_LIST)
11951                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11952                 op_lvalue(scalar(kid), type);
11953                 break;
11954             }
11955             oa >>= 4;
11956             prev_kid = kid;
11957             kid = OpSIBLING(kid);
11958         }
11959         /* FIXME - should the numargs or-ing move after the too many
11960          * arguments check? */
11961         o->op_private |= numargs;
11962         if (kid)
11963             return too_many_arguments_pv(o,OP_DESC(o), 0);
11964         listkids(o);
11965     }
11966     else if (PL_opargs[type] & OA_DEFGV) {
11967         /* Ordering of these two is important to keep f_map.t passing.  */
11968         op_free(o);
11969         return newUNOP(type, 0, newDEFSVOP());
11970     }
11971
11972     if (oa) {
11973         while (oa & OA_OPTIONAL)
11974             oa >>= 4;
11975         if (oa && oa != OA_LIST)
11976             return too_few_arguments_pv(o,OP_DESC(o), 0);
11977     }
11978     return o;
11979 }
11980
11981 OP *
11982 Perl_ck_glob(pTHX_ OP *o)
11983 {
11984     GV *gv;
11985
11986     PERL_ARGS_ASSERT_CK_GLOB;
11987
11988     o = ck_fun(o);
11989     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11990         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11991
11992     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11993     {
11994         /* convert
11995          *     glob
11996          *       \ null - const(wildcard)
11997          * into
11998          *     null
11999          *       \ enter
12000          *            \ list
12001          *                 \ mark - glob - rv2cv
12002          *                             |        \ gv(CORE::GLOBAL::glob)
12003          *                             |
12004          *                              \ null - const(wildcard)
12005          */
12006         o->op_flags |= OPf_SPECIAL;
12007         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12008         o = S_new_entersubop(aTHX_ gv, o);
12009         o = newUNOP(OP_NULL, 0, o);
12010         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12011         return o;
12012     }
12013     else o->op_flags &= ~OPf_SPECIAL;
12014 #if !defined(PERL_EXTERNAL_GLOB)
12015     if (!PL_globhook) {
12016         ENTER;
12017         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12018                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12019         LEAVE;
12020     }
12021 #endif /* !PERL_EXTERNAL_GLOB */
12022     gv = (GV *)newSV(0);
12023     gv_init(gv, 0, "", 0, 0);
12024     gv_IOadd(gv);
12025     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12026     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12027     scalarkids(o);
12028     return o;
12029 }
12030
12031 OP *
12032 Perl_ck_grep(pTHX_ OP *o)
12033 {
12034     LOGOP *gwop;
12035     OP *kid;
12036     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12037
12038     PERL_ARGS_ASSERT_CK_GREP;
12039
12040     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12041
12042     if (o->op_flags & OPf_STACKED) {
12043         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12044         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12045             return no_fh_allowed(o);
12046         o->op_flags &= ~OPf_STACKED;
12047     }
12048     kid = OpSIBLING(cLISTOPo->op_first);
12049     if (type == OP_MAPWHILE)
12050         list(kid);
12051     else
12052         scalar(kid);
12053     o = ck_fun(o);
12054     if (PL_parser && PL_parser->error_count)
12055         return o;
12056     kid = OpSIBLING(cLISTOPo->op_first);
12057     if (kid->op_type != OP_NULL)
12058         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12059     kid = kUNOP->op_first;
12060
12061     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12062     kid->op_next = (OP*)gwop;
12063     o->op_private = gwop->op_private = 0;
12064     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12065
12066     kid = OpSIBLING(cLISTOPo->op_first);
12067     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12068         op_lvalue(kid, OP_GREPSTART);
12069
12070     return (OP*)gwop;
12071 }
12072
12073 OP *
12074 Perl_ck_index(pTHX_ OP *o)
12075 {
12076     PERL_ARGS_ASSERT_CK_INDEX;
12077
12078     if (o->op_flags & OPf_KIDS) {
12079         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12080         if (kid)
12081             kid = OpSIBLING(kid);                       /* get past "big" */
12082         if (kid && kid->op_type == OP_CONST) {
12083             const bool save_taint = TAINT_get;
12084             SV *sv = kSVOP->op_sv;
12085             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12086                 && SvOK(sv) && !SvROK(sv))
12087             {
12088                 sv = newSV(0);
12089                 sv_copypv(sv, kSVOP->op_sv);
12090                 SvREFCNT_dec_NN(kSVOP->op_sv);
12091                 kSVOP->op_sv = sv;
12092             }
12093             if (SvOK(sv)) fbm_compile(sv, 0);
12094             TAINT_set(save_taint);
12095 #ifdef NO_TAINT_SUPPORT
12096             PERL_UNUSED_VAR(save_taint);
12097 #endif
12098         }
12099     }
12100     return ck_fun(o);
12101 }
12102
12103 OP *
12104 Perl_ck_lfun(pTHX_ OP *o)
12105 {
12106     const OPCODE type = o->op_type;
12107
12108     PERL_ARGS_ASSERT_CK_LFUN;
12109
12110     return modkids(ck_fun(o), type);
12111 }
12112
12113 OP *
12114 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12115 {
12116     PERL_ARGS_ASSERT_CK_DEFINED;
12117
12118     if ((o->op_flags & OPf_KIDS)) {
12119         switch (cUNOPo->op_first->op_type) {
12120         case OP_RV2AV:
12121         case OP_PADAV:
12122             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12123                              " (Maybe you should just omit the defined()?)");
12124             NOT_REACHED; /* NOTREACHED */
12125             break;
12126         case OP_RV2HV:
12127         case OP_PADHV:
12128             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12129                              " (Maybe you should just omit the defined()?)");
12130             NOT_REACHED; /* NOTREACHED */
12131             break;
12132         default:
12133             /* no warning */
12134             break;
12135         }
12136     }
12137     return ck_rfun(o);
12138 }
12139
12140 OP *
12141 Perl_ck_readline(pTHX_ OP *o)
12142 {
12143     PERL_ARGS_ASSERT_CK_READLINE;
12144
12145     if (o->op_flags & OPf_KIDS) {
12146          OP *kid = cLISTOPo->op_first;
12147          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12148     }
12149     else {
12150         OP * const newop
12151             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12152         op_free(o);
12153         return newop;
12154     }
12155     return o;
12156 }
12157
12158 OP *
12159 Perl_ck_rfun(pTHX_ OP *o)
12160 {
12161     const OPCODE type = o->op_type;
12162
12163     PERL_ARGS_ASSERT_CK_RFUN;
12164
12165     return refkids(ck_fun(o), type);
12166 }
12167
12168 OP *
12169 Perl_ck_listiob(pTHX_ OP *o)
12170 {
12171     OP *kid;
12172
12173     PERL_ARGS_ASSERT_CK_LISTIOB;
12174
12175     kid = cLISTOPo->op_first;
12176     if (!kid) {
12177         o = force_list(o, 1);
12178         kid = cLISTOPo->op_first;
12179     }
12180     if (kid->op_type == OP_PUSHMARK)
12181         kid = OpSIBLING(kid);
12182     if (kid && o->op_flags & OPf_STACKED)
12183         kid = OpSIBLING(kid);
12184     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12185         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12186          && !kid->op_folded) {
12187             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12188             scalar(kid);
12189             /* replace old const op with new OP_RV2GV parent */
12190             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12191                                         OP_RV2GV, OPf_REF);
12192             kid = OpSIBLING(kid);
12193         }
12194     }
12195
12196     if (!kid)
12197         op_append_elem(o->op_type, o, newDEFSVOP());
12198
12199     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12200     return listkids(o);
12201 }
12202
12203 OP *
12204 Perl_ck_smartmatch(pTHX_ OP *o)
12205 {
12206     dVAR;
12207     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12208     if (0 == (o->op_flags & OPf_SPECIAL)) {
12209         OP *first  = cBINOPo->op_first;
12210         OP *second = OpSIBLING(first);
12211
12212         /* Implicitly take a reference to an array or hash */
12213
12214         /* remove the original two siblings, then add back the
12215          * (possibly different) first and second sibs.
12216          */
12217         op_sibling_splice(o, NULL, 1, NULL);
12218         op_sibling_splice(o, NULL, 1, NULL);
12219         first  = ref_array_or_hash(first);
12220         second = ref_array_or_hash(second);
12221         op_sibling_splice(o, NULL, 0, second);
12222         op_sibling_splice(o, NULL, 0, first);
12223
12224         /* Implicitly take a reference to a regular expression */
12225         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12226             OpTYPE_set(first, OP_QR);
12227         }
12228         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12229             OpTYPE_set(second, OP_QR);
12230         }
12231     }
12232
12233     return o;
12234 }
12235
12236
12237 static OP *
12238 S_maybe_targlex(pTHX_ OP *o)
12239 {
12240     OP * const kid = cLISTOPo->op_first;
12241     /* has a disposable target? */
12242     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12243         && !(kid->op_flags & OPf_STACKED)
12244         /* Cannot steal the second time! */
12245         && !(kid->op_private & OPpTARGET_MY)
12246         )
12247     {
12248         OP * const kkid = OpSIBLING(kid);
12249
12250         /* Can just relocate the target. */
12251         if (kkid && kkid->op_type == OP_PADSV
12252             && (!(kkid->op_private & OPpLVAL_INTRO)
12253                || kkid->op_private & OPpPAD_STATE))
12254         {
12255             kid->op_targ = kkid->op_targ;
12256             kkid->op_targ = 0;
12257             /* Now we do not need PADSV and SASSIGN.
12258              * Detach kid and free the rest. */
12259             op_sibling_splice(o, NULL, 1, NULL);
12260             op_free(o);
12261             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12262             return kid;
12263         }
12264     }
12265     return o;
12266 }
12267
12268 OP *
12269 Perl_ck_sassign(pTHX_ OP *o)
12270 {
12271     dVAR;
12272     OP * const kid = cBINOPo->op_first;
12273
12274     PERL_ARGS_ASSERT_CK_SASSIGN;
12275
12276     if (OpHAS_SIBLING(kid)) {
12277         OP *kkid = OpSIBLING(kid);
12278         /* For state variable assignment with attributes, kkid is a list op
12279            whose op_last is a padsv. */
12280         if ((kkid->op_type == OP_PADSV ||
12281              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12282               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12283              )
12284             )
12285                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12286                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12287             return S_newONCEOP(aTHX_ o, kkid);
12288         }
12289     }
12290     return S_maybe_targlex(aTHX_ o);
12291 }
12292
12293
12294 OP *
12295 Perl_ck_match(pTHX_ OP *o)
12296 {
12297     PERL_UNUSED_CONTEXT;
12298     PERL_ARGS_ASSERT_CK_MATCH;
12299
12300     return o;
12301 }
12302
12303 OP *
12304 Perl_ck_method(pTHX_ OP *o)
12305 {
12306     SV *sv, *methsv, *rclass;
12307     const char* method;
12308     char* compatptr;
12309     int utf8;
12310     STRLEN len, nsplit = 0, i;
12311     OP* new_op;
12312     OP * const kid = cUNOPo->op_first;
12313
12314     PERL_ARGS_ASSERT_CK_METHOD;
12315     if (kid->op_type != OP_CONST) return o;
12316
12317     sv = kSVOP->op_sv;
12318
12319     /* replace ' with :: */
12320     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12321                                         SvEND(sv) - SvPVX(sv) )))
12322     {
12323         *compatptr = ':';
12324         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12325     }
12326
12327     method = SvPVX_const(sv);
12328     len = SvCUR(sv);
12329     utf8 = SvUTF8(sv) ? -1 : 1;
12330
12331     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12332         nsplit = i+1;
12333         break;
12334     }
12335
12336     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12337
12338     if (!nsplit) { /* $proto->method() */
12339         op_free(o);
12340         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12341     }
12342
12343     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12344         op_free(o);
12345         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12346     }
12347
12348     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12349     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12350         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12351         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12352     } else {
12353         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12354         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12355     }
12356 #ifdef USE_ITHREADS
12357     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12358 #else
12359     cMETHOPx(new_op)->op_rclass_sv = rclass;
12360 #endif
12361     op_free(o);
12362     return new_op;
12363 }
12364
12365 OP *
12366 Perl_ck_null(pTHX_ OP *o)
12367 {
12368     PERL_ARGS_ASSERT_CK_NULL;
12369     PERL_UNUSED_CONTEXT;
12370     return o;
12371 }
12372
12373 OP *
12374 Perl_ck_open(pTHX_ OP *o)
12375 {
12376     PERL_ARGS_ASSERT_CK_OPEN;
12377
12378     S_io_hints(aTHX_ o);
12379     {
12380          /* In case of three-arg dup open remove strictness
12381           * from the last arg if it is a bareword. */
12382          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12383          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12384          OP *oa;
12385          const char *mode;
12386
12387          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12388              (last->op_private & OPpCONST_BARE) &&
12389              (last->op_private & OPpCONST_STRICT) &&
12390              (oa = OpSIBLING(first)) &&         /* The fh. */
12391              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12392              (oa->op_type == OP_CONST) &&
12393              SvPOK(((SVOP*)oa)->op_sv) &&
12394              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12395              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12396              (last == OpSIBLING(oa)))                   /* The bareword. */
12397               last->op_private &= ~OPpCONST_STRICT;
12398     }
12399     return ck_fun(o);
12400 }
12401
12402 OP *
12403 Perl_ck_prototype(pTHX_ OP *o)
12404 {
12405     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12406     if (!(o->op_flags & OPf_KIDS)) {
12407         op_free(o);
12408         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12409     }
12410     return o;
12411 }
12412
12413 OP *
12414 Perl_ck_refassign(pTHX_ OP *o)
12415 {
12416     OP * const right = cLISTOPo->op_first;
12417     OP * const left = OpSIBLING(right);
12418     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12419     bool stacked = 0;
12420
12421     PERL_ARGS_ASSERT_CK_REFASSIGN;
12422     assert (left);
12423     assert (left->op_type == OP_SREFGEN);
12424
12425     o->op_private = 0;
12426     /* we use OPpPAD_STATE in refassign to mean either of those things,
12427      * and the code assumes the two flags occupy the same bit position
12428      * in the various ops below */
12429     assert(OPpPAD_STATE == OPpOUR_INTRO);
12430
12431     switch (varop->op_type) {
12432     case OP_PADAV:
12433         o->op_private |= OPpLVREF_AV;
12434         goto settarg;
12435     case OP_PADHV:
12436         o->op_private |= OPpLVREF_HV;
12437         /* FALLTHROUGH */
12438     case OP_PADSV:
12439       settarg:
12440         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12441         o->op_targ = varop->op_targ;
12442         varop->op_targ = 0;
12443         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12444         break;
12445
12446     case OP_RV2AV:
12447         o->op_private |= OPpLVREF_AV;
12448         goto checkgv;
12449         NOT_REACHED; /* NOTREACHED */
12450     case OP_RV2HV:
12451         o->op_private |= OPpLVREF_HV;
12452         /* FALLTHROUGH */
12453     case OP_RV2SV:
12454       checkgv:
12455         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12456         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12457       detach_and_stack:
12458         /* Point varop to its GV kid, detached.  */
12459         varop = op_sibling_splice(varop, NULL, -1, NULL);
12460         stacked = TRUE;
12461         break;
12462     case OP_RV2CV: {
12463         OP * const kidparent =
12464             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12465         OP * const kid = cUNOPx(kidparent)->op_first;
12466         o->op_private |= OPpLVREF_CV;
12467         if (kid->op_type == OP_GV) {
12468             varop = kidparent;
12469             goto detach_and_stack;
12470         }
12471         if (kid->op_type != OP_PADCV)   goto bad;
12472         o->op_targ = kid->op_targ;
12473         kid->op_targ = 0;
12474         break;
12475     }
12476     case OP_AELEM:
12477     case OP_HELEM:
12478         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12479         o->op_private |= OPpLVREF_ELEM;
12480         op_null(varop);
12481         stacked = TRUE;
12482         /* Detach varop.  */
12483         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12484         break;
12485     default:
12486       bad:
12487         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12488         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12489                                 "assignment",
12490                                  OP_DESC(varop)));
12491         return o;
12492     }
12493     if (!FEATURE_REFALIASING_IS_ENABLED)
12494         Perl_croak(aTHX_
12495                   "Experimental aliasing via reference not enabled");
12496     Perl_ck_warner_d(aTHX_
12497                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12498                     "Aliasing via reference is experimental");
12499     if (stacked) {
12500         o->op_flags |= OPf_STACKED;
12501         op_sibling_splice(o, right, 1, varop);
12502     }
12503     else {
12504         o->op_flags &=~ OPf_STACKED;
12505         op_sibling_splice(o, right, 1, NULL);
12506     }
12507     op_free(left);
12508     return o;
12509 }
12510
12511 OP *
12512 Perl_ck_repeat(pTHX_ OP *o)
12513 {
12514     PERL_ARGS_ASSERT_CK_REPEAT;
12515
12516     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12517         OP* kids;
12518         o->op_private |= OPpREPEAT_DOLIST;
12519         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12520         kids = force_list(kids, 1); /* promote it to a list */
12521         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12522     }
12523     else
12524         scalar(o);
12525     return o;
12526 }
12527
12528 OP *
12529 Perl_ck_require(pTHX_ OP *o)
12530 {
12531     GV* gv;
12532
12533     PERL_ARGS_ASSERT_CK_REQUIRE;
12534
12535     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12536         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12537         U32 hash;
12538         char *s;
12539         STRLEN len;
12540         if (kid->op_type == OP_CONST) {
12541           SV * const sv = kid->op_sv;
12542           U32 const was_readonly = SvREADONLY(sv);
12543           if (kid->op_private & OPpCONST_BARE) {
12544             dVAR;
12545             const char *end;
12546             HEK *hek;
12547
12548             if (was_readonly) {
12549                     SvREADONLY_off(sv);
12550             }
12551             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12552
12553             s = SvPVX(sv);
12554             len = SvCUR(sv);
12555             end = s + len;
12556             /* treat ::foo::bar as foo::bar */
12557             if (len >= 2 && s[0] == ':' && s[1] == ':')
12558                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12559             if (s == end)
12560                 DIE(aTHX_ "Bareword in require maps to empty filename");
12561
12562             for (; s < end; s++) {
12563                 if (*s == ':' && s[1] == ':') {
12564                     *s = '/';
12565                     Move(s+2, s+1, end - s - 1, char);
12566                     --end;
12567                 }
12568             }
12569             SvEND_set(sv, end);
12570             sv_catpvs(sv, ".pm");
12571             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12572             hek = share_hek(SvPVX(sv),
12573                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12574                             hash);
12575             sv_sethek(sv, hek);
12576             unshare_hek(hek);
12577             SvFLAGS(sv) |= was_readonly;
12578           }
12579           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12580                 && !SvVOK(sv)) {
12581             s = SvPV(sv, len);
12582             if (SvREFCNT(sv) > 1) {
12583                 kid->op_sv = newSVpvn_share(
12584                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12585                 SvREFCNT_dec_NN(sv);
12586             }
12587             else {
12588                 dVAR;
12589                 HEK *hek;
12590                 if (was_readonly) SvREADONLY_off(sv);
12591                 PERL_HASH(hash, s, len);
12592                 hek = share_hek(s,
12593                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12594                                 hash);
12595                 sv_sethek(sv, hek);
12596                 unshare_hek(hek);
12597                 SvFLAGS(sv) |= was_readonly;
12598             }
12599           }
12600         }
12601     }
12602
12603     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12604         /* handle override, if any */
12605      && (gv = gv_override("require", 7))) {
12606         OP *kid, *newop;
12607         if (o->op_flags & OPf_KIDS) {
12608             kid = cUNOPo->op_first;
12609             op_sibling_splice(o, NULL, -1, NULL);
12610         }
12611         else {
12612             kid = newDEFSVOP();
12613         }
12614         op_free(o);
12615         newop = S_new_entersubop(aTHX_ gv, kid);
12616         return newop;
12617     }
12618
12619     return ck_fun(o);
12620 }
12621
12622 OP *
12623 Perl_ck_return(pTHX_ OP *o)
12624 {
12625     OP *kid;
12626
12627     PERL_ARGS_ASSERT_CK_RETURN;
12628
12629     kid = OpSIBLING(cLISTOPo->op_first);
12630     if (PL_compcv && CvLVALUE(PL_compcv)) {
12631         for (; kid; kid = OpSIBLING(kid))
12632             op_lvalue(kid, OP_LEAVESUBLV);
12633     }
12634
12635     return o;
12636 }
12637
12638 OP *
12639 Perl_ck_select(pTHX_ OP *o)
12640 {
12641     dVAR;
12642     OP* kid;
12643
12644     PERL_ARGS_ASSERT_CK_SELECT;
12645
12646     if (o->op_flags & OPf_KIDS) {
12647         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12648         if (kid && OpHAS_SIBLING(kid)) {
12649             OpTYPE_set(o, OP_SSELECT);
12650             o = ck_fun(o);
12651             return fold_constants(op_integerize(op_std_init(o)));
12652         }
12653     }
12654     o = ck_fun(o);
12655     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12656     if (kid && kid->op_type == OP_RV2GV)
12657         kid->op_private &= ~HINT_STRICT_REFS;
12658     return o;
12659 }
12660
12661 OP *
12662 Perl_ck_shift(pTHX_ OP *o)
12663 {
12664     const I32 type = o->op_type;
12665
12666     PERL_ARGS_ASSERT_CK_SHIFT;
12667
12668     if (!(o->op_flags & OPf_KIDS)) {
12669         OP *argop;
12670
12671         if (!CvUNIQUE(PL_compcv)) {
12672             o->op_flags |= OPf_SPECIAL;
12673             return o;
12674         }
12675
12676         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12677         op_free(o);
12678         return newUNOP(type, 0, scalar(argop));
12679     }
12680     return scalar(ck_fun(o));
12681 }
12682
12683 OP *
12684 Perl_ck_sort(pTHX_ OP *o)
12685 {
12686     OP *firstkid;
12687     OP *kid;
12688     HV * const hinthv =
12689         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12690     U8 stacked;
12691
12692     PERL_ARGS_ASSERT_CK_SORT;
12693
12694     if (hinthv) {
12695             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12696             if (svp) {
12697                 const I32 sorthints = (I32)SvIV(*svp);
12698                 if ((sorthints & HINT_SORT_STABLE) != 0)
12699                     o->op_private |= OPpSORT_STABLE;
12700                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12701                     o->op_private |= OPpSORT_UNSTABLE;
12702             }
12703     }
12704
12705     if (o->op_flags & OPf_STACKED)
12706         simplify_sort(o);
12707     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12708
12709     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12710         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12711
12712         /* if the first arg is a code block, process it and mark sort as
12713          * OPf_SPECIAL */
12714         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12715             LINKLIST(kid);
12716             if (kid->op_type == OP_LEAVE)
12717                     op_null(kid);                       /* wipe out leave */
12718             /* Prevent execution from escaping out of the sort block. */
12719             kid->op_next = 0;
12720
12721             /* provide scalar context for comparison function/block */
12722             kid = scalar(firstkid);
12723             kid->op_next = kid;
12724             o->op_flags |= OPf_SPECIAL;
12725         }
12726         else if (kid->op_type == OP_CONST
12727               && kid->op_private & OPpCONST_BARE) {
12728             char tmpbuf[256];
12729             STRLEN len;
12730             PADOFFSET off;
12731             const char * const name = SvPV(kSVOP_sv, len);
12732             *tmpbuf = '&';
12733             assert (len < 256);
12734             Copy(name, tmpbuf+1, len, char);
12735             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12736             if (off != NOT_IN_PAD) {
12737                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12738                     SV * const fq =
12739                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12740                     sv_catpvs(fq, "::");
12741                     sv_catsv(fq, kSVOP_sv);
12742                     SvREFCNT_dec_NN(kSVOP_sv);
12743                     kSVOP->op_sv = fq;
12744                 }
12745                 else {
12746                     OP * const padop = newOP(OP_PADCV, 0);
12747                     padop->op_targ = off;
12748                     /* replace the const op with the pad op */
12749                     op_sibling_splice(firstkid, NULL, 1, padop);
12750                     op_free(kid);
12751                 }
12752             }
12753         }
12754
12755         firstkid = OpSIBLING(firstkid);
12756     }
12757
12758     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12759         /* provide list context for arguments */
12760         list(kid);
12761         if (stacked)
12762             op_lvalue(kid, OP_GREPSTART);
12763     }
12764
12765     return o;
12766 }
12767
12768 /* for sort { X } ..., where X is one of
12769  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12770  * elide the second child of the sort (the one containing X),
12771  * and set these flags as appropriate
12772         OPpSORT_NUMERIC;
12773         OPpSORT_INTEGER;
12774         OPpSORT_DESCEND;
12775  * Also, check and warn on lexical $a, $b.
12776  */
12777
12778 STATIC void
12779 S_simplify_sort(pTHX_ OP *o)
12780 {
12781     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12782     OP *k;
12783     int descending;
12784     GV *gv;
12785     const char *gvname;
12786     bool have_scopeop;
12787
12788     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12789
12790     kid = kUNOP->op_first;                              /* get past null */
12791     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12792      && kid->op_type != OP_LEAVE)
12793         return;
12794     kid = kLISTOP->op_last;                             /* get past scope */
12795     switch(kid->op_type) {
12796         case OP_NCMP:
12797         case OP_I_NCMP:
12798         case OP_SCMP:
12799             if (!have_scopeop) goto padkids;
12800             break;
12801         default:
12802             return;
12803     }
12804     k = kid;                                            /* remember this node*/
12805     if (kBINOP->op_first->op_type != OP_RV2SV
12806      || kBINOP->op_last ->op_type != OP_RV2SV)
12807     {
12808         /*
12809            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12810            then used in a comparison.  This catches most, but not
12811            all cases.  For instance, it catches
12812                sort { my($a); $a <=> $b }
12813            but not
12814                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12815            (although why you'd do that is anyone's guess).
12816         */
12817
12818        padkids:
12819         if (!ckWARN(WARN_SYNTAX)) return;
12820         kid = kBINOP->op_first;
12821         do {
12822             if (kid->op_type == OP_PADSV) {
12823                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12824                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12825                  && (  PadnamePV(name)[1] == 'a'
12826                     || PadnamePV(name)[1] == 'b'  ))
12827                     /* diag_listed_as: "my %s" used in sort comparison */
12828                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12829                                      "\"%s %s\" used in sort comparison",
12830                                       PadnameIsSTATE(name)
12831                                         ? "state"
12832                                         : "my",
12833                                       PadnamePV(name));
12834             }
12835         } while ((kid = OpSIBLING(kid)));
12836         return;
12837     }
12838     kid = kBINOP->op_first;                             /* get past cmp */
12839     if (kUNOP->op_first->op_type != OP_GV)
12840         return;
12841     kid = kUNOP->op_first;                              /* get past rv2sv */
12842     gv = kGVOP_gv;
12843     if (GvSTASH(gv) != PL_curstash)
12844         return;
12845     gvname = GvNAME(gv);
12846     if (*gvname == 'a' && gvname[1] == '\0')
12847         descending = 0;
12848     else if (*gvname == 'b' && gvname[1] == '\0')
12849         descending = 1;
12850     else
12851         return;
12852
12853     kid = k;                                            /* back to cmp */
12854     /* already checked above that it is rv2sv */
12855     kid = kBINOP->op_last;                              /* down to 2nd arg */
12856     if (kUNOP->op_first->op_type != OP_GV)
12857         return;
12858     kid = kUNOP->op_first;                              /* get past rv2sv */
12859     gv = kGVOP_gv;
12860     if (GvSTASH(gv) != PL_curstash)
12861         return;
12862     gvname = GvNAME(gv);
12863     if ( descending
12864          ? !(*gvname == 'a' && gvname[1] == '\0')
12865          : !(*gvname == 'b' && gvname[1] == '\0'))
12866         return;
12867     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12868     if (descending)
12869         o->op_private |= OPpSORT_DESCEND;
12870     if (k->op_type == OP_NCMP)
12871         o->op_private |= OPpSORT_NUMERIC;
12872     if (k->op_type == OP_I_NCMP)
12873         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12874     kid = OpSIBLING(cLISTOPo->op_first);
12875     /* cut out and delete old block (second sibling) */
12876     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12877     op_free(kid);
12878 }
12879
12880 OP *
12881 Perl_ck_split(pTHX_ OP *o)
12882 {
12883     dVAR;
12884     OP *kid;
12885     OP *sibs;
12886
12887     PERL_ARGS_ASSERT_CK_SPLIT;
12888
12889     assert(o->op_type == OP_LIST);
12890
12891     if (o->op_flags & OPf_STACKED)
12892         return no_fh_allowed(o);
12893
12894     kid = cLISTOPo->op_first;
12895     /* delete leading NULL node, then add a CONST if no other nodes */
12896     assert(kid->op_type == OP_NULL);
12897     op_sibling_splice(o, NULL, 1,
12898         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12899     op_free(kid);
12900     kid = cLISTOPo->op_first;
12901
12902     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12903         /* remove match expression, and replace with new optree with
12904          * a match op at its head */
12905         op_sibling_splice(o, NULL, 1, NULL);
12906         /* pmruntime will handle split " " behavior with flag==2 */
12907         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12908         op_sibling_splice(o, NULL, 0, kid);
12909     }
12910
12911     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12912
12913     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12914       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12915                      "Use of /g modifier is meaningless in split");
12916     }
12917
12918     /* eliminate the split op, and move the match op (plus any children)
12919      * into its place, then convert the match op into a split op. i.e.
12920      *
12921      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12922      *    |                        |                     |
12923      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12924      *    |                        |                     |
12925      *    R                        X - Y                 X - Y
12926      *    |
12927      *    X - Y
12928      *
12929      * (R, if it exists, will be a regcomp op)
12930      */
12931
12932     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12933     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12934     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12935     OpTYPE_set(kid, OP_SPLIT);
12936     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12937     kid->op_private = o->op_private;
12938     op_free(o);
12939     o = kid;
12940     kid = sibs; /* kid is now the string arg of the split */
12941
12942     if (!kid) {
12943         kid = newDEFSVOP();
12944         op_append_elem(OP_SPLIT, o, kid);
12945     }
12946     scalar(kid);
12947
12948     kid = OpSIBLING(kid);
12949     if (!kid) {
12950         kid = newSVOP(OP_CONST, 0, newSViv(0));
12951         op_append_elem(OP_SPLIT, o, kid);
12952         o->op_private |= OPpSPLIT_IMPLIM;
12953     }
12954     scalar(kid);
12955
12956     if (OpHAS_SIBLING(kid))
12957         return too_many_arguments_pv(o,OP_DESC(o), 0);
12958
12959     return o;
12960 }
12961
12962 OP *
12963 Perl_ck_stringify(pTHX_ OP *o)
12964 {
12965     OP * const kid = OpSIBLING(cUNOPo->op_first);
12966     PERL_ARGS_ASSERT_CK_STRINGIFY;
12967     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12968          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12969          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12970         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12971     {
12972         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12973         op_free(o);
12974         return kid;
12975     }
12976     return ck_fun(o);
12977 }
12978
12979 OP *
12980 Perl_ck_join(pTHX_ OP *o)
12981 {
12982     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12983
12984     PERL_ARGS_ASSERT_CK_JOIN;
12985
12986     if (kid && kid->op_type == OP_MATCH) {
12987         if (ckWARN(WARN_SYNTAX)) {
12988             const REGEXP *re = PM_GETRE(kPMOP);
12989             const SV *msg = re
12990                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12991                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12992                     : newSVpvs_flags( "STRING", SVs_TEMP );
12993             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12994                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12995                         SVfARG(msg), SVfARG(msg));
12996         }
12997     }
12998     if (kid
12999      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13000         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13001         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13002            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13003     {
13004         const OP * const bairn = OpSIBLING(kid); /* the list */
13005         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13006          && OP_GIMME(bairn,0) == G_SCALAR)
13007         {
13008             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13009                                      op_sibling_splice(o, kid, 1, NULL));
13010             op_free(o);
13011             return ret;
13012         }
13013     }
13014
13015     return ck_fun(o);
13016 }
13017
13018 /*
13019 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
13020
13021 Examines an op, which is expected to identify a subroutine at runtime,
13022 and attempts to determine at compile time which subroutine it identifies.
13023 This is normally used during Perl compilation to determine whether
13024 a prototype can be applied to a function call.  C<cvop> is the op
13025 being considered, normally an C<rv2cv> op.  A pointer to the identified
13026 subroutine is returned, if it could be determined statically, and a null
13027 pointer is returned if it was not possible to determine statically.
13028
13029 Currently, the subroutine can be identified statically if the RV that the
13030 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13031 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13032 suitable if the constant value must be an RV pointing to a CV.  Details of
13033 this process may change in future versions of Perl.  If the C<rv2cv> op
13034 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13035 the subroutine statically: this flag is used to suppress compile-time
13036 magic on a subroutine call, forcing it to use default runtime behaviour.
13037
13038 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13039 of a GV reference is modified.  If a GV was examined and its CV slot was
13040 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13041 If the op is not optimised away, and the CV slot is later populated with
13042 a subroutine having a prototype, that flag eventually triggers the warning
13043 "called too early to check prototype".
13044
13045 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13046 of returning a pointer to the subroutine it returns a pointer to the
13047 GV giving the most appropriate name for the subroutine in this context.
13048 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13049 (C<CvANON>) subroutine that is referenced through a GV it will be the
13050 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13051 A null pointer is returned as usual if there is no statically-determinable
13052 subroutine.
13053
13054 =cut
13055 */
13056
13057 /* shared by toke.c:yylex */
13058 CV *
13059 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13060 {
13061     PADNAME *name = PAD_COMPNAME(off);
13062     CV *compcv = PL_compcv;
13063     while (PadnameOUTER(name)) {
13064         assert(PARENT_PAD_INDEX(name));
13065         compcv = CvOUTSIDE(compcv);
13066         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13067                 [off = PARENT_PAD_INDEX(name)];
13068     }
13069     assert(!PadnameIsOUR(name));
13070     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13071         return PadnamePROTOCV(name);
13072     }
13073     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13074 }
13075
13076 CV *
13077 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13078 {
13079     OP *rvop;
13080     CV *cv;
13081     GV *gv;
13082     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13083     if (flags & ~RV2CVOPCV_FLAG_MASK)
13084         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13085     if (cvop->op_type != OP_RV2CV)
13086         return NULL;
13087     if (cvop->op_private & OPpENTERSUB_AMPER)
13088         return NULL;
13089     if (!(cvop->op_flags & OPf_KIDS))
13090         return NULL;
13091     rvop = cUNOPx(cvop)->op_first;
13092     switch (rvop->op_type) {
13093         case OP_GV: {
13094             gv = cGVOPx_gv(rvop);
13095             if (!isGV(gv)) {
13096                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13097                     cv = MUTABLE_CV(SvRV(gv));
13098                     gv = NULL;
13099                     break;
13100                 }
13101                 if (flags & RV2CVOPCV_RETURN_STUB)
13102                     return (CV *)gv;
13103                 else return NULL;
13104             }
13105             cv = GvCVu(gv);
13106             if (!cv) {
13107                 if (flags & RV2CVOPCV_MARK_EARLY)
13108                     rvop->op_private |= OPpEARLY_CV;
13109                 return NULL;
13110             }
13111         } break;
13112         case OP_CONST: {
13113             SV *rv = cSVOPx_sv(rvop);
13114             if (!SvROK(rv))
13115                 return NULL;
13116             cv = (CV*)SvRV(rv);
13117             gv = NULL;
13118         } break;
13119         case OP_PADCV: {
13120             cv = find_lexical_cv(rvop->op_targ);
13121             gv = NULL;
13122         } break;
13123         default: {
13124             return NULL;
13125         } NOT_REACHED; /* NOTREACHED */
13126     }
13127     if (SvTYPE((SV*)cv) != SVt_PVCV)
13128         return NULL;
13129     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13130         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13131             gv = CvGV(cv);
13132         return (CV*)gv;
13133     }
13134     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13135         if (CvLEXICAL(cv) || CvNAMED(cv))
13136             return NULL;
13137         if (!CvANON(cv) || !gv)
13138             gv = CvGV(cv);
13139         return (CV*)gv;
13140
13141     } else {
13142         return cv;
13143     }
13144 }
13145
13146 /*
13147 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13148
13149 Performs the default fixup of the arguments part of an C<entersub>
13150 op tree.  This consists of applying list context to each of the
13151 argument ops.  This is the standard treatment used on a call marked
13152 with C<&>, or a method call, or a call through a subroutine reference,
13153 or any other call where the callee can't be identified at compile time,
13154 or a call where the callee has no prototype.
13155
13156 =cut
13157 */
13158
13159 OP *
13160 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13161 {
13162     OP *aop;
13163
13164     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13165
13166     aop = cUNOPx(entersubop)->op_first;
13167     if (!OpHAS_SIBLING(aop))
13168         aop = cUNOPx(aop)->op_first;
13169     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13170         /* skip the extra attributes->import() call implicitly added in
13171          * something like foo(my $x : bar)
13172          */
13173         if (   aop->op_type == OP_ENTERSUB
13174             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13175         )
13176             continue;
13177         list(aop);
13178         op_lvalue(aop, OP_ENTERSUB);
13179     }
13180     return entersubop;
13181 }
13182
13183 /*
13184 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13185
13186 Performs the fixup of the arguments part of an C<entersub> op tree
13187 based on a subroutine prototype.  This makes various modifications to
13188 the argument ops, from applying context up to inserting C<refgen> ops,
13189 and checking the number and syntactic types of arguments, as directed by
13190 the prototype.  This is the standard treatment used on a subroutine call,
13191 not marked with C<&>, where the callee can be identified at compile time
13192 and has a prototype.
13193
13194 C<protosv> supplies the subroutine prototype to be applied to the call.
13195 It may be a normal defined scalar, of which the string value will be used.
13196 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13197 that has been cast to C<SV*>) which has a prototype.  The prototype
13198 supplied, in whichever form, does not need to match the actual callee
13199 referenced by the op tree.
13200
13201 If the argument ops disagree with the prototype, for example by having
13202 an unacceptable number of arguments, a valid op tree is returned anyway.
13203 The error is reflected in the parser state, normally resulting in a single
13204 exception at the top level of parsing which covers all the compilation
13205 errors that occurred.  In the error message, the callee is referred to
13206 by the name defined by the C<namegv> parameter.
13207
13208 =cut
13209 */
13210
13211 OP *
13212 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13213 {
13214     STRLEN proto_len;
13215     const char *proto, *proto_end;
13216     OP *aop, *prev, *cvop, *parent;
13217     int optional = 0;
13218     I32 arg = 0;
13219     I32 contextclass = 0;
13220     const char *e = NULL;
13221     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13222     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13223         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13224                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13225     if (SvTYPE(protosv) == SVt_PVCV)
13226          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13227     else proto = SvPV(protosv, proto_len);
13228     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13229     proto_end = proto + proto_len;
13230     parent = entersubop;
13231     aop = cUNOPx(entersubop)->op_first;
13232     if (!OpHAS_SIBLING(aop)) {
13233         parent = aop;
13234         aop = cUNOPx(aop)->op_first;
13235     }
13236     prev = aop;
13237     aop = OpSIBLING(aop);
13238     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13239     while (aop != cvop) {
13240         OP* o3 = aop;
13241
13242         if (proto >= proto_end)
13243         {
13244             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13245             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13246                                         SVfARG(namesv)), SvUTF8(namesv));
13247             return entersubop;
13248         }
13249
13250         switch (*proto) {
13251             case ';':
13252                 optional = 1;
13253                 proto++;
13254                 continue;
13255             case '_':
13256                 /* _ must be at the end */
13257                 if (proto[1] && !strchr(";@%", proto[1]))
13258                     goto oops;
13259                 /* FALLTHROUGH */
13260             case '$':
13261                 proto++;
13262                 arg++;
13263                 scalar(aop);
13264                 break;
13265             case '%':
13266             case '@':
13267                 list(aop);
13268                 arg++;
13269                 break;
13270             case '&':
13271                 proto++;
13272                 arg++;
13273                 if (    o3->op_type != OP_UNDEF
13274                     && (o3->op_type != OP_SREFGEN
13275                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13276                                 != OP_ANONCODE
13277                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13278                                 != OP_RV2CV)))
13279                     bad_type_gv(arg, namegv, o3,
13280                             arg == 1 ? "block or sub {}" : "sub {}");
13281                 break;
13282             case '*':
13283                 /* '*' allows any scalar type, including bareword */
13284                 proto++;
13285                 arg++;
13286                 if (o3->op_type == OP_RV2GV)
13287                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13288                 else if (o3->op_type == OP_CONST)
13289                     o3->op_private &= ~OPpCONST_STRICT;
13290                 scalar(aop);
13291                 break;
13292             case '+':
13293                 proto++;
13294                 arg++;
13295                 if (o3->op_type == OP_RV2AV ||
13296                     o3->op_type == OP_PADAV ||
13297                     o3->op_type == OP_RV2HV ||
13298                     o3->op_type == OP_PADHV
13299                 ) {
13300                     goto wrapref;
13301                 }
13302                 scalar(aop);
13303                 break;
13304             case '[': case ']':
13305                 goto oops;
13306
13307             case '\\':
13308                 proto++;
13309                 arg++;
13310             again:
13311                 switch (*proto++) {
13312                     case '[':
13313                         if (contextclass++ == 0) {
13314                             e = (char *) memchr(proto, ']', proto_end - proto);
13315                             if (!e || e == proto)
13316                                 goto oops;
13317                         }
13318                         else
13319                             goto oops;
13320                         goto again;
13321
13322                     case ']':
13323                         if (contextclass) {
13324                             const char *p = proto;
13325                             const char *const end = proto;
13326                             contextclass = 0;
13327                             while (*--p != '[')
13328                                 /* \[$] accepts any scalar lvalue */
13329                                 if (*p == '$'
13330                                  && Perl_op_lvalue_flags(aTHX_
13331                                      scalar(o3),
13332                                      OP_READ, /* not entersub */
13333                                      OP_LVALUE_NO_CROAK
13334                                     )) goto wrapref;
13335                             bad_type_gv(arg, namegv, o3,
13336                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13337                         } else
13338                             goto oops;
13339                         break;
13340                     case '*':
13341                         if (o3->op_type == OP_RV2GV)
13342                             goto wrapref;
13343                         if (!contextclass)
13344                             bad_type_gv(arg, namegv, o3, "symbol");
13345                         break;
13346                     case '&':
13347                         if (o3->op_type == OP_ENTERSUB
13348                          && !(o3->op_flags & OPf_STACKED))
13349                             goto wrapref;
13350                         if (!contextclass)
13351                             bad_type_gv(arg, namegv, o3, "subroutine");
13352                         break;
13353                     case '$':
13354                         if (o3->op_type == OP_RV2SV ||
13355                                 o3->op_type == OP_PADSV ||
13356                                 o3->op_type == OP_HELEM ||
13357                                 o3->op_type == OP_AELEM)
13358                             goto wrapref;
13359                         if (!contextclass) {
13360                             /* \$ accepts any scalar lvalue */
13361                             if (Perl_op_lvalue_flags(aTHX_
13362                                     scalar(o3),
13363                                     OP_READ,  /* not entersub */
13364                                     OP_LVALUE_NO_CROAK
13365                                )) goto wrapref;
13366                             bad_type_gv(arg, namegv, o3, "scalar");
13367                         }
13368                         break;
13369                     case '@':
13370                         if (o3->op_type == OP_RV2AV ||
13371                                 o3->op_type == OP_PADAV)
13372                         {
13373                             o3->op_flags &=~ OPf_PARENS;
13374                             goto wrapref;
13375                         }
13376                         if (!contextclass)
13377                             bad_type_gv(arg, namegv, o3, "array");
13378                         break;
13379                     case '%':
13380                         if (o3->op_type == OP_RV2HV ||
13381                                 o3->op_type == OP_PADHV)
13382                         {
13383                             o3->op_flags &=~ OPf_PARENS;
13384                             goto wrapref;
13385                         }
13386                         if (!contextclass)
13387                             bad_type_gv(arg, namegv, o3, "hash");
13388                         break;
13389                     wrapref:
13390                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13391                                                 OP_REFGEN, 0);
13392                         if (contextclass && e) {
13393                             proto = e + 1;
13394                             contextclass = 0;
13395                         }
13396                         break;
13397                     default: goto oops;
13398                 }
13399                 if (contextclass)
13400                     goto again;
13401                 break;
13402             case ' ':
13403                 proto++;
13404                 continue;
13405             default:
13406             oops: {
13407                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13408                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13409                                   SVfARG(protosv));
13410             }
13411         }
13412
13413         op_lvalue(aop, OP_ENTERSUB);
13414         prev = aop;
13415         aop = OpSIBLING(aop);
13416     }
13417     if (aop == cvop && *proto == '_') {
13418         /* generate an access to $_ */
13419         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13420     }
13421     if (!optional && proto_end > proto &&
13422         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13423     {
13424         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13425         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13426                                     SVfARG(namesv)), SvUTF8(namesv));
13427     }
13428     return entersubop;
13429 }
13430
13431 /*
13432 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13433
13434 Performs the fixup of the arguments part of an C<entersub> op tree either
13435 based on a subroutine prototype or using default list-context processing.
13436 This is the standard treatment used on a subroutine call, not marked
13437 with C<&>, where the callee can be identified at compile time.
13438
13439 C<protosv> supplies the subroutine prototype to be applied to the call,
13440 or indicates that there is no prototype.  It may be a normal scalar,
13441 in which case if it is defined then the string value will be used
13442 as a prototype, and if it is undefined then there is no prototype.
13443 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13444 that has been cast to C<SV*>), of which the prototype will be used if it
13445 has one.  The prototype (or lack thereof) supplied, in whichever form,
13446 does not need to match the actual callee referenced by the op tree.
13447
13448 If the argument ops disagree with the prototype, for example by having
13449 an unacceptable number of arguments, a valid op tree is returned anyway.
13450 The error is reflected in the parser state, normally resulting in a single
13451 exception at the top level of parsing which covers all the compilation
13452 errors that occurred.  In the error message, the callee is referred to
13453 by the name defined by the C<namegv> parameter.
13454
13455 =cut
13456 */
13457
13458 OP *
13459 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13460         GV *namegv, SV *protosv)
13461 {
13462     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13463     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13464         return ck_entersub_args_proto(entersubop, namegv, protosv);
13465     else
13466         return ck_entersub_args_list(entersubop);
13467 }
13468
13469 OP *
13470 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13471 {
13472     IV cvflags = SvIVX(protosv);
13473     int opnum = cvflags & 0xffff;
13474     OP *aop = cUNOPx(entersubop)->op_first;
13475
13476     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13477
13478     if (!opnum) {
13479         OP *cvop;
13480         if (!OpHAS_SIBLING(aop))
13481             aop = cUNOPx(aop)->op_first;
13482         aop = OpSIBLING(aop);
13483         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13484         if (aop != cvop) {
13485             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13486             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13487                 SVfARG(namesv)), SvUTF8(namesv));
13488         }
13489
13490         op_free(entersubop);
13491         switch(cvflags >> 16) {
13492         case 'F': return newSVOP(OP_CONST, 0,
13493                                         newSVpv(CopFILE(PL_curcop),0));
13494         case 'L': return newSVOP(
13495                            OP_CONST, 0,
13496                            Perl_newSVpvf(aTHX_
13497                              "%" IVdf, (IV)CopLINE(PL_curcop)
13498                            )
13499                          );
13500         case 'P': return newSVOP(OP_CONST, 0,
13501                                    (PL_curstash
13502                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13503                                      : &PL_sv_undef
13504                                    )
13505                                 );
13506         }
13507         NOT_REACHED; /* NOTREACHED */
13508     }
13509     else {
13510         OP *prev, *cvop, *first, *parent;
13511         U32 flags = 0;
13512
13513         parent = entersubop;
13514         if (!OpHAS_SIBLING(aop)) {
13515             parent = aop;
13516             aop = cUNOPx(aop)->op_first;
13517         }
13518
13519         first = prev = aop;
13520         aop = OpSIBLING(aop);
13521         /* find last sibling */
13522         for (cvop = aop;
13523              OpHAS_SIBLING(cvop);
13524              prev = cvop, cvop = OpSIBLING(cvop))
13525             ;
13526         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13527             /* Usually, OPf_SPECIAL on an op with no args means that it had
13528              * parens, but these have their own meaning for that flag: */
13529             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13530             && opnum != OP_DELETE && opnum != OP_EXISTS)
13531                 flags |= OPf_SPECIAL;
13532         /* excise cvop from end of sibling chain */
13533         op_sibling_splice(parent, prev, 1, NULL);
13534         op_free(cvop);
13535         if (aop == cvop) aop = NULL;
13536
13537         /* detach remaining siblings from the first sibling, then
13538          * dispose of original optree */
13539
13540         if (aop)
13541             op_sibling_splice(parent, first, -1, NULL);
13542         op_free(entersubop);
13543
13544         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13545             flags |= OPpEVAL_BYTES <<8;
13546
13547         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13548         case OA_UNOP:
13549         case OA_BASEOP_OR_UNOP:
13550         case OA_FILESTATOP:
13551             if (!aop)
13552                 return newOP(opnum,flags);       /* zero args */
13553             if (aop == prev)
13554                 return newUNOP(opnum,flags,aop); /* one arg */
13555             /* too many args */
13556             /* FALLTHROUGH */
13557         case OA_BASEOP:
13558             if (aop) {
13559                 SV *namesv;
13560                 OP *nextop;
13561
13562                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13563                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13564                     SVfARG(namesv)), SvUTF8(namesv));
13565                 while (aop) {
13566                     nextop = OpSIBLING(aop);
13567                     op_free(aop);
13568                     aop = nextop;
13569                 }
13570
13571             }
13572             return opnum == OP_RUNCV
13573                 ? newPVOP(OP_RUNCV,0,NULL)
13574                 : newOP(opnum,0);
13575         default:
13576             return op_convert_list(opnum,0,aop);
13577         }
13578     }
13579     NOT_REACHED; /* NOTREACHED */
13580     return entersubop;
13581 }
13582
13583 /*
13584 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13585
13586 Retrieves the function that will be used to fix up a call to C<cv>.
13587 Specifically, the function is applied to an C<entersub> op tree for a
13588 subroutine call, not marked with C<&>, where the callee can be identified
13589 at compile time as C<cv>.
13590
13591 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13592 for it is returned in C<*ckobj_p>, and control flags are returned in
13593 C<*ckflags_p>.  The function is intended to be called in this manner:
13594
13595  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13596
13597 In this call, C<entersubop> is a pointer to the C<entersub> op,
13598 which may be replaced by the check function, and C<namegv> supplies
13599 the name that should be used by the check function to refer
13600 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13601 It is permitted to apply the check function in non-standard situations,
13602 such as to a call to a different subroutine or to a method call.
13603
13604 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13605 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13606 instead, anything that can be used as the first argument to L</cv_name>.
13607 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13608 check function requires C<namegv> to be a genuine GV.
13609
13610 By default, the check function is
13611 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13612 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13613 flag is clear.  This implements standard prototype processing.  It can
13614 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13615
13616 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13617 indicates that the caller only knows about the genuine GV version of
13618 C<namegv>, and accordingly the corresponding bit will always be set in
13619 C<*ckflags_p>, regardless of the check function's recorded requirements.
13620 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13621 indicates the caller knows about the possibility of passing something
13622 other than a GV as C<namegv>, and accordingly the corresponding bit may
13623 be either set or clear in C<*ckflags_p>, indicating the check function's
13624 recorded requirements.
13625
13626 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13627 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13628 (for which see above).  All other bits should be clear.
13629
13630 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13631
13632 The original form of L</cv_get_call_checker_flags>, which does not return
13633 checker flags.  When using a checker function returned by this function,
13634 it is only safe to call it with a genuine GV as its C<namegv> argument.
13635
13636 =cut
13637 */
13638
13639 void
13640 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13641         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13642 {
13643     MAGIC *callmg;
13644     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13645     PERL_UNUSED_CONTEXT;
13646     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13647     if (callmg) {
13648         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13649         *ckobj_p = callmg->mg_obj;
13650         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13651     } else {
13652         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13653         *ckobj_p = (SV*)cv;
13654         *ckflags_p = gflags & MGf_REQUIRE_GV;
13655     }
13656 }
13657
13658 void
13659 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13660 {
13661     U32 ckflags;
13662     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13663     PERL_UNUSED_CONTEXT;
13664     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13665         &ckflags);
13666 }
13667
13668 /*
13669 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13670
13671 Sets the function that will be used to fix up a call to C<cv>.
13672 Specifically, the function is applied to an C<entersub> op tree for a
13673 subroutine call, not marked with C<&>, where the callee can be identified
13674 at compile time as C<cv>.
13675
13676 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13677 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13678 The function should be defined like this:
13679
13680     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13681
13682 It is intended to be called in this manner:
13683
13684     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13685
13686 In this call, C<entersubop> is a pointer to the C<entersub> op,
13687 which may be replaced by the check function, and C<namegv> supplies
13688 the name that should be used by the check function to refer
13689 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13690 It is permitted to apply the check function in non-standard situations,
13691 such as to a call to a different subroutine or to a method call.
13692
13693 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13694 CV or other SV instead.  Whatever is passed can be used as the first
13695 argument to L</cv_name>.  You can force perl to pass a GV by including
13696 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13697
13698 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13699 bit currently has a defined meaning (for which see above).  All other
13700 bits should be clear.
13701
13702 The current setting for a particular CV can be retrieved by
13703 L</cv_get_call_checker_flags>.
13704
13705 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13706
13707 The original form of L</cv_set_call_checker_flags>, which passes it the
13708 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13709 of that flag setting is that the check function is guaranteed to get a
13710 genuine GV as its C<namegv> argument.
13711
13712 =cut
13713 */
13714
13715 void
13716 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13717 {
13718     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13719     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13720 }
13721
13722 void
13723 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13724                                      SV *ckobj, U32 ckflags)
13725 {
13726     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13727     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13728         if (SvMAGICAL((SV*)cv))
13729             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13730     } else {
13731         MAGIC *callmg;
13732         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13733         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13734         assert(callmg);
13735         if (callmg->mg_flags & MGf_REFCOUNTED) {
13736             SvREFCNT_dec(callmg->mg_obj);
13737             callmg->mg_flags &= ~MGf_REFCOUNTED;
13738         }
13739         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13740         callmg->mg_obj = ckobj;
13741         if (ckobj != (SV*)cv) {
13742             SvREFCNT_inc_simple_void_NN(ckobj);
13743             callmg->mg_flags |= MGf_REFCOUNTED;
13744         }
13745         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13746                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13747     }
13748 }
13749
13750 static void
13751 S_entersub_alloc_targ(pTHX_ OP * const o)
13752 {
13753     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13754     o->op_private |= OPpENTERSUB_HASTARG;
13755 }
13756
13757 OP *
13758 Perl_ck_subr(pTHX_ OP *o)
13759 {
13760     OP *aop, *cvop;
13761     CV *cv;
13762     GV *namegv;
13763     SV **const_class = NULL;
13764
13765     PERL_ARGS_ASSERT_CK_SUBR;
13766
13767     aop = cUNOPx(o)->op_first;
13768     if (!OpHAS_SIBLING(aop))
13769         aop = cUNOPx(aop)->op_first;
13770     aop = OpSIBLING(aop);
13771     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13772     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13773     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13774
13775     o->op_private &= ~1;
13776     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13777     if (PERLDB_SUB && PL_curstash != PL_debstash)
13778         o->op_private |= OPpENTERSUB_DB;
13779     switch (cvop->op_type) {
13780         case OP_RV2CV:
13781             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13782             op_null(cvop);
13783             break;
13784         case OP_METHOD:
13785         case OP_METHOD_NAMED:
13786         case OP_METHOD_SUPER:
13787         case OP_METHOD_REDIR:
13788         case OP_METHOD_REDIR_SUPER:
13789             o->op_flags |= OPf_REF;
13790             if (aop->op_type == OP_CONST) {
13791                 aop->op_private &= ~OPpCONST_STRICT;
13792                 const_class = &cSVOPx(aop)->op_sv;
13793             }
13794             else if (aop->op_type == OP_LIST) {
13795                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13796                 if (sib && sib->op_type == OP_CONST) {
13797                     sib->op_private &= ~OPpCONST_STRICT;
13798                     const_class = &cSVOPx(sib)->op_sv;
13799                 }
13800             }
13801             /* make class name a shared cow string to speedup method calls */
13802             /* constant string might be replaced with object, f.e. bigint */
13803             if (const_class && SvPOK(*const_class)) {
13804                 STRLEN len;
13805                 const char* str = SvPV(*const_class, len);
13806                 if (len) {
13807                     SV* const shared = newSVpvn_share(
13808                         str, SvUTF8(*const_class)
13809                                     ? -(SSize_t)len : (SSize_t)len,
13810                         0
13811                     );
13812                     if (SvREADONLY(*const_class))
13813                         SvREADONLY_on(shared);
13814                     SvREFCNT_dec(*const_class);
13815                     *const_class = shared;
13816                 }
13817             }
13818             break;
13819     }
13820
13821     if (!cv) {
13822         S_entersub_alloc_targ(aTHX_ o);
13823         return ck_entersub_args_list(o);
13824     } else {
13825         Perl_call_checker ckfun;
13826         SV *ckobj;
13827         U32 ckflags;
13828         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13829         if (CvISXSUB(cv) || !CvROOT(cv))
13830             S_entersub_alloc_targ(aTHX_ o);
13831         if (!namegv) {
13832             /* The original call checker API guarantees that a GV will be
13833                be provided with the right name.  So, if the old API was
13834                used (or the REQUIRE_GV flag was passed), we have to reify
13835                the CV’s GV, unless this is an anonymous sub.  This is not
13836                ideal for lexical subs, as its stringification will include
13837                the package.  But it is the best we can do.  */
13838             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13839                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13840                     namegv = CvGV(cv);
13841             }
13842             else namegv = MUTABLE_GV(cv);
13843             /* After a syntax error in a lexical sub, the cv that
13844                rv2cv_op_cv returns may be a nameless stub. */
13845             if (!namegv) return ck_entersub_args_list(o);
13846
13847         }
13848         return ckfun(aTHX_ o, namegv, ckobj);
13849     }
13850 }
13851
13852 OP *
13853 Perl_ck_svconst(pTHX_ OP *o)
13854 {
13855     SV * const sv = cSVOPo->op_sv;
13856     PERL_ARGS_ASSERT_CK_SVCONST;
13857     PERL_UNUSED_CONTEXT;
13858 #ifdef PERL_COPY_ON_WRITE
13859     /* Since the read-only flag may be used to protect a string buffer, we
13860        cannot do copy-on-write with existing read-only scalars that are not
13861        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13862        that constant, mark the constant as COWable here, if it is not
13863        already read-only. */
13864     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13865         SvIsCOW_on(sv);
13866         CowREFCNT(sv) = 0;
13867 # ifdef PERL_DEBUG_READONLY_COW
13868         sv_buf_to_ro(sv);
13869 # endif
13870     }
13871 #endif
13872     SvREADONLY_on(sv);
13873     return o;
13874 }
13875
13876 OP *
13877 Perl_ck_trunc(pTHX_ OP *o)
13878 {
13879     PERL_ARGS_ASSERT_CK_TRUNC;
13880
13881     if (o->op_flags & OPf_KIDS) {
13882         SVOP *kid = (SVOP*)cUNOPo->op_first;
13883
13884         if (kid->op_type == OP_NULL)
13885             kid = (SVOP*)OpSIBLING(kid);
13886         if (kid && kid->op_type == OP_CONST &&
13887             (kid->op_private & OPpCONST_BARE) &&
13888             !kid->op_folded)
13889         {
13890             o->op_flags |= OPf_SPECIAL;
13891             kid->op_private &= ~OPpCONST_STRICT;
13892         }
13893     }
13894     return ck_fun(o);
13895 }
13896
13897 OP *
13898 Perl_ck_substr(pTHX_ OP *o)
13899 {
13900     PERL_ARGS_ASSERT_CK_SUBSTR;
13901
13902     o = ck_fun(o);
13903     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13904         OP *kid = cLISTOPo->op_first;
13905
13906         if (kid->op_type == OP_NULL)
13907             kid = OpSIBLING(kid);
13908         if (kid)
13909             /* Historically, substr(delete $foo{bar},...) has been allowed
13910                with 4-arg substr.  Keep it working by applying entersub
13911                lvalue context.  */
13912             op_lvalue(kid, OP_ENTERSUB);
13913
13914     }
13915     return o;
13916 }
13917
13918 OP *
13919 Perl_ck_tell(pTHX_ OP *o)
13920 {
13921     PERL_ARGS_ASSERT_CK_TELL;
13922     o = ck_fun(o);
13923     if (o->op_flags & OPf_KIDS) {
13924      OP *kid = cLISTOPo->op_first;
13925      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13926      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13927     }
13928     return o;
13929 }
13930
13931 OP *
13932 Perl_ck_each(pTHX_ OP *o)
13933 {
13934     dVAR;
13935     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13936     const unsigned orig_type  = o->op_type;
13937
13938     PERL_ARGS_ASSERT_CK_EACH;
13939
13940     if (kid) {
13941         switch (kid->op_type) {
13942             case OP_PADHV:
13943             case OP_RV2HV:
13944                 break;
13945             case OP_PADAV:
13946             case OP_RV2AV:
13947                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13948                             : orig_type == OP_KEYS ? OP_AKEYS
13949                             :                        OP_AVALUES);
13950                 break;
13951             case OP_CONST:
13952                 if (kid->op_private == OPpCONST_BARE
13953                  || !SvROK(cSVOPx_sv(kid))
13954                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13955                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13956                    )
13957                     goto bad;
13958                 /* FALLTHROUGH */
13959             default:
13960                 qerror(Perl_mess(aTHX_
13961                     "Experimental %s on scalar is now forbidden",
13962                      PL_op_desc[orig_type]));
13963                bad:
13964                 bad_type_pv(1, "hash or array", o, kid);
13965                 return o;
13966         }
13967     }
13968     return ck_fun(o);
13969 }
13970
13971 OP *
13972 Perl_ck_length(pTHX_ OP *o)
13973 {
13974     PERL_ARGS_ASSERT_CK_LENGTH;
13975
13976     o = ck_fun(o);
13977
13978     if (ckWARN(WARN_SYNTAX)) {
13979         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13980
13981         if (kid) {
13982             SV *name = NULL;
13983             const bool hash = kid->op_type == OP_PADHV
13984                            || kid->op_type == OP_RV2HV;
13985             switch (kid->op_type) {
13986                 case OP_PADHV:
13987                 case OP_PADAV:
13988                 case OP_RV2HV:
13989                 case OP_RV2AV:
13990                     name = S_op_varname(aTHX_ kid);
13991                     break;
13992                 default:
13993                     return o;
13994             }
13995             if (name)
13996                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13997                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13998                     ")\"?)",
13999                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
14000                 );
14001             else if (hash)
14002      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14003                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14004                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14005             else
14006      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14007                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14008                     "length() used on @array (did you mean \"scalar(@array)\"?)");
14009         }
14010     }
14011
14012     return o;
14013 }
14014
14015
14016
14017 /*
14018    ---------------------------------------------------------
14019
14020    Common vars in list assignment
14021
14022    There now follows some enums and static functions for detecting
14023    common variables in list assignments. Here is a little essay I wrote
14024    for myself when trying to get my head around this. DAPM.
14025
14026    ----
14027
14028    First some random observations:
14029
14030    * If a lexical var is an alias of something else, e.g.
14031        for my $x ($lex, $pkg, $a[0]) {...}
14032      then the act of aliasing will increase the reference count of the SV
14033
14034    * If a package var is an alias of something else, it may still have a
14035      reference count of 1, depending on how the alias was created, e.g.
14036      in *a = *b, $a may have a refcount of 1 since the GP is shared
14037      with a single GvSV pointer to the SV. So If it's an alias of another
14038      package var, then RC may be 1; if it's an alias of another scalar, e.g.
14039      a lexical var or an array element, then it will have RC > 1.
14040
14041    * There are many ways to create a package alias; ultimately, XS code
14042      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14043      run-time tracing mechanisms are unlikely to be able to catch all cases.
14044
14045    * When the LHS is all my declarations, the same vars can't appear directly
14046      on the RHS, but they can indirectly via closures, aliasing and lvalue
14047      subs. But those techniques all involve an increase in the lexical
14048      scalar's ref count.
14049
14050    * When the LHS is all lexical vars (but not necessarily my declarations),
14051      it is possible for the same lexicals to appear directly on the RHS, and
14052      without an increased ref count, since the stack isn't refcounted.
14053      This case can be detected at compile time by scanning for common lex
14054      vars with PL_generation.
14055
14056    * lvalue subs defeat common var detection, but they do at least
14057      return vars with a temporary ref count increment. Also, you can't
14058      tell at compile time whether a sub call is lvalue.
14059
14060
14061    So...
14062
14063    A: There are a few circumstances where there definitely can't be any
14064      commonality:
14065
14066        LHS empty:  () = (...);
14067        RHS empty:  (....) = ();
14068        RHS contains only constants or other 'can't possibly be shared'
14069            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
14070            i.e. they only contain ops not marked as dangerous, whose children
14071            are also not dangerous;
14072        LHS ditto;
14073        LHS contains a single scalar element: e.g. ($x) = (....); because
14074            after $x has been modified, it won't be used again on the RHS;
14075        RHS contains a single element with no aggregate on LHS: e.g.
14076            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
14077            won't be used again.
14078
14079    B: If LHS are all 'my' lexical var declarations (or safe ops, which
14080      we can ignore):
14081
14082        my ($a, $b, @c) = ...;
14083
14084        Due to closure and goto tricks, these vars may already have content.
14085        For the same reason, an element on the RHS may be a lexical or package
14086        alias of one of the vars on the left, or share common elements, for
14087        example:
14088
14089            my ($x,$y) = f(); # $x and $y on both sides
14090            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14091
14092        and
14093
14094            my $ra = f();
14095            my @a = @$ra;  # elements of @a on both sides
14096            sub f { @a = 1..4; \@a }
14097
14098
14099        First, just consider scalar vars on LHS:
14100
14101            RHS is safe only if (A), or in addition,
14102                * contains only lexical *scalar* vars, where neither side's
14103                  lexicals have been flagged as aliases
14104
14105            If RHS is not safe, then it's always legal to check LHS vars for
14106            RC==1, since the only RHS aliases will always be associated
14107            with an RC bump.
14108
14109            Note that in particular, RHS is not safe if:
14110
14111                * it contains package scalar vars; e.g.:
14112
14113                    f();
14114                    my ($x, $y) = (2, $x_alias);
14115                    sub f { $x = 1; *x_alias = \$x; }
14116
14117                * It contains other general elements, such as flattened or
14118                * spliced or single array or hash elements, e.g.
14119
14120                    f();
14121                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14122
14123                    sub f {
14124                        ($x, $y) = (1,2);
14125                        use feature 'refaliasing';
14126                        \($a[0], $a[1]) = \($y,$x);
14127                    }
14128
14129                  It doesn't matter if the array/hash is lexical or package.
14130
14131                * it contains a function call that happens to be an lvalue
14132                  sub which returns one or more of the above, e.g.
14133
14134                    f();
14135                    my ($x,$y) = f();
14136
14137                    sub f : lvalue {
14138                        ($x, $y) = (1,2);
14139                        *x1 = \$x;
14140                        $y, $x1;
14141                    }
14142
14143                    (so a sub call on the RHS should be treated the same
14144                    as having a package var on the RHS).
14145
14146                * any other "dangerous" thing, such an op or built-in that
14147                  returns one of the above, e.g. pp_preinc
14148
14149
14150            If RHS is not safe, what we can do however is at compile time flag
14151            that the LHS are all my declarations, and at run time check whether
14152            all the LHS have RC == 1, and if so skip the full scan.
14153
14154        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14155
14156            Here the issue is whether there can be elements of @a on the RHS
14157            which will get prematurely freed when @a is cleared prior to
14158            assignment. This is only a problem if the aliasing mechanism
14159            is one which doesn't increase the refcount - only if RC == 1
14160            will the RHS element be prematurely freed.
14161
14162            Because the array/hash is being INTROed, it or its elements
14163            can't directly appear on the RHS:
14164
14165                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14166
14167            but can indirectly, e.g.:
14168
14169                my $r = f();
14170                my (@a) = @$r;
14171                sub f { @a = 1..3; \@a }
14172
14173            So if the RHS isn't safe as defined by (A), we must always
14174            mortalise and bump the ref count of any remaining RHS elements
14175            when assigning to a non-empty LHS aggregate.
14176
14177            Lexical scalars on the RHS aren't safe if they've been involved in
14178            aliasing, e.g.
14179
14180                use feature 'refaliasing';
14181
14182                f();
14183                \(my $lex) = \$pkg;
14184                my @a = ($lex,3); # equivalent to ($a[0],3)
14185
14186                sub f {
14187                    @a = (1,2);
14188                    \$pkg = \$a[0];
14189                }
14190
14191            Similarly with lexical arrays and hashes on the RHS:
14192
14193                f();
14194                my @b;
14195                my @a = (@b);
14196
14197                sub f {
14198                    @a = (1,2);
14199                    \$b[0] = \$a[1];
14200                    \$b[1] = \$a[0];
14201                }
14202
14203
14204
14205    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14206        my $a; ($a, my $b) = (....);
14207
14208        The difference between (B) and (C) is that it is now physically
14209        possible for the LHS vars to appear on the RHS too, where they
14210        are not reference counted; but in this case, the compile-time
14211        PL_generation sweep will detect such common vars.
14212
14213        So the rules for (C) differ from (B) in that if common vars are
14214        detected, the runtime "test RC==1" optimisation can no longer be used,
14215        and a full mark and sweep is required
14216
14217    D: As (C), but in addition the LHS may contain package vars.
14218
14219        Since package vars can be aliased without a corresponding refcount
14220        increase, all bets are off. It's only safe if (A). E.g.
14221
14222            my ($x, $y) = (1,2);
14223
14224            for $x_alias ($x) {
14225                ($x_alias, $y) = (3, $x); # whoops
14226            }
14227
14228        Ditto for LHS aggregate package vars.
14229
14230    E: Any other dangerous ops on LHS, e.g.
14231            (f(), $a[0], @$r) = (...);
14232
14233        this is similar to (E) in that all bets are off. In addition, it's
14234        impossible to determine at compile time whether the LHS
14235        contains a scalar or an aggregate, e.g.
14236
14237            sub f : lvalue { @a }
14238            (f()) = 1..3;
14239
14240 * ---------------------------------------------------------
14241 */
14242
14243
14244 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14245  * that at least one of the things flagged was seen.
14246  */
14247
14248 enum {
14249     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14250     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14251     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14252     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14253     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14254     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14255     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14256     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14257                                          that's flagged OA_DANGEROUS */
14258     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14259                                         not in any of the categories above */
14260     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14261 };
14262
14263
14264
14265 /* helper function for S_aassign_scan().
14266  * check a PAD-related op for commonality and/or set its generation number.
14267  * Returns a boolean indicating whether its shared */
14268
14269 static bool
14270 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14271 {
14272     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14273         /* lexical used in aliasing */
14274         return TRUE;
14275
14276     if (rhs)
14277         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14278     else
14279         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14280
14281     return FALSE;
14282 }
14283
14284
14285 /*
14286   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14287   It scans the left or right hand subtree of the aassign op, and returns a
14288   set of flags indicating what sorts of things it found there.
14289   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14290   set PL_generation on lexical vars; if the latter, we see if
14291   PL_generation matches.
14292   'top' indicates whether we're recursing or at the top level.
14293   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14294   This fn will increment it by the number seen. It's not intended to
14295   be an accurate count (especially as many ops can push a variable
14296   number of SVs onto the stack); rather it's used as to test whether there
14297   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14298 */
14299
14300 static int
14301 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14302 {
14303     int flags = 0;
14304     bool kid_top = FALSE;
14305
14306     /* first, look for a solitary @_ on the RHS */
14307     if (   rhs
14308         && top
14309         && (o->op_flags & OPf_KIDS)
14310         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14311     ) {
14312         OP *kid = cUNOPo->op_first;
14313         if (   (   kid->op_type == OP_PUSHMARK
14314                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14315             && ((kid = OpSIBLING(kid)))
14316             && !OpHAS_SIBLING(kid)
14317             && kid->op_type == OP_RV2AV
14318             && !(kid->op_flags & OPf_REF)
14319             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14320             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14321             && ((kid = cUNOPx(kid)->op_first))
14322             && kid->op_type == OP_GV
14323             && cGVOPx_gv(kid) == PL_defgv
14324         )
14325             flags |= AAS_DEFAV;
14326     }
14327
14328     switch (o->op_type) {
14329     case OP_GVSV:
14330         (*scalars_p)++;
14331         return AAS_PKG_SCALAR;
14332
14333     case OP_PADAV:
14334     case OP_PADHV:
14335         (*scalars_p) += 2;
14336         /* if !top, could be e.g. @a[0,1] */
14337         if (top && (o->op_flags & OPf_REF))
14338             return (o->op_private & OPpLVAL_INTRO)
14339                 ? AAS_MY_AGG : AAS_LEX_AGG;
14340         return AAS_DANGEROUS;
14341
14342     case OP_PADSV:
14343         {
14344             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14345                         ?  AAS_LEX_SCALAR_COMM : 0;
14346             (*scalars_p)++;
14347             return (o->op_private & OPpLVAL_INTRO)
14348                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14349         }
14350
14351     case OP_RV2AV:
14352     case OP_RV2HV:
14353         (*scalars_p) += 2;
14354         if (cUNOPx(o)->op_first->op_type != OP_GV)
14355             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14356         /* @pkg, %pkg */
14357         /* if !top, could be e.g. @a[0,1] */
14358         if (top && (o->op_flags & OPf_REF))
14359             return AAS_PKG_AGG;
14360         return AAS_DANGEROUS;
14361
14362     case OP_RV2SV:
14363         (*scalars_p)++;
14364         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14365             (*scalars_p) += 2;
14366             return AAS_DANGEROUS; /* ${expr} */
14367         }
14368         return AAS_PKG_SCALAR; /* $pkg */
14369
14370     case OP_SPLIT:
14371         if (o->op_private & OPpSPLIT_ASSIGN) {
14372             /* the assign in @a = split() has been optimised away
14373              * and the @a attached directly to the split op
14374              * Treat the array as appearing on the RHS, i.e.
14375              *    ... = (@a = split)
14376              * is treated like
14377              *    ... = @a;
14378              */
14379
14380             if (o->op_flags & OPf_STACKED)
14381                 /* @{expr} = split() - the array expression is tacked
14382                  * on as an extra child to split - process kid */
14383                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14384                                         top, scalars_p);
14385
14386             /* ... else array is directly attached to split op */
14387             (*scalars_p) += 2;
14388             if (PL_op->op_private & OPpSPLIT_LEX)
14389                 return (o->op_private & OPpLVAL_INTRO)
14390                     ? AAS_MY_AGG : AAS_LEX_AGG;
14391             else
14392                 return AAS_PKG_AGG;
14393         }
14394         (*scalars_p)++;
14395         /* other args of split can't be returned */
14396         return AAS_SAFE_SCALAR;
14397
14398     case OP_UNDEF:
14399         /* undef counts as a scalar on the RHS:
14400          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14401          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14402          */
14403         if (rhs)
14404             (*scalars_p)++;
14405         flags = AAS_SAFE_SCALAR;
14406         break;
14407
14408     case OP_PUSHMARK:
14409     case OP_STUB:
14410         /* these are all no-ops; they don't push a potentially common SV
14411          * onto the stack, so they are neither AAS_DANGEROUS nor
14412          * AAS_SAFE_SCALAR */
14413         return 0;
14414
14415     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14416         break;
14417
14418     case OP_NULL:
14419     case OP_LIST:
14420         /* these do nothing but may have children; but their children
14421          * should also be treated as top-level */
14422         kid_top = top;
14423         break;
14424
14425     default:
14426         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14427             (*scalars_p) += 2;
14428             flags = AAS_DANGEROUS;
14429             break;
14430         }
14431
14432         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14433             && (o->op_private & OPpTARGET_MY))
14434         {
14435             (*scalars_p)++;
14436             return S_aassign_padcheck(aTHX_ o, rhs)
14437                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14438         }
14439
14440         /* if its an unrecognised, non-dangerous op, assume that it
14441          * it the cause of at least one safe scalar */
14442         (*scalars_p)++;
14443         flags = AAS_SAFE_SCALAR;
14444         break;
14445     }
14446
14447     /* XXX this assumes that all other ops are "transparent" - i.e. that
14448      * they can return some of their children. While this true for e.g.
14449      * sort and grep, it's not true for e.g. map. We really need a
14450      * 'transparent' flag added to regen/opcodes
14451      */
14452     if (o->op_flags & OPf_KIDS) {
14453         OP *kid;
14454         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14455             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14456     }
14457     return flags;
14458 }
14459
14460
14461 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14462    and modify the optree to make them work inplace */
14463
14464 STATIC void
14465 S_inplace_aassign(pTHX_ OP *o) {
14466
14467     OP *modop, *modop_pushmark;
14468     OP *oright;
14469     OP *oleft, *oleft_pushmark;
14470
14471     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14472
14473     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14474
14475     assert(cUNOPo->op_first->op_type == OP_NULL);
14476     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14477     assert(modop_pushmark->op_type == OP_PUSHMARK);
14478     modop = OpSIBLING(modop_pushmark);
14479
14480     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14481         return;
14482
14483     /* no other operation except sort/reverse */
14484     if (OpHAS_SIBLING(modop))
14485         return;
14486
14487     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14488     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14489
14490     if (modop->op_flags & OPf_STACKED) {
14491         /* skip sort subroutine/block */
14492         assert(oright->op_type == OP_NULL);
14493         oright = OpSIBLING(oright);
14494     }
14495
14496     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14497     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14498     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14499     oleft = OpSIBLING(oleft_pushmark);
14500
14501     /* Check the lhs is an array */
14502     if (!oleft ||
14503         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14504         || OpHAS_SIBLING(oleft)
14505         || (oleft->op_private & OPpLVAL_INTRO)
14506     )
14507         return;
14508
14509     /* Only one thing on the rhs */
14510     if (OpHAS_SIBLING(oright))
14511         return;
14512
14513     /* check the array is the same on both sides */
14514     if (oleft->op_type == OP_RV2AV) {
14515         if (oright->op_type != OP_RV2AV
14516             || !cUNOPx(oright)->op_first
14517             || cUNOPx(oright)->op_first->op_type != OP_GV
14518             || cUNOPx(oleft )->op_first->op_type != OP_GV
14519             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14520                cGVOPx_gv(cUNOPx(oright)->op_first)
14521         )
14522             return;
14523     }
14524     else if (oright->op_type != OP_PADAV
14525         || oright->op_targ != oleft->op_targ
14526     )
14527         return;
14528
14529     /* This actually is an inplace assignment */
14530
14531     modop->op_private |= OPpSORT_INPLACE;
14532
14533     /* transfer MODishness etc from LHS arg to RHS arg */
14534     oright->op_flags = oleft->op_flags;
14535
14536     /* remove the aassign op and the lhs */
14537     op_null(o);
14538     op_null(oleft_pushmark);
14539     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14540         op_null(cUNOPx(oleft)->op_first);
14541     op_null(oleft);
14542 }
14543
14544
14545
14546 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14547  * that potentially represent a series of one or more aggregate derefs
14548  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14549  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14550  * additional ops left in too).
14551  *
14552  * The caller will have already verified that the first few ops in the
14553  * chain following 'start' indicate a multideref candidate, and will have
14554  * set 'orig_o' to the point further on in the chain where the first index
14555  * expression (if any) begins.  'orig_action' specifies what type of
14556  * beginning has already been determined by the ops between start..orig_o
14557  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14558  *
14559  * 'hints' contains any hints flags that need adding (currently just
14560  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14561  */
14562
14563 STATIC void
14564 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14565 {
14566     dVAR;
14567     int pass;
14568     UNOP_AUX_item *arg_buf = NULL;
14569     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14570     int index_skip         = -1;    /* don't output index arg on this action */
14571
14572     /* similar to regex compiling, do two passes; the first pass
14573      * determines whether the op chain is convertible and calculates the
14574      * buffer size; the second pass populates the buffer and makes any
14575      * changes necessary to ops (such as moving consts to the pad on
14576      * threaded builds).
14577      *
14578      * NB: for things like Coverity, note that both passes take the same
14579      * path through the logic tree (except for 'if (pass)' bits), since
14580      * both passes are following the same op_next chain; and in
14581      * particular, if it would return early on the second pass, it would
14582      * already have returned early on the first pass.
14583      */
14584     for (pass = 0; pass < 2; pass++) {
14585         OP *o                = orig_o;
14586         UV action            = orig_action;
14587         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14588         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14589         int action_count     = 0;     /* number of actions seen so far */
14590         int action_ix        = 0;     /* action_count % (actions per IV) */
14591         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14592         bool is_last         = FALSE; /* no more derefs to follow */
14593         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14594         UNOP_AUX_item *arg     = arg_buf;
14595         UNOP_AUX_item *action_ptr = arg_buf;
14596
14597         if (pass)
14598             action_ptr->uv = 0;
14599         arg++;
14600
14601         switch (action) {
14602         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14603         case MDEREF_HV_gvhv_helem:
14604             next_is_hash = TRUE;
14605             /* FALLTHROUGH */
14606         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14607         case MDEREF_AV_gvav_aelem:
14608             if (pass) {
14609 #ifdef USE_ITHREADS
14610                 arg->pad_offset = cPADOPx(start)->op_padix;
14611                 /* stop it being swiped when nulled */
14612                 cPADOPx(start)->op_padix = 0;
14613 #else
14614                 arg->sv = cSVOPx(start)->op_sv;
14615                 cSVOPx(start)->op_sv = NULL;
14616 #endif
14617             }
14618             arg++;
14619             break;
14620
14621         case MDEREF_HV_padhv_helem:
14622         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14623             next_is_hash = TRUE;
14624             /* FALLTHROUGH */
14625         case MDEREF_AV_padav_aelem:
14626         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14627             if (pass) {
14628                 arg->pad_offset = start->op_targ;
14629                 /* we skip setting op_targ = 0 for now, since the intact
14630                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14631                 reset_start_targ = TRUE;
14632             }
14633             arg++;
14634             break;
14635
14636         case MDEREF_HV_pop_rv2hv_helem:
14637             next_is_hash = TRUE;
14638             /* FALLTHROUGH */
14639         case MDEREF_AV_pop_rv2av_aelem:
14640             break;
14641
14642         default:
14643             NOT_REACHED; /* NOTREACHED */
14644             return;
14645         }
14646
14647         while (!is_last) {
14648             /* look for another (rv2av/hv; get index;
14649              * aelem/helem/exists/delele) sequence */
14650
14651             OP *kid;
14652             bool is_deref;
14653             bool ok;
14654             UV index_type = MDEREF_INDEX_none;
14655
14656             if (action_count) {
14657                 /* if this is not the first lookup, consume the rv2av/hv  */
14658
14659                 /* for N levels of aggregate lookup, we normally expect
14660                  * that the first N-1 [ah]elem ops will be flagged as
14661                  * /DEREF (so they autovivifiy if necessary), and the last
14662                  * lookup op not to be.
14663                  * For other things (like @{$h{k1}{k2}}) extra scope or
14664                  * leave ops can appear, so abandon the effort in that
14665                  * case */
14666                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14667                     return;
14668
14669                 /* rv2av or rv2hv sKR/1 */
14670
14671                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14672                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14673                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14674                     return;
14675
14676                 /* at this point, we wouldn't expect any of these
14677                  * possible private flags:
14678                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14679                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14680                  */
14681                 ASSUME(!(o->op_private &
14682                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14683
14684                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14685
14686                 /* make sure the type of the previous /DEREF matches the
14687                  * type of the next lookup */
14688                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14689                 top_op = o;
14690
14691                 action = next_is_hash
14692                             ? MDEREF_HV_vivify_rv2hv_helem
14693                             : MDEREF_AV_vivify_rv2av_aelem;
14694                 o = o->op_next;
14695             }
14696
14697             /* if this is the second pass, and we're at the depth where
14698              * previously we encountered a non-simple index expression,
14699              * stop processing the index at this point */
14700             if (action_count != index_skip) {
14701
14702                 /* look for one or more simple ops that return an array
14703                  * index or hash key */
14704
14705                 switch (o->op_type) {
14706                 case OP_PADSV:
14707                     /* it may be a lexical var index */
14708                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14709                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14710                     ASSUME(!(o->op_private &
14711                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14712
14713                     if (   OP_GIMME(o,0) == G_SCALAR
14714                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14715                         && o->op_private == 0)
14716                     {
14717                         if (pass)
14718                             arg->pad_offset = o->op_targ;
14719                         arg++;
14720                         index_type = MDEREF_INDEX_padsv;
14721                         o = o->op_next;
14722                     }
14723                     break;
14724
14725                 case OP_CONST:
14726                     if (next_is_hash) {
14727                         /* it's a constant hash index */
14728                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14729                             /* "use constant foo => FOO; $h{+foo}" for
14730                              * some weird FOO, can leave you with constants
14731                              * that aren't simple strings. It's not worth
14732                              * the extra hassle for those edge cases */
14733                             break;
14734
14735                         {
14736                             UNOP *rop = NULL;
14737                             OP * helem_op = o->op_next;
14738
14739                             ASSUME(   helem_op->op_type == OP_HELEM
14740                                    || helem_op->op_type == OP_NULL
14741                                    || pass == 0);
14742                             if (helem_op->op_type == OP_HELEM) {
14743                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14744                                 if (   helem_op->op_private & OPpLVAL_INTRO
14745                                     || rop->op_type != OP_RV2HV
14746                                 )
14747                                     rop = NULL;
14748                             }
14749                             /* on first pass just check; on second pass
14750                              * hekify */
14751                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
14752                                                             pass);
14753                         }
14754
14755                         if (pass) {
14756 #ifdef USE_ITHREADS
14757                             /* Relocate sv to the pad for thread safety */
14758                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14759                             arg->pad_offset = o->op_targ;
14760                             o->op_targ = 0;
14761 #else
14762                             arg->sv = cSVOPx_sv(o);
14763 #endif
14764                         }
14765                     }
14766                     else {
14767                         /* it's a constant array index */
14768                         IV iv;
14769                         SV *ix_sv = cSVOPo->op_sv;
14770                         if (!SvIOK(ix_sv))
14771                             break;
14772                         iv = SvIV(ix_sv);
14773
14774                         if (   action_count == 0
14775                             && iv >= -128
14776                             && iv <= 127
14777                             && (   action == MDEREF_AV_padav_aelem
14778                                 || action == MDEREF_AV_gvav_aelem)
14779                         )
14780                             maybe_aelemfast = TRUE;
14781
14782                         if (pass) {
14783                             arg->iv = iv;
14784                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14785                         }
14786                     }
14787                     if (pass)
14788                         /* we've taken ownership of the SV */
14789                         cSVOPo->op_sv = NULL;
14790                     arg++;
14791                     index_type = MDEREF_INDEX_const;
14792                     o = o->op_next;
14793                     break;
14794
14795                 case OP_GV:
14796                     /* it may be a package var index */
14797
14798                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14799                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14800                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14801                         || o->op_private != 0
14802                     )
14803                         break;
14804
14805                     kid = o->op_next;
14806                     if (kid->op_type != OP_RV2SV)
14807                         break;
14808
14809                     ASSUME(!(kid->op_flags &
14810                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14811                              |OPf_SPECIAL|OPf_PARENS)));
14812                     ASSUME(!(kid->op_private &
14813                                     ~(OPpARG1_MASK
14814                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14815                                      |OPpDEREF|OPpLVAL_INTRO)));
14816                     if(   (kid->op_flags &~ OPf_PARENS)
14817                             != (OPf_WANT_SCALAR|OPf_KIDS)
14818                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14819                     )
14820                         break;
14821
14822                     if (pass) {
14823 #ifdef USE_ITHREADS
14824                         arg->pad_offset = cPADOPx(o)->op_padix;
14825                         /* stop it being swiped when nulled */
14826                         cPADOPx(o)->op_padix = 0;
14827 #else
14828                         arg->sv = cSVOPx(o)->op_sv;
14829                         cSVOPo->op_sv = NULL;
14830 #endif
14831                     }
14832                     arg++;
14833                     index_type = MDEREF_INDEX_gvsv;
14834                     o = kid->op_next;
14835                     break;
14836
14837                 } /* switch */
14838             } /* action_count != index_skip */
14839
14840             action |= index_type;
14841
14842
14843             /* at this point we have either:
14844              *   * detected what looks like a simple index expression,
14845              *     and expect the next op to be an [ah]elem, or
14846              *     an nulled  [ah]elem followed by a delete or exists;
14847              *  * found a more complex expression, so something other
14848              *    than the above follows.
14849              */
14850
14851             /* possibly an optimised away [ah]elem (where op_next is
14852              * exists or delete) */
14853             if (o->op_type == OP_NULL)
14854                 o = o->op_next;
14855
14856             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14857              * OP_EXISTS or OP_DELETE */
14858
14859             /* if a custom array/hash access checker is in scope,
14860              * abandon optimisation attempt */
14861             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14862                && PL_check[o->op_type] != Perl_ck_null)
14863                 return;
14864             /* similarly for customised exists and delete */
14865             if (  (o->op_type == OP_EXISTS)
14866                && PL_check[o->op_type] != Perl_ck_exists)
14867                 return;
14868             if (  (o->op_type == OP_DELETE)
14869                && PL_check[o->op_type] != Perl_ck_delete)
14870                 return;
14871
14872             if (   o->op_type != OP_AELEM
14873                 || (o->op_private &
14874                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14875                 )
14876                 maybe_aelemfast = FALSE;
14877
14878             /* look for aelem/helem/exists/delete. If it's not the last elem
14879              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14880              * flags; if it's the last, then it mustn't have
14881              * OPpDEREF_AV/HV, but may have lots of other flags, like
14882              * OPpLVAL_INTRO etc
14883              */
14884
14885             if (   index_type == MDEREF_INDEX_none
14886                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14887                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14888             )
14889                 ok = FALSE;
14890             else {
14891                 /* we have aelem/helem/exists/delete with valid simple index */
14892
14893                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14894                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14895                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14896
14897                 /* This doesn't make much sense but is legal:
14898                  *    @{ local $x[0][0] } = 1
14899                  * Since scope exit will undo the autovivification,
14900                  * don't bother in the first place. The OP_LEAVE
14901                  * assertion is in case there are other cases of both
14902                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14903                  * exit that would undo the local - in which case this
14904                  * block of code would need rethinking.
14905                  */
14906                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14907 #ifdef DEBUGGING
14908                     OP *n = o->op_next;
14909                     while (n && (  n->op_type == OP_NULL
14910                                 || n->op_type == OP_LIST))
14911                         n = n->op_next;
14912                     assert(n && n->op_type == OP_LEAVE);
14913 #endif
14914                     o->op_private &= ~OPpDEREF;
14915                     is_deref = FALSE;
14916                 }
14917
14918                 if (is_deref) {
14919                     ASSUME(!(o->op_flags &
14920                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14921                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14922
14923                     ok =    (o->op_flags &~ OPf_PARENS)
14924                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14925                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14926                 }
14927                 else if (o->op_type == OP_EXISTS) {
14928                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14929                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14930                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14931                     ok =  !(o->op_private & ~OPpARG1_MASK);
14932                 }
14933                 else if (o->op_type == OP_DELETE) {
14934                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14935                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14936                     ASSUME(!(o->op_private &
14937                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14938                     /* don't handle slices or 'local delete'; the latter
14939                      * is fairly rare, and has a complex runtime */
14940                     ok =  !(o->op_private & ~OPpARG1_MASK);
14941                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14942                         /* skip handling run-tome error */
14943                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14944                 }
14945                 else {
14946                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14947                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14948                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14949                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14950                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14951                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14952                 }
14953             }
14954
14955             if (ok) {
14956                 if (!first_elem_op)
14957                     first_elem_op = o;
14958                 top_op = o;
14959                 if (is_deref) {
14960                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14961                     o = o->op_next;
14962                 }
14963                 else {
14964                     is_last = TRUE;
14965                     action |= MDEREF_FLAG_last;
14966                 }
14967             }
14968             else {
14969                 /* at this point we have something that started
14970                  * promisingly enough (with rv2av or whatever), but failed
14971                  * to find a simple index followed by an
14972                  * aelem/helem/exists/delete. If this is the first action,
14973                  * give up; but if we've already seen at least one
14974                  * aelem/helem, then keep them and add a new action with
14975                  * MDEREF_INDEX_none, which causes it to do the vivify
14976                  * from the end of the previous lookup, and do the deref,
14977                  * but stop at that point. So $a[0][expr] will do one
14978                  * av_fetch, vivify and deref, then continue executing at
14979                  * expr */
14980                 if (!action_count)
14981                     return;
14982                 is_last = TRUE;
14983                 index_skip = action_count;
14984                 action |= MDEREF_FLAG_last;
14985                 if (index_type != MDEREF_INDEX_none)
14986                     arg--;
14987             }
14988
14989             if (pass)
14990                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14991             action_ix++;
14992             action_count++;
14993             /* if there's no space for the next action, create a new slot
14994              * for it *before* we start adding args for that action */
14995             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14996                 action_ptr = arg;
14997                 if (pass)
14998                     arg->uv = 0;
14999                 arg++;
15000                 action_ix = 0;
15001             }
15002         } /* while !is_last */
15003
15004         /* success! */
15005
15006         if (pass) {
15007             OP *mderef;
15008             OP *p, *q;
15009
15010             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15011             if (index_skip == -1) {
15012                 mderef->op_flags = o->op_flags
15013                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15014                 if (o->op_type == OP_EXISTS)
15015                     mderef->op_private = OPpMULTIDEREF_EXISTS;
15016                 else if (o->op_type == OP_DELETE)
15017                     mderef->op_private = OPpMULTIDEREF_DELETE;
15018                 else
15019                     mderef->op_private = o->op_private
15020                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15021             }
15022             /* accumulate strictness from every level (although I don't think
15023              * they can actually vary) */
15024             mderef->op_private |= hints;
15025
15026             /* integrate the new multideref op into the optree and the
15027              * op_next chain.
15028              *
15029              * In general an op like aelem or helem has two child
15030              * sub-trees: the aggregate expression (a_expr) and the
15031              * index expression (i_expr):
15032              *
15033              *     aelem
15034              *       |
15035              *     a_expr - i_expr
15036              *
15037              * The a_expr returns an AV or HV, while the i-expr returns an
15038              * index. In general a multideref replaces most or all of a
15039              * multi-level tree, e.g.
15040              *
15041              *     exists
15042              *       |
15043              *     ex-aelem
15044              *       |
15045              *     rv2av  - i_expr1
15046              *       |
15047              *     helem
15048              *       |
15049              *     rv2hv  - i_expr2
15050              *       |
15051              *     aelem
15052              *       |
15053              *     a_expr - i_expr3
15054              *
15055              * With multideref, all the i_exprs will be simple vars or
15056              * constants, except that i_expr1 may be arbitrary in the case
15057              * of MDEREF_INDEX_none.
15058              *
15059              * The bottom-most a_expr will be either:
15060              *   1) a simple var (so padXv or gv+rv2Xv);
15061              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
15062              *      so a simple var with an extra rv2Xv;
15063              *   3) or an arbitrary expression.
15064              *
15065              * 'start', the first op in the execution chain, will point to
15066              *   1),2): the padXv or gv op;
15067              *   3):    the rv2Xv which forms the last op in the a_expr
15068              *          execution chain, and the top-most op in the a_expr
15069              *          subtree.
15070              *
15071              * For all cases, the 'start' node is no longer required,
15072              * but we can't free it since one or more external nodes
15073              * may point to it. E.g. consider
15074              *     $h{foo} = $a ? $b : $c
15075              * Here, both the op_next and op_other branches of the
15076              * cond_expr point to the gv[*h] of the hash expression, so
15077              * we can't free the 'start' op.
15078              *
15079              * For expr->[...], we need to save the subtree containing the
15080              * expression; for the other cases, we just need to save the
15081              * start node.
15082              * So in all cases, we null the start op and keep it around by
15083              * making it the child of the multideref op; for the expr->
15084              * case, the expr will be a subtree of the start node.
15085              *
15086              * So in the simple 1,2 case the  optree above changes to
15087              *
15088              *     ex-exists
15089              *       |
15090              *     multideref
15091              *       |
15092              *     ex-gv (or ex-padxv)
15093              *
15094              *  with the op_next chain being
15095              *
15096              *  -> ex-gv -> multideref -> op-following-ex-exists ->
15097              *
15098              *  In the 3 case, we have
15099              *
15100              *     ex-exists
15101              *       |
15102              *     multideref
15103              *       |
15104              *     ex-rv2xv
15105              *       |
15106              *    rest-of-a_expr
15107              *      subtree
15108              *
15109              *  and
15110              *
15111              *  -> rest-of-a_expr subtree ->
15112              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15113              *
15114              *
15115              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15116              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15117              * multideref attached as the child, e.g.
15118              *
15119              *     exists
15120              *       |
15121              *     ex-aelem
15122              *       |
15123              *     ex-rv2av  - i_expr1
15124              *       |
15125              *     multideref
15126              *       |
15127              *     ex-whatever
15128              *
15129              */
15130
15131             /* if we free this op, don't free the pad entry */
15132             if (reset_start_targ)
15133                 start->op_targ = 0;
15134
15135
15136             /* Cut the bit we need to save out of the tree and attach to
15137              * the multideref op, then free the rest of the tree */
15138
15139             /* find parent of node to be detached (for use by splice) */
15140             p = first_elem_op;
15141             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15142                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15143             {
15144                 /* there is an arbitrary expression preceding us, e.g.
15145                  * expr->[..]? so we need to save the 'expr' subtree */
15146                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15147                     p = cUNOPx(p)->op_first;
15148                 ASSUME(   start->op_type == OP_RV2AV
15149                        || start->op_type == OP_RV2HV);
15150             }
15151             else {
15152                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15153                  * above for exists/delete. */
15154                 while (   (p->op_flags & OPf_KIDS)
15155                        && cUNOPx(p)->op_first != start
15156                 )
15157                     p = cUNOPx(p)->op_first;
15158             }
15159             ASSUME(cUNOPx(p)->op_first == start);
15160
15161             /* detach from main tree, and re-attach under the multideref */
15162             op_sibling_splice(mderef, NULL, 0,
15163                     op_sibling_splice(p, NULL, 1, NULL));
15164             op_null(start);
15165
15166             start->op_next = mderef;
15167
15168             mderef->op_next = index_skip == -1 ? o->op_next : o;
15169
15170             /* excise and free the original tree, and replace with
15171              * the multideref op */
15172             p = op_sibling_splice(top_op, NULL, -1, mderef);
15173             while (p) {
15174                 q = OpSIBLING(p);
15175                 op_free(p);
15176                 p = q;
15177             }
15178             op_null(top_op);
15179         }
15180         else {
15181             Size_t size = arg - arg_buf;
15182
15183             if (maybe_aelemfast && action_count == 1)
15184                 return;
15185
15186             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15187                                 sizeof(UNOP_AUX_item) * (size + 1));
15188             /* for dumping etc: store the length in a hidden first slot;
15189              * we set the op_aux pointer to the second slot */
15190             arg_buf->uv = size;
15191             arg_buf++;
15192         }
15193     } /* for (pass = ...) */
15194 }
15195
15196 /* See if the ops following o are such that o will always be executed in
15197  * boolean context: that is, the SV which o pushes onto the stack will
15198  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15199  * If so, set a suitable private flag on o. Normally this will be
15200  * bool_flag; but see below why maybe_flag is needed too.
15201  *
15202  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15203  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15204  * already be taken, so you'll have to give that op two different flags.
15205  *
15206  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15207  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15208  * those underlying ops) short-circuit, which means that rather than
15209  * necessarily returning a truth value, they may return the LH argument,
15210  * which may not be boolean. For example in $x = (keys %h || -1), keys
15211  * should return a key count rather than a boolean, even though its
15212  * sort-of being used in boolean context.
15213  *
15214  * So we only consider such logical ops to provide boolean context to
15215  * their LH argument if they themselves are in void or boolean context.
15216  * However, sometimes the context isn't known until run-time. In this
15217  * case the op is marked with the maybe_flag flag it.
15218  *
15219  * Consider the following.
15220  *
15221  *     sub f { ....;  if (%h) { .... } }
15222  *
15223  * This is actually compiled as
15224  *
15225  *     sub f { ....;  %h && do { .... } }
15226  *
15227  * Here we won't know until runtime whether the final statement (and hence
15228  * the &&) is in void context and so is safe to return a boolean value.
15229  * So mark o with maybe_flag rather than the bool_flag.
15230  * Note that there is cost associated with determining context at runtime
15231  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15232  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15233  * boolean costs savings are marginal.
15234  *
15235  * However, we can do slightly better with && (compared to || and //):
15236  * this op only returns its LH argument when that argument is false. In
15237  * this case, as long as the op promises to return a false value which is
15238  * valid in both boolean and scalar contexts, we can mark an op consumed
15239  * by && with bool_flag rather than maybe_flag.
15240  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15241  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15242  * op which promises to handle this case is indicated by setting safe_and
15243  * to true.
15244  */
15245
15246 static void
15247 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15248 {
15249     OP *lop;
15250     U8 flag = 0;
15251
15252     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15253
15254     /* OPpTARGET_MY and boolean context probably don't mix well.
15255      * If someone finds a valid use case, maybe add an extra flag to this
15256      * function which indicates its safe to do so for this op? */
15257     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15258              && (o->op_private & OPpTARGET_MY)));
15259
15260     lop = o->op_next;
15261
15262     while (lop) {
15263         switch (lop->op_type) {
15264         case OP_NULL:
15265         case OP_SCALAR:
15266             break;
15267
15268         /* these two consume the stack argument in the scalar case,
15269          * and treat it as a boolean in the non linenumber case */
15270         case OP_FLIP:
15271         case OP_FLOP:
15272             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15273                 || (lop->op_private & OPpFLIP_LINENUM))
15274             {
15275                 lop = NULL;
15276                 break;
15277             }
15278             /* FALLTHROUGH */
15279         /* these never leave the original value on the stack */
15280         case OP_NOT:
15281         case OP_XOR:
15282         case OP_COND_EXPR:
15283         case OP_GREPWHILE:
15284             flag = bool_flag;
15285             lop = NULL;
15286             break;
15287
15288         /* OR DOR and AND evaluate their arg as a boolean, but then may
15289          * leave the original scalar value on the stack when following the
15290          * op_next route. If not in void context, we need to ensure
15291          * that whatever follows consumes the arg only in boolean context
15292          * too.
15293          */
15294         case OP_AND:
15295             if (safe_and) {
15296                 flag = bool_flag;
15297                 lop = NULL;
15298                 break;
15299             }
15300             /* FALLTHROUGH */
15301         case OP_OR:
15302         case OP_DOR:
15303             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15304                 flag = bool_flag;
15305                 lop = NULL;
15306             }
15307             else if (!(lop->op_flags & OPf_WANT)) {
15308                 /* unknown context - decide at runtime */
15309                 flag = maybe_flag;
15310                 lop = NULL;
15311             }
15312             break;
15313
15314         default:
15315             lop = NULL;
15316             break;
15317         }
15318
15319         if (lop)
15320             lop = lop->op_next;
15321     }
15322
15323     o->op_private |= flag;
15324 }
15325
15326
15327
15328 /* mechanism for deferring recursion in rpeep() */
15329
15330 #define MAX_DEFERRED 4
15331
15332 #define DEFER(o) \
15333   STMT_START { \
15334     if (defer_ix == (MAX_DEFERRED-1)) { \
15335         OP **defer = defer_queue[defer_base]; \
15336         CALL_RPEEP(*defer); \
15337         S_prune_chain_head(defer); \
15338         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15339         defer_ix--; \
15340     } \
15341     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15342   } STMT_END
15343
15344 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15345 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15346
15347
15348 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15349  * See the comments at the top of this file for more details about when
15350  * peep() is called */
15351
15352 void
15353 Perl_rpeep(pTHX_ OP *o)
15354 {
15355     dVAR;
15356     OP* oldop = NULL;
15357     OP* oldoldop = NULL;
15358     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15359     int defer_base = 0;
15360     int defer_ix = -1;
15361
15362     if (!o || o->op_opt)
15363         return;
15364
15365     assert(o->op_type != OP_FREED);
15366
15367     ENTER;
15368     SAVEOP();
15369     SAVEVPTR(PL_curcop);
15370     for (;; o = o->op_next) {
15371         if (o && o->op_opt)
15372             o = NULL;
15373         if (!o) {
15374             while (defer_ix >= 0) {
15375                 OP **defer =
15376                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15377                 CALL_RPEEP(*defer);
15378                 S_prune_chain_head(defer);
15379             }
15380             break;
15381         }
15382
15383       redo:
15384
15385         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15386         assert(!oldoldop || oldoldop->op_next == oldop);
15387         assert(!oldop    || oldop->op_next    == o);
15388
15389         /* By default, this op has now been optimised. A couple of cases below
15390            clear this again.  */
15391         o->op_opt = 1;
15392         PL_op = o;
15393
15394         /* look for a series of 1 or more aggregate derefs, e.g.
15395          *   $a[1]{foo}[$i]{$k}
15396          * and replace with a single OP_MULTIDEREF op.
15397          * Each index must be either a const, or a simple variable,
15398          *
15399          * First, look for likely combinations of starting ops,
15400          * corresponding to (global and lexical variants of)
15401          *     $a[...]   $h{...}
15402          *     $r->[...] $r->{...}
15403          *     (preceding expression)->[...]
15404          *     (preceding expression)->{...}
15405          * and if so, call maybe_multideref() to do a full inspection
15406          * of the op chain and if appropriate, replace with an
15407          * OP_MULTIDEREF
15408          */
15409         {
15410             UV action;
15411             OP *o2 = o;
15412             U8 hints = 0;
15413
15414             switch (o2->op_type) {
15415             case OP_GV:
15416                 /* $pkg[..]   :   gv[*pkg]
15417                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15418
15419                 /* Fail if there are new op flag combinations that we're
15420                  * not aware of, rather than:
15421                  *  * silently failing to optimise, or
15422                  *  * silently optimising the flag away.
15423                  * If this ASSUME starts failing, examine what new flag
15424                  * has been added to the op, and decide whether the
15425                  * optimisation should still occur with that flag, then
15426                  * update the code accordingly. This applies to all the
15427                  * other ASSUMEs in the block of code too.
15428                  */
15429                 ASSUME(!(o2->op_flags &
15430                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15431                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15432
15433                 o2 = o2->op_next;
15434
15435                 if (o2->op_type == OP_RV2AV) {
15436                     action = MDEREF_AV_gvav_aelem;
15437                     goto do_deref;
15438                 }
15439
15440                 if (o2->op_type == OP_RV2HV) {
15441                     action = MDEREF_HV_gvhv_helem;
15442                     goto do_deref;
15443                 }
15444
15445                 if (o2->op_type != OP_RV2SV)
15446                     break;
15447
15448                 /* at this point we've seen gv,rv2sv, so the only valid
15449                  * construct left is $pkg->[] or $pkg->{} */
15450
15451                 ASSUME(!(o2->op_flags & OPf_STACKED));
15452                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15453                             != (OPf_WANT_SCALAR|OPf_MOD))
15454                     break;
15455
15456                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15457                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15458                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15459                     break;
15460                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15461                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15462                     break;
15463
15464                 o2 = o2->op_next;
15465                 if (o2->op_type == OP_RV2AV) {
15466                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15467                     goto do_deref;
15468                 }
15469                 if (o2->op_type == OP_RV2HV) {
15470                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15471                     goto do_deref;
15472                 }
15473                 break;
15474
15475             case OP_PADSV:
15476                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15477
15478                 ASSUME(!(o2->op_flags &
15479                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15480                 if ((o2->op_flags &
15481                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15482                      != (OPf_WANT_SCALAR|OPf_MOD))
15483                     break;
15484
15485                 ASSUME(!(o2->op_private &
15486                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15487                 /* skip if state or intro, or not a deref */
15488                 if (      o2->op_private != OPpDEREF_AV
15489                        && o2->op_private != OPpDEREF_HV)
15490                     break;
15491
15492                 o2 = o2->op_next;
15493                 if (o2->op_type == OP_RV2AV) {
15494                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15495                     goto do_deref;
15496                 }
15497                 if (o2->op_type == OP_RV2HV) {
15498                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15499                     goto do_deref;
15500                 }
15501                 break;
15502
15503             case OP_PADAV:
15504             case OP_PADHV:
15505                 /*    $lex[..]:  padav[@lex:1,2] sR *
15506                  * or $lex{..}:  padhv[%lex:1,2] sR */
15507                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15508                                             OPf_REF|OPf_SPECIAL)));
15509                 if ((o2->op_flags &
15510                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15511                      != (OPf_WANT_SCALAR|OPf_REF))
15512                     break;
15513                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15514                     break;
15515                 /* OPf_PARENS isn't currently used in this case;
15516                  * if that changes, let us know! */
15517                 ASSUME(!(o2->op_flags & OPf_PARENS));
15518
15519                 /* at this point, we wouldn't expect any of the remaining
15520                  * possible private flags:
15521                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15522                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15523                  *
15524                  * OPpSLICEWARNING shouldn't affect runtime
15525                  */
15526                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15527
15528                 action = o2->op_type == OP_PADAV
15529                             ? MDEREF_AV_padav_aelem
15530                             : MDEREF_HV_padhv_helem;
15531                 o2 = o2->op_next;
15532                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15533                 break;
15534
15535
15536             case OP_RV2AV:
15537             case OP_RV2HV:
15538                 action = o2->op_type == OP_RV2AV
15539                             ? MDEREF_AV_pop_rv2av_aelem
15540                             : MDEREF_HV_pop_rv2hv_helem;
15541                 /* FALLTHROUGH */
15542             do_deref:
15543                 /* (expr)->[...]:  rv2av sKR/1;
15544                  * (expr)->{...}:  rv2hv sKR/1; */
15545
15546                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15547
15548                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15549                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15550                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15551                     break;
15552
15553                 /* at this point, we wouldn't expect any of these
15554                  * possible private flags:
15555                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15556                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15557                  */
15558                 ASSUME(!(o2->op_private &
15559                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15560                      |OPpOUR_INTRO)));
15561                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15562
15563                 o2 = o2->op_next;
15564
15565                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15566                 break;
15567
15568             default:
15569                 break;
15570             }
15571         }
15572
15573
15574         switch (o->op_type) {
15575         case OP_DBSTATE:
15576             PL_curcop = ((COP*)o);              /* for warnings */
15577             break;
15578         case OP_NEXTSTATE:
15579             PL_curcop = ((COP*)o);              /* for warnings */
15580
15581             /* Optimise a "return ..." at the end of a sub to just be "...".
15582              * This saves 2 ops. Before:
15583              * 1  <;> nextstate(main 1 -e:1) v ->2
15584              * 4  <@> return K ->5
15585              * 2    <0> pushmark s ->3
15586              * -    <1> ex-rv2sv sK/1 ->4
15587              * 3      <#> gvsv[*cat] s ->4
15588              *
15589              * After:
15590              * -  <@> return K ->-
15591              * -    <0> pushmark s ->2
15592              * -    <1> ex-rv2sv sK/1 ->-
15593              * 2      <$> gvsv(*cat) s ->3
15594              */
15595             {
15596                 OP *next = o->op_next;
15597                 OP *sibling = OpSIBLING(o);
15598                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15599                     && OP_TYPE_IS(sibling, OP_RETURN)
15600                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15601                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15602                        ||OP_TYPE_IS(sibling->op_next->op_next,
15603                                     OP_LEAVESUBLV))
15604                     && cUNOPx(sibling)->op_first == next
15605                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15606                     && next->op_next
15607                 ) {
15608                     /* Look through the PUSHMARK's siblings for one that
15609                      * points to the RETURN */
15610                     OP *top = OpSIBLING(next);
15611                     while (top && top->op_next) {
15612                         if (top->op_next == sibling) {
15613                             top->op_next = sibling->op_next;
15614                             o->op_next = next->op_next;
15615                             break;
15616                         }
15617                         top = OpSIBLING(top);
15618                     }
15619                 }
15620             }
15621
15622             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15623              *
15624              * This latter form is then suitable for conversion into padrange
15625              * later on. Convert:
15626              *
15627              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15628              *
15629              * into:
15630              *
15631              *   nextstate1 ->     listop     -> nextstate3
15632              *                 /            \
15633              *         pushmark -> padop1 -> padop2
15634              */
15635             if (o->op_next && (
15636                     o->op_next->op_type == OP_PADSV
15637                  || o->op_next->op_type == OP_PADAV
15638                  || o->op_next->op_type == OP_PADHV
15639                 )
15640                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15641                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15642                 && o->op_next->op_next->op_next && (
15643                     o->op_next->op_next->op_next->op_type == OP_PADSV
15644                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15645                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15646                 )
15647                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15648                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15649                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15650                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15651             ) {
15652                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15653
15654                 pad1 =    o->op_next;
15655                 ns2  = pad1->op_next;
15656                 pad2 =  ns2->op_next;
15657                 ns3  = pad2->op_next;
15658
15659                 /* we assume here that the op_next chain is the same as
15660                  * the op_sibling chain */
15661                 assert(OpSIBLING(o)    == pad1);
15662                 assert(OpSIBLING(pad1) == ns2);
15663                 assert(OpSIBLING(ns2)  == pad2);
15664                 assert(OpSIBLING(pad2) == ns3);
15665
15666                 /* excise and delete ns2 */
15667                 op_sibling_splice(NULL, pad1, 1, NULL);
15668                 op_free(ns2);
15669
15670                 /* excise pad1 and pad2 */
15671                 op_sibling_splice(NULL, o, 2, NULL);
15672
15673                 /* create new listop, with children consisting of:
15674                  * a new pushmark, pad1, pad2. */
15675                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15676                 newop->op_flags |= OPf_PARENS;
15677                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15678
15679                 /* insert newop between o and ns3 */
15680                 op_sibling_splice(NULL, o, 0, newop);
15681
15682                 /*fixup op_next chain */
15683                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15684                 o    ->op_next = newpm;
15685                 newpm->op_next = pad1;
15686                 pad1 ->op_next = pad2;
15687                 pad2 ->op_next = newop; /* listop */
15688                 newop->op_next = ns3;
15689
15690                 /* Ensure pushmark has this flag if padops do */
15691                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15692                     newpm->op_flags |= OPf_MOD;
15693                 }
15694
15695                 break;
15696             }
15697
15698             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15699                to carry two labels. For now, take the easier option, and skip
15700                this optimisation if the first NEXTSTATE has a label.  */
15701             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15702                 OP *nextop = o->op_next;
15703                 while (nextop && nextop->op_type == OP_NULL)
15704                     nextop = nextop->op_next;
15705
15706                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15707                     op_null(o);
15708                     if (oldop)
15709                         oldop->op_next = nextop;
15710                     o = nextop;
15711                     /* Skip (old)oldop assignment since the current oldop's
15712                        op_next already points to the next op.  */
15713                     goto redo;
15714                 }
15715             }
15716             break;
15717
15718         case OP_CONCAT:
15719             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15720                 if (o->op_next->op_private & OPpTARGET_MY) {
15721                     if (o->op_flags & OPf_STACKED) /* chained concats */
15722                         break; /* ignore_optimization */
15723                     else {
15724                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15725                         o->op_targ = o->op_next->op_targ;
15726                         o->op_next->op_targ = 0;
15727                         o->op_private |= OPpTARGET_MY;
15728                     }
15729                 }
15730                 op_null(o->op_next);
15731             }
15732             break;
15733         case OP_STUB:
15734             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15735                 break; /* Scalar stub must produce undef.  List stub is noop */
15736             }
15737             goto nothin;
15738         case OP_NULL:
15739             if (o->op_targ == OP_NEXTSTATE
15740                 || o->op_targ == OP_DBSTATE)
15741             {
15742                 PL_curcop = ((COP*)o);
15743             }
15744             /* XXX: We avoid setting op_seq here to prevent later calls
15745                to rpeep() from mistakenly concluding that optimisation
15746                has already occurred. This doesn't fix the real problem,
15747                though (See 20010220.007 (#5874)). AMS 20010719 */
15748             /* op_seq functionality is now replaced by op_opt */
15749             o->op_opt = 0;
15750             /* FALLTHROUGH */
15751         case OP_SCALAR:
15752         case OP_LINESEQ:
15753         case OP_SCOPE:
15754         nothin:
15755             if (oldop) {
15756                 oldop->op_next = o->op_next;
15757                 o->op_opt = 0;
15758                 continue;
15759             }
15760             break;
15761
15762         case OP_PUSHMARK:
15763
15764             /* Given
15765                  5 repeat/DOLIST
15766                  3   ex-list
15767                  1     pushmark
15768                  2     scalar or const
15769                  4   const[0]
15770                convert repeat into a stub with no kids.
15771              */
15772             if (o->op_next->op_type == OP_CONST
15773              || (  o->op_next->op_type == OP_PADSV
15774                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15775              || (  o->op_next->op_type == OP_GV
15776                 && o->op_next->op_next->op_type == OP_RV2SV
15777                 && !(o->op_next->op_next->op_private
15778                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15779             {
15780                 const OP *kid = o->op_next->op_next;
15781                 if (o->op_next->op_type == OP_GV)
15782                    kid = kid->op_next;
15783                 /* kid is now the ex-list.  */
15784                 if (kid->op_type == OP_NULL
15785                  && (kid = kid->op_next)->op_type == OP_CONST
15786                     /* kid is now the repeat count.  */
15787                  && kid->op_next->op_type == OP_REPEAT
15788                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15789                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15790                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15791                  && oldop)
15792                 {
15793                     o = kid->op_next; /* repeat */
15794                     oldop->op_next = o;
15795                     op_free(cBINOPo->op_first);
15796                     op_free(cBINOPo->op_last );
15797                     o->op_flags &=~ OPf_KIDS;
15798                     /* stub is a baseop; repeat is a binop */
15799                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15800                     OpTYPE_set(o, OP_STUB);
15801                     o->op_private = 0;
15802                     break;
15803                 }
15804             }
15805
15806             /* Convert a series of PAD ops for my vars plus support into a
15807              * single padrange op. Basically
15808              *
15809              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15810              *
15811              * becomes, depending on circumstances, one of
15812              *
15813              *    padrange  ----------------------------------> (list) -> rest
15814              *    padrange  --------------------------------------------> rest
15815              *
15816              * where all the pad indexes are sequential and of the same type
15817              * (INTRO or not).
15818              * We convert the pushmark into a padrange op, then skip
15819              * any other pad ops, and possibly some trailing ops.
15820              * Note that we don't null() the skipped ops, to make it
15821              * easier for Deparse to undo this optimisation (and none of
15822              * the skipped ops are holding any resourses). It also makes
15823              * it easier for find_uninit_var(), as it can just ignore
15824              * padrange, and examine the original pad ops.
15825              */
15826         {
15827             OP *p;
15828             OP *followop = NULL; /* the op that will follow the padrange op */
15829             U8 count = 0;
15830             U8 intro = 0;
15831             PADOFFSET base = 0; /* init only to stop compiler whining */
15832             bool gvoid = 0;     /* init only to stop compiler whining */
15833             bool defav = 0;  /* seen (...) = @_ */
15834             bool reuse = 0;  /* reuse an existing padrange op */
15835
15836             /* look for a pushmark -> gv[_] -> rv2av */
15837
15838             {
15839                 OP *rv2av, *q;
15840                 p = o->op_next;
15841                 if (   p->op_type == OP_GV
15842                     && cGVOPx_gv(p) == PL_defgv
15843                     && (rv2av = p->op_next)
15844                     && rv2av->op_type == OP_RV2AV
15845                     && !(rv2av->op_flags & OPf_REF)
15846                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15847                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15848                 ) {
15849                     q = rv2av->op_next;
15850                     if (q->op_type == OP_NULL)
15851                         q = q->op_next;
15852                     if (q->op_type == OP_PUSHMARK) {
15853                         defav = 1;
15854                         p = q;
15855                     }
15856                 }
15857             }
15858             if (!defav) {
15859                 p = o;
15860             }
15861
15862             /* scan for PAD ops */
15863
15864             for (p = p->op_next; p; p = p->op_next) {
15865                 if (p->op_type == OP_NULL)
15866                     continue;
15867
15868                 if ((     p->op_type != OP_PADSV
15869                        && p->op_type != OP_PADAV
15870                        && p->op_type != OP_PADHV
15871                     )
15872                       /* any private flag other than INTRO? e.g. STATE */
15873                    || (p->op_private & ~OPpLVAL_INTRO)
15874                 )
15875                     break;
15876
15877                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15878                  * instead */
15879                 if (   p->op_type == OP_PADAV
15880                     && p->op_next
15881                     && p->op_next->op_type == OP_CONST
15882                     && p->op_next->op_next
15883                     && p->op_next->op_next->op_type == OP_AELEM
15884                 )
15885                     break;
15886
15887                 /* for 1st padop, note what type it is and the range
15888                  * start; for the others, check that it's the same type
15889                  * and that the targs are contiguous */
15890                 if (count == 0) {
15891                     intro = (p->op_private & OPpLVAL_INTRO);
15892                     base = p->op_targ;
15893                     gvoid = OP_GIMME(p,0) == G_VOID;
15894                 }
15895                 else {
15896                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15897                         break;
15898                     /* Note that you'd normally  expect targs to be
15899                      * contiguous in my($a,$b,$c), but that's not the case
15900                      * when external modules start doing things, e.g.
15901                      * Function::Parameters */
15902                     if (p->op_targ != base + count)
15903                         break;
15904                     assert(p->op_targ == base + count);
15905                     /* Either all the padops or none of the padops should
15906                        be in void context.  Since we only do the optimisa-
15907                        tion for av/hv when the aggregate itself is pushed
15908                        on to the stack (one item), there is no need to dis-
15909                        tinguish list from scalar context.  */
15910                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15911                         break;
15912                 }
15913
15914                 /* for AV, HV, only when we're not flattening */
15915                 if (   p->op_type != OP_PADSV
15916                     && !gvoid
15917                     && !(p->op_flags & OPf_REF)
15918                 )
15919                     break;
15920
15921                 if (count >= OPpPADRANGE_COUNTMASK)
15922                     break;
15923
15924                 /* there's a biggest base we can fit into a
15925                  * SAVEt_CLEARPADRANGE in pp_padrange.
15926                  * (The sizeof() stuff will be constant-folded, and is
15927                  * intended to avoid getting "comparison is always false"
15928                  * compiler warnings. See the comments above
15929                  * MEM_WRAP_CHECK for more explanation on why we do this
15930                  * in a weird way to avoid compiler warnings.)
15931                  */
15932                 if (   intro
15933                     && (8*sizeof(base) >
15934                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15935                         ? (Size_t)base
15936                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15937                         ) >
15938                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15939                 )
15940                     break;
15941
15942                 /* Success! We've got another valid pad op to optimise away */
15943                 count++;
15944                 followop = p->op_next;
15945             }
15946
15947             if (count < 1 || (count == 1 && !defav))
15948                 break;
15949
15950             /* pp_padrange in specifically compile-time void context
15951              * skips pushing a mark and lexicals; in all other contexts
15952              * (including unknown till runtime) it pushes a mark and the
15953              * lexicals. We must be very careful then, that the ops we
15954              * optimise away would have exactly the same effect as the
15955              * padrange.
15956              * In particular in void context, we can only optimise to
15957              * a padrange if we see the complete sequence
15958              *     pushmark, pad*v, ...., list
15959              * which has the net effect of leaving the markstack as it
15960              * was.  Not pushing onto the stack (whereas padsv does touch
15961              * the stack) makes no difference in void context.
15962              */
15963             assert(followop);
15964             if (gvoid) {
15965                 if (followop->op_type == OP_LIST
15966                         && OP_GIMME(followop,0) == G_VOID
15967                    )
15968                 {
15969                     followop = followop->op_next; /* skip OP_LIST */
15970
15971                     /* consolidate two successive my(...);'s */
15972
15973                     if (   oldoldop
15974                         && oldoldop->op_type == OP_PADRANGE
15975                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15976                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15977                         && !(oldoldop->op_flags & OPf_SPECIAL)
15978                     ) {
15979                         U8 old_count;
15980                         assert(oldoldop->op_next == oldop);
15981                         assert(   oldop->op_type == OP_NEXTSTATE
15982                                || oldop->op_type == OP_DBSTATE);
15983                         assert(oldop->op_next == o);
15984
15985                         old_count
15986                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15987
15988                        /* Do not assume pad offsets for $c and $d are con-
15989                           tiguous in
15990                             my ($a,$b,$c);
15991                             my ($d,$e,$f);
15992                         */
15993                         if (  oldoldop->op_targ + old_count == base
15994                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15995                             base = oldoldop->op_targ;
15996                             count += old_count;
15997                             reuse = 1;
15998                         }
15999                     }
16000
16001                     /* if there's any immediately following singleton
16002                      * my var's; then swallow them and the associated
16003                      * nextstates; i.e.
16004                      *    my ($a,$b); my $c; my $d;
16005                      * is treated as
16006                      *    my ($a,$b,$c,$d);
16007                      */
16008
16009                     while (    ((p = followop->op_next))
16010                             && (  p->op_type == OP_PADSV
16011                                || p->op_type == OP_PADAV
16012                                || p->op_type == OP_PADHV)
16013                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16014                             && (p->op_private & OPpLVAL_INTRO) == intro
16015                             && !(p->op_private & ~OPpLVAL_INTRO)
16016                             && p->op_next
16017                             && (   p->op_next->op_type == OP_NEXTSTATE
16018                                 || p->op_next->op_type == OP_DBSTATE)
16019                             && count < OPpPADRANGE_COUNTMASK
16020                             && base + count == p->op_targ
16021                     ) {
16022                         count++;
16023                         followop = p->op_next;
16024                     }
16025                 }
16026                 else
16027                     break;
16028             }
16029
16030             if (reuse) {
16031                 assert(oldoldop->op_type == OP_PADRANGE);
16032                 oldoldop->op_next = followop;
16033                 oldoldop->op_private = (intro | count);
16034                 o = oldoldop;
16035                 oldop = NULL;
16036                 oldoldop = NULL;
16037             }
16038             else {
16039                 /* Convert the pushmark into a padrange.
16040                  * To make Deparse easier, we guarantee that a padrange was
16041                  * *always* formerly a pushmark */
16042                 assert(o->op_type == OP_PUSHMARK);
16043                 o->op_next = followop;
16044                 OpTYPE_set(o, OP_PADRANGE);
16045                 o->op_targ = base;
16046                 /* bit 7: INTRO; bit 6..0: count */
16047                 o->op_private = (intro | count);
16048                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16049                               | gvoid * OPf_WANT_VOID
16050                               | (defav ? OPf_SPECIAL : 0));
16051             }
16052             break;
16053         }
16054
16055         case OP_RV2AV:
16056             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16057                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16058             break;
16059
16060         case OP_RV2HV:
16061         case OP_PADHV:
16062             /*'keys %h' in void or scalar context: skip the OP_KEYS
16063              * and perform the functionality directly in the RV2HV/PADHV
16064              * op
16065              */
16066             if (o->op_flags & OPf_REF) {
16067                 OP *k = o->op_next;
16068                 U8 want = (k->op_flags & OPf_WANT);
16069                 if (   k
16070                     && k->op_type == OP_KEYS
16071                     && (   want == OPf_WANT_VOID
16072                         || want == OPf_WANT_SCALAR)
16073                     && !(k->op_private & OPpMAYBE_LVSUB)
16074                     && !(k->op_flags & OPf_MOD)
16075                 ) {
16076                     o->op_next     = k->op_next;
16077                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
16078                     o->op_flags   |= want;
16079                     o->op_private |= (o->op_type == OP_PADHV ?
16080                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16081                     /* for keys(%lex), hold onto the OP_KEYS's targ
16082                      * since padhv doesn't have its own targ to return
16083                      * an int with */
16084                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16085                         op_null(k);
16086                 }
16087             }
16088
16089             /* see if %h is used in boolean context */
16090             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16091                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16092
16093
16094             if (o->op_type != OP_PADHV)
16095                 break;
16096             /* FALLTHROUGH */
16097         case OP_PADAV:
16098             if (   o->op_type == OP_PADAV
16099                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16100             )
16101                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16102             /* FALLTHROUGH */
16103         case OP_PADSV:
16104             /* Skip over state($x) in void context.  */
16105             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16106              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16107             {
16108                 oldop->op_next = o->op_next;
16109                 goto redo_nextstate;
16110             }
16111             if (o->op_type != OP_PADAV)
16112                 break;
16113             /* FALLTHROUGH */
16114         case OP_GV:
16115             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16116                 OP* const pop = (o->op_type == OP_PADAV) ?
16117                             o->op_next : o->op_next->op_next;
16118                 IV i;
16119                 if (pop && pop->op_type == OP_CONST &&
16120                     ((PL_op = pop->op_next)) &&
16121                     pop->op_next->op_type == OP_AELEM &&
16122                     !(pop->op_next->op_private &
16123                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16124                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16125                 {
16126                     GV *gv;
16127                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16128                         no_bareword_allowed(pop);
16129                     if (o->op_type == OP_GV)
16130                         op_null(o->op_next);
16131                     op_null(pop->op_next);
16132                     op_null(pop);
16133                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16134                     o->op_next = pop->op_next->op_next;
16135                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16136                     o->op_private = (U8)i;
16137                     if (o->op_type == OP_GV) {
16138                         gv = cGVOPo_gv;
16139                         GvAVn(gv);
16140                         o->op_type = OP_AELEMFAST;
16141                     }
16142                     else
16143                         o->op_type = OP_AELEMFAST_LEX;
16144                 }
16145                 if (o->op_type != OP_GV)
16146                     break;
16147             }
16148
16149             /* Remove $foo from the op_next chain in void context.  */
16150             if (oldop
16151              && (  o->op_next->op_type == OP_RV2SV
16152                 || o->op_next->op_type == OP_RV2AV
16153                 || o->op_next->op_type == OP_RV2HV  )
16154              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16155              && !(o->op_next->op_private & OPpLVAL_INTRO))
16156             {
16157                 oldop->op_next = o->op_next->op_next;
16158                 /* Reprocess the previous op if it is a nextstate, to
16159                    allow double-nextstate optimisation.  */
16160               redo_nextstate:
16161                 if (oldop->op_type == OP_NEXTSTATE) {
16162                     oldop->op_opt = 0;
16163                     o = oldop;
16164                     oldop = oldoldop;
16165                     oldoldop = NULL;
16166                     goto redo;
16167                 }
16168                 o = oldop->op_next;
16169                 goto redo;
16170             }
16171             else if (o->op_next->op_type == OP_RV2SV) {
16172                 if (!(o->op_next->op_private & OPpDEREF)) {
16173                     op_null(o->op_next);
16174                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16175                                                                | OPpOUR_INTRO);
16176                     o->op_next = o->op_next->op_next;
16177                     OpTYPE_set(o, OP_GVSV);
16178                 }
16179             }
16180             else if (o->op_next->op_type == OP_READLINE
16181                     && o->op_next->op_next->op_type == OP_CONCAT
16182                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16183             {
16184                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16185                 OpTYPE_set(o, OP_RCATLINE);
16186                 o->op_flags |= OPf_STACKED;
16187                 op_null(o->op_next->op_next);
16188                 op_null(o->op_next);
16189             }
16190
16191             break;
16192
16193         case OP_NOT:
16194             break;
16195
16196         case OP_AND:
16197         case OP_OR:
16198         case OP_DOR:
16199             while (cLOGOP->op_other->op_type == OP_NULL)
16200                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16201             while (o->op_next && (   o->op_type == o->op_next->op_type
16202                                   || o->op_next->op_type == OP_NULL))
16203                 o->op_next = o->op_next->op_next;
16204
16205             /* If we're an OR and our next is an AND in void context, we'll
16206                follow its op_other on short circuit, same for reverse.
16207                We can't do this with OP_DOR since if it's true, its return
16208                value is the underlying value which must be evaluated
16209                by the next op. */
16210             if (o->op_next &&
16211                 (
16212                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16213                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16214                 )
16215                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16216             ) {
16217                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16218             }
16219             DEFER(cLOGOP->op_other);
16220             o->op_opt = 1;
16221             break;
16222
16223         case OP_GREPWHILE:
16224             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16225                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16226             /* FALLTHROUGH */
16227         case OP_COND_EXPR:
16228         case OP_MAPWHILE:
16229         case OP_ANDASSIGN:
16230         case OP_ORASSIGN:
16231         case OP_DORASSIGN:
16232         case OP_RANGE:
16233         case OP_ONCE:
16234         case OP_ARGDEFELEM:
16235             while (cLOGOP->op_other->op_type == OP_NULL)
16236                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16237             DEFER(cLOGOP->op_other);
16238             break;
16239
16240         case OP_ENTERLOOP:
16241         case OP_ENTERITER:
16242             while (cLOOP->op_redoop->op_type == OP_NULL)
16243                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16244             while (cLOOP->op_nextop->op_type == OP_NULL)
16245                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16246             while (cLOOP->op_lastop->op_type == OP_NULL)
16247                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16248             /* a while(1) loop doesn't have an op_next that escapes the
16249              * loop, so we have to explicitly follow the op_lastop to
16250              * process the rest of the code */
16251             DEFER(cLOOP->op_lastop);
16252             break;
16253
16254         case OP_ENTERTRY:
16255             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16256             DEFER(cLOGOPo->op_other);
16257             break;
16258
16259         case OP_SUBST:
16260             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16261                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16262             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16263             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16264                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16265                 cPMOP->op_pmstashstartu.op_pmreplstart
16266                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16267             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16268             break;
16269
16270         case OP_SORT: {
16271             OP *oright;
16272
16273             if (o->op_flags & OPf_SPECIAL) {
16274                 /* first arg is a code block */
16275                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16276                 OP * kid          = cUNOPx(nullop)->op_first;
16277
16278                 assert(nullop->op_type == OP_NULL);
16279                 assert(kid->op_type == OP_SCOPE
16280                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16281                 /* since OP_SORT doesn't have a handy op_other-style
16282                  * field that can point directly to the start of the code
16283                  * block, store it in the otherwise-unused op_next field
16284                  * of the top-level OP_NULL. This will be quicker at
16285                  * run-time, and it will also allow us to remove leading
16286                  * OP_NULLs by just messing with op_nexts without
16287                  * altering the basic op_first/op_sibling layout. */
16288                 kid = kLISTOP->op_first;
16289                 assert(
16290                       (kid->op_type == OP_NULL
16291                       && (  kid->op_targ == OP_NEXTSTATE
16292                          || kid->op_targ == OP_DBSTATE  ))
16293                     || kid->op_type == OP_STUB
16294                     || kid->op_type == OP_ENTER
16295                     || (PL_parser && PL_parser->error_count));
16296                 nullop->op_next = kid->op_next;
16297                 DEFER(nullop->op_next);
16298             }
16299
16300             /* check that RHS of sort is a single plain array */
16301             oright = cUNOPo->op_first;
16302             if (!oright || oright->op_type != OP_PUSHMARK)
16303                 break;
16304
16305             if (o->op_private & OPpSORT_INPLACE)
16306                 break;
16307
16308             /* reverse sort ... can be optimised.  */
16309             if (!OpHAS_SIBLING(cUNOPo)) {
16310                 /* Nothing follows us on the list. */
16311                 OP * const reverse = o->op_next;
16312
16313                 if (reverse->op_type == OP_REVERSE &&
16314                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16315                     OP * const pushmark = cUNOPx(reverse)->op_first;
16316                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16317                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16318                         /* reverse -> pushmark -> sort */
16319                         o->op_private |= OPpSORT_REVERSE;
16320                         op_null(reverse);
16321                         pushmark->op_next = oright->op_next;
16322                         op_null(oright);
16323                     }
16324                 }
16325             }
16326
16327             break;
16328         }
16329
16330         case OP_REVERSE: {
16331             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16332             OP *gvop = NULL;
16333             LISTOP *enter, *exlist;
16334
16335             if (o->op_private & OPpSORT_INPLACE)
16336                 break;
16337
16338             enter = (LISTOP *) o->op_next;
16339             if (!enter)
16340                 break;
16341             if (enter->op_type == OP_NULL) {
16342                 enter = (LISTOP *) enter->op_next;
16343                 if (!enter)
16344                     break;
16345             }
16346             /* for $a (...) will have OP_GV then OP_RV2GV here.
16347                for (...) just has an OP_GV.  */
16348             if (enter->op_type == OP_GV) {
16349                 gvop = (OP *) enter;
16350                 enter = (LISTOP *) enter->op_next;
16351                 if (!enter)
16352                     break;
16353                 if (enter->op_type == OP_RV2GV) {
16354                   enter = (LISTOP *) enter->op_next;
16355                   if (!enter)
16356                     break;
16357                 }
16358             }
16359
16360             if (enter->op_type != OP_ENTERITER)
16361                 break;
16362
16363             iter = enter->op_next;
16364             if (!iter || iter->op_type != OP_ITER)
16365                 break;
16366
16367             expushmark = enter->op_first;
16368             if (!expushmark || expushmark->op_type != OP_NULL
16369                 || expushmark->op_targ != OP_PUSHMARK)
16370                 break;
16371
16372             exlist = (LISTOP *) OpSIBLING(expushmark);
16373             if (!exlist || exlist->op_type != OP_NULL
16374                 || exlist->op_targ != OP_LIST)
16375                 break;
16376
16377             if (exlist->op_last != o) {
16378                 /* Mmm. Was expecting to point back to this op.  */
16379                 break;
16380             }
16381             theirmark = exlist->op_first;
16382             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16383                 break;
16384
16385             if (OpSIBLING(theirmark) != o) {
16386                 /* There's something between the mark and the reverse, eg
16387                    for (1, reverse (...))
16388                    so no go.  */
16389                 break;
16390             }
16391
16392             ourmark = ((LISTOP *)o)->op_first;
16393             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16394                 break;
16395
16396             ourlast = ((LISTOP *)o)->op_last;
16397             if (!ourlast || ourlast->op_next != o)
16398                 break;
16399
16400             rv2av = OpSIBLING(ourmark);
16401             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16402                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16403                 /* We're just reversing a single array.  */
16404                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16405                 enter->op_flags |= OPf_STACKED;
16406             }
16407
16408             /* We don't have control over who points to theirmark, so sacrifice
16409                ours.  */
16410             theirmark->op_next = ourmark->op_next;
16411             theirmark->op_flags = ourmark->op_flags;
16412             ourlast->op_next = gvop ? gvop : (OP *) enter;
16413             op_null(ourmark);
16414             op_null(o);
16415             enter->op_private |= OPpITER_REVERSED;
16416             iter->op_private |= OPpITER_REVERSED;
16417
16418             oldoldop = NULL;
16419             oldop    = ourlast;
16420             o        = oldop->op_next;
16421             goto redo;
16422             NOT_REACHED; /* NOTREACHED */
16423             break;
16424         }
16425
16426         case OP_QR:
16427         case OP_MATCH:
16428             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16429                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16430             }
16431             break;
16432
16433         case OP_RUNCV:
16434             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16435              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16436             {
16437                 SV *sv;
16438                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16439                 else {
16440                     sv = newRV((SV *)PL_compcv);
16441                     sv_rvweaken(sv);
16442                     SvREADONLY_on(sv);
16443                 }
16444                 OpTYPE_set(o, OP_CONST);
16445                 o->op_flags |= OPf_SPECIAL;
16446                 cSVOPo->op_sv = sv;
16447             }
16448             break;
16449
16450         case OP_SASSIGN:
16451             if (OP_GIMME(o,0) == G_VOID
16452              || (  o->op_next->op_type == OP_LINESEQ
16453                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16454                    || (  o->op_next->op_next->op_type == OP_RETURN
16455                       && !CvLVALUE(PL_compcv)))))
16456             {
16457                 OP *right = cBINOP->op_first;
16458                 if (right) {
16459                     /*   sassign
16460                     *      RIGHT
16461                     *      substr
16462                     *         pushmark
16463                     *         arg1
16464                     *         arg2
16465                     *         ...
16466                     * becomes
16467                     *
16468                     *  ex-sassign
16469                     *     substr
16470                     *        pushmark
16471                     *        RIGHT
16472                     *        arg1
16473                     *        arg2
16474                     *        ...
16475                     */
16476                     OP *left = OpSIBLING(right);
16477                     if (left->op_type == OP_SUBSTR
16478                          && (left->op_private & 7) < 4) {
16479                         op_null(o);
16480                         /* cut out right */
16481                         op_sibling_splice(o, NULL, 1, NULL);
16482                         /* and insert it as second child of OP_SUBSTR */
16483                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16484                                     right);
16485                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16486                         left->op_flags =
16487                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16488                     }
16489                 }
16490             }
16491             break;
16492
16493         case OP_AASSIGN: {
16494             int l, r, lr, lscalars, rscalars;
16495
16496             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16497                Note that we do this now rather than in newASSIGNOP(),
16498                since only by now are aliased lexicals flagged as such
16499
16500                See the essay "Common vars in list assignment" above for
16501                the full details of the rationale behind all the conditions
16502                below.
16503
16504                PL_generation sorcery:
16505                To detect whether there are common vars, the global var
16506                PL_generation is incremented for each assign op we scan.
16507                Then we run through all the lexical variables on the LHS,
16508                of the assignment, setting a spare slot in each of them to
16509                PL_generation.  Then we scan the RHS, and if any lexicals
16510                already have that value, we know we've got commonality.
16511                Also, if the generation number is already set to
16512                PERL_INT_MAX, then the variable is involved in aliasing, so
16513                we also have potential commonality in that case.
16514              */
16515
16516             PL_generation++;
16517             /* scan LHS */
16518             lscalars = 0;
16519             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16520             /* scan RHS */
16521             rscalars = 0;
16522             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16523             lr = (l|r);
16524
16525
16526             /* After looking for things which are *always* safe, this main
16527              * if/else chain selects primarily based on the type of the
16528              * LHS, gradually working its way down from the more dangerous
16529              * to the more restrictive and thus safer cases */
16530
16531             if (   !l                      /* () = ....; */
16532                 || !r                      /* .... = (); */
16533                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16534                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16535                 || (lscalars < 2)          /* ($x, undef) = ... */
16536             ) {
16537                 NOOP; /* always safe */
16538             }
16539             else if (l & AAS_DANGEROUS) {
16540                 /* always dangerous */
16541                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16542                 o->op_private |= OPpASSIGN_COMMON_AGG;
16543             }
16544             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16545                 /* package vars are always dangerous - too many
16546                  * aliasing possibilities */
16547                 if (l & AAS_PKG_SCALAR)
16548                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16549                 if (l & AAS_PKG_AGG)
16550                     o->op_private |= OPpASSIGN_COMMON_AGG;
16551             }
16552             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16553                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16554             {
16555                 /* LHS contains only lexicals and safe ops */
16556
16557                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16558                     o->op_private |= OPpASSIGN_COMMON_AGG;
16559
16560                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16561                     if (lr & AAS_LEX_SCALAR_COMM)
16562                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16563                     else if (   !(l & AAS_LEX_SCALAR)
16564                              && (r & AAS_DEFAV))
16565                     {
16566                         /* falsely mark
16567                          *    my (...) = @_
16568                          * as scalar-safe for performance reasons.
16569                          * (it will still have been marked _AGG if necessary */
16570                         NOOP;
16571                     }
16572                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16573                         /* if there are only lexicals on the LHS and no
16574                          * common ones on the RHS, then we assume that the
16575                          * only way those lexicals could also get
16576                          * on the RHS is via some sort of dereffing or
16577                          * closure, e.g.
16578                          *    $r = \$lex;
16579                          *    ($lex, $x) = (1, $$r)
16580                          * and in this case we assume the var must have
16581                          *  a bumped ref count. So if its ref count is 1,
16582                          *  it must only be on the LHS.
16583                          */
16584                         o->op_private |= OPpASSIGN_COMMON_RC1;
16585                 }
16586             }
16587
16588             /* ... = ($x)
16589              * may have to handle aggregate on LHS, but we can't
16590              * have common scalars. */
16591             if (rscalars < 2)
16592                 o->op_private &=
16593                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16594
16595             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16596                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16597             break;
16598         }
16599
16600         case OP_REF:
16601             /* see if ref() is used in boolean context */
16602             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16603                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16604             break;
16605
16606         case OP_LENGTH:
16607             /* see if the op is used in known boolean context,
16608              * but not if OA_TARGLEX optimisation is enabled */
16609             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16610                 && !(o->op_private & OPpTARGET_MY)
16611             )
16612                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16613             break;
16614
16615         case OP_POS:
16616             /* see if the op is used in known boolean context */
16617             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16618                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16619             break;
16620
16621         case OP_CUSTOM: {
16622             Perl_cpeep_t cpeep =
16623                 XopENTRYCUSTOM(o, xop_peep);
16624             if (cpeep)
16625                 cpeep(aTHX_ o, oldop);
16626             break;
16627         }
16628
16629         }
16630         /* did we just null the current op? If so, re-process it to handle
16631          * eliding "empty" ops from the chain */
16632         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16633             o->op_opt = 0;
16634             o = oldop;
16635         }
16636         else {
16637             oldoldop = oldop;
16638             oldop = o;
16639         }
16640     }
16641     LEAVE;
16642 }
16643
16644 void
16645 Perl_peep(pTHX_ OP *o)
16646 {
16647     CALL_RPEEP(o);
16648 }
16649
16650 /*
16651 =head1 Custom Operators
16652
16653 =for apidoc Ao||custom_op_xop
16654 Return the XOP structure for a given custom op.  This macro should be
16655 considered internal to C<OP_NAME> and the other access macros: use them instead.
16656 This macro does call a function.  Prior
16657 to 5.19.6, this was implemented as a
16658 function.
16659
16660 =cut
16661 */
16662
16663
16664 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16665  * freeing PL_custom_ops */
16666
16667 static int
16668 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16669 {
16670     XOP *xop;
16671
16672     PERL_UNUSED_ARG(mg);
16673     xop = INT2PTR(XOP *, SvIV(sv));
16674     Safefree(xop->xop_name);
16675     Safefree(xop->xop_desc);
16676     Safefree(xop);
16677     return 0;
16678 }
16679
16680
16681 static const MGVTBL custom_op_register_vtbl = {
16682     0,                          /* get */
16683     0,                          /* set */
16684     0,                          /* len */
16685     0,                          /* clear */
16686     custom_op_register_free,     /* free */
16687     0,                          /* copy */
16688     0,                          /* dup */
16689 #ifdef MGf_LOCAL
16690     0,                          /* local */
16691 #endif
16692 };
16693
16694
16695 XOPRETANY
16696 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16697 {
16698     SV *keysv;
16699     HE *he = NULL;
16700     XOP *xop;
16701
16702     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16703
16704     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16705     assert(o->op_type == OP_CUSTOM);
16706
16707     /* This is wrong. It assumes a function pointer can be cast to IV,
16708      * which isn't guaranteed, but this is what the old custom OP code
16709      * did. In principle it should be safer to Copy the bytes of the
16710      * pointer into a PV: since the new interface is hidden behind
16711      * functions, this can be changed later if necessary.  */
16712     /* Change custom_op_xop if this ever happens */
16713     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16714
16715     if (PL_custom_ops)
16716         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16717
16718     /* See if the op isn't registered, but its name *is* registered.
16719      * That implies someone is using the pre-5.14 API,where only name and
16720      * description could be registered. If so, fake up a real
16721      * registration.
16722      * We only check for an existing name, and assume no one will have
16723      * just registered a desc */
16724     if (!he && PL_custom_op_names &&
16725         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16726     ) {
16727         const char *pv;
16728         STRLEN l;
16729
16730         /* XXX does all this need to be shared mem? */
16731         Newxz(xop, 1, XOP);
16732         pv = SvPV(HeVAL(he), l);
16733         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16734         if (PL_custom_op_descs &&
16735             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16736         ) {
16737             pv = SvPV(HeVAL(he), l);
16738             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16739         }
16740         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16741         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16742         /* add magic to the SV so that the xop struct (pointed to by
16743          * SvIV(sv)) is freed. Normally a static xop is registered, but
16744          * for this backcompat hack, we've alloced one */
16745         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
16746                 &custom_op_register_vtbl, NULL, 0);
16747
16748     }
16749     else {
16750         if (!he)
16751             xop = (XOP *)&xop_null;
16752         else
16753             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16754     }
16755     {
16756         XOPRETANY any;
16757         if(field == XOPe_xop_ptr) {
16758             any.xop_ptr = xop;
16759         } else {
16760             const U32 flags = XopFLAGS(xop);
16761             if(flags & field) {
16762                 switch(field) {
16763                 case XOPe_xop_name:
16764                     any.xop_name = xop->xop_name;
16765                     break;
16766                 case XOPe_xop_desc:
16767                     any.xop_desc = xop->xop_desc;
16768                     break;
16769                 case XOPe_xop_class:
16770                     any.xop_class = xop->xop_class;
16771                     break;
16772                 case XOPe_xop_peep:
16773                     any.xop_peep = xop->xop_peep;
16774                     break;
16775                 default:
16776                     NOT_REACHED; /* NOTREACHED */
16777                     break;
16778                 }
16779             } else {
16780                 switch(field) {
16781                 case XOPe_xop_name:
16782                     any.xop_name = XOPd_xop_name;
16783                     break;
16784                 case XOPe_xop_desc:
16785                     any.xop_desc = XOPd_xop_desc;
16786                     break;
16787                 case XOPe_xop_class:
16788                     any.xop_class = XOPd_xop_class;
16789                     break;
16790                 case XOPe_xop_peep:
16791                     any.xop_peep = XOPd_xop_peep;
16792                     break;
16793                 default:
16794                     NOT_REACHED; /* NOTREACHED */
16795                     break;
16796                 }
16797             }
16798         }
16799         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16800          * op.c: In function 'Perl_custom_op_get_field':
16801          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16802          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16803          * expands to assert(0), which expands to ((0) ? (void)0 :
16804          * __assert(...)), and gcc doesn't know that __assert can never return. */
16805         return any;
16806     }
16807 }
16808
16809 /*
16810 =for apidoc Ao||custom_op_register
16811 Register a custom op.  See L<perlguts/"Custom Operators">.
16812
16813 =cut
16814 */
16815
16816 void
16817 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16818 {
16819     SV *keysv;
16820
16821     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16822
16823     /* see the comment in custom_op_xop */
16824     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16825
16826     if (!PL_custom_ops)
16827         PL_custom_ops = newHV();
16828
16829     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16830         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16831 }
16832
16833 /*
16834
16835 =for apidoc core_prototype
16836
16837 This function assigns the prototype of the named core function to C<sv>, or
16838 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16839 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16840 by C<keyword()>.  It must not be equal to 0.
16841
16842 =cut
16843 */
16844
16845 SV *
16846 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16847                           int * const opnum)
16848 {
16849     int i = 0, n = 0, seen_question = 0, defgv = 0;
16850     I32 oa;
16851 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16852     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16853     bool nullret = FALSE;
16854
16855     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16856
16857     assert (code);
16858
16859     if (!sv) sv = sv_newmortal();
16860
16861 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16862
16863     switch (code < 0 ? -code : code) {
16864     case KEY_and   : case KEY_chop: case KEY_chomp:
16865     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16866     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16867     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16868     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16869     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16870     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16871     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16872     case KEY_x     : case KEY_xor    :
16873         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16874     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16875     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16876     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16877     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16878     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16879     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16880         retsetpvs("", 0);
16881     case KEY_evalbytes:
16882         name = "entereval"; break;
16883     case KEY_readpipe:
16884         name = "backtick";
16885     }
16886
16887 #undef retsetpvs
16888
16889   findopnum:
16890     while (i < MAXO) {  /* The slow way. */
16891         if (strEQ(name, PL_op_name[i])
16892             || strEQ(name, PL_op_desc[i]))
16893         {
16894             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16895             goto found;
16896         }
16897         i++;
16898     }
16899     return NULL;
16900   found:
16901     defgv = PL_opargs[i] & OA_DEFGV;
16902     oa = PL_opargs[i] >> OASHIFT;
16903     while (oa) {
16904         if (oa & OA_OPTIONAL && !seen_question && (
16905               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16906         )) {
16907             seen_question = 1;
16908             str[n++] = ';';
16909         }
16910         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16911             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16912             /* But globs are already references (kinda) */
16913             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16914         ) {
16915             str[n++] = '\\';
16916         }
16917         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16918          && !scalar_mod_type(NULL, i)) {
16919             str[n++] = '[';
16920             str[n++] = '$';
16921             str[n++] = '@';
16922             str[n++] = '%';
16923             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16924             str[n++] = '*';
16925             str[n++] = ']';
16926         }
16927         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16928         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16929             str[n-1] = '_'; defgv = 0;
16930         }
16931         oa = oa >> 4;
16932     }
16933     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16934     str[n++] = '\0';
16935     sv_setpvn(sv, str, n - 1);
16936     if (opnum) *opnum = i;
16937     return sv;
16938 }
16939
16940 OP *
16941 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16942                       const int opnum)
16943 {
16944     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
16945                                         newSVOP(OP_COREARGS,0,coreargssv);
16946     OP *o;
16947
16948     PERL_ARGS_ASSERT_CORESUB_OP;
16949
16950     switch(opnum) {
16951     case 0:
16952         return op_append_elem(OP_LINESEQ,
16953                        argop,
16954                        newSLICEOP(0,
16955                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16956                                   newOP(OP_CALLER,0)
16957                        )
16958                );
16959     case OP_EACH:
16960     case OP_KEYS:
16961     case OP_VALUES:
16962         o = newUNOP(OP_AVHVSWITCH,0,argop);
16963         o->op_private = opnum-OP_EACH;
16964         return o;
16965     case OP_SELECT: /* which represents OP_SSELECT as well */
16966         if (code)
16967             return newCONDOP(
16968                          0,
16969                          newBINOP(OP_GT, 0,
16970                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16971                                   newSVOP(OP_CONST, 0, newSVuv(1))
16972                                  ),
16973                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16974                                     OP_SSELECT),
16975                          coresub_op(coreargssv, 0, OP_SELECT)
16976                    );
16977         /* FALLTHROUGH */
16978     default:
16979         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16980         case OA_BASEOP:
16981             return op_append_elem(
16982                         OP_LINESEQ, argop,
16983                         newOP(opnum,
16984                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16985                                 ? OPpOFFBYONE << 8 : 0)
16986                    );
16987         case OA_BASEOP_OR_UNOP:
16988             if (opnum == OP_ENTEREVAL) {
16989                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16990                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16991             }
16992             else o = newUNOP(opnum,0,argop);
16993             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16994             else {
16995           onearg:
16996               if (is_handle_constructor(o, 1))
16997                 argop->op_private |= OPpCOREARGS_DEREF1;
16998               if (scalar_mod_type(NULL, opnum))
16999                 argop->op_private |= OPpCOREARGS_SCALARMOD;
17000             }
17001             return o;
17002         default:
17003             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17004             if (is_handle_constructor(o, 2))
17005                 argop->op_private |= OPpCOREARGS_DEREF2;
17006             if (opnum == OP_SUBSTR) {
17007                 o->op_private |= OPpMAYBE_LVSUB;
17008                 return o;
17009             }
17010             else goto onearg;
17011         }
17012     }
17013 }
17014
17015 void
17016 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17017                                SV * const *new_const_svp)
17018 {
17019     const char *hvname;
17020     bool is_const = !!CvCONST(old_cv);
17021     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17022
17023     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17024
17025     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17026         return;
17027         /* They are 2 constant subroutines generated from
17028            the same constant. This probably means that
17029            they are really the "same" proxy subroutine
17030            instantiated in 2 places. Most likely this is
17031            when a constant is exported twice.  Don't warn.
17032         */
17033     if (
17034         (ckWARN(WARN_REDEFINE)
17035          && !(
17036                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17037              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17038              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17039                  strEQ(hvname, "autouse"))
17040              )
17041         )
17042      || (is_const
17043          && ckWARN_d(WARN_REDEFINE)
17044          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17045         )
17046     )
17047         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17048                           is_const
17049                             ? "Constant subroutine %" SVf " redefined"
17050                             : "Subroutine %" SVf " redefined",
17051                           SVfARG(name));
17052 }
17053
17054 /*
17055 =head1 Hook manipulation
17056
17057 These functions provide convenient and thread-safe means of manipulating
17058 hook variables.
17059
17060 =cut
17061 */
17062
17063 /*
17064 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
17065
17066 Puts a C function into the chain of check functions for a specified op
17067 type.  This is the preferred way to manipulate the L</PL_check> array.
17068 C<opcode> specifies which type of op is to be affected.  C<new_checker>
17069 is a pointer to the C function that is to be added to that opcode's
17070 check chain, and C<old_checker_p> points to the storage location where a
17071 pointer to the next function in the chain will be stored.  The value of
17072 C<new_checker> is written into the L</PL_check> array, while the value
17073 previously stored there is written to C<*old_checker_p>.
17074
17075 L</PL_check> is global to an entire process, and a module wishing to
17076 hook op checking may find itself invoked more than once per process,
17077 typically in different threads.  To handle that situation, this function
17078 is idempotent.  The location C<*old_checker_p> must initially (once
17079 per process) contain a null pointer.  A C variable of static duration
17080 (declared at file scope, typically also marked C<static> to give
17081 it internal linkage) will be implicitly initialised appropriately,
17082 if it does not have an explicit initialiser.  This function will only
17083 actually modify the check chain if it finds C<*old_checker_p> to be null.
17084 This function is also thread safe on the small scale.  It uses appropriate
17085 locking to avoid race conditions in accessing L</PL_check>.
17086
17087 When this function is called, the function referenced by C<new_checker>
17088 must be ready to be called, except for C<*old_checker_p> being unfilled.
17089 In a threading situation, C<new_checker> may be called immediately,
17090 even before this function has returned.  C<*old_checker_p> will always
17091 be appropriately set before C<new_checker> is called.  If C<new_checker>
17092 decides not to do anything special with an op that it is given (which
17093 is the usual case for most uses of op check hooking), it must chain the
17094 check function referenced by C<*old_checker_p>.
17095
17096 Taken all together, XS code to hook an op checker should typically look
17097 something like this:
17098
17099     static Perl_check_t nxck_frob;
17100     static OP *myck_frob(pTHX_ OP *op) {
17101         ...
17102         op = nxck_frob(aTHX_ op);
17103         ...
17104         return op;
17105     }
17106     BOOT:
17107         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17108
17109 If you want to influence compilation of calls to a specific subroutine,
17110 then use L</cv_set_call_checker_flags> rather than hooking checking of
17111 all C<entersub> ops.
17112
17113 =cut
17114 */
17115
17116 void
17117 Perl_wrap_op_checker(pTHX_ Optype opcode,
17118     Perl_check_t new_checker, Perl_check_t *old_checker_p)
17119 {
17120     dVAR;
17121
17122     PERL_UNUSED_CONTEXT;
17123     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17124     if (*old_checker_p) return;
17125     OP_CHECK_MUTEX_LOCK;
17126     if (!*old_checker_p) {
17127         *old_checker_p = PL_check[opcode];
17128         PL_check[opcode] = new_checker;
17129     }
17130     OP_CHECK_MUTEX_UNLOCK;
17131 }
17132
17133 #include "XSUB.h"
17134
17135 /* Efficient sub that returns a constant scalar value. */
17136 static void
17137 const_sv_xsub(pTHX_ CV* cv)
17138 {
17139     dXSARGS;
17140     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17141     PERL_UNUSED_ARG(items);
17142     if (!sv) {
17143         XSRETURN(0);
17144     }
17145     EXTEND(sp, 1);
17146     ST(0) = sv;
17147     XSRETURN(1);
17148 }
17149
17150 static void
17151 const_av_xsub(pTHX_ CV* cv)
17152 {
17153     dXSARGS;
17154     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17155     SP -= items;
17156     assert(av);
17157 #ifndef DEBUGGING
17158     if (!av) {
17159         XSRETURN(0);
17160     }
17161 #endif
17162     if (SvRMAGICAL(av))
17163         Perl_croak(aTHX_ "Magical list constants are not supported");
17164     if (GIMME_V != G_ARRAY) {
17165         EXTEND(SP, 1);
17166         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17167         XSRETURN(1);
17168     }
17169     EXTEND(SP, AvFILLp(av)+1);
17170     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17171     XSRETURN(AvFILLp(av)+1);
17172 }
17173
17174 /* Copy an existing cop->cop_warnings field.
17175  * If it's one of the standard addresses, just re-use the address.
17176  * This is the e implementation for the DUP_WARNINGS() macro
17177  */
17178
17179 STRLEN*
17180 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17181 {
17182     Size_t size;
17183     STRLEN *new_warnings;
17184
17185     if (warnings == NULL || specialWARN(warnings))
17186         return warnings;
17187
17188     size = sizeof(*warnings) + *warnings;
17189
17190     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17191     Copy(warnings, new_warnings, size, char);
17192     return new_warnings;
17193 }
17194
17195 /*
17196  * ex: set ts=8 sts=4 sw=4 et:
17197  */