op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* remove any leading "empty" ops from the op_next chain whose first
 175  * node's address is stored in op_p. Store the updated address of the
 176  * first node in op_p.
 177  */
 178
 179 STATIC void
 180 S_prune_chain_head(OP** op_p)
 181 {
 182     while (*op_p
 183         && (   (*op_p)->op_type == OP_NULL
 184             || (*op_p)->op_type == OP_SCOPE
 185             || (*op_p)->op_type == OP_SCALAR
 186             || (*op_p)->op_type == OP_LINESEQ)
 187     )
 188         *op_p = (*op_p)->op_next;
 189 }
 190
 191
 192 /* See the explanatory comments above struct opslab in op.h. */
 193
 194 #ifdef PERL_DEBUG_READONLY_OPS
 195 #  define PERL_SLAB_SIZE 128
 196 #  define PERL_MAX_SLAB_SIZE 4096
 197 #  include <sys/mman.h>
 198 #endif
 199
 200 #ifndef PERL_SLAB_SIZE
 201 #  define PERL_SLAB_SIZE 64
 202 #endif
 203 #ifndef PERL_MAX_SLAB_SIZE
 204 #  define PERL_MAX_SLAB_SIZE 2048
 205 #endif
 206
 207 /* rounds up to nearest pointer */
 208 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 209 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 210
 211 /* malloc a new op slab (suitable for attaching to PL_compcv) */
 212
 213 static OPSLAB *
 214 S_new_slab(pTHX_ size_t sz)
 215 {
 216 #ifdef PERL_DEBUG_READONLY_OPS
 217     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 218                                    PROT_READ|PROT_WRITE,
 219                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 220     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 221                           (unsigned long) sz, slab));
 222     if (slab == MAP_FAILED) {
 223         perror("mmap failed");
 224         abort();
 225     }
 226     slab->opslab_size = (U16)sz;
 227 #else
 228     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 229 #endif
 230 #ifndef WIN32
 231     /* The context is unused in non-Windows */
 232     PERL_UNUSED_CONTEXT;
 233 #endif
 234     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 235     return slab;
 236 }
 237
 238 /* requires double parens and aTHX_ */
 239 #define DEBUG_S_warn(args)                                             \
 240     DEBUG_S(                                                            \
 241         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 242     )
 243
 244 /* Returns a sz-sized block of memory (suitable for holding an op) from
 245  * a free slot in the chain of op slabs attached to PL_compcv.
 246  * Allocates a new slab if necessary.
 247  * if PL_compcv isn't compiling, malloc() instead.
 248  */
 249
 250 void *
 251 Perl_Slab_Alloc(pTHX_ size_t sz)
 252 {
 253     OPSLAB *slab;
 254     OPSLAB *slab2;
 255     OPSLOT *slot;
 256     OP *o;
 257     size_t opsz, space;
 258
 259     /* We only allocate ops from the slab during subroutine compilation.
 260        We find the slab via PL_compcv, hence that must be non-NULL. It could
 261        also be pointing to a subroutine which is now fully set up (CvROOT()
 262        pointing to the top of the optree for that sub), or a subroutine
 263        which isn't using the slab allocator. If our sanity checks aren't met,
 264        don't use a slab, but allocate the OP directly from the heap.  */
 265     if (!PL_compcv || CvROOT(PL_compcv)
 266      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 267     {
 268         o = (OP*)PerlMemShared_calloc(1, sz);
 269         goto gotit;
 270     }
 271
 272     /* While the subroutine is under construction, the slabs are accessed via
 273        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 274        unneeded at runtime. Once a subroutine is constructed, the slabs are
 275        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 276        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 277        details.  */
 278     if (!CvSTART(PL_compcv)) {
 279         CvSTART(PL_compcv) =
 280             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 281         CvSLABBED_on(PL_compcv);
 282         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 283     }
 284     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 285
 286     opsz = SIZE_TO_PSIZE(sz);
 287     sz = opsz + OPSLOT_HEADER_P;
 288
 289     /* The slabs maintain a free list of OPs. In particular, constant folding
 290        will free up OPs, so it makes sense to re-use them where possible. A
 291        freed up slot is used in preference to a new allocation.  */
 292     if (slab->opslab_freed) {
 293         OP **too = &slab->opslab_freed;
 294         o = *too;
 295         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 296         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 297             DEBUG_S_warn((aTHX_ "Alas! too small"));
 298             o = *(too = &o->op_next);
 299             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 300         }
 301         if (o) {
 302             *too = o->op_next;
 303             Zero(o, opsz, I32 *);
 304             o->op_slabbed = 1;
 305             goto gotit;
 306         }
 307     }
 308
 309 #define INIT_OPSLOT \
 310             slot->opslot_slab = slab;                   \
 311             slot->opslot_next = slab2->opslab_first;    \
 312             slab2->opslab_first = slot;                 \
 313             o = &slot->opslot_op;                       \
 314             o->op_slabbed = 1
 315
 316     /* The partially-filled slab is next in the chain. */
 317     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 318     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 319         /* Remaining space is too small. */
 320
 321         /* If we can fit a BASEOP, add it to the free chain, so as not
 322            to waste it. */
 323         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 324             slot = &slab2->opslab_slots;
 325             INIT_OPSLOT;
 326             o->op_type = OP_FREED;
 327             o->op_next = slab->opslab_freed;
 328             slab->opslab_freed = o;
 329         }
 330
 331         /* Create a new slab.  Make this one twice as big. */
 332         slot = slab2->opslab_first;
 333         while (slot->opslot_next) slot = slot->opslot_next;
 334         slab2 = S_new_slab(aTHX_
 335                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 336                                         ? PERL_MAX_SLAB_SIZE
 337                                         : (DIFF(slab2, slot)+1)*2);
 338         slab2->opslab_next = slab->opslab_next;
 339         slab->opslab_next = slab2;
 340     }
 341     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 342
 343     /* Create a new op slot */
 344     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 345     assert(slot >= &slab2->opslab_slots);
 346     if (DIFF(&slab2->opslab_slots, slot)
 347          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 348         slot = &slab2->opslab_slots;
 349     INIT_OPSLOT;
 350     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 351
 352   gotit:
 353     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 354     assert(!o->op_moresib);
 355     assert(!o->op_sibparent);
 356
 357     return (void *)o;
 358 }
 359
 360 #undef INIT_OPSLOT
 361
 362 #ifdef PERL_DEBUG_READONLY_OPS
 363 void
 364 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 365 {
 366     PERL_ARGS_ASSERT_SLAB_TO_RO;
 367
 368     if (slab->opslab_readonly) return;
 369     slab->opslab_readonly = 1;
 370     for (; slab; slab = slab->opslab_next) {
 371         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 372                               (unsigned long) slab->opslab_size, slab));*/
 373         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 374             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 375                              (unsigned long)slab->opslab_size, errno);
 376     }
 377 }
 378
 379 void
 380 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 381 {
 382     OPSLAB *slab2;
 383
 384     PERL_ARGS_ASSERT_SLAB_TO_RW;
 385
 386     if (!slab->opslab_readonly) return;
 387     slab2 = slab;
 388     for (; slab2; slab2 = slab2->opslab_next) {
 389         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 390                               (unsigned long) size, slab2));*/
 391         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 392                      PROT_READ|PROT_WRITE)) {
 393             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 394                              (unsigned long)slab2->opslab_size, errno);
 395         }
 396     }
 397     slab->opslab_readonly = 0;
 398 }
 399
 400 #else
 401 #  define Slab_to_rw(op)    NOOP
 402 #endif
 403
 404 /* This cannot possibly be right, but it was copied from the old slab
 405    allocator, to which it was originally added, without explanation, in
 406    commit 083fcd5. */
 407 #ifdef NETWARE
 408 #    define PerlMemShared PerlMem
 409 #endif
 410
 411 /* make freed ops die if they're inadvertently executed */
 412 #ifdef DEBUGGING
 413 static OP *
 414 S_pp_freed(pTHX)
 415 {
 416     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 417 }
 418 #endif
 419
 420
 421 /* Return the block of memory used by an op to the free list of
 422  * the OP slab associated with that op.
 423  */
 424
 425 void
 426 Perl_Slab_Free(pTHX_ void *op)
 427 {
 428     OP * const o = (OP *)op;
 429     OPSLAB *slab;
 430
 431     PERL_ARGS_ASSERT_SLAB_FREE;
 432
 433 #ifdef DEBUGGING
 434     o->op_ppaddr = S_pp_freed;
 435 #endif
 436
 437     if (!o->op_slabbed) {
 438         if (!o->op_static)
 439             PerlMemShared_free(op);
 440         return;
 441     }
 442
 443     slab = OpSLAB(o);
 444     /* If this op is already freed, our refcount will get screwy. */
 445     assert(o->op_type != OP_FREED);
 446     o->op_type = OP_FREED;
 447     o->op_next = slab->opslab_freed;
 448     slab->opslab_freed = o;
 449     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 450     OpslabREFCNT_dec_padok(slab);
 451 }
 452
 453 void
 454 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 455 {
 456     const bool havepad = !!PL_comppad;
 457     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 458     if (havepad) {
 459         ENTER;
 460         PAD_SAVE_SETNULLPAD();
 461     }
 462     opslab_free(slab);
 463     if (havepad) LEAVE;
 464 }
 465
 466 /* Free a chain of OP slabs. Should only be called after all ops contained
 467  * in it have been freed. At this point, its reference count should be 1,
 468  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
 469  * and just directly calls opslab_free().
 470  * (Note that the reference count which PL_compcv held on the slab should
 471  * have been removed once compilation of the sub was complete).
 472  *
 473  *
 474  */
 475
 476 void
 477 Perl_opslab_free(pTHX_ OPSLAB *slab)
 478 {
 479     OPSLAB *slab2;
 480     PERL_ARGS_ASSERT_OPSLAB_FREE;
 481     PERL_UNUSED_CONTEXT;
 482     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 483     assert(slab->opslab_refcnt == 1);
 484     do {
 485         slab2 = slab->opslab_next;
 486 #ifdef DEBUGGING
 487         slab->opslab_refcnt = ~(size_t)0;
 488 #endif
 489 #ifdef PERL_DEBUG_READONLY_OPS
 490         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 491                                                (void*)slab));
 492         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 493             perror("munmap failed");
 494             abort();
 495         }
 496 #else
 497         PerlMemShared_free(slab);
 498 #endif
 499         slab = slab2;
 500     } while (slab);
 501 }
 502
 503 /* like opslab_free(), but first calls op_free() on any ops in the slab
 504  * not marked as OP_FREED
 505  */
 506
 507 void
 508 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 509 {
 510     OPSLAB *slab2;
 511 #ifdef DEBUGGING
 512     size_t savestack_count = 0;
 513 #endif
 514     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 515     slab2 = slab;
 516     do {
 517         OPSLOT *slot;
 518         for (slot = slab2->opslab_first;
 519              slot->opslot_next;
 520              slot = slot->opslot_next) {
 521             if (slot->opslot_op.op_type != OP_FREED
 522              && !(slot->opslot_op.op_savefree
 523 #ifdef DEBUGGING
 524                   && ++savestack_count
 525 #endif
 526                  )
 527             ) {
 528                 assert(slot->opslot_op.op_slabbed);
 529                 op_free(&slot->opslot_op);
 530                 if (slab->opslab_refcnt == 1) goto free;
 531             }
 532         }
 533     } while ((slab2 = slab2->opslab_next));
 534     /* > 1 because the CV still holds a reference count. */
 535     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 536 #ifdef DEBUGGING
 537         assert(savestack_count == slab->opslab_refcnt-1);
 538 #endif
 539         /* Remove the CV’s reference count. */
 540         slab->opslab_refcnt--;
 541         return;
 542     }
 543    free:
 544     opslab_free(slab);
 545 }
 546
 547 #ifdef PERL_DEBUG_READONLY_OPS
 548 OP *
 549 Perl_op_refcnt_inc(pTHX_ OP *o)
 550 {
 551     if(o) {
 552         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 553         if (slab && slab->opslab_readonly) {
 554             Slab_to_rw(slab);
 555             ++o->op_targ;
 556             Slab_to_ro(slab);
 557         } else {
 558             ++o->op_targ;
 559         }
 560     }
 561     return o;
 562
 563 }
 564
 565 PADOFFSET
 566 Perl_op_refcnt_dec(pTHX_ OP *o)
 567 {
 568     PADOFFSET result;
 569     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 570
 571     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 572
 573     if (slab && slab->opslab_readonly) {
 574         Slab_to_rw(slab);
 575         result = --o->op_targ;
 576         Slab_to_ro(slab);
 577     } else {
 578         result = --o->op_targ;
 579     }
 580     return result;
 581 }
 582 #endif
 583 /*
 584  * In the following definition, the ", (OP*)0" is just to make the compiler
 585  * think the expression is of the right type: croak actually does a Siglongjmp.
 586  */
 587 #define CHECKOP(type,o) \
 588     ((PL_op_mask && PL_op_mask[type])                           \
 589      ? ( op_free((OP*)o),                                       \
 590          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 591          (OP*)0 )                                               \
 592      : PL_check[type](aTHX_ (OP*)o))
 593
 594 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 595
 596 #define OpTYPE_set(o,type) \
 597     STMT_START {                                \
 598         o->op_type = (OPCODE)type;              \
 599         o->op_ppaddr = PL_ppaddr[type];         \
 600     } STMT_END
 601
 602 STATIC OP *
 603 S_no_fh_allowed(pTHX_ OP *o)
 604 {
 605     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 606
 607     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 608                  OP_DESC(o)));
 609     return o;
 610 }
 611
 612 STATIC OP *
 613 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 614 {
 615     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 616     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 617     return o;
 618 }
 619
 620 STATIC OP *
 621 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 622 {
 623     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 624
 625     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 626     return o;
 627 }
 628
 629 STATIC void
 630 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 631 {
 632     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 633
 634     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 635                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 636 }
 637
 638 /* remove flags var, its unused in all callers, move to to right end since gv
 639   and kid are always the same */
 640 STATIC void
 641 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 642 {
 643     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 644     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 645
 646     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 647                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 648 }
 649
 650 STATIC void
 651 S_no_bareword_allowed(pTHX_ OP *o)
 652 {
 653     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 654
 655     qerror(Perl_mess(aTHX_
 656                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 657                      SVfARG(cSVOPo_sv)));
 658     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 659 }
 660
 661 /* "register" allocation */
 662
 663 PADOFFSET
 664 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 665 {
 666     PADOFFSET off;
 667     const bool is_our = (PL_parser->in_my == KEY_our);
 668
 669     PERL_ARGS_ASSERT_ALLOCMY;
 670
 671     if (flags & ~SVf_UTF8)
 672         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 673                    (UV)flags);
 674
 675     /* complain about "my $<special_var>" etc etc */
 676     if (   len
 677         && !(  is_our
 678             || isALPHA(name[1])
 679             || (   (flags & SVf_UTF8)
 680                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 681             || (name[1] == '_' && len > 2)))
 682     {
 683         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 684          && isASCII(name[1])
 685          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 686             /* diag_listed_as: Can't use global %s in "%s" */
 687             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 688                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 689                               PL_parser->in_my == KEY_state ? "state" : "my"));
 690         } else {
 691             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 692                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 693         }
 694     }
 695
 696     /* allocate a spare slot and store the name in that slot */
 697
 698     off = pad_add_name_pvn(name, len,
 699                        (is_our ? padadd_OUR :
 700                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 701                     PL_parser->in_my_stash,
 702                     (is_our
 703                         /* $_ is always in main::, even with our */
 704                         ? (PL_curstash && !memEQs(name,len,"$_")
 705                             ? PL_curstash
 706                             : PL_defstash)
 707                         : NULL
 708                     )
 709     );
 710     /* anon sub prototypes contains state vars should always be cloned,
 711      * otherwise the state var would be shared between anon subs */
 712
 713     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 714         CvCLONE_on(PL_compcv);
 715
 716     return off;
 717 }
 718
 719 /*
 720 =head1 Optree Manipulation Functions
 721
 722 =for apidoc alloccopstash
 723
 724 Available only under threaded builds, this function allocates an entry in
 725 C<PL_stashpad> for the stash passed to it.
 726
 727 =cut
 728 */
 729
 730 #ifdef USE_ITHREADS
 731 PADOFFSET
 732 Perl_alloccopstash(pTHX_ HV *hv)
 733 {
 734     PADOFFSET off = 0, o = 1;
 735     bool found_slot = FALSE;
 736
 737     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 738
 739     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 740
 741     for (; o < PL_stashpadmax; ++o) {
 742         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 743         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 744             found_slot = TRUE, off = o;
 745     }
 746     if (!found_slot) {
 747         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 748         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 749         off = PL_stashpadmax;
 750         PL_stashpadmax += 10;
 751     }
 752
 753     PL_stashpad[PL_stashpadix = off] = hv;
 754     return off;
 755 }
 756 #endif
 757
 758 /* free the body of an op without examining its contents.
 759  * Always use this rather than FreeOp directly */
 760
 761 static void
 762 S_op_destroy(pTHX_ OP *o)
 763 {
 764     FreeOp(o);
 765 }
 766
 767 /* Destructor */
 768
 769 /*
 770 =for apidoc op_free
 771
 772 Free an op and its children. Only use this when an op is no longer linked
 773 to from any optree.
 774
 775 =cut
 776 */
 777
 778 void
 779 Perl_op_free(pTHX_ OP *o)
 780 {
 781     dVAR;
 782     OPCODE type;
 783     OP *top_op = o;
 784     OP *next_op = o;
 785     bool went_up = FALSE; /* whether we reached the current node by
 786                             following the parent pointer from a child, and
 787                             so have already seen this node */
 788
 789     if (!o || o->op_type == OP_FREED)
 790         return;
 791
 792     if (o->op_private & OPpREFCOUNTED) {
 793         /* if base of tree is refcounted, just decrement */
 794         switch (o->op_type) {
 795         case OP_LEAVESUB:
 796         case OP_LEAVESUBLV:
 797         case OP_LEAVEEVAL:
 798         case OP_LEAVE:
 799         case OP_SCOPE:
 800         case OP_LEAVEWRITE:
 801             {
 802                 PADOFFSET refcnt;
 803                 OP_REFCNT_LOCK;
 804                 refcnt = OpREFCNT_dec(o);
 805                 OP_REFCNT_UNLOCK;
 806                 if (refcnt) {
 807                     /* Need to find and remove any pattern match ops from
 808                      * the list we maintain for reset().  */
 809                     find_and_forget_pmops(o);
 810                     return;
 811                 }
 812             }
 813             break;
 814         default:
 815             break;
 816         }
 817     }
 818
 819     while (next_op) {
 820         o = next_op;
 821
 822         /* free child ops before ourself, (then free ourself "on the
 823          * way back up") */
 824
 825         if (!went_up && o->op_flags & OPf_KIDS) {
 826             next_op = cUNOPo->op_first;
 827             continue;
 828         }
 829
 830         /* find the next node to visit, *then* free the current node
 831          * (can't rely on o->op_* fields being valid after o has been
 832          * freed) */
 833
 834         /* The next node to visit will be either the sibling, or the
 835          * parent if no siblings left, or NULL if we've worked our way
 836          * back up to the top node in the tree */
 837         next_op = (o == top_op) ? NULL : o->op_sibparent;
 838         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
 839
 840         /* Now process the current node */
 841
 842         /* Though ops may be freed twice, freeing the op after its slab is a
 843            big no-no. */
 844         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 845         /* During the forced freeing of ops after compilation failure, kidops
 846            may be freed before their parents. */
 847         if (!o || o->op_type == OP_FREED)
 848             continue;
 849
 850         type = o->op_type;
 851
 852         /* an op should only ever acquire op_private flags that we know about.
 853          * If this fails, you may need to fix something in regen/op_private.
 854          * Don't bother testing if:
 855          *   * the op_ppaddr doesn't match the op; someone may have
 856          *     overridden the op and be doing strange things with it;
 857          *   * we've errored, as op flags are often left in an
 858          *     inconsistent state then. Note that an error when
 859          *     compiling the main program leaves PL_parser NULL, so
 860          *     we can't spot faults in the main code, only
 861          *     evaled/required code */
 862 #ifdef DEBUGGING
 863         if (   o->op_ppaddr == PL_ppaddr[type]
 864             && PL_parser
 865             && !PL_parser->error_count)
 866         {
 867             assert(!(o->op_private & ~PL_op_private_valid[type]));
 868         }
 869 #endif
 870
 871
 872         /* Call the op_free hook if it has been set. Do it now so that it's called
 873          * at the right time for refcounted ops, but still before all of the kids
 874          * are freed. */
 875         CALL_OPFREEHOOK(o);
 876
 877         if (type == OP_NULL)
 878             type = (OPCODE)o->op_targ;
 879
 880         if (o->op_slabbed)
 881             Slab_to_rw(OpSLAB(o));
 882
 883         /* COP* is not cleared by op_clear() so that we may track line
 884          * numbers etc even after null() */
 885         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 886             cop_free((COP*)o);
 887         }
 888
 889         op_clear(o);
 890         FreeOp(o);
 891         if (PL_op == o)
 892             PL_op = NULL;
 893     }
 894 }
 895
 896
 897 /* S_op_clear_gv(): free a GV attached to an OP */
 898
 899 STATIC
 900 #ifdef USE_ITHREADS
 901 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 902 #else
 903 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 904 #endif
 905 {
 906
 907     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 908             || o->op_type == OP_MULTIDEREF)
 909 #ifdef USE_ITHREADS
 910                 && PL_curpad
 911                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 912 #else
 913                 ? (GV*)(*svp) : NULL;
 914 #endif
 915     /* It's possible during global destruction that the GV is freed
 916        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 917        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 918        will trigger an assertion failure, because the entry to sv_clear
 919        checks that the scalar is not already freed.  A check of for
 920        !SvIS_FREED(gv) turns out to be invalid, because during global
 921        destruction the reference count can be forced down to zero
 922        (with SVf_BREAK set).  In which case raising to 1 and then
 923        dropping to 0 triggers cleanup before it should happen.  I
 924        *think* that this might actually be a general, systematic,
 925        weakness of the whole idea of SVf_BREAK, in that code *is*
 926        allowed to raise and lower references during global destruction,
 927        so any *valid* code that happens to do this during global
 928        destruction might well trigger premature cleanup.  */
 929     bool still_valid = gv && SvREFCNT(gv);
 930
 931     if (still_valid)
 932         SvREFCNT_inc_simple_void(gv);
 933 #ifdef USE_ITHREADS
 934     if (*ixp > 0) {
 935         pad_swipe(*ixp, TRUE);
 936         *ixp = 0;
 937     }
 938 #else
 939     SvREFCNT_dec(*svp);
 940     *svp = NULL;
 941 #endif
 942     if (still_valid) {
 943         int try_downgrade = SvREFCNT(gv) == 2;
 944         SvREFCNT_dec_NN(gv);
 945         if (try_downgrade)
 946             gv_try_downgrade(gv);
 947     }
 948 }
 949
 950
 951 void
 952 Perl_op_clear(pTHX_ OP *o)
 953 {
 954
 955     dVAR;
 956
 957     PERL_ARGS_ASSERT_OP_CLEAR;
 958
 959     switch (o->op_type) {
 960     case OP_NULL:       /* Was holding old type, if any. */
 961         /* FALLTHROUGH */
 962     case OP_ENTERTRY:
 963     case OP_ENTEREVAL:  /* Was holding hints. */
 964     case OP_ARGDEFELEM: /* Was holding signature index. */
 965         o->op_targ = 0;
 966         break;
 967     default:
 968         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
 969             break;
 970         /* FALLTHROUGH */
 971     case OP_GVSV:
 972     case OP_GV:
 973     case OP_AELEMFAST:
 974 #ifdef USE_ITHREADS
 975             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 976 #else
 977             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 978 #endif
 979         break;
 980     case OP_METHOD_REDIR:
 981     case OP_METHOD_REDIR_SUPER:
 982 #ifdef USE_ITHREADS
 983         if (cMETHOPx(o)->op_rclass_targ) {
 984             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 985             cMETHOPx(o)->op_rclass_targ = 0;
 986         }
 987 #else
 988         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 989         cMETHOPx(o)->op_rclass_sv = NULL;
 990 #endif
 991         /* FALLTHROUGH */
 992     case OP_METHOD_NAMED:
 993     case OP_METHOD_SUPER:
 994         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 995         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 996 #ifdef USE_ITHREADS
 997         if (o->op_targ) {
 998             pad_swipe(o->op_targ, 1);
 999             o->op_targ = 0;
1000         }
1001 #endif
1002         break;
1003     case OP_CONST:
1004     case OP_HINTSEVAL:
1005         SvREFCNT_dec(cSVOPo->op_sv);
1006         cSVOPo->op_sv = NULL;
1007 #ifdef USE_ITHREADS
1008         /** Bug #15654
1009           Even if op_clear does a pad_free for the target of the op,
1010           pad_free doesn't actually remove the sv that exists in the pad;
1011           instead it lives on. This results in that it could be reused as
1012           a target later on when the pad was reallocated.
1013         **/
1014         if(o->op_targ) {
1015           pad_swipe(o->op_targ,1);
1016           o->op_targ = 0;
1017         }
1018 #endif
1019         break;
1020     case OP_DUMP:
1021     case OP_GOTO:
1022     case OP_NEXT:
1023     case OP_LAST:
1024     case OP_REDO:
1025         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1026             break;
1027         /* FALLTHROUGH */
1028     case OP_TRANS:
1029     case OP_TRANSR:
1030         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1031             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1032         {
1033 #ifdef USE_ITHREADS
1034             if (cPADOPo->op_padix > 0) {
1035                 pad_swipe(cPADOPo->op_padix, TRUE);
1036                 cPADOPo->op_padix = 0;
1037             }
1038 #else
1039             SvREFCNT_dec(cSVOPo->op_sv);
1040             cSVOPo->op_sv = NULL;
1041 #endif
1042         }
1043         else {
1044             PerlMemShared_free(cPVOPo->op_pv);
1045             cPVOPo->op_pv = NULL;
1046         }
1047         break;
1048     case OP_SUBST:
1049         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1050         goto clear_pmop;
1051
1052     case OP_SPLIT:
1053         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1054             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1055         {
1056             if (o->op_private & OPpSPLIT_LEX)
1057                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1058             else
1059 #ifdef USE_ITHREADS
1060                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1061 #else
1062                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1063 #endif
1064         }
1065         /* FALLTHROUGH */
1066     case OP_MATCH:
1067     case OP_QR:
1068     clear_pmop:
1069         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1070             op_free(cPMOPo->op_code_list);
1071         cPMOPo->op_code_list = NULL;
1072         forget_pmop(cPMOPo);
1073         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1074         /* we use the same protection as the "SAFE" version of the PM_ macros
1075          * here since sv_clean_all might release some PMOPs
1076          * after PL_regex_padav has been cleared
1077          * and the clearing of PL_regex_padav needs to
1078          * happen before sv_clean_all
1079          */
1080 #ifdef USE_ITHREADS
1081         if(PL_regex_pad) {        /* We could be in destruction */
1082             const IV offset = (cPMOPo)->op_pmoffset;
1083             ReREFCNT_dec(PM_GETRE(cPMOPo));
1084             PL_regex_pad[offset] = &PL_sv_undef;
1085             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1086                            sizeof(offset));
1087         }
1088 #else
1089         ReREFCNT_dec(PM_GETRE(cPMOPo));
1090         PM_SETRE(cPMOPo, NULL);
1091 #endif
1092
1093         break;
1094
1095     case OP_ARGCHECK:
1096         PerlMemShared_free(cUNOP_AUXo->op_aux);
1097         break;
1098
1099     case OP_MULTICONCAT:
1100         {
1101             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1102             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1103              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1104              * utf8 shared strings */
1105             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1106             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1107             if (p1)
1108                 PerlMemShared_free(p1);
1109             if (p2 && p1 != p2)
1110                 PerlMemShared_free(p2);
1111             PerlMemShared_free(aux);
1112         }
1113         break;
1114
1115     case OP_MULTIDEREF:
1116         {
1117             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118             UV actions = items->uv;
1119             bool last = 0;
1120             bool is_hash = FALSE;
1121
1122             while (!last) {
1123                 switch (actions & MDEREF_ACTION_MASK) {
1124
1125                 case MDEREF_reload:
1126                     actions = (++items)->uv;
1127                     continue;
1128
1129                 case MDEREF_HV_padhv_helem:
1130                     is_hash = TRUE;
1131                     /* FALLTHROUGH */
1132                 case MDEREF_AV_padav_aelem:
1133                     pad_free((++items)->pad_offset);
1134                     goto do_elem;
1135
1136                 case MDEREF_HV_gvhv_helem:
1137                     is_hash = TRUE;
1138                     /* FALLTHROUGH */
1139                 case MDEREF_AV_gvav_aelem:
1140 #ifdef USE_ITHREADS
1141                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142 #else
1143                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1144 #endif
1145                     goto do_elem;
1146
1147                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1148                     is_hash = TRUE;
1149                     /* FALLTHROUGH */
1150                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1151 #ifdef USE_ITHREADS
1152                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1153 #else
1154                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1155 #endif
1156                     goto do_vivify_rv2xv_elem;
1157
1158                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1159                     is_hash = TRUE;
1160                     /* FALLTHROUGH */
1161                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1162                     pad_free((++items)->pad_offset);
1163                     goto do_vivify_rv2xv_elem;
1164
1165                 case MDEREF_HV_pop_rv2hv_helem:
1166                 case MDEREF_HV_vivify_rv2hv_helem:
1167                     is_hash = TRUE;
1168                     /* FALLTHROUGH */
1169                 do_vivify_rv2xv_elem:
1170                 case MDEREF_AV_pop_rv2av_aelem:
1171                 case MDEREF_AV_vivify_rv2av_aelem:
1172                 do_elem:
1173                     switch (actions & MDEREF_INDEX_MASK) {
1174                     case MDEREF_INDEX_none:
1175                         last = 1;
1176                         break;
1177                     case MDEREF_INDEX_const:
1178                         if (is_hash) {
1179 #ifdef USE_ITHREADS
1180                             /* see RT #15654 */
1181                             pad_swipe((++items)->pad_offset, 1);
1182 #else
1183                             SvREFCNT_dec((++items)->sv);
1184 #endif
1185                         }
1186                         else
1187                             items++;
1188                         break;
1189                     case MDEREF_INDEX_padsv:
1190                         pad_free((++items)->pad_offset);
1191                         break;
1192                     case MDEREF_INDEX_gvsv:
1193 #ifdef USE_ITHREADS
1194                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1195 #else
1196                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1197 #endif
1198                         break;
1199                     }
1200
1201                     if (actions & MDEREF_FLAG_last)
1202                         last = 1;
1203                     is_hash = FALSE;
1204
1205                     break;
1206
1207                 default:
1208                     assert(0);
1209                     last = 1;
1210                     break;
1211
1212                 } /* switch */
1213
1214                 actions >>= MDEREF_SHIFT;
1215             } /* while */
1216
1217             /* start of malloc is at op_aux[-1], where the length is
1218              * stored */
1219             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1220         }
1221         break;
1222     }
1223
1224     if (o->op_targ > 0) {
1225         pad_free(o->op_targ);
1226         o->op_targ = 0;
1227     }
1228 }
1229
1230 STATIC void
1231 S_cop_free(pTHX_ COP* cop)
1232 {
1233     PERL_ARGS_ASSERT_COP_FREE;
1234
1235     CopFILE_free(cop);
1236     if (! specialWARN(cop->cop_warnings))
1237         PerlMemShared_free(cop->cop_warnings);
1238     cophh_free(CopHINTHASH_get(cop));
1239     if (PL_curcop == cop)
1240        PL_curcop = NULL;
1241 }
1242
1243 STATIC void
1244 S_forget_pmop(pTHX_ PMOP *const o)
1245 {
1246     HV * const pmstash = PmopSTASH(o);
1247
1248     PERL_ARGS_ASSERT_FORGET_PMOP;
1249
1250     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1251         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1252         if (mg) {
1253             PMOP **const array = (PMOP**) mg->mg_ptr;
1254             U32 count = mg->mg_len / sizeof(PMOP**);
1255             U32 i = count;
1256
1257             while (i--) {
1258                 if (array[i] == o) {
1259                     /* Found it. Move the entry at the end to overwrite it.  */
1260                     array[i] = array[--count];
1261                     mg->mg_len = count * sizeof(PMOP**);
1262                     /* Could realloc smaller at this point always, but probably
1263                        not worth it. Probably worth free()ing if we're the
1264                        last.  */
1265                     if(!count) {
1266                         Safefree(mg->mg_ptr);
1267                         mg->mg_ptr = NULL;
1268                     }
1269                     break;
1270                 }
1271             }
1272         }
1273     }
1274     if (PL_curpm == o)
1275         PL_curpm = NULL;
1276 }
1277
1278 STATIC void
1279 S_find_and_forget_pmops(pTHX_ OP *o)
1280 {
1281     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1282
1283     if (o->op_flags & OPf_KIDS) {
1284         OP *kid = cUNOPo->op_first;
1285         while (kid) {
1286             switch (kid->op_type) {
1287             case OP_SUBST:
1288             case OP_SPLIT:
1289             case OP_MATCH:
1290             case OP_QR:
1291                 forget_pmop((PMOP*)kid);
1292             }
1293             find_and_forget_pmops(kid);
1294             kid = OpSIBLING(kid);
1295         }
1296     }
1297 }
1298
1299 /*
1300 =for apidoc op_null
1301
1302 Neutralizes an op when it is no longer needed, but is still linked to from
1303 other ops.
1304
1305 =cut
1306 */
1307
1308 void
1309 Perl_op_null(pTHX_ OP *o)
1310 {
1311     dVAR;
1312
1313     PERL_ARGS_ASSERT_OP_NULL;
1314
1315     if (o->op_type == OP_NULL)
1316         return;
1317     op_clear(o);
1318     o->op_targ = o->op_type;
1319     OpTYPE_set(o, OP_NULL);
1320 }
1321
1322 void
1323 Perl_op_refcnt_lock(pTHX)
1324   PERL_TSA_ACQUIRE(PL_op_mutex)
1325 {
1326 #ifdef USE_ITHREADS
1327     dVAR;
1328 #endif
1329     PERL_UNUSED_CONTEXT;
1330     OP_REFCNT_LOCK;
1331 }
1332
1333 void
1334 Perl_op_refcnt_unlock(pTHX)
1335   PERL_TSA_RELEASE(PL_op_mutex)
1336 {
1337 #ifdef USE_ITHREADS
1338     dVAR;
1339 #endif
1340     PERL_UNUSED_CONTEXT;
1341     OP_REFCNT_UNLOCK;
1342 }
1343
1344
1345 /*
1346 =for apidoc op_sibling_splice
1347
1348 A general function for editing the structure of an existing chain of
1349 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1350 you to delete zero or more sequential nodes, replacing them with zero or
1351 more different nodes.  Performs the necessary op_first/op_last
1352 housekeeping on the parent node and op_sibling manipulation on the
1353 children.  The last deleted node will be marked as as the last node by
1354 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1355
1356 Note that op_next is not manipulated, and nodes are not freed; that is the
1357 responsibility of the caller.  It also won't create a new list op for an
1358 empty list etc; use higher-level functions like op_append_elem() for that.
1359
1360 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1361 the splicing doesn't affect the first or last op in the chain.
1362
1363 C<start> is the node preceding the first node to be spliced.  Node(s)
1364 following it will be deleted, and ops will be inserted after it.  If it is
1365 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1366 beginning.
1367
1368 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1369 If -1 or greater than or equal to the number of remaining kids, all
1370 remaining kids are deleted.
1371
1372 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1373 If C<NULL>, no nodes are inserted.
1374
1375 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1376 deleted.
1377
1378 For example:
1379
1380     action                    before      after         returns
1381     ------                    -----       -----         -------
1382
1383                               P           P
1384     splice(P, A, 2, X-Y-Z)    |           |             B-C
1385                               A-B-C-D     A-X-Y-Z-D
1386
1387                               P           P
1388     splice(P, NULL, 1, X-Y)   |           |             A
1389                               A-B-C-D     X-Y-B-C-D
1390
1391                               P           P
1392     splice(P, NULL, 3, NULL)  |           |             A-B-C
1393                               A-B-C-D     D
1394
1395                               P           P
1396     splice(P, B, 0, X-Y)      |           |             NULL
1397                               A-B-C-D     A-B-X-Y-C-D
1398
1399
1400 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1401 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1402
1403 =cut
1404 */
1405
1406 OP *
1407 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1408 {
1409     OP *first;
1410     OP *rest;
1411     OP *last_del = NULL;
1412     OP *last_ins = NULL;
1413
1414     if (start)
1415         first = OpSIBLING(start);
1416     else if (!parent)
1417         goto no_parent;
1418     else
1419         first = cLISTOPx(parent)->op_first;
1420
1421     assert(del_count >= -1);
1422
1423     if (del_count && first) {
1424         last_del = first;
1425         while (--del_count && OpHAS_SIBLING(last_del))
1426             last_del = OpSIBLING(last_del);
1427         rest = OpSIBLING(last_del);
1428         OpLASTSIB_set(last_del, NULL);
1429     }
1430     else
1431         rest = first;
1432
1433     if (insert) {
1434         last_ins = insert;
1435         while (OpHAS_SIBLING(last_ins))
1436             last_ins = OpSIBLING(last_ins);
1437         OpMAYBESIB_set(last_ins, rest, NULL);
1438     }
1439     else
1440         insert = rest;
1441
1442     if (start) {
1443         OpMAYBESIB_set(start, insert, NULL);
1444     }
1445     else {
1446         assert(parent);
1447         cLISTOPx(parent)->op_first = insert;
1448         if (insert)
1449             parent->op_flags |= OPf_KIDS;
1450         else
1451             parent->op_flags &= ~OPf_KIDS;
1452     }
1453
1454     if (!rest) {
1455         /* update op_last etc */
1456         U32 type;
1457         OP *lastop;
1458
1459         if (!parent)
1460             goto no_parent;
1461
1462         /* ought to use OP_CLASS(parent) here, but that can't handle
1463          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1464          * either */
1465         type = parent->op_type;
1466         if (type == OP_CUSTOM) {
1467             dTHX;
1468             type = XopENTRYCUSTOM(parent, xop_class);
1469         }
1470         else {
1471             if (type == OP_NULL)
1472                 type = parent->op_targ;
1473             type = PL_opargs[type] & OA_CLASS_MASK;
1474         }
1475
1476         lastop = last_ins ? last_ins : start ? start : NULL;
1477         if (   type == OA_BINOP
1478             || type == OA_LISTOP
1479             || type == OA_PMOP
1480             || type == OA_LOOP
1481         )
1482             cLISTOPx(parent)->op_last = lastop;
1483
1484         if (lastop)
1485             OpLASTSIB_set(lastop, parent);
1486     }
1487     return last_del ? first : NULL;
1488
1489   no_parent:
1490     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1491 }
1492
1493 /*
1494 =for apidoc op_parent
1495
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1497
1498 =cut
1499 */
1500
1501 OP *
1502 Perl_op_parent(OP *o)
1503 {
1504     PERL_ARGS_ASSERT_OP_PARENT;
1505     while (OpHAS_SIBLING(o))
1506         o = OpSIBLING(o);
1507     return o->op_sibparent;
1508 }
1509
1510 /* replace the sibling following start with a new UNOP, which becomes
1511  * the parent of the original sibling; e.g.
1512  *
1513  *  op_sibling_newUNOP(P, A, unop-args...)
1514  *
1515  *  P              P
1516  *  |      becomes |
1517  *  A-B-C          A-U-C
1518  *                   |
1519  *                   B
1520  *
1521  * where U is the new UNOP.
1522  *
1523  * parent and start args are the same as for op_sibling_splice();
1524  * type and flags args are as newUNOP().
1525  *
1526  * Returns the new UNOP.
1527  */
1528
1529 STATIC OP *
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1531 {
1532     OP *kid, *newop;
1533
1534     kid = op_sibling_splice(parent, start, 1, NULL);
1535     newop = newUNOP(type, flags, kid);
1536     op_sibling_splice(parent, start, 0, newop);
1537     return newop;
1538 }
1539
1540
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542  * the struct. Higher-level stuff should be done by S_new_logop() /
1543  * newLOGOP(). This function exists mainly to avoid op_first assignment
1544  * being spread throughout this file.
1545  */
1546
1547 LOGOP *
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1549 {
1550     dVAR;
1551     LOGOP *logop;
1552     OP *kid = first;
1553     NewOp(1101, logop, 1, LOGOP);
1554     OpTYPE_set(logop, type);
1555     logop->op_first = first;
1556     logop->op_other = other;
1557     if (first)
1558         logop->op_flags = OPf_KIDS;
1559     while (kid && OpHAS_SIBLING(kid))
1560         kid = OpSIBLING(kid);
1561     if (kid)
1562         OpLASTSIB_set(kid, (OP*)logop);
1563     return logop;
1564 }
1565
1566
1567 /* Contextualizers */
1568
1569 /*
1570 =for apidoc op_contextualize
1571
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply.  The modified op tree
1575 is returned.
1576
1577 =cut
1578 */
1579
1580 OP *
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582 {
1583     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584     switch (context) {
1585         case G_SCALAR: return scalar(o);
1586         case G_ARRAY:  return list(o);
1587         case G_VOID:   return scalarvoid(o);
1588         default:
1589             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1590                        (long) context);
1591     }
1592 }
1593
1594 /*
1595
1596 =for apidoc op_linklist
1597 This function is the implementation of the L</LINKLIST> macro.  It should
1598 not be called directly.
1599
1600 =cut
1601 */
1602
1603 OP *
1604 Perl_op_linklist(pTHX_ OP *o)
1605 {
1606     OP *first;
1607
1608     PERL_ARGS_ASSERT_OP_LINKLIST;
1609
1610     if (o->op_next)
1611         return o->op_next;
1612
1613     /* establish postfix order */
1614     first = cUNOPo->op_first;
1615     if (first) {
1616         OP *kid;
1617         o->op_next = LINKLIST(first);
1618         kid = first;
1619         for (;;) {
1620             OP *sibl = OpSIBLING(kid);
1621             if (sibl) {
1622                 kid->op_next = LINKLIST(sibl);
1623                 kid = sibl;
1624             } else {
1625                 kid->op_next = o;
1626                 break;
1627             }
1628         }
1629     }
1630     else
1631         o->op_next = o;
1632
1633     return o->op_next;
1634 }
1635
1636 static OP *
1637 S_scalarkids(pTHX_ OP *o)
1638 {
1639     if (o && o->op_flags & OPf_KIDS) {
1640         OP *kid;
1641         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1642             scalar(kid);
1643     }
1644     return o;
1645 }
1646
1647 STATIC OP *
1648 S_scalarboolean(pTHX_ OP *o)
1649 {
1650     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1651
1652     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657         if (ckWARN(WARN_SYNTAX)) {
1658             const line_t oldline = CopLINE(PL_curcop);
1659
1660             if (PL_parser && PL_parser->copline != NOLINE) {
1661                 /* This ensures that warnings are reported at the first line
1662                    of the conditional, not the last.  */
1663                 CopLINE_set(PL_curcop, PL_parser->copline);
1664             }
1665             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666             CopLINE_set(PL_curcop, oldline);
1667         }
1668     }
1669     return scalar(o);
1670 }
1671
1672 static SV *
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1674 {
1675     assert(o);
1676     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1678     {
1679         const char funny  = o->op_type == OP_PADAV
1680                          || o->op_type == OP_RV2AV ? '@' : '%';
1681         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1682             GV *gv;
1683             if (cUNOPo->op_first->op_type != OP_GV
1684              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1685                 return NULL;
1686             return varname(gv, funny, 0, NULL, 0, subscript_type);
1687         }
1688         return
1689             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1690     }
1691 }
1692
1693 static SV *
1694 S_op_varname(pTHX_ const OP *o)
1695 {
1696     return S_op_varname_subscript(aTHX_ o, 1);
1697 }
1698
1699 static void
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702     if (o->op_type == OP_CONST) {
1703         *retsv = cSVOPo_sv;
1704         if (SvPOK(*retsv)) {
1705             SV *sv = *retsv;
1706             *retsv = sv_newmortal();
1707             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1709         }
1710         else if (!SvOK(*retsv))
1711             *retpv = "undef";
1712     }
1713     else *retpv = "...";
1714 }
1715
1716 static void
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1718 {
1719     OP *kid;
1720     const bool h = o->op_type == OP_HSLICE
1721                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1722     const char lbrack =
1723         h ? '{' : '[';
1724     const char rbrack =
1725         h ? '}' : ']';
1726     SV *name;
1727     SV *keysv = NULL; /* just to silence compiler warnings */
1728     const char *key = NULL;
1729
1730     if (!(o->op_private & OPpSLICEWARNING))
1731         return;
1732     if (PL_parser && PL_parser->error_count)
1733         /* This warning can be nonsensical when there is a syntax error. */
1734         return;
1735
1736     kid = cLISTOPo->op_first;
1737     kid = OpSIBLING(kid); /* get past pushmark */
1738     /* weed out false positives: any ops that can return lists */
1739     switch (kid->op_type) {
1740     case OP_BACKTICK:
1741     case OP_GLOB:
1742     case OP_READLINE:
1743     case OP_MATCH:
1744     case OP_RV2AV:
1745     case OP_EACH:
1746     case OP_VALUES:
1747     case OP_KEYS:
1748     case OP_SPLIT:
1749     case OP_LIST:
1750     case OP_SORT:
1751     case OP_REVERSE:
1752     case OP_ENTERSUB:
1753     case OP_CALLER:
1754     case OP_LSTAT:
1755     case OP_STAT:
1756     case OP_READDIR:
1757     case OP_SYSTEM:
1758     case OP_TMS:
1759     case OP_LOCALTIME:
1760     case OP_GMTIME:
1761     case OP_ENTEREVAL:
1762         return;
1763     }
1764
1765     /* Don't warn if we have a nulled list either. */
1766     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1767         return;
1768
1769     assert(OpSIBLING(kid));
1770     name = S_op_varname(aTHX_ OpSIBLING(kid));
1771     if (!name) /* XS module fiddling with the op tree */
1772         return;
1773     S_op_pretty(aTHX_ kid, &keysv, &key);
1774     assert(SvPOK(name));
1775     sv_chop(name,SvPVX(name)+1);
1776     if (key)
1777        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1780                    "%c%s%c",
1781                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782                     lbrack, key, rbrack);
1783     else
1784        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1787                     SVf "%c%" SVf "%c",
1788                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1790 }
1791
1792 OP *
1793 Perl_scalar(pTHX_ OP *o)
1794 {
1795     OP *kid;
1796
1797     /* assumes no premature commitment */
1798     if (!o || (PL_parser && PL_parser->error_count)
1799          || (o->op_flags & OPf_WANT)
1800          || o->op_type == OP_RETURN)
1801     {
1802         return o;
1803     }
1804
1805     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1806
1807     switch (o->op_type) {
1808     case OP_REPEAT:
1809         scalar(cBINOPo->op_first);
1810         if (o->op_private & OPpREPEAT_DOLIST) {
1811             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1812             assert(kid->op_type == OP_PUSHMARK);
1813             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1814                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1815                 o->op_private &=~ OPpREPEAT_DOLIST;
1816             }
1817         }
1818         break;
1819     case OP_OR:
1820     case OP_AND:
1821     case OP_COND_EXPR:
1822         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1823             scalar(kid);
1824         break;
1825         /* FALLTHROUGH */
1826     case OP_SPLIT:
1827     case OP_MATCH:
1828     case OP_QR:
1829     case OP_SUBST:
1830     case OP_NULL:
1831     default:
1832         if (o->op_flags & OPf_KIDS) {
1833             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1834                 scalar(kid);
1835         }
1836         break;
1837     case OP_LEAVE:
1838     case OP_LEAVETRY:
1839         kid = cLISTOPo->op_first;
1840         scalar(kid);
1841         kid = OpSIBLING(kid);
1842     do_kids:
1843         while (kid) {
1844             OP *sib = OpSIBLING(kid);
1845             if (sib && kid->op_type != OP_LEAVEWHEN
1846              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1847                 || (  sib->op_targ != OP_NEXTSTATE
1848                    && sib->op_targ != OP_DBSTATE  )))
1849                 scalarvoid(kid);
1850             else
1851                 scalar(kid);
1852             kid = sib;
1853         }
1854         PL_curcop = &PL_compiling;
1855         break;
1856     case OP_SCOPE:
1857     case OP_LINESEQ:
1858     case OP_LIST:
1859         kid = cLISTOPo->op_first;
1860         goto do_kids;
1861     case OP_SORT:
1862         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1863         break;
1864     case OP_KVHSLICE:
1865     case OP_KVASLICE:
1866     {
1867         /* Warn about scalar context */
1868         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1869         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1870         SV *name;
1871         SV *keysv;
1872         const char *key = NULL;
1873
1874         /* This warning can be nonsensical when there is a syntax error. */
1875         if (PL_parser && PL_parser->error_count)
1876             break;
1877
1878         if (!ckWARN(WARN_SYNTAX)) break;
1879
1880         kid = cLISTOPo->op_first;
1881         kid = OpSIBLING(kid); /* get past pushmark */
1882         assert(OpSIBLING(kid));
1883         name = S_op_varname(aTHX_ OpSIBLING(kid));
1884         if (!name) /* XS module fiddling with the op tree */
1885             break;
1886         S_op_pretty(aTHX_ kid, &keysv, &key);
1887         assert(SvPOK(name));
1888         sv_chop(name,SvPVX(name)+1);
1889         if (key)
1890   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1891             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1892                        "%%%" SVf "%c%s%c in scalar context better written "
1893                        "as $%" SVf "%c%s%c",
1894                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1895                         lbrack, key, rbrack);
1896         else
1897   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1898             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1899                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1900                        "written as $%" SVf "%c%" SVf "%c",
1901                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1902                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1903     }
1904     }
1905     return o;
1906 }
1907
1908 OP *
1909 Perl_scalarvoid(pTHX_ OP *arg)
1910 {
1911     dVAR;
1912     OP *kid;
1913     SV* sv;
1914     OP *o = arg;
1915
1916     PERL_ARGS_ASSERT_SCALARVOID;
1917
1918     while (1) {
1919         U8 want;
1920         SV *useless_sv = NULL;
1921         const char* useless = NULL;
1922         OP * next_kid = NULL;
1923
1924         if (o->op_type == OP_NEXTSTATE
1925             || o->op_type == OP_DBSTATE
1926             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1927                                           || o->op_targ == OP_DBSTATE)))
1928             PL_curcop = (COP*)o;                /* for warning below */
1929
1930         /* assumes no premature commitment */
1931         want = o->op_flags & OPf_WANT;
1932         if ((want && want != OPf_WANT_SCALAR)
1933             || (PL_parser && PL_parser->error_count)
1934             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1935         {
1936             goto get_next_op;
1937         }
1938
1939         if ((o->op_private & OPpTARGET_MY)
1940             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1941         {
1942             /* newASSIGNOP has already applied scalar context, which we
1943                leave, as if this op is inside SASSIGN.  */
1944             goto get_next_op;
1945         }
1946
1947         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1948
1949         switch (o->op_type) {
1950         default:
1951             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1952                 break;
1953             /* FALLTHROUGH */
1954         case OP_REPEAT:
1955             if (o->op_flags & OPf_STACKED)
1956                 break;
1957             if (o->op_type == OP_REPEAT)
1958                 scalar(cBINOPo->op_first);
1959             goto func_ops;
1960         case OP_CONCAT:
1961             if ((o->op_flags & OPf_STACKED) &&
1962                     !(o->op_private & OPpCONCAT_NESTED))
1963                 break;
1964             goto func_ops;
1965         case OP_SUBSTR:
1966             if (o->op_private == 4)
1967                 break;
1968             /* FALLTHROUGH */
1969         case OP_WANTARRAY:
1970         case OP_GV:
1971         case OP_SMARTMATCH:
1972         case OP_AV2ARYLEN:
1973         case OP_REF:
1974         case OP_REFGEN:
1975         case OP_SREFGEN:
1976         case OP_DEFINED:
1977         case OP_HEX:
1978         case OP_OCT:
1979         case OP_LENGTH:
1980         case OP_VEC:
1981         case OP_INDEX:
1982         case OP_RINDEX:
1983         case OP_SPRINTF:
1984         case OP_KVASLICE:
1985         case OP_KVHSLICE:
1986         case OP_UNPACK:
1987         case OP_PACK:
1988         case OP_JOIN:
1989         case OP_LSLICE:
1990         case OP_ANONLIST:
1991         case OP_ANONHASH:
1992         case OP_SORT:
1993         case OP_REVERSE:
1994         case OP_RANGE:
1995         case OP_FLIP:
1996         case OP_FLOP:
1997         case OP_CALLER:
1998         case OP_FILENO:
1999         case OP_EOF:
2000         case OP_TELL:
2001         case OP_GETSOCKNAME:
2002         case OP_GETPEERNAME:
2003         case OP_READLINK:
2004         case OP_TELLDIR:
2005         case OP_GETPPID:
2006         case OP_GETPGRP:
2007         case OP_GETPRIORITY:
2008         case OP_TIME:
2009         case OP_TMS:
2010         case OP_LOCALTIME:
2011         case OP_GMTIME:
2012         case OP_GHBYNAME:
2013         case OP_GHBYADDR:
2014         case OP_GHOSTENT:
2015         case OP_GNBYNAME:
2016         case OP_GNBYADDR:
2017         case OP_GNETENT:
2018         case OP_GPBYNAME:
2019         case OP_GPBYNUMBER:
2020         case OP_GPROTOENT:
2021         case OP_GSBYNAME:
2022         case OP_GSBYPORT:
2023         case OP_GSERVENT:
2024         case OP_GPWNAM:
2025         case OP_GPWUID:
2026         case OP_GGRNAM:
2027         case OP_GGRGID:
2028         case OP_GETLOGIN:
2029         case OP_PROTOTYPE:
2030         case OP_RUNCV:
2031         func_ops:
2032             useless = OP_DESC(o);
2033             break;
2034
2035         case OP_GVSV:
2036         case OP_PADSV:
2037         case OP_PADAV:
2038         case OP_PADHV:
2039         case OP_PADANY:
2040         case OP_AELEM:
2041         case OP_AELEMFAST:
2042         case OP_AELEMFAST_LEX:
2043         case OP_ASLICE:
2044         case OP_HELEM:
2045         case OP_HSLICE:
2046             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2047                 /* Otherwise it's "Useless use of grep iterator" */
2048                 useless = OP_DESC(o);
2049             break;
2050
2051         case OP_SPLIT:
2052             if (!(o->op_private & OPpSPLIT_ASSIGN))
2053                 useless = OP_DESC(o);
2054             break;
2055
2056         case OP_NOT:
2057             kid = cUNOPo->op_first;
2058             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2059                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2060                 goto func_ops;
2061             }
2062             useless = "negative pattern binding (!~)";
2063             break;
2064
2065         case OP_SUBST:
2066             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2067                 useless = "non-destructive substitution (s///r)";
2068             break;
2069
2070         case OP_TRANSR:
2071             useless = "non-destructive transliteration (tr///r)";
2072             break;
2073
2074         case OP_RV2GV:
2075         case OP_RV2SV:
2076         case OP_RV2AV:
2077         case OP_RV2HV:
2078             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2079                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2080                 useless = "a variable";
2081             break;
2082
2083         case OP_CONST:
2084             sv = cSVOPo_sv;
2085             if (cSVOPo->op_private & OPpCONST_STRICT)
2086                 no_bareword_allowed(o);
2087             else {
2088                 if (ckWARN(WARN_VOID)) {
2089                     NV nv;
2090                     /* don't warn on optimised away booleans, eg
2091                      * use constant Foo, 5; Foo || print; */
2092                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2093                         useless = NULL;
2094                     /* the constants 0 and 1 are permitted as they are
2095                        conventionally used as dummies in constructs like
2096                        1 while some_condition_with_side_effects;  */
2097                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2098                         useless = NULL;
2099                     else if (SvPOK(sv)) {
2100                         SV * const dsv = newSVpvs("");
2101                         useless_sv
2102                             = Perl_newSVpvf(aTHX_
2103                                             "a constant (%s)",
2104                                             pv_pretty(dsv, SvPVX_const(sv),
2105                                                       SvCUR(sv), 32, NULL, NULL,
2106                                                       PERL_PV_PRETTY_DUMP
2107                                                       | PERL_PV_ESCAPE_NOCLEAR
2108                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2109                         SvREFCNT_dec_NN(dsv);
2110                     }
2111                     else if (SvOK(sv)) {
2112                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2113                     }
2114                     else
2115                         useless = "a constant (undef)";
2116                 }
2117             }
2118             op_null(o);         /* don't execute or even remember it */
2119             break;
2120
2121         case OP_POSTINC:
2122             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2123             break;
2124
2125         case OP_POSTDEC:
2126             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2127             break;
2128
2129         case OP_I_POSTINC:
2130             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2131             break;
2132
2133         case OP_I_POSTDEC:
2134             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2135             break;
2136
2137         case OP_SASSIGN: {
2138             OP *rv2gv;
2139             UNOP *refgen, *rv2cv;
2140             LISTOP *exlist;
2141
2142             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2143                 break;
2144
2145             rv2gv = ((BINOP *)o)->op_last;
2146             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2147                 break;
2148
2149             refgen = (UNOP *)((BINOP *)o)->op_first;
2150
2151             if (!refgen || (refgen->op_type != OP_REFGEN
2152                             && refgen->op_type != OP_SREFGEN))
2153                 break;
2154
2155             exlist = (LISTOP *)refgen->op_first;
2156             if (!exlist || exlist->op_type != OP_NULL
2157                 || exlist->op_targ != OP_LIST)
2158                 break;
2159
2160             if (exlist->op_first->op_type != OP_PUSHMARK
2161                 && exlist->op_first != exlist->op_last)
2162                 break;
2163
2164             rv2cv = (UNOP*)exlist->op_last;
2165
2166             if (rv2cv->op_type != OP_RV2CV)
2167                 break;
2168
2169             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2170             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2171             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2172
2173             o->op_private |= OPpASSIGN_CV_TO_GV;
2174             rv2gv->op_private |= OPpDONT_INIT_GV;
2175             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2176
2177             break;
2178         }
2179
2180         case OP_AASSIGN: {
2181             inplace_aassign(o);
2182             break;
2183         }
2184
2185         case OP_OR:
2186         case OP_AND:
2187             kid = cLOGOPo->op_first;
2188             if (kid->op_type == OP_NOT
2189                 && (kid->op_flags & OPf_KIDS)) {
2190                 if (o->op_type == OP_AND) {
2191                     OpTYPE_set(o, OP_OR);
2192                 } else {
2193                     OpTYPE_set(o, OP_AND);
2194                 }
2195                 op_null(kid);
2196             }
2197             /* FALLTHROUGH */
2198
2199         case OP_DOR:
2200         case OP_COND_EXPR:
2201         case OP_ENTERGIVEN:
2202         case OP_ENTERWHEN:
2203             next_kid = OpSIBLING(cUNOPo->op_first);
2204         break;
2205
2206         case OP_NULL:
2207             if (o->op_flags & OPf_STACKED)
2208                 break;
2209             /* FALLTHROUGH */
2210         case OP_NEXTSTATE:
2211         case OP_DBSTATE:
2212         case OP_ENTERTRY:
2213         case OP_ENTER:
2214             if (!(o->op_flags & OPf_KIDS))
2215                 break;
2216             /* FALLTHROUGH */
2217         case OP_SCOPE:
2218         case OP_LEAVE:
2219         case OP_LEAVETRY:
2220         case OP_LEAVELOOP:
2221         case OP_LINESEQ:
2222         case OP_LEAVEGIVEN:
2223         case OP_LEAVEWHEN:
2224         kids:
2225             next_kid = cLISTOPo->op_first;
2226             break;
2227         case OP_LIST:
2228             /* If the first kid after pushmark is something that the padrange
2229                optimisation would reject, then null the list and the pushmark.
2230             */
2231             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2232                 && (  !(kid = OpSIBLING(kid))
2233                       || (  kid->op_type != OP_PADSV
2234                             && kid->op_type != OP_PADAV
2235                             && kid->op_type != OP_PADHV)
2236                       || kid->op_private & ~OPpLVAL_INTRO
2237                       || !(kid = OpSIBLING(kid))
2238                       || (  kid->op_type != OP_PADSV
2239                             && kid->op_type != OP_PADAV
2240                             && kid->op_type != OP_PADHV)
2241                       || kid->op_private & ~OPpLVAL_INTRO)
2242             ) {
2243                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2244                 op_null(o); /* NULL the list */
2245             }
2246             goto kids;
2247         case OP_ENTEREVAL:
2248             scalarkids(o);
2249             break;
2250         case OP_SCALAR:
2251             scalar(o);
2252             break;
2253         }
2254
2255         if (useless_sv) {
2256             /* mortalise it, in case warnings are fatal.  */
2257             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2258                            "Useless use of %" SVf " in void context",
2259                            SVfARG(sv_2mortal(useless_sv)));
2260         }
2261         else if (useless) {
2262             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2263                            "Useless use of %s in void context",
2264                            useless);
2265         }
2266
2267       get_next_op:
2268         /* if a kid hasn't been nominated to process, continue with the
2269          * next sibling, or if no siblings left, go back to the parent's
2270          * siblings and so on
2271          */
2272         while (!next_kid) {
2273             if (o == arg)
2274                 return arg; /* at top; no parents/siblings to try */
2275             if (OpHAS_SIBLING(o))
2276                 next_kid = o->op_sibparent;
2277             else
2278                 o = o->op_sibparent; /*try parent's next sibling */
2279         }
2280         o = next_kid;
2281     }
2282
2283     return arg;
2284 }
2285
2286
2287 static OP *
2288 S_listkids(pTHX_ OP *o)
2289 {
2290     if (o && o->op_flags & OPf_KIDS) {
2291         OP *kid;
2292         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2293             list(kid);
2294     }
2295     return o;
2296 }
2297
2298
2299 /* apply list context to the o subtree */
2300
2301 OP *
2302 Perl_list(pTHX_ OP *o)
2303 {
2304     OP * top_op = o;
2305
2306     while (1) {
2307         OP *next_kid = NULL; /* what op (if any) to process next */
2308
2309         OP *kid;
2310
2311         /* assumes no premature commitment */
2312         if (!o || (o->op_flags & OPf_WANT)
2313              || (PL_parser && PL_parser->error_count)
2314              || o->op_type == OP_RETURN)
2315         {
2316             goto do_next;
2317         }
2318
2319         if ((o->op_private & OPpTARGET_MY)
2320             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2321         {
2322             goto do_next;                               /* As if inside SASSIGN */
2323         }
2324
2325         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2326
2327         switch (o->op_type) {
2328         case OP_REPEAT:
2329             if (o->op_private & OPpREPEAT_DOLIST
2330              && !(o->op_flags & OPf_STACKED))
2331             {
2332                 list(cBINOPo->op_first);
2333                 kid = cBINOPo->op_last;
2334                 /* optimise away (.....) x 1 */
2335                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2336                  && SvIVX(kSVOP_sv) == 1)
2337                 {
2338                     op_null(o); /* repeat */
2339                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2340                     /* const (rhs): */
2341                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2342                 }
2343             }
2344             break;
2345
2346         case OP_OR:
2347         case OP_AND:
2348         case OP_COND_EXPR:
2349             /* impose list context on everything except the condition */
2350             next_kid = OpSIBLING(cUNOPo->op_first);
2351             break;
2352
2353         default:
2354             if (!(o->op_flags & OPf_KIDS))
2355                 break;
2356             /* possibly flatten 1..10 into a constant array */
2357             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2358                 list(cBINOPo->op_first);
2359                 gen_constant_list(o);
2360                 goto do_next;
2361             }
2362             next_kid = cUNOPo->op_first; /* do all kids */
2363             break;
2364
2365         case OP_LIST:
2366             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2367                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2368                 op_null(o); /* NULL the list */
2369             }
2370             if (o->op_flags & OPf_KIDS)
2371                 next_kid = cUNOPo->op_first; /* do all kids */
2372             break;
2373
2374         /* the children of these ops are usually a list of statements,
2375          * except the leaves, whose first child is is corresponding enter
2376          */
2377         case OP_SCOPE:
2378         case OP_LINESEQ:
2379             kid = cLISTOPo->op_first;
2380             goto do_kids;
2381         case OP_LEAVE:
2382         case OP_LEAVETRY:
2383             kid = cLISTOPo->op_first;
2384             list(kid);
2385             kid = OpSIBLING(kid);
2386         do_kids:
2387             while (kid) {
2388                 OP *sib = OpSIBLING(kid);
2389                 if (sib && kid->op_type != OP_LEAVEWHEN)
2390                     scalarvoid(kid);
2391                 else
2392                     list(kid);
2393                 kid = sib;
2394             }
2395             PL_curcop = &PL_compiling;
2396             break;
2397
2398         }
2399
2400         /* If next_kid is set, someone in the code above wanted us to process
2401          * that kid and all its remaining siblings.  Otherwise, work our way
2402          * back up the tree */
2403       do_next:
2404         while (!next_kid) {
2405             if (o == top_op)
2406                 return top_op; /* at top; no parents/siblings to try */
2407             if (OpHAS_SIBLING(o))
2408                 next_kid = o->op_sibparent;
2409             else
2410                 o = o->op_sibparent; /*try parent's next sibling */
2411
2412         }
2413         o = next_kid;
2414     } /* while */
2415 }
2416
2417
2418 static OP *
2419 S_scalarseq(pTHX_ OP *o)
2420 {
2421     if (o) {
2422         const OPCODE type = o->op_type;
2423
2424         if (type == OP_LINESEQ || type == OP_SCOPE ||
2425             type == OP_LEAVE || type == OP_LEAVETRY)
2426         {
2427             OP *kid, *sib;
2428             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2429                 if ((sib = OpSIBLING(kid))
2430                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2431                     || (  sib->op_targ != OP_NEXTSTATE
2432                        && sib->op_targ != OP_DBSTATE  )))
2433                 {
2434                     scalarvoid(kid);
2435                 }
2436             }
2437             PL_curcop = &PL_compiling;
2438         }
2439         o->op_flags &= ~OPf_PARENS;
2440         if (PL_hints & HINT_BLOCK_SCOPE)
2441             o->op_flags |= OPf_PARENS;
2442     }
2443     else
2444         o = newOP(OP_STUB, 0);
2445     return o;
2446 }
2447
2448 STATIC OP *
2449 S_modkids(pTHX_ OP *o, I32 type)
2450 {
2451     if (o && o->op_flags & OPf_KIDS) {
2452         OP *kid;
2453         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2454             op_lvalue(kid, type);
2455     }
2456     return o;
2457 }
2458
2459
2460 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2461  * const fields. Also, convert CONST keys to HEK-in-SVs.
2462  * rop    is the op that retrieves the hash;
2463  * key_op is the first key
2464  * real   if false, only check (and possibly croak); don't update op
2465  */
2466
2467 STATIC void
2468 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2469 {
2470     PADNAME *lexname;
2471     GV **fields;
2472     bool check_fields;
2473
2474     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2475     if (rop) {
2476         if (rop->op_first->op_type == OP_PADSV)
2477             /* @$hash{qw(keys here)} */
2478             rop = (UNOP*)rop->op_first;
2479         else {
2480             /* @{$hash}{qw(keys here)} */
2481             if (rop->op_first->op_type == OP_SCOPE
2482                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2483                 {
2484                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2485                 }
2486             else
2487                 rop = NULL;
2488         }
2489     }
2490
2491     lexname = NULL; /* just to silence compiler warnings */
2492     fields  = NULL; /* just to silence compiler warnings */
2493
2494     check_fields =
2495             rop
2496          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2497              SvPAD_TYPED(lexname))
2498          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2499          && isGV(*fields) && GvHV(*fields);
2500
2501     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2502         SV **svp, *sv;
2503         if (key_op->op_type != OP_CONST)
2504             continue;
2505         svp = cSVOPx_svp(key_op);
2506
2507         /* make sure it's not a bareword under strict subs */
2508         if (key_op->op_private & OPpCONST_BARE &&
2509             key_op->op_private & OPpCONST_STRICT)
2510         {
2511             no_bareword_allowed((OP*)key_op);
2512         }
2513
2514         /* Make the CONST have a shared SV */
2515         if (   !SvIsCOW_shared_hash(sv = *svp)
2516             && SvTYPE(sv) < SVt_PVMG
2517             && SvOK(sv)
2518             && !SvROK(sv)
2519             && real)
2520         {
2521             SSize_t keylen;
2522             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2523             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2524             SvREFCNT_dec_NN(sv);
2525             *svp = nsv;
2526         }
2527
2528         if (   check_fields
2529             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2530         {
2531             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2532                         "in variable %" PNf " of type %" HEKf,
2533                         SVfARG(*svp), PNfARG(lexname),
2534                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2535         }
2536     }
2537 }
2538
2539 /* info returned by S_sprintf_is_multiconcatable() */
2540
2541 struct sprintf_ismc_info {
2542     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2543     char  *start;     /* start of raw format string */
2544     char  *end;       /* bytes after end of raw format string */
2545     STRLEN total_len; /* total length (in bytes) of format string, not
2546                          including '%s' and  half of '%%' */
2547     STRLEN variant;   /* number of bytes by which total_len_p would grow
2548                          if upgraded to utf8 */
2549     bool   utf8;      /* whether the format is utf8 */
2550 };
2551
2552
2553 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2554  * i.e. its format argument is a const string with only '%s' and '%%'
2555  * formats, and the number of args is known, e.g.
2556  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2557  * but not
2558  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2559  *
2560  * If successful, the sprintf_ismc_info struct pointed to by info will be
2561  * populated.
2562  */
2563
2564 STATIC bool
2565 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2566 {
2567     OP    *pm, *constop, *kid;
2568     SV    *sv;
2569     char  *s, *e, *p;
2570     SSize_t nargs, nformats;
2571     STRLEN cur, total_len, variant;
2572     bool   utf8;
2573
2574     /* if sprintf's behaviour changes, die here so that someone
2575      * can decide whether to enhance this function or skip optimising
2576      * under those new circumstances */
2577     assert(!(o->op_flags & OPf_STACKED));
2578     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2579     assert(!(o->op_private & ~OPpARG4_MASK));
2580
2581     pm = cUNOPo->op_first;
2582     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2583         return FALSE;
2584     constop = OpSIBLING(pm);
2585     if (!constop || constop->op_type != OP_CONST)
2586         return FALSE;
2587     sv = cSVOPx_sv(constop);
2588     if (SvMAGICAL(sv) || !SvPOK(sv))
2589         return FALSE;
2590
2591     s = SvPV(sv, cur);
2592     e = s + cur;
2593
2594     /* Scan format for %% and %s and work out how many %s there are.
2595      * Abandon if other format types are found.
2596      */
2597
2598     nformats  = 0;
2599     total_len = 0;
2600     variant   = 0;
2601
2602     for (p = s; p < e; p++) {
2603         if (*p != '%') {
2604             total_len++;
2605             if (!UTF8_IS_INVARIANT(*p))
2606                 variant++;
2607             continue;
2608         }
2609         p++;
2610         if (p >= e)
2611             return FALSE; /* lone % at end gives "Invalid conversion" */
2612         if (*p == '%')
2613             total_len++;
2614         else if (*p == 's')
2615             nformats++;
2616         else
2617             return FALSE;
2618     }
2619
2620     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2621         return FALSE;
2622
2623     utf8 = cBOOL(SvUTF8(sv));
2624     if (utf8)
2625         variant = 0;
2626
2627     /* scan args; they must all be in scalar cxt */
2628
2629     nargs = 0;
2630     kid = OpSIBLING(constop);
2631
2632     while (kid) {
2633         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2634             return FALSE;
2635         nargs++;
2636         kid = OpSIBLING(kid);
2637     }
2638
2639     if (nargs != nformats)
2640         return FALSE; /* e.g. sprintf("%s%s", $a); */
2641
2642
2643     info->nargs      = nargs;
2644     info->start      = s;
2645     info->end        = e;
2646     info->total_len  = total_len;
2647     info->variant    = variant;
2648     info->utf8       = utf8;
2649
2650     return TRUE;
2651 }
2652
2653
2654
2655 /* S_maybe_multiconcat():
2656  *
2657  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2658  * convert it (and its children) into an OP_MULTICONCAT. See the code
2659  * comments just before pp_multiconcat() for the full details of what
2660  * OP_MULTICONCAT supports.
2661  *
2662  * Basically we're looking for an optree with a chain of OP_CONCATS down
2663  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2664  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2665  *
2666  *      $x = "$a$b-$c"
2667  *
2668  *  looks like
2669  *
2670  *      SASSIGN
2671  *         |
2672  *      STRINGIFY   -- PADSV[$x]
2673  *         |
2674  *         |
2675  *      ex-PUSHMARK -- CONCAT/S
2676  *                        |
2677  *                     CONCAT/S  -- PADSV[$d]
2678  *                        |
2679  *                     CONCAT    -- CONST["-"]
2680  *                        |
2681  *                     PADSV[$a] -- PADSV[$b]
2682  *
2683  * Note that at this stage the OP_SASSIGN may have already been optimised
2684  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2685  */
2686
2687 STATIC void
2688 S_maybe_multiconcat(pTHX_ OP *o)
2689 {
2690     dVAR;
2691     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2692     OP *topop;       /* the top-most op in the concat tree (often equals o,
2693                         unless there are assign/stringify ops above it */
2694     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2695     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2696     OP *targetop;    /* the op corresponding to target=... or target.=... */
2697     OP *stringop;    /* the OP_STRINGIFY op, if any */
2698     OP *nextop;      /* used for recreating the op_next chain without consts */
2699     OP *kid;         /* general-purpose op pointer */
2700     UNOP_AUX_item *aux;
2701     UNOP_AUX_item *lenp;
2702     char *const_str, *p;
2703     struct sprintf_ismc_info sprintf_info;
2704
2705                      /* store info about each arg in args[];
2706                       * toparg is the highest used slot; argp is a general
2707                       * pointer to args[] slots */
2708     struct {
2709         void *p;      /* initially points to const sv (or null for op);
2710                          later, set to SvPV(constsv), with ... */
2711         STRLEN len;   /* ... len set to SvPV(..., len) */
2712     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2713
2714     SSize_t nargs  = 0;
2715     SSize_t nconst = 0;
2716     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2717     STRLEN variant;
2718     bool utf8 = FALSE;
2719     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2720                                  the last-processed arg will the LHS of one,
2721                                  as args are processed in reverse order */
2722     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2723     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2724     U8 flags          = 0;   /* what will become the op_flags and ... */
2725     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2726     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2727     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2728     bool prev_was_const = FALSE; /* previous arg was a const */
2729
2730     /* -----------------------------------------------------------------
2731      * Phase 1:
2732      *
2733      * Examine the optree non-destructively to determine whether it's
2734      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2735      * information about the optree in args[].
2736      */
2737
2738     argp     = args;
2739     targmyop = NULL;
2740     targetop = NULL;
2741     stringop = NULL;
2742     topop    = o;
2743     parentop = o;
2744
2745     assert(   o->op_type == OP_SASSIGN
2746            || o->op_type == OP_CONCAT
2747            || o->op_type == OP_SPRINTF
2748            || o->op_type == OP_STRINGIFY);
2749
2750     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2751
2752     /* first see if, at the top of the tree, there is an assign,
2753      * append and/or stringify */
2754
2755     if (topop->op_type == OP_SASSIGN) {
2756         /* expr = ..... */
2757         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2758             return;
2759         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2760             return;
2761         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2762
2763         parentop = topop;
2764         topop = cBINOPo->op_first;
2765         targetop = OpSIBLING(topop);
2766         if (!targetop) /* probably some sort of syntax error */
2767             return;
2768     }
2769     else if (   topop->op_type == OP_CONCAT
2770              && (topop->op_flags & OPf_STACKED)
2771              && (!(topop->op_private & OPpCONCAT_NESTED))
2772             )
2773     {
2774         /* expr .= ..... */
2775
2776         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2777          * decide what to do about it */
2778         assert(!(o->op_private & OPpTARGET_MY));
2779
2780         /* barf on unknown flags */
2781         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2782         private_flags |= OPpMULTICONCAT_APPEND;
2783         targetop = cBINOPo->op_first;
2784         parentop = topop;
2785         topop    = OpSIBLING(targetop);
2786
2787         /* $x .= <FOO> gets optimised to rcatline instead */
2788         if (topop->op_type == OP_READLINE)
2789             return;
2790     }
2791
2792     if (targetop) {
2793         /* Can targetop (the LHS) if it's a padsv, be be optimised
2794          * away and use OPpTARGET_MY instead?
2795          */
2796         if (    (targetop->op_type == OP_PADSV)
2797             && !(targetop->op_private & OPpDEREF)
2798             && !(targetop->op_private & OPpPAD_STATE)
2799                /* we don't support 'my $x .= ...' */
2800             && (   o->op_type == OP_SASSIGN
2801                 || !(targetop->op_private & OPpLVAL_INTRO))
2802         )
2803             is_targable = TRUE;
2804     }
2805
2806     if (topop->op_type == OP_STRINGIFY) {
2807         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2808             return;
2809         stringop = topop;
2810
2811         /* barf on unknown flags */
2812         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2813
2814         if ((topop->op_private & OPpTARGET_MY)) {
2815             if (o->op_type == OP_SASSIGN)
2816                 return; /* can't have two assigns */
2817             targmyop = topop;
2818         }
2819
2820         private_flags |= OPpMULTICONCAT_STRINGIFY;
2821         parentop = topop;
2822         topop = cBINOPx(topop)->op_first;
2823         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2824         topop = OpSIBLING(topop);
2825     }
2826
2827     if (topop->op_type == OP_SPRINTF) {
2828         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2829             return;
2830         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2831             nargs     = sprintf_info.nargs;
2832             total_len = sprintf_info.total_len;
2833             variant   = sprintf_info.variant;
2834             utf8      = sprintf_info.utf8;
2835             is_sprintf = TRUE;
2836             private_flags |= OPpMULTICONCAT_FAKE;
2837             toparg = argp;
2838             /* we have an sprintf op rather than a concat optree.
2839              * Skip most of the code below which is associated with
2840              * processing that optree. We also skip phase 2, determining
2841              * whether its cost effective to optimise, since for sprintf,
2842              * multiconcat is *always* faster */
2843             goto create_aux;
2844         }
2845         /* note that even if the sprintf itself isn't multiconcatable,
2846          * the expression as a whole may be, e.g. in
2847          *    $x .= sprintf("%d",...)
2848          * the sprintf op will be left as-is, but the concat/S op may
2849          * be upgraded to multiconcat
2850          */
2851     }
2852     else if (topop->op_type == OP_CONCAT) {
2853         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2854             return;
2855
2856         if ((topop->op_private & OPpTARGET_MY)) {
2857             if (o->op_type == OP_SASSIGN || targmyop)
2858                 return; /* can't have two assigns */
2859             targmyop = topop;
2860         }
2861     }
2862
2863     /* Is it safe to convert a sassign/stringify/concat op into
2864      * a multiconcat? */
2865     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2866     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2867     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2868     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2869     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2870                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2871     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2872                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2873
2874     /* Now scan the down the tree looking for a series of
2875      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2876      * stacked). For example this tree:
2877      *
2878      *     |
2879      *   CONCAT/STACKED
2880      *     |
2881      *   CONCAT/STACKED -- EXPR5
2882      *     |
2883      *   CONCAT/STACKED -- EXPR4
2884      *     |
2885      *   CONCAT -- EXPR3
2886      *     |
2887      *   EXPR1  -- EXPR2
2888      *
2889      * corresponds to an expression like
2890      *
2891      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2892      *
2893      * Record info about each EXPR in args[]: in particular, whether it is
2894      * a stringifiable OP_CONST and if so what the const sv is.
2895      *
2896      * The reason why the last concat can't be STACKED is the difference
2897      * between
2898      *
2899      *    ((($a .= $a) .= $a) .= $a) .= $a
2900      *
2901      * and
2902      *    $a . $a . $a . $a . $a
2903      *
2904      * The main difference between the optrees for those two constructs
2905      * is the presence of the last STACKED. As well as modifying $a,
2906      * the former sees the changed $a between each concat, so if $s is
2907      * initially 'a', the first returns 'a' x 16, while the latter returns
2908      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2909      */
2910
2911     kid = topop;
2912
2913     for (;;) {
2914         OP *argop;
2915         SV *sv;
2916         bool last = FALSE;
2917
2918         if (    kid->op_type == OP_CONCAT
2919             && !kid_is_last
2920         ) {
2921             OP *k1, *k2;
2922             k1 = cUNOPx(kid)->op_first;
2923             k2 = OpSIBLING(k1);
2924             /* shouldn't happen except maybe after compile err? */
2925             if (!k2)
2926                 return;
2927
2928             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2929             if (kid->op_private & OPpTARGET_MY)
2930                 kid_is_last = TRUE;
2931
2932             stacked_last = (kid->op_flags & OPf_STACKED);
2933             if (!stacked_last)
2934                 kid_is_last = TRUE;
2935
2936             kid   = k1;
2937             argop = k2;
2938         }
2939         else {
2940             argop = kid;
2941             last = TRUE;
2942         }
2943
2944         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2945             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2946         {
2947             /* At least two spare slots are needed to decompose both
2948              * concat args. If there are no slots left, continue to
2949              * examine the rest of the optree, but don't push new values
2950              * on args[]. If the optree as a whole is legal for conversion
2951              * (in particular that the last concat isn't STACKED), then
2952              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2953              * can be converted into an OP_MULTICONCAT now, with the first
2954              * child of that op being the remainder of the optree -
2955              * which may itself later be converted to a multiconcat op
2956              * too.
2957              */
2958             if (last) {
2959                 /* the last arg is the rest of the optree */
2960                 argp++->p = NULL;
2961                 nargs++;
2962             }
2963         }
2964         else if (   argop->op_type == OP_CONST
2965             && ((sv = cSVOPx_sv(argop)))
2966             /* defer stringification until runtime of 'constant'
2967              * things that might stringify variantly, e.g. the radix
2968              * point of NVs, or overloaded RVs */
2969             && (SvPOK(sv) || SvIOK(sv))
2970             && (!SvGMAGICAL(sv))
2971         ) {
2972             argp++->p = sv;
2973             utf8   |= cBOOL(SvUTF8(sv));
2974             nconst++;
2975             if (prev_was_const)
2976                 /* this const may be demoted back to a plain arg later;
2977                  * make sure we have enough arg slots left */
2978                 nadjconst++;
2979             prev_was_const = !prev_was_const;
2980         }
2981         else {
2982             argp++->p = NULL;
2983             nargs++;
2984             prev_was_const = FALSE;
2985         }
2986
2987         if (last)
2988             break;
2989     }
2990
2991     toparg = argp - 1;
2992
2993     if (stacked_last)
2994         return; /* we don't support ((A.=B).=C)...) */
2995
2996     /* look for two adjacent consts and don't fold them together:
2997      *     $o . "a" . "b"
2998      * should do
2999      *     $o->concat("a")->concat("b")
3000      * rather than
3001      *     $o->concat("ab")
3002      * (but $o .=  "a" . "b" should still fold)
3003      */
3004     {
3005         bool seen_nonconst = FALSE;
3006         for (argp = toparg; argp >= args; argp--) {
3007             if (argp->p == NULL) {
3008                 seen_nonconst = TRUE;
3009                 continue;
3010             }
3011             if (!seen_nonconst)
3012                 continue;
3013             if (argp[1].p) {
3014                 /* both previous and current arg were constants;
3015                  * leave the current OP_CONST as-is */
3016                 argp->p = NULL;
3017                 nconst--;
3018                 nargs++;
3019             }
3020         }
3021     }
3022
3023     /* -----------------------------------------------------------------
3024      * Phase 2:
3025      *
3026      * At this point we have determined that the optree *can* be converted
3027      * into a multiconcat. Having gathered all the evidence, we now decide
3028      * whether it *should*.
3029      */
3030
3031
3032     /* we need at least one concat action, e.g.:
3033      *
3034      *  Y . Z
3035      *  X = Y . Z
3036      *  X .= Y
3037      *
3038      * otherwise we could be doing something like $x = "foo", which
3039      * if treated as as a concat, would fail to COW.
3040      */
3041     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3042         return;
3043
3044     /* Benchmarking seems to indicate that we gain if:
3045      * * we optimise at least two actions into a single multiconcat
3046      *    (e.g concat+concat, sassign+concat);
3047      * * or if we can eliminate at least 1 OP_CONST;
3048      * * or if we can eliminate a padsv via OPpTARGET_MY
3049      */
3050
3051     if (
3052            /* eliminated at least one OP_CONST */
3053            nconst >= 1
3054            /* eliminated an OP_SASSIGN */
3055         || o->op_type == OP_SASSIGN
3056            /* eliminated an OP_PADSV */
3057         || (!targmyop && is_targable)
3058     )
3059         /* definitely a net gain to optimise */
3060         goto optimise;
3061
3062     /* ... if not, what else? */
3063
3064     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3065      * multiconcat is faster (due to not creating a temporary copy of
3066      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3067      * faster.
3068      */
3069     if (   nconst == 0
3070          && nargs == 2
3071          && targmyop
3072          && topop->op_type == OP_CONCAT
3073     ) {
3074         PADOFFSET t = targmyop->op_targ;
3075         OP *k1 = cBINOPx(topop)->op_first;
3076         OP *k2 = cBINOPx(topop)->op_last;
3077         if (   k2->op_type == OP_PADSV
3078             && k2->op_targ == t
3079             && (   k1->op_type != OP_PADSV
3080                 || k1->op_targ != t)
3081         )
3082             goto optimise;
3083     }
3084
3085     /* need at least two concats */
3086     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3087         return;
3088
3089
3090
3091     /* -----------------------------------------------------------------
3092      * Phase 3:
3093      *
3094      * At this point the optree has been verified as ok to be optimised
3095      * into an OP_MULTICONCAT. Now start changing things.
3096      */
3097
3098    optimise:
3099
3100     /* stringify all const args and determine utf8ness */
3101
3102     variant = 0;
3103     for (argp = args; argp <= toparg; argp++) {
3104         SV *sv = (SV*)argp->p;
3105         if (!sv)
3106             continue; /* not a const op */
3107         if (utf8 && !SvUTF8(sv))
3108             sv_utf8_upgrade_nomg(sv);
3109         argp->p = SvPV_nomg(sv, argp->len);
3110         total_len += argp->len;
3111
3112         /* see if any strings would grow if converted to utf8 */
3113         if (!utf8) {
3114             variant += variant_under_utf8_count((U8 *) argp->p,
3115                                                 (U8 *) argp->p + argp->len);
3116         }
3117     }
3118
3119     /* create and populate aux struct */
3120
3121   create_aux:
3122
3123     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3124                     sizeof(UNOP_AUX_item)
3125                     *  (
3126                            PERL_MULTICONCAT_HEADER_SIZE
3127                          + ((nargs + 1) * (variant ? 2 : 1))
3128                         )
3129                     );
3130     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3131
3132     /* Extract all the non-const expressions from the concat tree then
3133      * dispose of the old tree, e.g. convert the tree from this:
3134      *
3135      *  o => SASSIGN
3136      *         |
3137      *       STRINGIFY   -- TARGET
3138      *         |
3139      *       ex-PUSHMARK -- CONCAT
3140      *                        |
3141      *                      CONCAT -- EXPR5
3142      *                        |
3143      *                      CONCAT -- EXPR4
3144      *                        |
3145      *                      CONCAT -- EXPR3
3146      *                        |
3147      *                      EXPR1  -- EXPR2
3148      *
3149      *
3150      * to:
3151      *
3152      *  o => MULTICONCAT
3153      *         |
3154      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3155      *
3156      * except that if EXPRi is an OP_CONST, it's discarded.
3157      *
3158      * During the conversion process, EXPR ops are stripped from the tree
3159      * and unshifted onto o. Finally, any of o's remaining original
3160      * childen are discarded and o is converted into an OP_MULTICONCAT.
3161      *
3162      * In this middle of this, o may contain both: unshifted args on the
3163      * left, and some remaining original args on the right. lastkidop
3164      * is set to point to the right-most unshifted arg to delineate
3165      * between the two sets.
3166      */
3167
3168
3169     if (is_sprintf) {
3170         /* create a copy of the format with the %'s removed, and record
3171          * the sizes of the const string segments in the aux struct */
3172         char *q, *oldq;
3173         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3174
3175         p    = sprintf_info.start;
3176         q    = const_str;
3177         oldq = q;
3178         for (; p < sprintf_info.end; p++) {
3179             if (*p == '%') {
3180                 p++;
3181                 if (*p != '%') {
3182                     (lenp++)->ssize = q - oldq;
3183                     oldq = q;
3184                     continue;
3185                 }
3186             }
3187             *q++ = *p;
3188         }
3189         lenp->ssize = q - oldq;
3190         assert((STRLEN)(q - const_str) == total_len);
3191
3192         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3193          * may or may not be topop) The pushmark and const ops need to be
3194          * kept in case they're an op_next entry point.
3195          */
3196         lastkidop = cLISTOPx(topop)->op_last;
3197         kid = cUNOPx(topop)->op_first; /* pushmark */
3198         op_null(kid);
3199         op_null(OpSIBLING(kid));       /* const */
3200         if (o != topop) {
3201             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3202             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3203             lastkidop->op_next = o;
3204         }
3205     }
3206     else {
3207         p = const_str;
3208         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3209
3210         lenp->ssize = -1;
3211
3212         /* Concatenate all const strings into const_str.
3213          * Note that args[] contains the RHS args in reverse order, so
3214          * we scan args[] from top to bottom to get constant strings
3215          * in L-R order
3216          */
3217         for (argp = toparg; argp >= args; argp--) {
3218             if (!argp->p)
3219                 /* not a const op */
3220                 (++lenp)->ssize = -1;
3221             else {
3222                 STRLEN l = argp->len;
3223                 Copy(argp->p, p, l, char);
3224                 p += l;
3225                 if (lenp->ssize == -1)
3226                     lenp->ssize = l;
3227                 else
3228                     lenp->ssize += l;
3229             }
3230         }
3231
3232         kid = topop;
3233         nextop = o;
3234         lastkidop = NULL;
3235
3236         for (argp = args; argp <= toparg; argp++) {
3237             /* only keep non-const args, except keep the first-in-next-chain
3238              * arg no matter what it is (but nulled if OP_CONST), because it
3239              * may be the entry point to this subtree from the previous
3240              * op_next.
3241              */
3242             bool last = (argp == toparg);
3243             OP *prev;
3244
3245             /* set prev to the sibling *before* the arg to be cut out,
3246              * e.g. when cutting EXPR:
3247              *
3248              *         |
3249              * kid=  CONCAT
3250              *         |
3251              * prev= CONCAT -- EXPR
3252              *         |
3253              */
3254             if (argp == args && kid->op_type != OP_CONCAT) {
3255                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3256                  * so the expression to be cut isn't kid->op_last but
3257                  * kid itself */
3258                 OP *o1, *o2;
3259                 /* find the op before kid */
3260                 o1 = NULL;
3261                 o2 = cUNOPx(parentop)->op_first;
3262                 while (o2 && o2 != kid) {
3263                     o1 = o2;
3264                     o2 = OpSIBLING(o2);
3265                 }
3266                 assert(o2 == kid);
3267                 prev = o1;
3268                 kid  = parentop;
3269             }
3270             else if (kid == o && lastkidop)
3271                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3272             else
3273                 prev = last ? NULL : cUNOPx(kid)->op_first;
3274
3275             if (!argp->p || last) {
3276                 /* cut RH op */
3277                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3278                 /* and unshift to front of o */
3279                 op_sibling_splice(o, NULL, 0, aop);
3280                 /* record the right-most op added to o: later we will
3281                  * free anything to the right of it */
3282                 if (!lastkidop)
3283                     lastkidop = aop;
3284                 aop->op_next = nextop;
3285                 if (last) {
3286                     if (argp->p)
3287                         /* null the const at start of op_next chain */
3288                         op_null(aop);
3289                 }
3290                 else if (prev)
3291                     nextop = prev->op_next;
3292             }
3293
3294             /* the last two arguments are both attached to the same concat op */
3295             if (argp < toparg - 1)
3296                 kid = prev;
3297         }
3298     }
3299
3300     /* Populate the aux struct */
3301
3302     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3303     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3304     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3305     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3306     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3307
3308     /* if variant > 0, calculate a variant const string and lengths where
3309      * the utf8 version of the string will take 'variant' more bytes than
3310      * the plain one. */
3311
3312     if (variant) {
3313         char              *p = const_str;
3314         STRLEN          ulen = total_len + variant;
3315         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3316         UNOP_AUX_item *ulens = lens + (nargs + 1);
3317         char             *up = (char*)PerlMemShared_malloc(ulen);
3318         SSize_t            n;
3319
3320         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3321         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3322
3323         for (n = 0; n < (nargs + 1); n++) {
3324             SSize_t i;
3325             char * orig_up = up;
3326             for (i = (lens++)->ssize; i > 0; i--) {
3327                 U8 c = *p++;
3328                 append_utf8_from_native_byte(c, (U8**)&up);
3329             }
3330             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3331         }
3332     }
3333
3334     if (stringop) {
3335         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3336          * that op's first child - an ex-PUSHMARK - because the op_next of
3337          * the previous op may point to it (i.e. it's the entry point for
3338          * the o optree)
3339          */
3340         OP *pmop =
3341             (stringop == o)
3342                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3343                 : op_sibling_splice(stringop, NULL, 1, NULL);
3344         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3345         op_sibling_splice(o, NULL, 0, pmop);
3346         if (!lastkidop)
3347             lastkidop = pmop;
3348     }
3349
3350     /* Optimise
3351      *    target  = A.B.C...
3352      *    target .= A.B.C...
3353      */
3354
3355     if (targetop) {
3356         assert(!targmyop);
3357
3358         if (o->op_type == OP_SASSIGN) {
3359             /* Move the target subtree from being the last of o's children
3360              * to being the last of o's preserved children.
3361              * Note the difference between 'target = ...' and 'target .= ...':
3362              * for the former, target is executed last; for the latter,
3363              * first.
3364              */
3365             kid = OpSIBLING(lastkidop);
3366             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3367             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3368             lastkidop->op_next = kid->op_next;
3369             lastkidop = targetop;
3370         }
3371         else {
3372             /* Move the target subtree from being the first of o's
3373              * original children to being the first of *all* o's children.
3374              */
3375             if (lastkidop) {
3376                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3377                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3378             }
3379             else {
3380                 /* if the RHS of .= doesn't contain a concat (e.g.
3381                  * $x .= "foo"), it gets missed by the "strip ops from the
3382                  * tree and add to o" loop earlier */
3383                 assert(topop->op_type != OP_CONCAT);
3384                 if (stringop) {
3385                     /* in e.g. $x .= "$y", move the $y expression
3386                      * from being a child of OP_STRINGIFY to being the
3387                      * second child of the OP_CONCAT
3388                      */
3389                     assert(cUNOPx(stringop)->op_first == topop);
3390                     op_sibling_splice(stringop, NULL, 1, NULL);
3391                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3392                 }
3393                 assert(topop == OpSIBLING(cBINOPo->op_first));
3394                 if (toparg->p)
3395                     op_null(topop);
3396                 lastkidop = topop;
3397             }
3398         }
3399
3400         if (is_targable) {
3401             /* optimise
3402              *  my $lex  = A.B.C...
3403              *     $lex  = A.B.C...
3404              *     $lex .= A.B.C...
3405              * The original padsv op is kept but nulled in case it's the
3406              * entry point for the optree (which it will be for
3407              * '$lex .=  ... '
3408              */
3409             private_flags |= OPpTARGET_MY;
3410             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3411             o->op_targ = targetop->op_targ;
3412             targetop->op_targ = 0;
3413             op_null(targetop);
3414         }
3415         else
3416             flags |= OPf_STACKED;
3417     }
3418     else if (targmyop) {
3419         private_flags |= OPpTARGET_MY;
3420         if (o != targmyop) {
3421             o->op_targ = targmyop->op_targ;
3422             targmyop->op_targ = 0;
3423         }
3424     }
3425
3426     /* detach the emaciated husk of the sprintf/concat optree and free it */
3427     for (;;) {
3428         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3429         if (!kid)
3430             break;
3431         op_free(kid);
3432     }
3433
3434     /* and convert o into a multiconcat */
3435
3436     o->op_flags        = (flags|OPf_KIDS|stacked_last
3437                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3438     o->op_private      = private_flags;
3439     o->op_type         = OP_MULTICONCAT;
3440     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3441     cUNOP_AUXo->op_aux = aux;
3442 }
3443
3444
3445 /* do all the final processing on an optree (e.g. running the peephole
3446  * optimiser on it), then attach it to cv (if cv is non-null)
3447  */
3448
3449 static void
3450 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3451 {
3452     OP **startp;
3453
3454     /* XXX for some reason, evals, require and main optrees are
3455      * never attached to their CV; instead they just hang off
3456      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3457      * and get manually freed when appropriate */
3458     if (cv)
3459         startp = &CvSTART(cv);
3460     else
3461         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3462
3463     *startp = start;
3464     optree->op_private |= OPpREFCOUNTED;
3465     OpREFCNT_set(optree, 1);
3466     optimize_optree(optree);
3467     CALL_PEEP(*startp);
3468     finalize_optree(optree);
3469     S_prune_chain_head(startp);
3470
3471     if (cv) {
3472         /* now that optimizer has done its work, adjust pad values */
3473         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3474                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3475     }
3476 }
3477
3478
3479 /*
3480 =for apidoc optimize_optree
3481
3482 This function applies some optimisations to the optree in top-down order.
3483 It is called before the peephole optimizer, which processes ops in
3484 execution order. Note that finalize_optree() also does a top-down scan,
3485 but is called *after* the peephole optimizer.
3486
3487 =cut
3488 */
3489
3490 void
3491 Perl_optimize_optree(pTHX_ OP* o)
3492 {
3493     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3494
3495     ENTER;
3496     SAVEVPTR(PL_curcop);
3497
3498     optimize_op(o);
3499
3500     LEAVE;
3501 }
3502
3503
3504 /* helper for optimize_optree() which optimises one op then recurses
3505  * to optimise any children.
3506  */
3507
3508 STATIC void
3509 S_optimize_op(pTHX_ OP* o)
3510 {
3511     OP *top_op = o;
3512
3513     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3514
3515     while (1) {
3516         OP * next_kid = NULL;
3517
3518         assert(o->op_type != OP_FREED);
3519
3520         switch (o->op_type) {
3521         case OP_NEXTSTATE:
3522         case OP_DBSTATE:
3523             PL_curcop = ((COP*)o);              /* for warnings */
3524             break;
3525
3526
3527         case OP_CONCAT:
3528         case OP_SASSIGN:
3529         case OP_STRINGIFY:
3530         case OP_SPRINTF:
3531             S_maybe_multiconcat(aTHX_ o);
3532             break;
3533
3534         case OP_SUBST:
3535             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3536                 /* we can't assume that op_pmreplroot->op_sibparent == o
3537                  * and that it is thus possible to walk back up the tree
3538                  * past op_pmreplroot. So, although we try to avoid
3539                  * recursing through op trees, do it here. After all,
3540                  * there are unlikely to be many nested s///e's within
3541                  * the replacement part of a s///e.
3542                  */
3543                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3544             }
3545             break;
3546
3547         default:
3548             break;
3549         }
3550
3551         if (o->op_flags & OPf_KIDS)
3552             next_kid = cUNOPo->op_first;
3553
3554         /* if a kid hasn't been nominated to process, continue with the
3555          * next sibling, or if no siblings left, go back to the parent's
3556          * siblings and so on
3557          */
3558         while (!next_kid) {
3559             if (o == top_op)
3560                 return; /* at top; no parents/siblings to try */
3561             if (OpHAS_SIBLING(o))
3562                 next_kid = o->op_sibparent;
3563             else
3564                 o = o->op_sibparent; /*try parent's next sibling */
3565         }
3566
3567       /* this label not yet used. Goto here if any code above sets
3568        * next-kid
3569        get_next_op:
3570        */
3571         o = next_kid;
3572     }
3573 }
3574
3575
3576 /*
3577 =for apidoc finalize_optree
3578
3579 This function finalizes the optree.  Should be called directly after
3580 the complete optree is built.  It does some additional
3581 checking which can't be done in the normal C<ck_>xxx functions and makes
3582 the tree thread-safe.
3583
3584 =cut
3585 */
3586 void
3587 Perl_finalize_optree(pTHX_ OP* o)
3588 {
3589     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3590
3591     ENTER;
3592     SAVEVPTR(PL_curcop);
3593
3594     finalize_op(o);
3595
3596     LEAVE;
3597 }
3598
3599 #ifdef USE_ITHREADS
3600 /* Relocate sv to the pad for thread safety.
3601  * Despite being a "constant", the SV is written to,
3602  * for reference counts, sv_upgrade() etc. */
3603 PERL_STATIC_INLINE void
3604 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3605 {
3606     PADOFFSET ix;
3607     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3608     if (!*svp) return;
3609     ix = pad_alloc(OP_CONST, SVf_READONLY);
3610     SvREFCNT_dec(PAD_SVl(ix));
3611     PAD_SETSV(ix, *svp);
3612     /* XXX I don't know how this isn't readonly already. */
3613     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3614     *svp = NULL;
3615     *targp = ix;
3616 }
3617 #endif
3618
3619 /*
3620 =for apidoc traverse_op_tree
3621
3622 Return the next op in a depth-first traversal of the op tree,
3623 returning NULL when the traversal is complete.
3624
3625 The initial call must supply the root of the tree as both top and o.
3626
3627 For now it's static, but it may be exposed to the API in the future.
3628
3629 =cut
3630 */
3631
3632 STATIC OP*
3633 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3634     OP *sib;
3635
3636     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3637
3638     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3639         return cUNOPo->op_first;
3640     }
3641     else if ((sib = OpSIBLING(o))) {
3642         return sib;
3643     }
3644     else {
3645         OP *parent = o->op_sibparent;
3646         assert(!(o->op_moresib));
3647         while (parent && parent != top) {
3648             OP *sib = OpSIBLING(parent);
3649             if (sib)
3650                 return sib;
3651             parent = parent->op_sibparent;
3652         }
3653
3654         return NULL;
3655     }
3656 }
3657
3658 STATIC void
3659 S_finalize_op(pTHX_ OP* o)
3660 {
3661     OP * const top = o;
3662     PERL_ARGS_ASSERT_FINALIZE_OP;
3663
3664     do {
3665         assert(o->op_type != OP_FREED);
3666
3667         switch (o->op_type) {
3668         case OP_NEXTSTATE:
3669         case OP_DBSTATE:
3670             PL_curcop = ((COP*)o);              /* for warnings */
3671             break;
3672         case OP_EXEC:
3673             if (OpHAS_SIBLING(o)) {
3674                 OP *sib = OpSIBLING(o);
3675                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3676                     && ckWARN(WARN_EXEC)
3677                     && OpHAS_SIBLING(sib))
3678                 {
3679                     const OPCODE type = OpSIBLING(sib)->op_type;
3680                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3681                         const line_t oldline = CopLINE(PL_curcop);
3682                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3683                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3684                             "Statement unlikely to be reached");
3685                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3686                             "\t(Maybe you meant system() when you said exec()?)\n");
3687                         CopLINE_set(PL_curcop, oldline);
3688                     }
3689                 }
3690             }
3691             break;
3692
3693         case OP_GV:
3694             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3695                 GV * const gv = cGVOPo_gv;
3696                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3697                     /* XXX could check prototype here instead of just carping */
3698                     SV * const sv = sv_newmortal();
3699                     gv_efullname3(sv, gv, NULL);
3700                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3701                                 "%" SVf "() called too early to check prototype",
3702                                 SVfARG(sv));
3703                 }
3704             }
3705             break;
3706
3707         case OP_CONST:
3708             if (cSVOPo->op_private & OPpCONST_STRICT)
3709                 no_bareword_allowed(o);
3710 #ifdef USE_ITHREADS
3711             /* FALLTHROUGH */
3712         case OP_HINTSEVAL:
3713             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3714 #endif
3715             break;
3716
3717 #ifdef USE_ITHREADS
3718             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3719         case OP_METHOD_NAMED:
3720         case OP_METHOD_SUPER:
3721         case OP_METHOD_REDIR:
3722         case OP_METHOD_REDIR_SUPER:
3723             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3724             break;
3725 #endif
3726
3727         case OP_HELEM: {
3728             UNOP *rop;
3729             SVOP *key_op;
3730             OP *kid;
3731
3732             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3733                 break;
3734
3735             rop = (UNOP*)((BINOP*)o)->op_first;
3736
3737             goto check_keys;
3738
3739             case OP_HSLICE:
3740                 S_scalar_slice_warning(aTHX_ o);
3741                 /* FALLTHROUGH */
3742
3743             case OP_KVHSLICE:
3744                 kid = OpSIBLING(cLISTOPo->op_first);
3745             if (/* I bet there's always a pushmark... */
3746                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3747                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3748             {
3749                 break;
3750             }
3751
3752             key_op = (SVOP*)(kid->op_type == OP_CONST
3753                              ? kid
3754                              : OpSIBLING(kLISTOP->op_first));
3755
3756             rop = (UNOP*)((LISTOP*)o)->op_last;
3757
3758         check_keys:
3759             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3760                 rop = NULL;
3761             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3762             break;
3763         }
3764         case OP_NULL:
3765             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3766                 break;
3767             /* FALLTHROUGH */
3768         case OP_ASLICE:
3769             S_scalar_slice_warning(aTHX_ o);
3770             break;
3771
3772         case OP_SUBST: {
3773             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3774                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3775             break;
3776         }
3777         default:
3778             break;
3779         }
3780
3781 #ifdef DEBUGGING
3782         if (o->op_flags & OPf_KIDS) {
3783             OP *kid;
3784
3785             /* check that op_last points to the last sibling, and that
3786              * the last op_sibling/op_sibparent field points back to the
3787              * parent, and that the only ops with KIDS are those which are
3788              * entitled to them */
3789             U32 type = o->op_type;
3790             U32 family;
3791             bool has_last;
3792
3793             if (type == OP_NULL) {
3794                 type = o->op_targ;
3795                 /* ck_glob creates a null UNOP with ex-type GLOB
3796                  * (which is a list op. So pretend it wasn't a listop */
3797                 if (type == OP_GLOB)
3798                     type = OP_NULL;
3799             }
3800             family = PL_opargs[type] & OA_CLASS_MASK;
3801
3802             has_last = (   family == OA_BINOP
3803                         || family == OA_LISTOP
3804                         || family == OA_PMOP
3805                         || family == OA_LOOP
3806                        );
3807             assert(  has_last /* has op_first and op_last, or ...
3808                   ... has (or may have) op_first: */
3809                   || family == OA_UNOP
3810                   || family == OA_UNOP_AUX
3811                   || family == OA_LOGOP
3812                   || family == OA_BASEOP_OR_UNOP
3813                   || family == OA_FILESTATOP
3814                   || family == OA_LOOPEXOP
3815                   || family == OA_METHOP
3816                   || type == OP_CUSTOM
3817                   || type == OP_NULL /* new_logop does this */
3818                   );
3819
3820             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3821                 if (!OpHAS_SIBLING(kid)) {
3822                     if (has_last)
3823                         assert(kid == cLISTOPo->op_last);
3824                     assert(kid->op_sibparent == o);
3825                 }
3826             }
3827         }
3828 #endif
3829     } while (( o = traverse_op_tree(top, o)) != NULL);
3830 }
3831
3832 /*
3833 =for apidoc op_lvalue
3834
3835 Propagate lvalue ("modifiable") context to an op and its children.
3836 C<type> represents the context type, roughly based on the type of op that
3837 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3838 because it has no op type of its own (it is signalled by a flag on
3839 the lvalue op).
3840
3841 This function detects things that can't be modified, such as C<$x+1>, and
3842 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3843 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3844
3845 It also flags things that need to behave specially in an lvalue context,
3846 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3847
3848 =cut
3849 */
3850
3851 static void
3852 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3853 {
3854     CV *cv = PL_compcv;
3855     PadnameLVALUE_on(pn);
3856     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3857         cv = CvOUTSIDE(cv);
3858         /* RT #127786: cv can be NULL due to an eval within the DB package
3859          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3860          * unless they contain an eval, but calling eval within DB
3861          * pretends the eval was done in the caller's scope.
3862          */
3863         if (!cv)
3864             break;
3865         assert(CvPADLIST(cv));
3866         pn =
3867            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3868         assert(PadnameLEN(pn));
3869         PadnameLVALUE_on(pn);
3870     }
3871 }
3872
3873 static bool
3874 S_vivifies(const OPCODE type)
3875 {
3876     switch(type) {
3877     case OP_RV2AV:     case   OP_ASLICE:
3878     case OP_RV2HV:     case OP_KVASLICE:
3879     case OP_RV2SV:     case   OP_HSLICE:
3880     case OP_AELEMFAST: case OP_KVHSLICE:
3881     case OP_HELEM:
3882     case OP_AELEM:
3883         return 1;
3884     }
3885     return 0;
3886 }
3887
3888 static void
3889 S_lvref(pTHX_ OP *o, I32 type)
3890 {
3891     dVAR;
3892     OP *kid;
3893     switch (o->op_type) {
3894     case OP_COND_EXPR:
3895         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3896              kid = OpSIBLING(kid))
3897             S_lvref(aTHX_ kid, type);
3898         /* FALLTHROUGH */
3899     case OP_PUSHMARK:
3900         return;
3901     case OP_RV2AV:
3902         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3903         o->op_flags |= OPf_STACKED;
3904         if (o->op_flags & OPf_PARENS) {
3905             if (o->op_private & OPpLVAL_INTRO) {
3906                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3907                       "localized parenthesized array in list assignment"));
3908                 return;
3909             }
3910           slurpy:
3911             OpTYPE_set(o, OP_LVAVREF);
3912             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3913             o->op_flags |= OPf_MOD|OPf_REF;
3914             return;
3915         }
3916         o->op_private |= OPpLVREF_AV;
3917         goto checkgv;
3918     case OP_RV2CV:
3919         kid = cUNOPo->op_first;
3920         if (kid->op_type == OP_NULL)
3921             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3922                 ->op_first;
3923         o->op_private = OPpLVREF_CV;
3924         if (kid->op_type == OP_GV)
3925             o->op_flags |= OPf_STACKED;
3926         else if (kid->op_type == OP_PADCV) {
3927             o->op_targ = kid->op_targ;
3928             kid->op_targ = 0;
3929             op_free(cUNOPo->op_first);
3930             cUNOPo->op_first = NULL;
3931             o->op_flags &=~ OPf_KIDS;
3932         }
3933         else goto badref;
3934         break;
3935     case OP_RV2HV:
3936         if (o->op_flags & OPf_PARENS) {
3937           parenhash:
3938             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3939                                  "parenthesized hash in list assignment"));
3940                 return;
3941         }
3942         o->op_private |= OPpLVREF_HV;
3943         /* FALLTHROUGH */
3944     case OP_RV2SV:
3945       checkgv:
3946         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3947         o->op_flags |= OPf_STACKED;
3948         break;
3949     case OP_PADHV:
3950         if (o->op_flags & OPf_PARENS) goto parenhash;
3951         o->op_private |= OPpLVREF_HV;
3952         /* FALLTHROUGH */
3953     case OP_PADSV:
3954         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3955         break;
3956     case OP_PADAV:
3957         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3958         if (o->op_flags & OPf_PARENS) goto slurpy;
3959         o->op_private |= OPpLVREF_AV;
3960         break;
3961     case OP_AELEM:
3962     case OP_HELEM:
3963         o->op_private |= OPpLVREF_ELEM;
3964         o->op_flags   |= OPf_STACKED;
3965         break;
3966     case OP_ASLICE:
3967     case OP_HSLICE:
3968         OpTYPE_set(o, OP_LVREFSLICE);
3969         o->op_private &= OPpLVAL_INTRO;
3970         return;
3971     case OP_NULL:
3972         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3973             goto badref;
3974         else if (!(o->op_flags & OPf_KIDS))
3975             return;
3976         if (o->op_targ != OP_LIST) {
3977             S_lvref(aTHX_ cBINOPo->op_first, type);
3978             return;
3979         }
3980         /* FALLTHROUGH */
3981     case OP_LIST:
3982         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3983             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3984             S_lvref(aTHX_ kid, type);
3985         }
3986         return;
3987     case OP_STUB:
3988         if (o->op_flags & OPf_PARENS)
3989             return;
3990         /* FALLTHROUGH */
3991     default:
3992       badref:
3993         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3994         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3995                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3996                       ? "do block"
3997                       : OP_DESC(o),
3998                      PL_op_desc[type]));
3999         return;
4000     }
4001     OpTYPE_set(o, OP_LVREF);
4002     o->op_private &=
4003         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4004     if (type == OP_ENTERLOOP)
4005         o->op_private |= OPpLVREF_ITER;
4006 }
4007
4008 PERL_STATIC_INLINE bool
4009 S_potential_mod_type(I32 type)
4010 {
4011     /* Types that only potentially result in modification.  */
4012     return type == OP_GREPSTART || type == OP_ENTERSUB
4013         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
4014 }
4015
4016 OP *
4017 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4018 {
4019     dVAR;
4020     OP *kid;
4021     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4022     int localize = -1;
4023
4024     if (!o || (PL_parser && PL_parser->error_count))
4025         return o;
4026
4027     if ((o->op_private & OPpTARGET_MY)
4028         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4029     {
4030         return o;
4031     }
4032
4033     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4034
4035     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4036
4037     switch (o->op_type) {
4038     case OP_UNDEF:
4039         PL_modcount++;
4040         return o;
4041     case OP_STUB:
4042         if ((o->op_flags & OPf_PARENS))
4043             break;
4044         goto nomod;
4045     case OP_ENTERSUB:
4046         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4047             !(o->op_flags & OPf_STACKED)) {
4048             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4049             assert(cUNOPo->op_first->op_type == OP_NULL);
4050             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4051             break;
4052         }
4053         else {                          /* lvalue subroutine call */
4054             o->op_private |= OPpLVAL_INTRO;
4055             PL_modcount = RETURN_UNLIMITED_NUMBER;
4056             if (S_potential_mod_type(type)) {
4057                 o->op_private |= OPpENTERSUB_INARGS;
4058                 break;
4059             }
4060             else {                      /* Compile-time error message: */
4061                 OP *kid = cUNOPo->op_first;
4062                 CV *cv;
4063                 GV *gv;
4064                 SV *namesv;
4065
4066                 if (kid->op_type != OP_PUSHMARK) {
4067                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4068                         Perl_croak(aTHX_
4069                                 "panic: unexpected lvalue entersub "
4070                                 "args: type/targ %ld:%" UVuf,
4071                                 (long)kid->op_type, (UV)kid->op_targ);
4072                     kid = kLISTOP->op_first;
4073                 }
4074                 while (OpHAS_SIBLING(kid))
4075                     kid = OpSIBLING(kid);
4076                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4077                     break;      /* Postpone until runtime */
4078                 }
4079
4080                 kid = kUNOP->op_first;
4081                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4082                     kid = kUNOP->op_first;
4083                 if (kid->op_type == OP_NULL)
4084                     Perl_croak(aTHX_
4085                                "Unexpected constant lvalue entersub "
4086                                "entry via type/targ %ld:%" UVuf,
4087                                (long)kid->op_type, (UV)kid->op_targ);
4088                 if (kid->op_type != OP_GV) {
4089                     break;
4090                 }
4091
4092                 gv = kGVOP_gv;
4093                 cv = isGV(gv)
4094                     ? GvCV(gv)
4095                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4096                         ? MUTABLE_CV(SvRV(gv))
4097                         : NULL;
4098                 if (!cv)
4099                     break;
4100                 if (CvLVALUE(cv))
4101                     break;
4102                 if (flags & OP_LVALUE_NO_CROAK)
4103                     return NULL;
4104
4105                 namesv = cv_name(cv, NULL, 0);
4106                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4107                                      "subroutine call of &%" SVf " in %s",
4108                                      SVfARG(namesv), PL_op_desc[type]),
4109                            SvUTF8(namesv));
4110                 return o;
4111             }
4112         }
4113         /* FALLTHROUGH */
4114     default:
4115       nomod:
4116         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4117         /* grep, foreach, subcalls, refgen */
4118         if (S_potential_mod_type(type))
4119             break;
4120         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4121                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4122                       ? "do block"
4123                       : OP_DESC(o)),
4124                      type ? PL_op_desc[type] : "local"));
4125         return o;
4126
4127     case OP_PREINC:
4128     case OP_PREDEC:
4129     case OP_POW:
4130     case OP_MULTIPLY:
4131     case OP_DIVIDE:
4132     case OP_MODULO:
4133     case OP_ADD:
4134     case OP_SUBTRACT:
4135     case OP_CONCAT:
4136     case OP_LEFT_SHIFT:
4137     case OP_RIGHT_SHIFT:
4138     case OP_BIT_AND:
4139     case OP_BIT_XOR:
4140     case OP_BIT_OR:
4141     case OP_I_MULTIPLY:
4142     case OP_I_DIVIDE:
4143     case OP_I_MODULO:
4144     case OP_I_ADD:
4145     case OP_I_SUBTRACT:
4146         if (!(o->op_flags & OPf_STACKED))
4147             goto nomod;
4148         PL_modcount++;
4149         break;
4150
4151     case OP_REPEAT:
4152         if (o->op_flags & OPf_STACKED) {
4153             PL_modcount++;
4154             break;
4155         }
4156         if (!(o->op_private & OPpREPEAT_DOLIST))
4157             goto nomod;
4158         else {
4159             const I32 mods = PL_modcount;
4160             modkids(cBINOPo->op_first, type);
4161             if (type != OP_AASSIGN)
4162                 goto nomod;
4163             kid = cBINOPo->op_last;
4164             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4165                 const IV iv = SvIV(kSVOP_sv);
4166                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4167                     PL_modcount =
4168                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4169             }
4170             else
4171                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4172         }
4173         break;
4174
4175     case OP_COND_EXPR:
4176         localize = 1;
4177         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4178             op_lvalue(kid, type);
4179         break;
4180
4181     case OP_RV2AV:
4182     case OP_RV2HV:
4183         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4184            PL_modcount = RETURN_UNLIMITED_NUMBER;
4185            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4186               fiable since some contexts need to know.  */
4187            o->op_flags |= OPf_MOD;
4188            return o;
4189         }
4190         /* FALLTHROUGH */
4191     case OP_RV2GV:
4192         if (scalar_mod_type(o, type))
4193             goto nomod;
4194         ref(cUNOPo->op_first, o->op_type);
4195         /* FALLTHROUGH */
4196     case OP_ASLICE:
4197     case OP_HSLICE:
4198         localize = 1;
4199         /* FALLTHROUGH */
4200     case OP_AASSIGN:
4201         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4202         if (type == OP_LEAVESUBLV && (
4203                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4204              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4205            ))
4206             o->op_private |= OPpMAYBE_LVSUB;
4207         /* FALLTHROUGH */
4208     case OP_NEXTSTATE:
4209     case OP_DBSTATE:
4210        PL_modcount = RETURN_UNLIMITED_NUMBER;
4211         break;
4212     case OP_KVHSLICE:
4213     case OP_KVASLICE:
4214     case OP_AKEYS:
4215         if (type == OP_LEAVESUBLV)
4216             o->op_private |= OPpMAYBE_LVSUB;
4217         goto nomod;
4218     case OP_AVHVSWITCH:
4219         if (type == OP_LEAVESUBLV
4220          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4221             o->op_private |= OPpMAYBE_LVSUB;
4222         goto nomod;
4223     case OP_AV2ARYLEN:
4224         PL_hints |= HINT_BLOCK_SCOPE;
4225         if (type == OP_LEAVESUBLV)
4226             o->op_private |= OPpMAYBE_LVSUB;
4227         PL_modcount++;
4228         break;
4229     case OP_RV2SV:
4230         ref(cUNOPo->op_first, o->op_type);
4231         localize = 1;
4232         /* FALLTHROUGH */
4233     case OP_GV:
4234         PL_hints |= HINT_BLOCK_SCOPE;
4235         /* FALLTHROUGH */
4236     case OP_SASSIGN:
4237     case OP_ANDASSIGN:
4238     case OP_ORASSIGN:
4239     case OP_DORASSIGN:
4240         PL_modcount++;
4241         break;
4242
4243     case OP_AELEMFAST:
4244     case OP_AELEMFAST_LEX:
4245         localize = -1;
4246         PL_modcount++;
4247         break;
4248
4249     case OP_PADAV:
4250     case OP_PADHV:
4251        PL_modcount = RETURN_UNLIMITED_NUMBER;
4252         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4253         {
4254            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4255               fiable since some contexts need to know.  */
4256             o->op_flags |= OPf_MOD;
4257             return o;
4258         }
4259         if (scalar_mod_type(o, type))
4260             goto nomod;
4261         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4262           && type == OP_LEAVESUBLV)
4263             o->op_private |= OPpMAYBE_LVSUB;
4264         /* FALLTHROUGH */
4265     case OP_PADSV:
4266         PL_modcount++;
4267         if (!type) /* local() */
4268             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4269                               PNfARG(PAD_COMPNAME(o->op_targ)));
4270         if (!(o->op_private & OPpLVAL_INTRO)
4271          || (  type != OP_SASSIGN && type != OP_AASSIGN
4272             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4273             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4274         break;
4275
4276     case OP_PUSHMARK:
4277         localize = 0;
4278         break;
4279
4280     case OP_KEYS:
4281         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4282             goto nomod;
4283         goto lvalue_func;
4284     case OP_SUBSTR:
4285         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4286             goto nomod;
4287         /* FALLTHROUGH */
4288     case OP_POS:
4289     case OP_VEC:
4290       lvalue_func:
4291         if (type == OP_LEAVESUBLV)
4292             o->op_private |= OPpMAYBE_LVSUB;
4293         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4294             /* substr and vec */
4295             /* If this op is in merely potential (non-fatal) modifiable
4296                context, then apply OP_ENTERSUB context to
4297                the kid op (to avoid croaking).  Other-
4298                wise pass this op’s own type so the correct op is mentioned
4299                in error messages.  */
4300             op_lvalue(OpSIBLING(cBINOPo->op_first),
4301                       S_potential_mod_type(type)
4302                         ? (I32)OP_ENTERSUB
4303                         : o->op_type);
4304         }
4305         break;
4306
4307     case OP_AELEM:
4308     case OP_HELEM:
4309         ref(cBINOPo->op_first, o->op_type);
4310         if (type == OP_ENTERSUB &&
4311              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4312             o->op_private |= OPpLVAL_DEFER;
4313         if (type == OP_LEAVESUBLV)
4314             o->op_private |= OPpMAYBE_LVSUB;
4315         localize = 1;
4316         PL_modcount++;
4317         break;
4318
4319     case OP_LEAVE:
4320     case OP_LEAVELOOP:
4321         o->op_private |= OPpLVALUE;
4322         /* FALLTHROUGH */
4323     case OP_SCOPE:
4324     case OP_ENTER:
4325     case OP_LINESEQ:
4326         localize = 0;
4327         if (o->op_flags & OPf_KIDS)
4328             op_lvalue(cLISTOPo->op_last, type);
4329         break;
4330
4331     case OP_NULL:
4332         localize = 0;
4333         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4334             goto nomod;
4335         else if (!(o->op_flags & OPf_KIDS))
4336             break;
4337
4338         if (o->op_targ != OP_LIST) {
4339             OP *sib = OpSIBLING(cLISTOPo->op_first);
4340             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4341              * that looks like
4342              *
4343              *   null
4344              *      arg
4345              *      trans
4346              *
4347              * compared with things like OP_MATCH which have the argument
4348              * as a child:
4349              *
4350              *   match
4351              *      arg
4352              *
4353              * so handle specially to correctly get "Can't modify" croaks etc
4354              */
4355
4356             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4357             {
4358                 /* this should trigger a "Can't modify transliteration" err */
4359                 op_lvalue(sib, type);
4360             }
4361             op_lvalue(cBINOPo->op_first, type);
4362             break;
4363         }
4364         /* FALLTHROUGH */
4365     case OP_LIST:
4366         localize = 0;
4367         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4368             /* elements might be in void context because the list is
4369                in scalar context or because they are attribute sub calls */
4370             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4371                 op_lvalue(kid, type);
4372         break;
4373
4374     case OP_COREARGS:
4375         return o;
4376
4377     case OP_AND:
4378     case OP_OR:
4379         if (type == OP_LEAVESUBLV
4380          || !S_vivifies(cLOGOPo->op_first->op_type))
4381             op_lvalue(cLOGOPo->op_first, type);
4382         if (type == OP_LEAVESUBLV
4383          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4384             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4385         goto nomod;
4386
4387     case OP_SREFGEN:
4388         if (type == OP_NULL) { /* local */
4389           local_refgen:
4390             if (!FEATURE_MYREF_IS_ENABLED)
4391                 Perl_croak(aTHX_ "The experimental declared_refs "
4392                                  "feature is not enabled");
4393             Perl_ck_warner_d(aTHX_
4394                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4395                     "Declaring references is experimental");
4396             op_lvalue(cUNOPo->op_first, OP_NULL);
4397             return o;
4398         }
4399         if (type != OP_AASSIGN && type != OP_SASSIGN
4400          && type != OP_ENTERLOOP)
4401             goto nomod;
4402         /* Don’t bother applying lvalue context to the ex-list.  */
4403         kid = cUNOPx(cUNOPo->op_first)->op_first;
4404         assert (!OpHAS_SIBLING(kid));
4405         goto kid_2lvref;
4406     case OP_REFGEN:
4407         if (type == OP_NULL) /* local */
4408             goto local_refgen;
4409         if (type != OP_AASSIGN) goto nomod;
4410         kid = cUNOPo->op_first;
4411       kid_2lvref:
4412         {
4413             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4414             S_lvref(aTHX_ kid, type);
4415             if (!PL_parser || PL_parser->error_count == ec) {
4416                 if (!FEATURE_REFALIASING_IS_ENABLED)
4417                     Perl_croak(aTHX_
4418                        "Experimental aliasing via reference not enabled");
4419                 Perl_ck_warner_d(aTHX_
4420                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4421                                 "Aliasing via reference is experimental");
4422             }
4423         }
4424         if (o->op_type == OP_REFGEN)
4425             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4426         op_null(o);
4427         return o;
4428
4429     case OP_SPLIT:
4430         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4431             /* This is actually @array = split.  */
4432             PL_modcount = RETURN_UNLIMITED_NUMBER;
4433             break;
4434         }
4435         goto nomod;
4436
4437     case OP_SCALAR:
4438         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4439         goto nomod;
4440     }
4441
4442     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4443        their argument is a filehandle; thus \stat(".") should not set
4444        it. AMS 20011102 */
4445     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4446         return o;
4447
4448     if (type != OP_LEAVESUBLV)
4449         o->op_flags |= OPf_MOD;
4450
4451     if (type == OP_AASSIGN || type == OP_SASSIGN)
4452         o->op_flags |= OPf_SPECIAL
4453                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4454     else if (!type) { /* local() */
4455         switch (localize) {
4456         case 1:
4457             o->op_private |= OPpLVAL_INTRO;
4458             o->op_flags &= ~OPf_SPECIAL;
4459             PL_hints |= HINT_BLOCK_SCOPE;
4460             break;
4461         case 0:
4462             break;
4463         case -1:
4464             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4465                            "Useless localization of %s", OP_DESC(o));
4466         }
4467     }
4468     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4469              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4470         o->op_flags |= OPf_REF;
4471     return o;
4472 }
4473
4474 STATIC bool
4475 S_scalar_mod_type(const OP *o, I32 type)
4476 {
4477     switch (type) {
4478     case OP_POS:
4479     case OP_SASSIGN:
4480         if (o && o->op_type == OP_RV2GV)
4481             return FALSE;
4482         /* FALLTHROUGH */
4483     case OP_PREINC:
4484     case OP_PREDEC:
4485     case OP_POSTINC:
4486     case OP_POSTDEC:
4487     case OP_I_PREINC:
4488     case OP_I_PREDEC:
4489     case OP_I_POSTINC:
4490     case OP_I_POSTDEC:
4491     case OP_POW:
4492     case OP_MULTIPLY:
4493     case OP_DIVIDE:
4494     case OP_MODULO:
4495     case OP_REPEAT:
4496     case OP_ADD:
4497     case OP_SUBTRACT:
4498     case OP_I_MULTIPLY:
4499     case OP_I_DIVIDE:
4500     case OP_I_MODULO:
4501     case OP_I_ADD:
4502     case OP_I_SUBTRACT:
4503     case OP_LEFT_SHIFT:
4504     case OP_RIGHT_SHIFT:
4505     case OP_BIT_AND:
4506     case OP_BIT_XOR:
4507     case OP_BIT_OR:
4508     case OP_NBIT_AND:
4509     case OP_NBIT_XOR:
4510     case OP_NBIT_OR:
4511     case OP_SBIT_AND:
4512     case OP_SBIT_XOR:
4513     case OP_SBIT_OR:
4514     case OP_CONCAT:
4515     case OP_SUBST:
4516     case OP_TRANS:
4517     case OP_TRANSR:
4518     case OP_READ:
4519     case OP_SYSREAD:
4520     case OP_RECV:
4521     case OP_ANDASSIGN:
4522     case OP_ORASSIGN:
4523     case OP_DORASSIGN:
4524     case OP_VEC:
4525     case OP_SUBSTR:
4526         return TRUE;
4527     default:
4528         return FALSE;
4529     }
4530 }
4531
4532 STATIC bool
4533 S_is_handle_constructor(const OP *o, I32 numargs)
4534 {
4535     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4536
4537     switch (o->op_type) {
4538     case OP_PIPE_OP:
4539     case OP_SOCKPAIR:
4540         if (numargs == 2)
4541             return TRUE;
4542         /* FALLTHROUGH */
4543     case OP_SYSOPEN:
4544     case OP_OPEN:
4545     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4546     case OP_SOCKET:
4547     case OP_OPEN_DIR:
4548     case OP_ACCEPT:
4549         if (numargs == 1)
4550             return TRUE;
4551         /* FALLTHROUGH */
4552     default:
4553         return FALSE;
4554     }
4555 }
4556
4557 static OP *
4558 S_refkids(pTHX_ OP *o, I32 type)
4559 {
4560     if (o && o->op_flags & OPf_KIDS) {
4561         OP *kid;
4562         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4563             ref(kid, type);
4564     }
4565     return o;
4566 }
4567
4568 OP *
4569 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4570 {
4571     dVAR;
4572     OP *kid;
4573
4574     PERL_ARGS_ASSERT_DOREF;
4575
4576     if (PL_parser && PL_parser->error_count)
4577         return o;
4578
4579     switch (o->op_type) {
4580     case OP_ENTERSUB:
4581         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4582             !(o->op_flags & OPf_STACKED)) {
4583             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4584             assert(cUNOPo->op_first->op_type == OP_NULL);
4585             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4586             o->op_flags |= OPf_SPECIAL;
4587         }
4588         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4589             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4590                               : type == OP_RV2HV ? OPpDEREF_HV
4591                               : OPpDEREF_SV);
4592             o->op_flags |= OPf_MOD;
4593         }
4594
4595         break;
4596
4597     case OP_COND_EXPR:
4598         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4599             doref(kid, type, set_op_ref);
4600         break;
4601     case OP_RV2SV:
4602         if (type == OP_DEFINED)
4603             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4604         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4605         /* FALLTHROUGH */
4606     case OP_PADSV:
4607         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4608             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4609                               : type == OP_RV2HV ? OPpDEREF_HV
4610                               : OPpDEREF_SV);
4611             o->op_flags |= OPf_MOD;
4612         }
4613         break;
4614
4615     case OP_RV2AV:
4616     case OP_RV2HV:
4617         if (set_op_ref)
4618             o->op_flags |= OPf_REF;
4619         /* FALLTHROUGH */
4620     case OP_RV2GV:
4621         if (type == OP_DEFINED)
4622             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4623         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4624         break;
4625
4626     case OP_PADAV:
4627     case OP_PADHV:
4628         if (set_op_ref)
4629             o->op_flags |= OPf_REF;
4630         break;
4631
4632     case OP_SCALAR:
4633     case OP_NULL:
4634         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4635             break;
4636         doref(cBINOPo->op_first, type, set_op_ref);
4637         break;
4638     case OP_AELEM:
4639     case OP_HELEM:
4640         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4641         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4642             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4643                               : type == OP_RV2HV ? OPpDEREF_HV
4644                               : OPpDEREF_SV);
4645             o->op_flags |= OPf_MOD;
4646         }
4647         break;
4648
4649     case OP_SCOPE:
4650     case OP_LEAVE:
4651         set_op_ref = FALSE;
4652         /* FALLTHROUGH */
4653     case OP_ENTER:
4654     case OP_LIST:
4655         if (!(o->op_flags & OPf_KIDS))
4656             break;
4657         doref(cLISTOPo->op_last, type, set_op_ref);
4658         break;
4659     default:
4660         break;
4661     }
4662     return scalar(o);
4663
4664 }
4665
4666 STATIC OP *
4667 S_dup_attrlist(pTHX_ OP *o)
4668 {
4669     OP *rop;
4670
4671     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4672
4673     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4674      * where the first kid is OP_PUSHMARK and the remaining ones
4675      * are OP_CONST.  We need to push the OP_CONST values.
4676      */
4677     if (o->op_type == OP_CONST)
4678         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4679     else {
4680         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4681         rop = NULL;
4682         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4683             if (o->op_type == OP_CONST)
4684                 rop = op_append_elem(OP_LIST, rop,
4685                                   newSVOP(OP_CONST, o->op_flags,
4686                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4687         }
4688     }
4689     return rop;
4690 }
4691
4692 STATIC void
4693 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4694 {
4695     PERL_ARGS_ASSERT_APPLY_ATTRS;
4696     {
4697         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4698
4699         /* fake up C<use attributes $pkg,$rv,@attrs> */
4700
4701 #define ATTRSMODULE "attributes"
4702 #define ATTRSMODULE_PM "attributes.pm"
4703
4704         Perl_load_module(
4705           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4706           newSVpvs(ATTRSMODULE),
4707           NULL,
4708           op_prepend_elem(OP_LIST,
4709                           newSVOP(OP_CONST, 0, stashsv),
4710                           op_prepend_elem(OP_LIST,
4711                                           newSVOP(OP_CONST, 0,
4712                                                   newRV(target)),
4713                                           dup_attrlist(attrs))));
4714     }
4715 }
4716
4717 STATIC void
4718 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4719 {
4720     OP *pack, *imop, *arg;
4721     SV *meth, *stashsv, **svp;
4722
4723     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4724
4725     if (!attrs)
4726         return;
4727
4728     assert(target->op_type == OP_PADSV ||
4729            target->op_type == OP_PADHV ||
4730            target->op_type == OP_PADAV);
4731
4732     /* Ensure that attributes.pm is loaded. */
4733     /* Don't force the C<use> if we don't need it. */
4734     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4735     if (svp && *svp != &PL_sv_undef)
4736         NOOP;   /* already in %INC */
4737     else
4738         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4739                                newSVpvs(ATTRSMODULE), NULL);
4740
4741     /* Need package name for method call. */
4742     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4743
4744     /* Build up the real arg-list. */
4745     stashsv = newSVhek(HvNAME_HEK(stash));
4746
4747     arg = newOP(OP_PADSV, 0);
4748     arg->op_targ = target->op_targ;
4749     arg = op_prepend_elem(OP_LIST,
4750                        newSVOP(OP_CONST, 0, stashsv),
4751                        op_prepend_elem(OP_LIST,
4752                                     newUNOP(OP_REFGEN, 0,
4753                                             arg),
4754                                     dup_attrlist(attrs)));
4755
4756     /* Fake up a method call to import */
4757     meth = newSVpvs_share("import");
4758     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4759                    op_append_elem(OP_LIST,
4760                                op_prepend_elem(OP_LIST, pack, arg),
4761                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4762
4763     /* Combine the ops. */
4764     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4765 }
4766
4767 /*
4768 =notfor apidoc apply_attrs_string
4769
4770 Attempts to apply a list of attributes specified by the C<attrstr> and
4771 C<len> arguments to the subroutine identified by the C<cv> argument which
4772 is expected to be associated with the package identified by the C<stashpv>
4773 argument (see L<attributes>).  It gets this wrong, though, in that it
4774 does not correctly identify the boundaries of the individual attribute
4775 specifications within C<attrstr>.  This is not really intended for the
4776 public API, but has to be listed here for systems such as AIX which
4777 need an explicit export list for symbols.  (It's called from XS code
4778 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4779 to respect attribute syntax properly would be welcome.
4780
4781 =cut
4782 */
4783
4784 void
4785 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4786                         const char *attrstr, STRLEN len)
4787 {
4788     OP *attrs = NULL;
4789
4790     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4791
4792     if (!len) {
4793         len = strlen(attrstr);
4794     }
4795
4796     while (len) {
4797         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4798         if (len) {
4799             const char * const sstr = attrstr;
4800             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4801             attrs = op_append_elem(OP_LIST, attrs,
4802                                 newSVOP(OP_CONST, 0,
4803                                         newSVpvn(sstr, attrstr-sstr)));
4804         }
4805     }
4806
4807     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4808                      newSVpvs(ATTRSMODULE),
4809                      NULL, op_prepend_elem(OP_LIST,
4810                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4811                                   op_prepend_elem(OP_LIST,
4812                                                newSVOP(OP_CONST, 0,
4813                                                        newRV(MUTABLE_SV(cv))),
4814                                                attrs)));
4815 }
4816
4817 STATIC void
4818 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4819                         bool curstash)
4820 {
4821     OP *new_proto = NULL;
4822     STRLEN pvlen;
4823     char *pv;
4824     OP *o;
4825
4826     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4827
4828     if (!*attrs)
4829         return;
4830
4831     o = *attrs;
4832     if (o->op_type == OP_CONST) {
4833         pv = SvPV(cSVOPo_sv, pvlen);
4834         if (memBEGINs(pv, pvlen, "prototype(")) {
4835             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4836             SV ** const tmpo = cSVOPx_svp(o);
4837             SvREFCNT_dec(cSVOPo_sv);
4838             *tmpo = tmpsv;
4839             new_proto = o;
4840             *attrs = NULL;
4841         }
4842     } else if (o->op_type == OP_LIST) {
4843         OP * lasto;
4844         assert(o->op_flags & OPf_KIDS);
4845         lasto = cLISTOPo->op_first;
4846         assert(lasto->op_type == OP_PUSHMARK);
4847         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4848             if (o->op_type == OP_CONST) {
4849                 pv = SvPV(cSVOPo_sv, pvlen);
4850                 if (memBEGINs(pv, pvlen, "prototype(")) {
4851                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4852                     SV ** const tmpo = cSVOPx_svp(o);
4853                     SvREFCNT_dec(cSVOPo_sv);
4854                     *tmpo = tmpsv;
4855                     if (new_proto && ckWARN(WARN_MISC)) {
4856                         STRLEN new_len;
4857                         const char * newp = SvPV(cSVOPo_sv, new_len);
4858                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4859                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4860                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4861                         op_free(new_proto);
4862                     }
4863                     else if (new_proto)
4864                         op_free(new_proto);
4865                     new_proto = o;
4866                     /* excise new_proto from the list */
4867                     op_sibling_splice(*attrs, lasto, 1, NULL);
4868                     o = lasto;
4869                     continue;
4870                 }
4871             }
4872             lasto = o;
4873         }
4874         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4875            would get pulled in with no real need */
4876         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4877             op_free(*attrs);
4878             *attrs = NULL;
4879         }
4880     }
4881
4882     if (new_proto) {
4883         SV *svname;
4884         if (isGV(name)) {
4885             svname = sv_newmortal();
4886             gv_efullname3(svname, name, NULL);
4887         }
4888         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4889             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4890         else
4891             svname = (SV *)name;
4892         if (ckWARN(WARN_ILLEGALPROTO))
4893             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4894                                  curstash);
4895         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4896             STRLEN old_len, new_len;
4897             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4898             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4899
4900             if (curstash && svname == (SV *)name
4901              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4902                 svname = sv_2mortal(newSVsv(PL_curstname));
4903                 sv_catpvs(svname, "::");
4904                 sv_catsv(svname, (SV *)name);
4905             }
4906
4907             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4908                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4909                 " in %" SVf,
4910                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4911                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4912                 SVfARG(svname));
4913         }
4914         if (*proto)
4915             op_free(*proto);
4916         *proto = new_proto;
4917     }
4918 }
4919
4920 static void
4921 S_cant_declare(pTHX_ OP *o)
4922 {
4923     if (o->op_type == OP_NULL
4924      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4925         o = cUNOPo->op_first;
4926     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4927                              o->op_type == OP_NULL
4928                                && o->op_flags & OPf_SPECIAL
4929                                  ? "do block"
4930                                  : OP_DESC(o),
4931                              PL_parser->in_my == KEY_our   ? "our"   :
4932                              PL_parser->in_my == KEY_state ? "state" :
4933                                                              "my"));
4934 }
4935
4936 STATIC OP *
4937 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4938 {
4939     I32 type;
4940     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4941
4942     PERL_ARGS_ASSERT_MY_KID;
4943
4944     if (!o || (PL_parser && PL_parser->error_count))
4945         return o;
4946
4947     type = o->op_type;
4948
4949     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4950         OP *kid;
4951         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4952             my_kid(kid, attrs, imopsp);
4953         return o;
4954     } else if (type == OP_UNDEF || type == OP_STUB) {
4955         return o;
4956     } else if (type == OP_RV2SV ||      /* "our" declaration */
4957                type == OP_RV2AV ||
4958                type == OP_RV2HV) {
4959         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4960             S_cant_declare(aTHX_ o);
4961         } else if (attrs) {
4962             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4963             assert(PL_parser);
4964             PL_parser->in_my = FALSE;
4965             PL_parser->in_my_stash = NULL;
4966             apply_attrs(GvSTASH(gv),
4967                         (type == OP_RV2SV ? GvSVn(gv) :
4968                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4969                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4970                         attrs);
4971         }
4972         o->op_private |= OPpOUR_INTRO;
4973         return o;
4974     }
4975     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4976         if (!FEATURE_MYREF_IS_ENABLED)
4977             Perl_croak(aTHX_ "The experimental declared_refs "
4978                              "feature is not enabled");
4979         Perl_ck_warner_d(aTHX_
4980              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4981             "Declaring references is experimental");
4982         /* Kid is a nulled OP_LIST, handled above.  */
4983         my_kid(cUNOPo->op_first, attrs, imopsp);
4984         return o;
4985     }
4986     else if (type != OP_PADSV &&
4987              type != OP_PADAV &&
4988              type != OP_PADHV &&
4989              type != OP_PUSHMARK)
4990     {
4991         S_cant_declare(aTHX_ o);
4992         return o;
4993     }
4994     else if (attrs && type != OP_PUSHMARK) {
4995         HV *stash;
4996
4997         assert(PL_parser);
4998         PL_parser->in_my = FALSE;
4999         PL_parser->in_my_stash = NULL;
5000
5001         /* check for C<my Dog $spot> when deciding package */
5002         stash = PAD_COMPNAME_TYPE(o->op_targ);
5003         if (!stash)
5004             stash = PL_curstash;
5005         apply_attrs_my(stash, o, attrs, imopsp);
5006     }
5007     o->op_flags |= OPf_MOD;
5008     o->op_private |= OPpLVAL_INTRO;
5009     if (stately)
5010         o->op_private |= OPpPAD_STATE;
5011     return o;
5012 }
5013
5014 OP *
5015 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5016 {
5017     OP *rops;
5018     int maybe_scalar = 0;
5019
5020     PERL_ARGS_ASSERT_MY_ATTRS;
5021
5022 /* [perl #17376]: this appears to be premature, and results in code such as
5023    C< our(%x); > executing in list mode rather than void mode */
5024 #if 0
5025     if (o->op_flags & OPf_PARENS)
5026         list(o);
5027     else
5028         maybe_scalar = 1;
5029 #else
5030     maybe_scalar = 1;
5031 #endif
5032     if (attrs)
5033         SAVEFREEOP(attrs);
5034     rops = NULL;
5035     o = my_kid(o, attrs, &rops);
5036     if (rops) {
5037         if (maybe_scalar && o->op_type == OP_PADSV) {
5038             o = scalar(op_append_list(OP_LIST, rops, o));
5039             o->op_private |= OPpLVAL_INTRO;
5040         }
5041         else {
5042             /* The listop in rops might have a pushmark at the beginning,
5043                which will mess up list assignment. */
5044             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5045             if (rops->op_type == OP_LIST &&
5046                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5047             {
5048                 OP * const pushmark = lrops->op_first;
5049                 /* excise pushmark */
5050                 op_sibling_splice(rops, NULL, 1, NULL);
5051                 op_free(pushmark);
5052             }
5053             o = op_append_list(OP_LIST, o, rops);
5054         }
5055     }
5056     PL_parser->in_my = FALSE;
5057     PL_parser->in_my_stash = NULL;
5058     return o;
5059 }
5060
5061 OP *
5062 Perl_sawparens(pTHX_ OP *o)
5063 {
5064     PERL_UNUSED_CONTEXT;
5065     if (o)
5066         o->op_flags |= OPf_PARENS;
5067     return o;
5068 }
5069
5070 OP *
5071 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5072 {
5073     OP *o;
5074     bool ismatchop = 0;
5075     const OPCODE ltype = left->op_type;
5076     const OPCODE rtype = right->op_type;
5077
5078     PERL_ARGS_ASSERT_BIND_MATCH;
5079
5080     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5081           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5082     {
5083       const char * const desc
5084           = PL_op_desc[(
5085                           rtype == OP_SUBST || rtype == OP_TRANS
5086                        || rtype == OP_TRANSR
5087                        )
5088                        ? (int)rtype : OP_MATCH];
5089       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5090       SV * const name =
5091         S_op_varname(aTHX_ left);
5092       if (name)
5093         Perl_warner(aTHX_ packWARN(WARN_MISC),
5094              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5095              desc, SVfARG(name), SVfARG(name));
5096       else {
5097         const char * const sample = (isary
5098              ? "@array" : "%hash");
5099         Perl_warner(aTHX_ packWARN(WARN_MISC),
5100              "Applying %s to %s will act on scalar(%s)",
5101              desc, sample, sample);
5102       }
5103     }
5104
5105     if (rtype == OP_CONST &&
5106         cSVOPx(right)->op_private & OPpCONST_BARE &&
5107         cSVOPx(right)->op_private & OPpCONST_STRICT)
5108     {
5109         no_bareword_allowed(right);
5110     }
5111
5112     /* !~ doesn't make sense with /r, so error on it for now */
5113     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5114         type == OP_NOT)
5115         /* diag_listed_as: Using !~ with %s doesn't make sense */
5116         yyerror("Using !~ with s///r doesn't make sense");
5117     if (rtype == OP_TRANSR && type == OP_NOT)
5118         /* diag_listed_as: Using !~ with %s doesn't make sense */
5119         yyerror("Using !~ with tr///r doesn't make sense");
5120
5121     ismatchop = (rtype == OP_MATCH ||
5122                  rtype == OP_SUBST ||
5123                  rtype == OP_TRANS || rtype == OP_TRANSR)
5124              && !(right->op_flags & OPf_SPECIAL);
5125     if (ismatchop && right->op_private & OPpTARGET_MY) {
5126         right->op_targ = 0;
5127         right->op_private &= ~OPpTARGET_MY;
5128     }
5129     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5130         if (left->op_type == OP_PADSV
5131          && !(left->op_private & OPpLVAL_INTRO))
5132         {
5133             right->op_targ = left->op_targ;
5134             op_free(left);
5135             o = right;
5136         }
5137         else {
5138             right->op_flags |= OPf_STACKED;
5139             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5140             ! (rtype == OP_TRANS &&
5141                right->op_private & OPpTRANS_IDENTICAL) &&
5142             ! (rtype == OP_SUBST &&
5143                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5144                 left = op_lvalue(left, rtype);
5145             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5146                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5147             else
5148                 o = op_prepend_elem(rtype, scalar(left), right);
5149         }
5150         if (type == OP_NOT)
5151             return newUNOP(OP_NOT, 0, scalar(o));
5152         return o;
5153     }
5154     else
5155         return bind_match(type, left,
5156                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5157 }
5158
5159 OP *
5160 Perl_invert(pTHX_ OP *o)
5161 {
5162     if (!o)
5163         return NULL;
5164     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5165 }
5166
5167 /*
5168 =for apidoc op_scope
5169
5170 Wraps up an op tree with some additional ops so that at runtime a dynamic
5171 scope will be created.  The original ops run in the new dynamic scope,
5172 and then, provided that they exit normally, the scope will be unwound.
5173 The additional ops used to create and unwind the dynamic scope will
5174 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5175 instead if the ops are simple enough to not need the full dynamic scope
5176 structure.
5177
5178 =cut
5179 */
5180
5181 OP *
5182 Perl_op_scope(pTHX_ OP *o)
5183 {
5184     dVAR;
5185     if (o) {
5186         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5187             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5188             OpTYPE_set(o, OP_LEAVE);
5189         }
5190         else if (o->op_type == OP_LINESEQ) {
5191             OP *kid;
5192             OpTYPE_set(o, OP_SCOPE);
5193             kid = ((LISTOP*)o)->op_first;
5194             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5195                 op_null(kid);
5196
5197                 /* The following deals with things like 'do {1 for 1}' */
5198                 kid = OpSIBLING(kid);
5199                 if (kid &&
5200                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5201                     op_null(kid);
5202             }
5203         }
5204         else
5205             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5206     }
5207     return o;
5208 }
5209
5210 OP *
5211 Perl_op_unscope(pTHX_ OP *o)
5212 {
5213     if (o && o->op_type == OP_LINESEQ) {
5214         OP *kid = cLISTOPo->op_first;
5215         for(; kid; kid = OpSIBLING(kid))
5216             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5217                 op_null(kid);
5218     }
5219     return o;
5220 }
5221
5222 /*
5223 =for apidoc block_start
5224
5225 Handles compile-time scope entry.
5226 Arranges for hints to be restored on block
5227 exit and also handles pad sequence numbers to make lexical variables scope
5228 right.  Returns a savestack index for use with C<block_end>.
5229
5230 =cut
5231 */
5232
5233 int
5234 Perl_block_start(pTHX_ int full)
5235 {
5236     const int retval = PL_savestack_ix;
5237
5238     PL_compiling.cop_seq = PL_cop_seqmax;
5239     COP_SEQMAX_INC;
5240     pad_block_start(full);
5241     SAVEHINTS();
5242     PL_hints &= ~HINT_BLOCK_SCOPE;
5243     SAVECOMPILEWARNINGS();
5244     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5245     SAVEI32(PL_compiling.cop_seq);
5246     PL_compiling.cop_seq = 0;
5247
5248     CALL_BLOCK_HOOKS(bhk_start, full);
5249
5250     return retval;
5251 }
5252
5253 /*
5254 =for apidoc block_end
5255
5256 Handles compile-time scope exit.  C<floor>
5257 is the savestack index returned by
5258 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5259 possibly modified.
5260
5261 =cut
5262 */
5263
5264 OP*
5265 Perl_block_end(pTHX_ I32 floor, OP *seq)
5266 {
5267     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5268     OP* retval = scalarseq(seq);
5269     OP *o;
5270
5271     /* XXX Is the null PL_parser check necessary here? */
5272     assert(PL_parser); /* Let’s find out under debugging builds.  */
5273     if (PL_parser && PL_parser->parsed_sub) {
5274         o = newSTATEOP(0, NULL, NULL);
5275         op_null(o);
5276         retval = op_append_elem(OP_LINESEQ, retval, o);
5277     }
5278
5279     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5280
5281     LEAVE_SCOPE(floor);
5282     if (needblockscope)
5283         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5284     o = pad_leavemy();
5285
5286     if (o) {
5287         /* pad_leavemy has created a sequence of introcv ops for all my
5288            subs declared in the block.  We have to replicate that list with
5289            clonecv ops, to deal with this situation:
5290
5291                sub {
5292                    my sub s1;
5293                    my sub s2;
5294                    sub s1 { state sub foo { \&s2 } }
5295                }->()
5296
5297            Originally, I was going to have introcv clone the CV and turn
5298            off the stale flag.  Since &s1 is declared before &s2, the
5299            introcv op for &s1 is executed (on sub entry) before the one for
5300            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5301            cloned, since it is a state sub) closes over &s2 and expects
5302            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5303            then &s2 is still marked stale.  Since &s1 is not active, and
5304            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5305            ble will not stay shared’ warning.  Because it is the same stub
5306            that will be used when the introcv op for &s2 is executed, clos-
5307            ing over it is safe.  Hence, we have to turn off the stale flag
5308            on all lexical subs in the block before we clone any of them.
5309            Hence, having introcv clone the sub cannot work.  So we create a
5310            list of ops like this:
5311
5312                lineseq
5313                   |
5314                   +-- introcv
5315                   |
5316                   +-- introcv
5317                   |
5318                   +-- introcv
5319                   |
5320                   .
5321                   .
5322                   .
5323                   |
5324                   +-- clonecv
5325                   |
5326                   +-- clonecv
5327                   |
5328                   +-- clonecv
5329                   |
5330                   .
5331                   .
5332                   .
5333          */
5334         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5335         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5336         for (;; kid = OpSIBLING(kid)) {
5337             OP *newkid = newOP(OP_CLONECV, 0);
5338             newkid->op_targ = kid->op_targ;
5339             o = op_append_elem(OP_LINESEQ, o, newkid);
5340             if (kid == last) break;
5341         }
5342         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5343     }
5344
5345     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5346
5347     return retval;
5348 }
5349
5350 /*
5351 =head1 Compile-time scope hooks
5352
5353 =for apidoc blockhook_register
5354
5355 Register a set of hooks to be called when the Perl lexical scope changes
5356 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5357
5358 =cut
5359 */
5360
5361 void
5362 Perl_blockhook_register(pTHX_ BHK *hk)
5363 {
5364     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5365
5366     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5367 }
5368
5369 void
5370 Perl_newPROG(pTHX_ OP *o)
5371 {
5372     OP *start;
5373
5374     PERL_ARGS_ASSERT_NEWPROG;
5375
5376     if (PL_in_eval) {
5377         PERL_CONTEXT *cx;
5378         I32 i;
5379         if (PL_eval_root)
5380                 return;
5381         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5382                                ((PL_in_eval & EVAL_KEEPERR)
5383                                 ? OPf_SPECIAL : 0), o);
5384
5385         cx = CX_CUR();
5386         assert(CxTYPE(cx) == CXt_EVAL);
5387
5388         if ((cx->blk_gimme & G_WANT) == G_VOID)
5389             scalarvoid(PL_eval_root);
5390         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5391             list(PL_eval_root);
5392         else
5393             scalar(PL_eval_root);
5394
5395         start = op_linklist(PL_eval_root);
5396         PL_eval_root->op_next = 0;
5397         i = PL_savestack_ix;
5398         SAVEFREEOP(o);
5399         ENTER;
5400         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5401         LEAVE;
5402         PL_savestack_ix = i;
5403     }
5404     else {
5405         if (o->op_type == OP_STUB) {
5406             /* This block is entered if nothing is compiled for the main
5407                program. This will be the case for an genuinely empty main
5408                program, or one which only has BEGIN blocks etc, so already
5409                run and freed.
5410
5411                Historically (5.000) the guard above was !o. However, commit
5412                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5413                c71fccf11fde0068, changed perly.y so that newPROG() is now
5414                called with the output of block_end(), which returns a new
5415                OP_STUB for the case of an empty optree. ByteLoader (and
5416                maybe other things) also take this path, because they set up
5417                PL_main_start and PL_main_root directly, without generating an
5418                optree.
5419
5420                If the parsing the main program aborts (due to parse errors,
5421                or due to BEGIN or similar calling exit), then newPROG()
5422                isn't even called, and hence this code path and its cleanups
5423                are skipped. This shouldn't make a make a difference:
5424                * a non-zero return from perl_parse is a failure, and
5425                  perl_destruct() should be called immediately.
5426                * however, if exit(0) is called during the parse, then
5427                  perl_parse() returns 0, and perl_run() is called. As
5428                  PL_main_start will be NULL, perl_run() will return
5429                  promptly, and the exit code will remain 0.
5430             */
5431
5432             PL_comppad_name = 0;
5433             PL_compcv = 0;
5434             S_op_destroy(aTHX_ o);
5435             return;
5436         }
5437         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5438         PL_curcop = &PL_compiling;
5439         start = LINKLIST(PL_main_root);
5440         PL_main_root->op_next = 0;
5441         S_process_optree(aTHX_ NULL, PL_main_root, start);
5442         if (!PL_parser->error_count)
5443             /* on error, leave CV slabbed so that ops left lying around
5444              * will eb cleaned up. Else unslab */
5445             cv_forget_slab(PL_compcv);
5446         PL_compcv = 0;
5447
5448         /* Register with debugger */
5449         if (PERLDB_INTER) {
5450             CV * const cv = get_cvs("DB::postponed", 0);
5451             if (cv) {
5452                 dSP;
5453                 PUSHMARK(SP);
5454                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5455                 PUTBACK;
5456                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5457             }
5458         }
5459     }
5460 }
5461
5462 OP *
5463 Perl_localize(pTHX_ OP *o, I32 lex)
5464 {
5465     PERL_ARGS_ASSERT_LOCALIZE;
5466
5467     if (o->op_flags & OPf_PARENS)
5468 /* [perl #17376]: this appears to be premature, and results in code such as
5469    C< our(%x); > executing in list mode rather than void mode */
5470 #if 0
5471         list(o);
5472 #else
5473         NOOP;
5474 #endif
5475     else {
5476         if ( PL_parser->bufptr > PL_parser->oldbufptr
5477             && PL_parser->bufptr[-1] == ','
5478             && ckWARN(WARN_PARENTHESIS))
5479         {
5480             char *s = PL_parser->bufptr;
5481             bool sigil = FALSE;
5482
5483             /* some heuristics to detect a potential error */
5484             while (*s && (strchr(", \t\n", *s)))
5485                 s++;
5486
5487             while (1) {
5488                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5489                        && *++s
5490                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5491                     s++;
5492                     sigil = TRUE;
5493                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5494                         s++;
5495                     while (*s && (strchr(", \t\n", *s)))
5496                         s++;
5497                 }
5498                 else
5499                     break;
5500             }
5501             if (sigil && (*s == ';' || *s == '=')) {
5502                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5503                                 "Parentheses missing around \"%s\" list",
5504                                 lex
5505                                     ? (PL_parser->in_my == KEY_our
5506                                         ? "our"
5507                                         : PL_parser->in_my == KEY_state
5508                                             ? "state"
5509                                             : "my")
5510                                     : "local");
5511             }
5512         }
5513     }
5514     if (lex)
5515         o = my(o);
5516     else
5517         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5518     PL_parser->in_my = FALSE;
5519     PL_parser->in_my_stash = NULL;
5520     return o;
5521 }
5522
5523 OP *
5524 Perl_jmaybe(pTHX_ OP *o)
5525 {
5526     PERL_ARGS_ASSERT_JMAYBE;
5527
5528     if (o->op_type == OP_LIST) {
5529         OP * const o2
5530             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5531         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5532     }
5533     return o;
5534 }
5535
5536 PERL_STATIC_INLINE OP *
5537 S_op_std_init(pTHX_ OP *o)
5538 {
5539     I32 type = o->op_type;
5540
5541     PERL_ARGS_ASSERT_OP_STD_INIT;
5542
5543     if (PL_opargs[type] & OA_RETSCALAR)
5544         scalar(o);
5545     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5546         o->op_targ = pad_alloc(type, SVs_PADTMP);
5547
5548     return o;
5549 }
5550
5551 PERL_STATIC_INLINE OP *
5552 S_op_integerize(pTHX_ OP *o)
5553 {
5554     I32 type = o->op_type;
5555
5556     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5557
5558     /* integerize op. */
5559     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5560     {
5561         dVAR;
5562         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5563     }
5564
5565     if (type == OP_NEGATE)
5566         /* XXX might want a ck_negate() for this */
5567         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5568
5569     return o;
5570 }
5571
5572 /* This function exists solely to provide a scope to limit
5573    setjmp/longjmp() messing with auto variables.
5574  */
5575 PERL_STATIC_INLINE int
5576 S_fold_constants_eval(pTHX) {
5577     int ret = 0;
5578     dJMPENV;
5579
5580     JMPENV_PUSH(ret);
5581
5582     if (ret == 0) {
5583         CALLRUNOPS(aTHX);
5584     }
5585
5586     JMPENV_POP;
5587
5588     return ret;
5589 }
5590
5591 static OP *
5592 S_fold_constants(pTHX_ OP *const o)
5593 {
5594     dVAR;
5595     OP *curop;
5596     OP *newop;
5597     I32 type = o->op_type;
5598     bool is_stringify;
5599     SV *sv = NULL;
5600     int ret = 0;
5601     OP *old_next;
5602     SV * const oldwarnhook = PL_warnhook;
5603     SV * const olddiehook  = PL_diehook;
5604     COP not_compiling;
5605     U8 oldwarn = PL_dowarn;
5606     I32 old_cxix;
5607
5608     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5609
5610     if (!(PL_opargs[type] & OA_FOLDCONST))
5611         goto nope;
5612
5613     switch (type) {
5614     case OP_UCFIRST:
5615     case OP_LCFIRST:
5616     case OP_UC:
5617     case OP_LC:
5618     case OP_FC:
5619 #ifdef USE_LOCALE_CTYPE
5620         if (IN_LC_COMPILETIME(LC_CTYPE))
5621             goto nope;
5622 #endif
5623         break;
5624     case OP_SLT:
5625     case OP_SGT:
5626     case OP_SLE:
5627     case OP_SGE:
5628     case OP_SCMP:
5629 #ifdef USE_LOCALE_COLLATE
5630         if (IN_LC_COMPILETIME(LC_COLLATE))
5631             goto nope;
5632 #endif
5633         break;
5634     case OP_SPRINTF:
5635         /* XXX what about the numeric ops? */
5636 #ifdef USE_LOCALE_NUMERIC
5637         if (IN_LC_COMPILETIME(LC_NUMERIC))
5638             goto nope;
5639 #endif
5640         break;
5641     case OP_PACK:
5642         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5643           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5644             goto nope;
5645         {
5646             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5647             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5648             {
5649                 const char *s = SvPVX_const(sv);
5650                 while (s < SvEND(sv)) {
5651                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5652                     s++;
5653                 }
5654             }
5655         }
5656         break;
5657     case OP_REPEAT:
5658         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5659         break;
5660     case OP_SREFGEN:
5661         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5662          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5663             goto nope;
5664     }
5665
5666     if (PL_parser && PL_parser->error_count)
5667         goto nope;              /* Don't try to run w/ errors */
5668
5669     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5670         switch (curop->op_type) {
5671         case OP_CONST:
5672             if (   (curop->op_private & OPpCONST_BARE)
5673                 && (curop->op_private & OPpCONST_STRICT)) {
5674                 no_bareword_allowed(curop);
5675                 goto nope;
5676             }
5677             /* FALLTHROUGH */
5678         case OP_LIST:
5679         case OP_SCALAR:
5680         case OP_NULL:
5681         case OP_PUSHMARK:
5682             /* Foldable; move to next op in list */
5683             break;
5684
5685         default:
5686             /* No other op types are considered foldable */
5687             goto nope;
5688         }
5689     }
5690
5691     curop = LINKLIST(o);
5692     old_next = o->op_next;
5693     o->op_next = 0;
5694     PL_op = curop;
5695
5696     old_cxix = cxstack_ix;
5697     create_eval_scope(NULL, G_FAKINGEVAL);
5698
5699     /* Verify that we don't need to save it:  */
5700     assert(PL_curcop == &PL_compiling);
5701     StructCopy(&PL_compiling, &not_compiling, COP);
5702     PL_curcop = &not_compiling;
5703     /* The above ensures that we run with all the correct hints of the
5704        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5705     assert(IN_PERL_RUNTIME);
5706     PL_warnhook = PERL_WARNHOOK_FATAL;
5707     PL_diehook  = NULL;
5708
5709     /* Effective $^W=1.  */
5710     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5711         PL_dowarn |= G_WARN_ON;
5712
5713     ret = S_fold_constants_eval(aTHX);
5714
5715     switch (ret) {
5716     case 0:
5717         sv = *(PL_stack_sp--);
5718         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5719             pad_swipe(o->op_targ,  FALSE);
5720         }
5721         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5722             SvREFCNT_inc_simple_void(sv);
5723             SvTEMP_off(sv);
5724         }
5725         else { assert(SvIMMORTAL(sv)); }
5726         break;
5727     case 3:
5728         /* Something tried to die.  Abandon constant folding.  */
5729         /* Pretend the error never happened.  */
5730         CLEAR_ERRSV();
5731         o->op_next = old_next;
5732         break;
5733     default:
5734         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5735         PL_warnhook = oldwarnhook;
5736         PL_diehook  = olddiehook;
5737         /* XXX note that this croak may fail as we've already blown away
5738          * the stack - eg any nested evals */
5739         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5740     }
5741     PL_dowarn   = oldwarn;
5742     PL_warnhook = oldwarnhook;
5743     PL_diehook  = olddiehook;
5744     PL_curcop = &PL_compiling;
5745
5746     /* if we croaked, depending on how we croaked the eval scope
5747      * may or may not have already been popped */
5748     if (cxstack_ix > old_cxix) {
5749         assert(cxstack_ix == old_cxix + 1);
5750         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5751         delete_eval_scope();
5752     }
5753     if (ret)
5754         goto nope;
5755
5756     /* OP_STRINGIFY and constant folding are used to implement qq.
5757        Here the constant folding is an implementation detail that we
5758        want to hide.  If the stringify op is itself already marked
5759        folded, however, then it is actually a folded join.  */
5760     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5761     op_free(o);
5762     assert(sv);
5763     if (is_stringify)
5764         SvPADTMP_off(sv);
5765     else if (!SvIMMORTAL(sv)) {
5766         SvPADTMP_on(sv);
5767         SvREADONLY_on(sv);
5768     }
5769     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5770     if (!is_stringify) newop->op_folded = 1;
5771     return newop;
5772
5773  nope:
5774     return o;
5775 }
5776
5777 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5778  * the constant value being an AV holding the flattened range.
5779  */
5780
5781 static void
5782 S_gen_constant_list(pTHX_ OP *o)
5783 {
5784     dVAR;
5785     OP *curop, *old_next;
5786     SV * const oldwarnhook = PL_warnhook;
5787     SV * const olddiehook  = PL_diehook;
5788     COP *old_curcop;
5789     U8 oldwarn = PL_dowarn;
5790     SV **svp;
5791     AV *av;
5792     I32 old_cxix;
5793     COP not_compiling;
5794     int ret = 0;
5795     dJMPENV;
5796     bool op_was_null;
5797
5798     list(o);
5799     if (PL_parser && PL_parser->error_count)
5800         return;         /* Don't attempt to run with errors */
5801
5802     curop = LINKLIST(o);
5803     old_next = o->op_next;
5804     o->op_next = 0;
5805     op_was_null = o->op_type == OP_NULL;
5806     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5807         o->op_type = OP_CUSTOM;
5808     CALL_PEEP(curop);
5809     if (op_was_null)
5810         o->op_type = OP_NULL;
5811     S_prune_chain_head(&curop);
5812     PL_op = curop;
5813
5814     old_cxix = cxstack_ix;
5815     create_eval_scope(NULL, G_FAKINGEVAL);
5816
5817     old_curcop = PL_curcop;
5818     StructCopy(old_curcop, &not_compiling, COP);
5819     PL_curcop = &not_compiling;
5820     /* The above ensures that we run with all the correct hints of the
5821        current COP, but that IN_PERL_RUNTIME is true. */
5822     assert(IN_PERL_RUNTIME);
5823     PL_warnhook = PERL_WARNHOOK_FATAL;
5824     PL_diehook  = NULL;
5825     JMPENV_PUSH(ret);
5826
5827     /* Effective $^W=1.  */
5828     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5829         PL_dowarn |= G_WARN_ON;
5830
5831     switch (ret) {
5832     case 0:
5833 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5834         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5835 #endif
5836         Perl_pp_pushmark(aTHX);
5837         CALLRUNOPS(aTHX);
5838         PL_op = curop;
5839         assert (!(curop->op_flags & OPf_SPECIAL));
5840         assert(curop->op_type == OP_RANGE);
5841         Perl_pp_anonlist(aTHX);
5842         break;
5843     case 3:
5844         CLEAR_ERRSV();
5845         o->op_next = old_next;
5846         break;
5847     default:
5848         JMPENV_POP;
5849         PL_warnhook = oldwarnhook;
5850         PL_diehook = olddiehook;
5851         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5852             ret);
5853     }
5854
5855     JMPENV_POP;
5856     PL_dowarn = oldwarn;
5857     PL_warnhook = oldwarnhook;
5858     PL_diehook = olddiehook;
5859     PL_curcop = old_curcop;
5860
5861     if (cxstack_ix > old_cxix) {
5862         assert(cxstack_ix == old_cxix + 1);
5863         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5864         delete_eval_scope();
5865     }
5866     if (ret)
5867         return;
5868
5869     OpTYPE_set(o, OP_RV2AV);
5870     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5871     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5872     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5873     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5874
5875     /* replace subtree with an OP_CONST */
5876     curop = ((UNOP*)o)->op_first;
5877     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5878     op_free(curop);
5879
5880     if (AvFILLp(av) != -1)
5881         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5882         {
5883             SvPADTMP_on(*svp);
5884             SvREADONLY_on(*svp);
5885         }
5886     LINKLIST(o);
5887     list(o);
5888     return;
5889 }
5890
5891 /*
5892 =head1 Optree Manipulation Functions
5893 */
5894
5895 /* List constructors */
5896
5897 /*
5898 =for apidoc op_append_elem
5899
5900 Append an item to the list of ops contained directly within a list-type
5901 op, returning the lengthened list.  C<first> is the list-type op,
5902 and C<last> is the op to append to the list.  C<optype> specifies the
5903 intended opcode for the list.  If C<first> is not already a list of the
5904 right type, it will be upgraded into one.  If either C<first> or C<last>
5905 is null, the other is returned unchanged.
5906
5907 =cut
5908 */
5909
5910 OP *
5911 Perl_op_append_elem(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         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5921     {
5922         return newLISTOP(type, 0, first, last);
5923     }
5924
5925     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5926     first->op_flags |= OPf_KIDS;
5927     return first;
5928 }
5929
5930 /*
5931 =for apidoc op_append_list
5932
5933 Concatenate the lists of ops contained directly within two list-type ops,
5934 returning the combined list.  C<first> and C<last> are the list-type ops
5935 to concatenate.  C<optype> specifies the intended opcode for the list.
5936 If either C<first> or C<last> is not already a list of the right type,
5937 it will be upgraded into one.  If either C<first> or C<last> is null,
5938 the other is returned unchanged.
5939
5940 =cut
5941 */
5942
5943 OP *
5944 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5945 {
5946     if (!first)
5947         return last;
5948
5949     if (!last)
5950         return first;
5951
5952     if (first->op_type != (unsigned)type)
5953         return op_prepend_elem(type, first, last);
5954
5955     if (last->op_type != (unsigned)type)
5956         return op_append_elem(type, first, last);
5957
5958     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5959     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5960     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5961     first->op_flags |= (last->op_flags & OPf_KIDS);
5962
5963     S_op_destroy(aTHX_ last);
5964
5965     return first;
5966 }
5967
5968 /*
5969 =for apidoc op_prepend_elem
5970
5971 Prepend an item to the list of ops contained directly within a list-type
5972 op, returning the lengthened list.  C<first> is the op to prepend to the
5973 list, and C<last> is the list-type op.  C<optype> specifies the intended
5974 opcode for the list.  If C<last> is not already a list of the right type,
5975 it will be upgraded into one.  If either C<first> or C<last> is null,
5976 the other is returned unchanged.
5977
5978 =cut
5979 */
5980
5981 OP *
5982 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5983 {
5984     if (!first)
5985         return last;
5986
5987     if (!last)
5988         return first;
5989
5990     if (last->op_type == (unsigned)type) {
5991         if (type == OP_LIST) {  /* already a PUSHMARK there */
5992             /* insert 'first' after pushmark */
5993             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5994             if (!(first->op_flags & OPf_PARENS))
5995                 last->op_flags &= ~OPf_PARENS;
5996         }
5997         else
5998             op_sibling_splice(last, NULL, 0, first);
5999         last->op_flags |= OPf_KIDS;
6000         return last;
6001     }
6002
6003     return newLISTOP(type, 0, first, last);
6004 }
6005
6006 /*
6007 =for apidoc op_convert_list
6008
6009 Converts C<o> into a list op if it is not one already, and then converts it
6010 into the specified C<type>, calling its check function, allocating a target if
6011 it needs one, and folding constants.
6012
6013 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6014 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
6015 C<op_convert_list> to make it the right type.
6016
6017 =cut
6018 */
6019
6020 OP *
6021 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6022 {
6023     dVAR;
6024     if (type < 0) type = -type, flags |= OPf_SPECIAL;
6025     if (!o || o->op_type != OP_LIST)
6026         o = force_list(o, 0);
6027     else
6028     {
6029         o->op_flags &= ~OPf_WANT;
6030         o->op_private &= ~OPpLVAL_INTRO;
6031     }
6032
6033     if (!(PL_opargs[type] & OA_MARK))
6034         op_null(cLISTOPo->op_first);
6035     else {
6036         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6037         if (kid2 && kid2->op_type == OP_COREARGS) {
6038             op_null(cLISTOPo->op_first);
6039             kid2->op_private |= OPpCOREARGS_PUSHMARK;
6040         }
6041     }
6042
6043     if (type != OP_SPLIT)
6044         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6045          * ck_split() create a real PMOP and leave the op's type as listop
6046          * for now. Otherwise op_free() etc will crash.
6047          */
6048         OpTYPE_set(o, type);
6049
6050     o->op_flags |= flags;
6051     if (flags & OPf_FOLDED)
6052         o->op_folded = 1;
6053
6054     o = CHECKOP(type, o);
6055     if (o->op_type != (unsigned)type)
6056         return o;
6057
6058     return fold_constants(op_integerize(op_std_init(o)));
6059 }
6060
6061 /* Constructors */
6062
6063
6064 /*
6065 =head1 Optree construction
6066
6067 =for apidoc newNULLLIST
6068
6069 Constructs, checks, and returns a new C<stub> op, which represents an
6070 empty list expression.
6071
6072 =cut
6073 */
6074
6075 OP *
6076 Perl_newNULLLIST(pTHX)
6077 {
6078     return newOP(OP_STUB, 0);
6079 }
6080
6081 /* promote o and any siblings to be a list if its not already; i.e.
6082  *
6083  *  o - A - B
6084  *
6085  * becomes
6086  *
6087  *  list
6088  *    |
6089  *  pushmark - o - A - B
6090  *
6091  * If nullit it true, the list op is nulled.
6092  */
6093
6094 static OP *
6095 S_force_list(pTHX_ OP *o, bool nullit)
6096 {
6097     if (!o || o->op_type != OP_LIST) {
6098         OP *rest = NULL;
6099         if (o) {
6100             /* manually detach any siblings then add them back later */
6101             rest = OpSIBLING(o);
6102             OpLASTSIB_set(o, NULL);
6103         }
6104         o = newLISTOP(OP_LIST, 0, o, NULL);
6105         if (rest)
6106             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6107     }
6108     if (nullit)
6109         op_null(o);
6110     return o;
6111 }
6112
6113 /*
6114 =for apidoc newLISTOP
6115
6116 Constructs, checks, and returns an op of any list type.  C<type> is
6117 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6118 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6119 supply up to two ops to be direct children of the list op; they are
6120 consumed by this function and become part of the constructed op tree.
6121
6122 For most list operators, the check function expects all the kid ops to be
6123 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6124 appropriate.  What you want to do in that case is create an op of type
6125 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6126 See L</op_convert_list> for more information.
6127
6128
6129 =cut
6130 */
6131
6132 OP *
6133 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6134 {
6135     dVAR;
6136     LISTOP *listop;
6137     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6138      * pushmark is banned. So do it now while existing ops are in a
6139      * consistent state, in case they suddenly get freed */
6140     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6141
6142     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6143         || type == OP_CUSTOM);
6144
6145     NewOp(1101, listop, 1, LISTOP);
6146     OpTYPE_set(listop, type);
6147     if (first || last)
6148         flags |= OPf_KIDS;
6149     listop->op_flags = (U8)flags;
6150
6151     if (!last && first)
6152         last = first;
6153     else if (!first && last)
6154         first = last;
6155     else if (first)
6156         OpMORESIB_set(first, last);
6157     listop->op_first = first;
6158     listop->op_last = last;
6159
6160     if (pushop) {
6161         OpMORESIB_set(pushop, first);
6162         listop->op_first = pushop;
6163         listop->op_flags |= OPf_KIDS;
6164         if (!last)
6165             listop->op_last = pushop;
6166     }
6167     if (listop->op_last)
6168         OpLASTSIB_set(listop->op_last, (OP*)listop);
6169
6170     return CHECKOP(type, listop);
6171 }
6172
6173 /*
6174 =for apidoc newOP
6175
6176 Constructs, checks, and returns an op of any base type (any type that
6177 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6178 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6179 of C<op_private>.
6180
6181 =cut
6182 */
6183
6184 OP *
6185 Perl_newOP(pTHX_ I32 type, I32 flags)
6186 {
6187     dVAR;
6188     OP *o;
6189
6190     if (type == -OP_ENTEREVAL) {
6191         type = OP_ENTEREVAL;
6192         flags |= OPpEVAL_BYTES<<8;
6193     }
6194
6195     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6196         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6197         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6198         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6199
6200     NewOp(1101, o, 1, OP);
6201     OpTYPE_set(o, type);
6202     o->op_flags = (U8)flags;
6203
6204     o->op_next = o;
6205     o->op_private = (U8)(0 | (flags >> 8));
6206     if (PL_opargs[type] & OA_RETSCALAR)
6207         scalar(o);
6208     if (PL_opargs[type] & OA_TARGET)
6209         o->op_targ = pad_alloc(type, SVs_PADTMP);
6210     return CHECKOP(type, o);
6211 }
6212
6213 /*
6214 =for apidoc newUNOP
6215
6216 Constructs, checks, and returns an op of any unary type.  C<type> is
6217 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6218 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6219 bits, the eight bits of C<op_private>, except that the bit with value 1
6220 is automatically set.  C<first> supplies an optional op to be the direct
6221 child of the unary op; it is consumed by this function and become part
6222 of the constructed op tree.
6223
6224 =cut
6225 */
6226
6227 OP *
6228 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6229 {
6230     dVAR;
6231     UNOP *unop;
6232
6233     if (type == -OP_ENTEREVAL) {
6234         type = OP_ENTEREVAL;
6235         flags |= OPpEVAL_BYTES<<8;
6236     }
6237
6238     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6239         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6240         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6241         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6242         || type == OP_SASSIGN
6243         || type == OP_ENTERTRY
6244         || type == OP_CUSTOM
6245         || type == OP_NULL );
6246
6247     if (!first)
6248         first = newOP(OP_STUB, 0);
6249     if (PL_opargs[type] & OA_MARK)
6250         first = force_list(first, 1);
6251
6252     NewOp(1101, unop, 1, UNOP);
6253     OpTYPE_set(unop, type);
6254     unop->op_first = first;
6255     unop->op_flags = (U8)(flags | OPf_KIDS);
6256     unop->op_private = (U8)(1 | (flags >> 8));
6257
6258     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6259         OpLASTSIB_set(first, (OP*)unop);
6260
6261     unop = (UNOP*) CHECKOP(type, unop);
6262     if (unop->op_next)
6263         return (OP*)unop;
6264
6265     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6266 }
6267
6268 /*
6269 =for apidoc newUNOP_AUX
6270
6271 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6272 initialised to C<aux>
6273
6274 =cut
6275 */
6276
6277 OP *
6278 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6279 {
6280     dVAR;
6281     UNOP_AUX *unop;
6282
6283     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6284         || type == OP_CUSTOM);
6285
6286     NewOp(1101, unop, 1, UNOP_AUX);
6287     unop->op_type = (OPCODE)type;
6288     unop->op_ppaddr = PL_ppaddr[type];
6289     unop->op_first = first;
6290     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6291     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6292     unop->op_aux = aux;
6293
6294     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6295         OpLASTSIB_set(first, (OP*)unop);
6296
6297     unop = (UNOP_AUX*) CHECKOP(type, unop);
6298
6299     return op_std_init((OP *) unop);
6300 }
6301
6302 /*
6303 =for apidoc newMETHOP
6304
6305 Constructs, checks, and returns an op of method type with a method name
6306 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6307 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6308 and, shifted up eight bits, the eight bits of C<op_private>, except that
6309 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6310 op which evaluates method name; it is consumed by this function and
6311 become part of the constructed op tree.
6312 Supported optypes: C<OP_METHOD>.
6313
6314 =cut
6315 */
6316
6317 static OP*
6318 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6319     dVAR;
6320     METHOP *methop;
6321
6322     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6323         || type == OP_CUSTOM);
6324
6325     NewOp(1101, methop, 1, METHOP);
6326     if (dynamic_meth) {
6327         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6328         methop->op_flags = (U8)(flags | OPf_KIDS);
6329         methop->op_u.op_first = dynamic_meth;
6330         methop->op_private = (U8)(1 | (flags >> 8));
6331
6332         if (!OpHAS_SIBLING(dynamic_meth))
6333             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6334     }
6335     else {
6336         assert(const_meth);
6337         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6338         methop->op_u.op_meth_sv = const_meth;
6339         methop->op_private = (U8)(0 | (flags >> 8));
6340         methop->op_next = (OP*)methop;
6341     }
6342
6343 #ifdef USE_ITHREADS
6344     methop->op_rclass_targ = 0;
6345 #else
6346     methop->op_rclass_sv = NULL;
6347 #endif
6348
6349     OpTYPE_set(methop, type);
6350     return CHECKOP(type, methop);
6351 }
6352
6353 OP *
6354 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6355     PERL_ARGS_ASSERT_NEWMETHOP;
6356     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6357 }
6358
6359 /*
6360 =for apidoc newMETHOP_named
6361
6362 Constructs, checks, and returns an op of method type with a constant
6363 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6364 C<op_flags>, and, shifted up eight bits, the eight bits of
6365 C<op_private>.  C<const_meth> supplies a constant method name;
6366 it must be a shared COW string.
6367 Supported optypes: C<OP_METHOD_NAMED>.
6368
6369 =cut
6370 */
6371
6372 OP *
6373 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6374     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6375     return newMETHOP_internal(type, flags, NULL, const_meth);
6376 }
6377
6378 /*
6379 =for apidoc newBINOP
6380
6381 Constructs, checks, and returns an op of any binary type.  C<type>
6382 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6383 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6384 the eight bits of C<op_private>, except that the bit with value 1 or
6385 2 is automatically set as required.  C<first> and C<last> supply up to
6386 two ops to be the direct children of the binary op; they are consumed
6387 by this function and become part of the constructed op tree.
6388
6389 =cut
6390 */
6391
6392 OP *
6393 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6394 {
6395     dVAR;
6396     BINOP *binop;
6397
6398     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6399         || type == OP_NULL || type == OP_CUSTOM);
6400
6401     NewOp(1101, binop, 1, BINOP);
6402
6403     if (!first)
6404         first = newOP(OP_NULL, 0);
6405
6406     OpTYPE_set(binop, type);
6407     binop->op_first = first;
6408     binop->op_flags = (U8)(flags | OPf_KIDS);
6409     if (!last) {
6410         last = first;
6411         binop->op_private = (U8)(1 | (flags >> 8));
6412     }
6413     else {
6414         binop->op_private = (U8)(2 | (flags >> 8));
6415         OpMORESIB_set(first, last);
6416     }
6417
6418     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6419         OpLASTSIB_set(last, (OP*)binop);
6420
6421     binop->op_last = OpSIBLING(binop->op_first);
6422     if (binop->op_last)
6423         OpLASTSIB_set(binop->op_last, (OP*)binop);
6424
6425     binop = (BINOP*)CHECKOP(type, binop);
6426     if (binop->op_next || binop->op_type != (OPCODE)type)
6427         return (OP*)binop;
6428
6429     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6430 }
6431
6432 /* Helper function for S_pmtrans(): comparison function to sort an array
6433  * of codepoint range pairs. Sorts by start point, or if equal, by end
6434  * point */
6435
6436 static int uvcompare(const void *a, const void *b)
6437     __attribute__nonnull__(1)
6438     __attribute__nonnull__(2)
6439     __attribute__pure__;
6440 static int uvcompare(const void *a, const void *b)
6441 {
6442     if (*((const UV *)a) < (*(const UV *)b))
6443         return -1;
6444     if (*((const UV *)a) > (*(const UV *)b))
6445         return 1;
6446     if (*((const UV *)a+1) < (*(const UV *)b+1))
6447         return -1;
6448     if (*((const UV *)a+1) > (*(const UV *)b+1))
6449         return 1;
6450     return 0;
6451 }
6452
6453 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6454  * containing the search and replacement strings, assemble into
6455  * a translation table attached as o->op_pv.
6456  * Free expr and repl.
6457  * It expects the toker to have already set the
6458  *   OPpTRANS_COMPLEMENT
6459  *   OPpTRANS_SQUASH
6460  *   OPpTRANS_DELETE
6461  * flags as appropriate; this function may add
6462  *   OPpTRANS_FROM_UTF
6463  *   OPpTRANS_TO_UTF
6464  *   OPpTRANS_IDENTICAL
6465  *   OPpTRANS_GROWS
6466  * flags
6467  */
6468
6469 static OP *
6470 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6471 {
6472     SV * const tstr = ((SVOP*)expr)->op_sv;
6473     SV * const rstr = ((SVOP*)repl)->op_sv;
6474     STRLEN tlen;
6475     STRLEN rlen;
6476     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6477     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6478     Size_t i, j;
6479     bool grows = FALSE;
6480     OPtrans_map *tbl;
6481     SSize_t struct_size; /* malloced size of table struct */
6482
6483     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6484     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6485     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6486     SV* swash;
6487
6488     PERL_ARGS_ASSERT_PMTRANS;
6489
6490     PL_hints |= HINT_BLOCK_SCOPE;
6491
6492     if (SvUTF8(tstr))
6493         o->op_private |= OPpTRANS_FROM_UTF;
6494
6495     if (SvUTF8(rstr))
6496         o->op_private |= OPpTRANS_TO_UTF;
6497
6498     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6499
6500         /* for utf8 translations, op_sv will be set to point to a swash
6501          * containing codepoint ranges. This is done by first assembling
6502          * a textual representation of the ranges in listsv then compiling
6503          * it using swash_init(). For more details of the textual format,
6504          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6505          */
6506
6507         SV* const listsv = newSVpvs("# comment\n");
6508         SV* transv = NULL;
6509         const U8* tend = t + tlen;
6510         const U8* rend = r + rlen;
6511         STRLEN ulen;
6512         UV tfirst = 1;
6513         UV tlast = 0;
6514         IV tdiff;
6515         STRLEN tcount = 0;
6516         UV rfirst = 1;
6517         UV rlast = 0;
6518         IV rdiff;
6519         STRLEN rcount = 0;
6520         IV diff;
6521         I32 none = 0;
6522         U32 max = 0;
6523         I32 bits;
6524         I32 havefinal = 0;
6525         U32 final = 0;
6526         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6527         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6528         U8* tsave = NULL;
6529         U8* rsave = NULL;
6530         const U32 flags = UTF8_ALLOW_DEFAULT;
6531
6532         if (!from_utf) {
6533             STRLEN len = tlen;
6534             t = tsave = bytes_to_utf8(t, &len);
6535             tend = t + len;
6536         }
6537         if (!to_utf && rlen) {
6538             STRLEN len = rlen;
6539             r = rsave = bytes_to_utf8(r, &len);
6540             rend = r + len;
6541         }
6542
6543 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6544  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6545  * odd.  */
6546
6547         if (complement) {
6548             /* utf8 and /c:
6549              * replace t/tlen/tend with a version that has the ranges
6550              * complemented
6551              */
6552             U8 tmpbuf[UTF8_MAXBYTES+1];
6553             UV *cp;
6554             UV nextmin = 0;
6555             Newx(cp, 2*tlen, UV);
6556             i = 0;
6557             transv = newSVpvs("");
6558
6559             /* convert search string into array of (start,end) range
6560              * codepoint pairs stored in cp[]. Most "ranges" will start
6561              * and end at the same char */
6562             while (t < tend) {
6563                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6564                 t += ulen;
6565                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6566                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6567                     t++;
6568                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6569                     t += ulen;
6570                 }
6571                 else {
6572                  cp[2*i+1] = cp[2*i];
6573                 }
6574                 i++;
6575             }
6576
6577             /* sort the ranges */
6578             qsort(cp, i, 2*sizeof(UV), uvcompare);
6579
6580             /* Create a utf8 string containing the complement of the
6581              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6582              * then transv will contain the equivalent of:
6583              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6584              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6585              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6586              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6587              * end cp.
6588              */
6589             for (j = 0; j < i; j++) {
6590                 UV  val = cp[2*j];
6591                 diff = val - nextmin;
6592                 if (diff > 0) {
6593                     t = uvchr_to_utf8(tmpbuf,nextmin);
6594                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6595                     if (diff > 1) {
6596                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6597                         t = uvchr_to_utf8(tmpbuf, val - 1);
6598                         sv_catpvn(transv, (char *)&range_mark, 1);
6599                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6600                     }
6601                 }
6602                 val = cp[2*j+1];
6603                 if (val >= nextmin)
6604                     nextmin = val + 1;
6605             }
6606
6607             t = uvchr_to_utf8(tmpbuf,nextmin);
6608             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6609             {
6610                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6611                 sv_catpvn(transv, (char *)&range_mark, 1);
6612             }
6613             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6614             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6615             t = (const U8*)SvPVX_const(transv);
6616             tlen = SvCUR(transv);
6617             tend = t + tlen;
6618             Safefree(cp);
6619         }
6620         else if (!rlen && !del) {
6621             r = t; rlen = tlen; rend = tend;
6622         }
6623
6624         if (!squash) {
6625                 if ((!rlen && !del) || t == r ||
6626                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6627                 {
6628                     o->op_private |= OPpTRANS_IDENTICAL;
6629                 }
6630         }
6631
6632         /* extract char ranges from t and r and append them to listsv */
6633
6634         while (t < tend || tfirst <= tlast) {
6635             /* see if we need more "t" chars */
6636             if (tfirst > tlast) {
6637                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6638                 t += ulen;
6639                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6640                     t++;
6641                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6642                     t += ulen;
6643                 }
6644                 else
6645                     tlast = tfirst;
6646             }
6647
6648             /* now see if we need more "r" chars */
6649             if (rfirst > rlast) {
6650                 if (r < rend) {
6651                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6652                     r += ulen;
6653                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6654                         r++;
6655                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6656                         r += ulen;
6657                     }
6658                     else
6659                         rlast = rfirst;
6660                 }
6661                 else {
6662                     if (!havefinal++)
6663                         final = rlast;
6664                     rfirst = rlast = 0xffffffff;
6665                 }
6666             }
6667
6668             /* now see which range will peter out first, if either. */
6669             tdiff = tlast - tfirst;
6670             rdiff = rlast - rfirst;
6671             tcount += tdiff + 1;
6672             rcount += rdiff + 1;
6673
6674             if (tdiff <= rdiff)
6675                 diff = tdiff;
6676             else
6677                 diff = rdiff;
6678
6679             if (rfirst == 0xffffffff) {
6680                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6681                 if (diff > 0)
6682                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6683                                    (long)tfirst, (long)tlast);
6684                 else
6685                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6686             }
6687             else {
6688                 if (diff > 0)
6689                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6690                                    (long)tfirst, (long)(tfirst + diff),
6691                                    (long)rfirst);
6692                 else
6693                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6694                                    (long)tfirst, (long)rfirst);
6695
6696                 if (rfirst + diff > max)
6697                     max = rfirst + diff;
6698                 if (!grows)
6699                     grows = (tfirst < rfirst &&
6700                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6701                 rfirst += diff + 1;
6702             }
6703             tfirst += diff + 1;
6704         }
6705
6706         /* compile listsv into a swash and attach to o */
6707
6708         none = ++max;
6709         if (del)
6710             ++max;
6711
6712         if (max > 0xffff)
6713             bits = 32;
6714         else if (max > 0xff)
6715             bits = 16;
6716         else
6717             bits = 8;
6718
6719         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6720 #ifdef USE_ITHREADS
6721         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6722         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6723         PAD_SETSV(cPADOPo->op_padix, swash);
6724         SvPADTMP_on(swash);
6725         SvREADONLY_on(swash);
6726 #else
6727         cSVOPo->op_sv = swash;
6728 #endif
6729         SvREFCNT_dec(listsv);
6730         SvREFCNT_dec(transv);
6731
6732         if (!del && havefinal && rlen)
6733             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6734                            newSVuv((UV)final), 0);
6735
6736         Safefree(tsave);
6737         Safefree(rsave);
6738
6739         tlen = tcount;
6740         rlen = rcount;
6741         if (r < rend)
6742             rlen++;
6743         else if (rlast == 0xffffffff)
6744             rlen = 0;
6745
6746         goto warnins;
6747     }
6748
6749     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6750      * table. Entries with the value -1 indicate chars not to be
6751      * translated, while -2 indicates a search char without a
6752      * corresponding replacement char under /d.
6753      *
6754      * Normally, the table has 256 slots. However, in the presence of
6755      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6756      * added, and if there are enough replacement chars to start pairing
6757      * with the \x{100},... search chars, then a larger (> 256) table
6758      * is allocated.
6759      *
6760      * In addition, regardless of whether under /c, an extra slot at the
6761      * end is used to store the final repeating char, or -3 under an empty
6762      * replacement list, or -2 under /d; which makes the runtime code
6763      * easier.
6764      *
6765      * The toker will have already expanded char ranges in t and r.
6766      */
6767
6768     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6769      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6770      * The OPtrans_map struct already contains one slot; hence the -1.
6771      */
6772     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6773     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6774     tbl->size = 256;
6775     cPVOPo->op_pv = (char*)tbl;
6776
6777     if (complement) {
6778         Size_t excess;
6779
6780         /* in this branch, j is a count of 'consumed' (i.e. paired off
6781          * with a search char) replacement chars (so j <= rlen always)
6782          */
6783         for (i = 0; i < tlen; i++)
6784             tbl->map[t[i]] = -1;
6785
6786         for (i = 0, j = 0; i < 256; i++) {
6787             if (!tbl->map[i]) {
6788                 if (j == rlen) {
6789                     if (del)
6790                         tbl->map[i] = -2;
6791                     else if (rlen)
6792                         tbl->map[i] = r[j-1];
6793                     else
6794                         tbl->map[i] = (short)i;
6795                 }
6796                 else {
6797                     tbl->map[i] = r[j++];
6798                 }
6799                 if (   tbl->map[i] >= 0
6800                     &&  UVCHR_IS_INVARIANT((UV)i)
6801                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6802                 )
6803                     grows = TRUE;
6804             }
6805         }
6806
6807         ASSUME(j <= rlen);
6808         excess = rlen - j;
6809
6810         if (excess) {
6811             /* More replacement chars than search chars:
6812              * store excess replacement chars at end of main table.
6813              */
6814
6815             struct_size += excess;
6816             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6817                         struct_size + excess * sizeof(short));
6818             tbl->size += excess;
6819             cPVOPo->op_pv = (char*)tbl;
6820
6821             for (i = 0; i < excess; i++)
6822                 tbl->map[i + 256] = r[j+i];
6823         }
6824         else {
6825             /* no more replacement chars than search chars */
6826             if (!rlen && !del && !squash)
6827                 o->op_private |= OPpTRANS_IDENTICAL;
6828         }
6829
6830         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6831     }
6832     else {
6833         if (!rlen && !del) {
6834             r = t; rlen = tlen;
6835             if (!squash)
6836                 o->op_private |= OPpTRANS_IDENTICAL;
6837         }
6838         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6839             o->op_private |= OPpTRANS_IDENTICAL;
6840         }
6841
6842         for (i = 0; i < 256; i++)
6843             tbl->map[i] = -1;
6844         for (i = 0, j = 0; i < tlen; i++,j++) {
6845             if (j >= rlen) {
6846                 if (del) {
6847                     if (tbl->map[t[i]] == -1)
6848                         tbl->map[t[i]] = -2;
6849                     continue;
6850                 }
6851                 --j;
6852             }
6853             if (tbl->map[t[i]] == -1) {
6854                 if (     UVCHR_IS_INVARIANT(t[i])
6855                     && ! UVCHR_IS_INVARIANT(r[j]))
6856                     grows = TRUE;
6857                 tbl->map[t[i]] = r[j];
6858             }
6859         }
6860         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6861     }
6862
6863     /* both non-utf8 and utf8 code paths end up here */
6864
6865   warnins:
6866     if(del && rlen == tlen) {
6867         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6868     } else if(rlen > tlen && !complement) {
6869         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6870     }
6871
6872     if (grows)
6873         o->op_private |= OPpTRANS_GROWS;
6874     op_free(expr);
6875     op_free(repl);
6876
6877     return o;
6878 }
6879
6880
6881 /*
6882 =for apidoc newPMOP
6883
6884 Constructs, checks, and returns an op of any pattern matching type.
6885 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6886 and, shifted up eight bits, the eight bits of C<op_private>.
6887
6888 =cut
6889 */
6890
6891 OP *
6892 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6893 {
6894     dVAR;
6895     PMOP *pmop;
6896
6897     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6898         || type == OP_CUSTOM);
6899
6900     NewOp(1101, pmop, 1, PMOP);
6901     OpTYPE_set(pmop, type);
6902     pmop->op_flags = (U8)flags;
6903     pmop->op_private = (U8)(0 | (flags >> 8));
6904     if (PL_opargs[type] & OA_RETSCALAR)
6905         scalar((OP *)pmop);
6906
6907     if (PL_hints & HINT_RE_TAINT)
6908         pmop->op_pmflags |= PMf_RETAINT;
6909 #ifdef USE_LOCALE_CTYPE
6910     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6911         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6912     }
6913     else
6914 #endif
6915          if (IN_UNI_8_BIT) {
6916         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6917     }
6918     if (PL_hints & HINT_RE_FLAGS) {
6919         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6920          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6921         );
6922         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6923         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6924          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6925         );
6926         if (reflags && SvOK(reflags)) {
6927             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6928         }
6929     }
6930
6931
6932 #ifdef USE_ITHREADS
6933     assert(SvPOK(PL_regex_pad[0]));
6934     if (SvCUR(PL_regex_pad[0])) {
6935         /* Pop off the "packed" IV from the end.  */
6936         SV *const repointer_list = PL_regex_pad[0];
6937         const char *p = SvEND(repointer_list) - sizeof(IV);
6938         const IV offset = *((IV*)p);
6939
6940         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6941
6942         SvEND_set(repointer_list, p);
6943
6944         pmop->op_pmoffset = offset;
6945         /* This slot should be free, so assert this:  */
6946         assert(PL_regex_pad[offset] == &PL_sv_undef);
6947     } else {
6948         SV * const repointer = &PL_sv_undef;
6949         av_push(PL_regex_padav, repointer);
6950         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6951         PL_regex_pad = AvARRAY(PL_regex_padav);
6952     }
6953 #endif
6954
6955     return CHECKOP(type, pmop);
6956 }
6957
6958 static void
6959 S_set_haseval(pTHX)
6960 {
6961     PADOFFSET i = 1;
6962     PL_cv_has_eval = 1;
6963     /* Any pad names in scope are potentially lvalues.  */
6964     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6965         PADNAME *pn = PAD_COMPNAME_SV(i);
6966         if (!pn || !PadnameLEN(pn))
6967             continue;
6968         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6969             S_mark_padname_lvalue(aTHX_ pn);
6970     }
6971 }
6972
6973 /* Given some sort of match op o, and an expression expr containing a
6974  * pattern, either compile expr into a regex and attach it to o (if it's
6975  * constant), or convert expr into a runtime regcomp op sequence (if it's
6976  * not)
6977  *
6978  * Flags currently has 2 bits of meaning:
6979  * 1: isreg indicates that the pattern is part of a regex construct, eg
6980  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6981  * split "pattern", which aren't. In the former case, expr will be a list
6982  * if the pattern contains more than one term (eg /a$b/).
6983  * 2: The pattern is for a split.
6984  *
6985  * When the pattern has been compiled within a new anon CV (for
6986  * qr/(?{...})/ ), then floor indicates the savestack level just before
6987  * the new sub was created
6988  */
6989
6990 OP *
6991 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6992 {
6993     PMOP *pm;
6994     LOGOP *rcop;
6995     I32 repl_has_vars = 0;
6996     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6997     bool is_compiletime;
6998     bool has_code;
6999     bool isreg    = cBOOL(flags & 1);
7000     bool is_split = cBOOL(flags & 2);
7001
7002     PERL_ARGS_ASSERT_PMRUNTIME;
7003
7004     if (is_trans) {
7005         return pmtrans(o, expr, repl);
7006     }
7007
7008     /* find whether we have any runtime or code elements;
7009      * at the same time, temporarily set the op_next of each DO block;
7010      * then when we LINKLIST, this will cause the DO blocks to be excluded
7011      * from the op_next chain (and from having LINKLIST recursively
7012      * applied to them). We fix up the DOs specially later */
7013
7014     is_compiletime = 1;
7015     has_code = 0;
7016     if (expr->op_type == OP_LIST) {
7017         OP *o;
7018         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7019             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
7020                 has_code = 1;
7021                 assert(!o->op_next);
7022                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
7023                     assert(PL_parser && PL_parser->error_count);
7024                     /* This can happen with qr/ (?{(^{})/.  Just fake up
7025                        the op we were expecting to see, to avoid crashing
7026                        elsewhere.  */
7027                     op_sibling_splice(expr, o, 0,
7028                                       newSVOP(OP_CONST, 0, &PL_sv_no));
7029                 }
7030                 o->op_next = OpSIBLING(o);
7031             }
7032             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7033                 is_compiletime = 0;
7034         }
7035     }
7036     else if (expr->op_type != OP_CONST)
7037         is_compiletime = 0;
7038
7039     LINKLIST(expr);
7040
7041     /* fix up DO blocks; treat each one as a separate little sub;
7042      * also, mark any arrays as LIST/REF */
7043
7044     if (expr->op_type == OP_LIST) {
7045         OP *o;
7046         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7047
7048             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7049                 assert( !(o->op_flags  & OPf_WANT));
7050                 /* push the array rather than its contents. The regex
7051                  * engine will retrieve and join the elements later */
7052                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7053                 continue;
7054             }
7055
7056             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7057                 continue;
7058             o->op_next = NULL; /* undo temporary hack from above */
7059             scalar(o);
7060             LINKLIST(o);
7061             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7062                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7063                 /* skip ENTER */
7064                 assert(leaveop->op_first->op_type == OP_ENTER);
7065                 assert(OpHAS_SIBLING(leaveop->op_first));
7066                 o->op_next = OpSIBLING(leaveop->op_first);
7067                 /* skip leave */
7068                 assert(leaveop->op_flags & OPf_KIDS);
7069                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7070                 leaveop->op_next = NULL; /* stop on last op */
7071                 op_null((OP*)leaveop);
7072             }
7073             else {
7074                 /* skip SCOPE */
7075                 OP *scope = cLISTOPo->op_first;
7076                 assert(scope->op_type == OP_SCOPE);
7077                 assert(scope->op_flags & OPf_KIDS);
7078                 scope->op_next = NULL; /* stop on last op */
7079                 op_null(scope);
7080             }
7081
7082             /* XXX optimize_optree() must be called on o before
7083              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7084              * currently cope with a peephole-optimised optree.
7085              * Calling optimize_optree() here ensures that condition
7086              * is met, but may mean optimize_optree() is applied
7087              * to the same optree later (where hopefully it won't do any
7088              * harm as it can't convert an op to multiconcat if it's
7089              * already been converted */
7090             optimize_optree(o);
7091
7092             /* have to peep the DOs individually as we've removed it from
7093              * the op_next chain */
7094             CALL_PEEP(o);
7095             S_prune_chain_head(&(o->op_next));
7096             if (is_compiletime)
7097                 /* runtime finalizes as part of finalizing whole tree */
7098                 finalize_optree(o);
7099         }
7100     }
7101     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7102         assert( !(expr->op_flags  & OPf_WANT));
7103         /* push the array rather than its contents. The regex
7104          * engine will retrieve and join the elements later */
7105         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7106     }
7107
7108     PL_hints |= HINT_BLOCK_SCOPE;
7109     pm = (PMOP*)o;
7110     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7111
7112     if (is_compiletime) {
7113         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7114         regexp_engine const *eng = current_re_engine();
7115
7116         if (is_split) {
7117             /* make engine handle split ' ' specially */
7118             pm->op_pmflags |= PMf_SPLIT;
7119             rx_flags |= RXf_SPLIT;
7120         }
7121
7122         if (!has_code || !eng->op_comp) {
7123             /* compile-time simple constant pattern */
7124
7125             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7126                 /* whoops! we guessed that a qr// had a code block, but we
7127                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7128                  * that isn't required now. Note that we have to be pretty
7129                  * confident that nothing used that CV's pad while the
7130                  * regex was parsed, except maybe op targets for \Q etc.
7131                  * If there were any op targets, though, they should have
7132                  * been stolen by constant folding.
7133                  */
7134 #ifdef DEBUGGING
7135                 SSize_t i = 0;
7136                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7137                 while (++i <= AvFILLp(PL_comppad)) {
7138 #  ifdef USE_PAD_RESET
7139                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7140                      * folded constant with a fresh padtmp */
7141                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7142 #  else
7143                     assert(!PL_curpad[i]);
7144 #  endif
7145                 }
7146 #endif
7147                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7148                  * outer CV (the one whose slab holds the pm op). The
7149                  * inner CV (which holds expr) will be freed later, once
7150                  * all the entries on the parse stack have been popped on
7151                  * return from this function. Which is why its safe to
7152                  * call op_free(expr) below.
7153                  */
7154                 LEAVE_SCOPE(floor);
7155                 pm->op_pmflags &= ~PMf_HAS_CV;
7156             }
7157
7158             /* Skip compiling if parser found an error for this pattern */
7159             if (pm->op_pmflags & PMf_HAS_ERROR) {
7160                 return o;
7161             }
7162
7163             PM_SETRE(pm,
7164                 eng->op_comp
7165                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7166                                         rx_flags, pm->op_pmflags)
7167                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7168                                         rx_flags, pm->op_pmflags)
7169             );
7170             op_free(expr);
7171         }
7172         else {
7173             /* compile-time pattern that includes literal code blocks */
7174
7175             REGEXP* re;
7176
7177             /* Skip compiling if parser found an error for this pattern */
7178             if (pm->op_pmflags & PMf_HAS_ERROR) {
7179                 return o;
7180             }
7181
7182             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7183                         rx_flags,
7184                         (pm->op_pmflags |
7185                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7186                     );
7187             PM_SETRE(pm, re);
7188             if (pm->op_pmflags & PMf_HAS_CV) {
7189                 CV *cv;
7190                 /* this QR op (and the anon sub we embed it in) is never
7191                  * actually executed. It's just a placeholder where we can
7192                  * squirrel away expr in op_code_list without the peephole
7193                  * optimiser etc processing it for a second time */
7194                 OP *qr = newPMOP(OP_QR, 0);
7195                 ((PMOP*)qr)->op_code_list = expr;
7196
7197                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7198                 SvREFCNT_inc_simple_void(PL_compcv);
7199                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7200                 ReANY(re)->qr_anoncv = cv;
7201
7202                 /* attach the anon CV to the pad so that
7203                  * pad_fixup_inner_anons() can find it */
7204                 (void)pad_add_anon(cv, o->op_type);
7205                 SvREFCNT_inc_simple_void(cv);
7206             }
7207             else {
7208                 pm->op_code_list = expr;
7209             }
7210         }
7211     }
7212     else {
7213         /* runtime pattern: build chain of regcomp etc ops */
7214         bool reglist;
7215         PADOFFSET cv_targ = 0;
7216
7217         reglist = isreg && expr->op_type == OP_LIST;
7218         if (reglist)
7219             op_null(expr);
7220
7221         if (has_code) {
7222             pm->op_code_list = expr;
7223             /* don't free op_code_list; its ops are embedded elsewhere too */
7224             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7225         }
7226
7227         if (is_split)
7228             /* make engine handle split ' ' specially */
7229             pm->op_pmflags |= PMf_SPLIT;
7230
7231         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7232          * to allow its op_next to be pointed past the regcomp and
7233          * preceding stacking ops;
7234          * OP_REGCRESET is there to reset taint before executing the
7235          * stacking ops */
7236         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7237             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7238
7239         if (pm->op_pmflags & PMf_HAS_CV) {
7240             /* we have a runtime qr with literal code. This means
7241              * that the qr// has been wrapped in a new CV, which
7242              * means that runtime consts, vars etc will have been compiled
7243              * against a new pad. So... we need to execute those ops
7244              * within the environment of the new CV. So wrap them in a call
7245              * to a new anon sub. i.e. for
7246              *
7247              *     qr/a$b(?{...})/,
7248              *
7249              * we build an anon sub that looks like
7250              *
7251              *     sub { "a", $b, '(?{...})' }
7252              *
7253              * and call it, passing the returned list to regcomp.
7254              * Or to put it another way, the list of ops that get executed
7255              * are:
7256              *
7257              *     normal              PMf_HAS_CV
7258              *     ------              -------------------
7259              *                         pushmark (for regcomp)
7260              *                         pushmark (for entersub)
7261              *                         anoncode
7262              *                         srefgen
7263              *                         entersub
7264              *     regcreset                  regcreset
7265              *     pushmark                   pushmark
7266              *     const("a")                 const("a")
7267              *     gvsv(b)                    gvsv(b)
7268              *     const("(?{...})")          const("(?{...})")
7269              *                                leavesub
7270              *     regcomp             regcomp
7271              */
7272
7273             SvREFCNT_inc_simple_void(PL_compcv);
7274             CvLVALUE_on(PL_compcv);
7275             /* these lines are just an unrolled newANONATTRSUB */
7276             expr = newSVOP(OP_ANONCODE, 0,
7277                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7278             cv_targ = expr->op_targ;
7279             expr = newUNOP(OP_REFGEN, 0, expr);
7280
7281             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7282         }
7283
7284         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7285         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7286                            | (reglist ? OPf_STACKED : 0);
7287         rcop->op_targ = cv_targ;
7288
7289         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7290         if (PL_hints & HINT_RE_EVAL)
7291             S_set_haseval(aTHX);
7292
7293         /* establish postfix order */
7294         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7295             LINKLIST(expr);
7296             rcop->op_next = expr;
7297             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7298         }
7299         else {
7300             rcop->op_next = LINKLIST(expr);
7301             expr->op_next = (OP*)rcop;
7302         }
7303
7304         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7305     }
7306
7307     if (repl) {
7308         OP *curop = repl;
7309         bool konst;
7310         /* If we are looking at s//.../e with a single statement, get past
7311            the implicit do{}. */
7312         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7313              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7314              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7315          {
7316             OP *sib;
7317             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7318             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7319              && !OpHAS_SIBLING(sib))
7320                 curop = sib;
7321         }
7322         if (curop->op_type == OP_CONST)
7323             konst = TRUE;
7324         else if (( (curop->op_type == OP_RV2SV ||
7325                     curop->op_type == OP_RV2AV ||
7326                     curop->op_type == OP_RV2HV ||
7327                     curop->op_type == OP_RV2GV)
7328                    && cUNOPx(curop)->op_first
7329                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7330                 || curop->op_type == OP_PADSV
7331                 || curop->op_type == OP_PADAV
7332                 || curop->op_type == OP_PADHV
7333                 || curop->op_type == OP_PADANY) {
7334             repl_has_vars = 1;
7335             konst = TRUE;
7336         }
7337         else konst = FALSE;
7338         if (konst
7339             && !(repl_has_vars
7340                  && (!PM_GETRE(pm)
7341                      || !RX_PRELEN(PM_GETRE(pm))
7342                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7343         {
7344             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7345             op_prepend_elem(o->op_type, scalar(repl), o);
7346         }
7347         else {
7348             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7349             rcop->op_private = 1;
7350
7351             /* establish postfix order */
7352             rcop->op_next = LINKLIST(repl);
7353             repl->op_next = (OP*)rcop;
7354
7355             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7356             assert(!(pm->op_pmflags & PMf_ONCE));
7357             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7358             rcop->op_next = 0;
7359         }
7360     }
7361
7362     return (OP*)pm;
7363 }
7364
7365 /*
7366 =for apidoc newSVOP
7367
7368 Constructs, checks, and returns an op of any type that involves an
7369 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7370 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7371 takes ownership of one reference to it.
7372
7373 =cut
7374 */
7375
7376 OP *
7377 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7378 {
7379     dVAR;
7380     SVOP *svop;
7381
7382     PERL_ARGS_ASSERT_NEWSVOP;
7383
7384     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7385         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7386         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7387         || type == OP_CUSTOM);
7388
7389     NewOp(1101, svop, 1, SVOP);
7390     OpTYPE_set(svop, type);
7391     svop->op_sv = sv;
7392     svop->op_next = (OP*)svop;
7393     svop->op_flags = (U8)flags;
7394     svop->op_private = (U8)(0 | (flags >> 8));
7395     if (PL_opargs[type] & OA_RETSCALAR)
7396         scalar((OP*)svop);
7397     if (PL_opargs[type] & OA_TARGET)
7398         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7399     return CHECKOP(type, svop);
7400 }
7401
7402 /*
7403 =for apidoc newDEFSVOP
7404
7405 Constructs and returns an op to access C<$_>.
7406
7407 =cut
7408 */
7409
7410 OP *
7411 Perl_newDEFSVOP(pTHX)
7412 {
7413         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7414 }
7415
7416 #ifdef USE_ITHREADS
7417
7418 /*
7419 =for apidoc newPADOP
7420
7421 Constructs, checks, and returns an op of any type that involves a
7422 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7423 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7424 is populated with C<sv>; this function takes ownership of one reference
7425 to it.
7426
7427 This function only exists if Perl has been compiled to use ithreads.
7428
7429 =cut
7430 */
7431
7432 OP *
7433 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7434 {
7435     dVAR;
7436     PADOP *padop;
7437
7438     PERL_ARGS_ASSERT_NEWPADOP;
7439
7440     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7441         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7442         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7443         || type == OP_CUSTOM);
7444
7445     NewOp(1101, padop, 1, PADOP);
7446     OpTYPE_set(padop, type);
7447     padop->op_padix =
7448         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7449     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7450     PAD_SETSV(padop->op_padix, sv);
7451     assert(sv);
7452     padop->op_next = (OP*)padop;
7453     padop->op_flags = (U8)flags;
7454     if (PL_opargs[type] & OA_RETSCALAR)
7455         scalar((OP*)padop);
7456     if (PL_opargs[type] & OA_TARGET)
7457         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7458     return CHECKOP(type, padop);
7459 }
7460
7461 #endif /* USE_ITHREADS */
7462
7463 /*
7464 =for apidoc newGVOP
7465
7466 Constructs, checks, and returns an op of any type that involves an
7467 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7468 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7469 reference; calling this function does not transfer ownership of any
7470 reference to it.
7471
7472 =cut
7473 */
7474
7475 OP *
7476 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7477 {
7478     PERL_ARGS_ASSERT_NEWGVOP;
7479
7480 #ifdef USE_ITHREADS
7481     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7482 #else
7483     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7484 #endif
7485 }
7486
7487 /*
7488 =for apidoc newPVOP
7489
7490 Constructs, checks, and returns an op of any type that involves an
7491 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7492 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7493 Depending on the op type, the memory referenced by C<pv> may be freed
7494 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7495 have been allocated using C<PerlMemShared_malloc>.
7496
7497 =cut
7498 */
7499
7500 OP *
7501 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7502 {
7503     dVAR;
7504     const bool utf8 = cBOOL(flags & SVf_UTF8);
7505     PVOP *pvop;
7506
7507     flags &= ~SVf_UTF8;
7508
7509     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7510         || type == OP_RUNCV || type == OP_CUSTOM
7511         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7512
7513     NewOp(1101, pvop, 1, PVOP);
7514     OpTYPE_set(pvop, type);
7515     pvop->op_pv = pv;
7516     pvop->op_next = (OP*)pvop;
7517     pvop->op_flags = (U8)flags;
7518     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7519     if (PL_opargs[type] & OA_RETSCALAR)
7520         scalar((OP*)pvop);
7521     if (PL_opargs[type] & OA_TARGET)
7522         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7523     return CHECKOP(type, pvop);
7524 }
7525
7526 void
7527 Perl_package(pTHX_ OP *o)
7528 {
7529     SV *const sv = cSVOPo->op_sv;
7530
7531     PERL_ARGS_ASSERT_PACKAGE;
7532
7533     SAVEGENERICSV(PL_curstash);
7534     save_item(PL_curstname);
7535
7536     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7537
7538     sv_setsv(PL_curstname, sv);
7539
7540     PL_hints |= HINT_BLOCK_SCOPE;
7541     PL_parser->copline = NOLINE;
7542
7543     op_free(o);
7544 }
7545
7546 void
7547 Perl_package_version( pTHX_ OP *v )
7548 {
7549     U32 savehints = PL_hints;
7550     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7551     PL_hints &= ~HINT_STRICT_VARS;
7552     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7553     PL_hints = savehints;
7554     op_free(v);
7555 }
7556
7557 void
7558 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7559 {
7560     OP *pack;
7561     OP *imop;
7562     OP *veop;
7563     SV *use_version = NULL;
7564
7565     PERL_ARGS_ASSERT_UTILIZE;
7566
7567     if (idop->op_type != OP_CONST)
7568         Perl_croak(aTHX_ "Module name must be constant");
7569
7570     veop = NULL;
7571
7572     if (version) {
7573         SV * const vesv = ((SVOP*)version)->op_sv;
7574
7575         if (!arg && !SvNIOKp(vesv)) {
7576             arg = version;
7577         }
7578         else {
7579             OP *pack;
7580             SV *meth;
7581
7582             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7583                 Perl_croak(aTHX_ "Version number must be a constant number");
7584
7585             /* Make copy of idop so we don't free it twice */
7586             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7587
7588             /* Fake up a method call to VERSION */
7589             meth = newSVpvs_share("VERSION");
7590             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7591                             op_append_elem(OP_LIST,
7592                                         op_prepend_elem(OP_LIST, pack, version),
7593                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7594         }
7595     }
7596
7597     /* Fake up an import/unimport */
7598     if (arg && arg->op_type == OP_STUB) {
7599         imop = arg;             /* no import on explicit () */
7600     }
7601     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7602         imop = NULL;            /* use 5.0; */
7603         if (aver)
7604             use_version = ((SVOP*)idop)->op_sv;
7605         else
7606             idop->op_private |= OPpCONST_NOVER;
7607     }
7608     else {
7609         SV *meth;
7610
7611         /* Make copy of idop so we don't free it twice */
7612         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7613
7614         /* Fake up a method call to import/unimport */
7615         meth = aver
7616             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7617         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7618                        op_append_elem(OP_LIST,
7619                                    op_prepend_elem(OP_LIST, pack, arg),
7620                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7621                        ));
7622     }
7623
7624     /* Fake up the BEGIN {}, which does its thing immediately. */
7625     newATTRSUB(floor,
7626         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7627         NULL,
7628         NULL,
7629         op_append_elem(OP_LINESEQ,
7630             op_append_elem(OP_LINESEQ,
7631                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7632                 newSTATEOP(0, NULL, veop)),
7633             newSTATEOP(0, NULL, imop) ));
7634
7635     if (use_version) {
7636         /* Enable the
7637          * feature bundle that corresponds to the required version. */
7638         use_version = sv_2mortal(new_version(use_version));
7639         S_enable_feature_bundle(aTHX_ use_version);
7640
7641         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7642         if (vcmp(use_version,
7643                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7644             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7645                 PL_hints |= HINT_STRICT_REFS;
7646             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7647                 PL_hints |= HINT_STRICT_SUBS;
7648             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7649                 PL_hints |= HINT_STRICT_VARS;
7650         }
7651         /* otherwise they are off */
7652         else {
7653             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7654                 PL_hints &= ~HINT_STRICT_REFS;
7655             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7656                 PL_hints &= ~HINT_STRICT_SUBS;
7657             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7658                 PL_hints &= ~HINT_STRICT_VARS;
7659         }
7660     }
7661
7662     /* The "did you use incorrect case?" warning used to be here.
7663      * The problem is that on case-insensitive filesystems one
7664      * might get false positives for "use" (and "require"):
7665      * "use Strict" or "require CARP" will work.  This causes
7666      * portability problems for the script: in case-strict
7667      * filesystems the script will stop working.
7668      *
7669      * The "incorrect case" warning checked whether "use Foo"
7670      * imported "Foo" to your namespace, but that is wrong, too:
7671      * there is no requirement nor promise in the language that
7672      * a Foo.pm should or would contain anything in package "Foo".
7673      *
7674      * There is very little Configure-wise that can be done, either:
7675      * the case-sensitivity of the build filesystem of Perl does not
7676      * help in guessing the case-sensitivity of the runtime environment.
7677      */
7678
7679     PL_hints |= HINT_BLOCK_SCOPE;
7680     PL_parser->copline = NOLINE;
7681     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7682 }
7683
7684 /*
7685 =head1 Embedding Functions
7686
7687 =for apidoc load_module
7688
7689 Loads the module whose name is pointed to by the string part of C<name>.
7690 Note that the actual module name, not its filename, should be given.
7691 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7692 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7693 trailing arguments can be used to specify arguments to the module's C<import()>
7694 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7695 on the flags. The flags argument is a bitwise-ORed collection of any of
7696 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7697 (or 0 for no flags).
7698
7699 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7700 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7701 the trailing optional arguments may be omitted entirely. Otherwise, if
7702 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7703 exactly one C<OP*>, containing the op tree that produces the relevant import
7704 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7705 will be used as import arguments; and the list must be terminated with C<(SV*)
7706 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7707 set, the trailing C<NULL> pointer is needed even if no import arguments are
7708 desired. The reference count for each specified C<SV*> argument is
7709 decremented. In addition, the C<name> argument is modified.
7710
7711 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7712 than C<use>.
7713
7714 =cut */
7715
7716 void
7717 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7718 {
7719     va_list args;
7720
7721     PERL_ARGS_ASSERT_LOAD_MODULE;
7722
7723     va_start(args, ver);
7724     vload_module(flags, name, ver, &args);
7725     va_end(args);
7726 }
7727
7728 #ifdef PERL_IMPLICIT_CONTEXT
7729 void
7730 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7731 {
7732     dTHX;
7733     va_list args;
7734     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7735     va_start(args, ver);
7736     vload_module(flags, name, ver, &args);
7737     va_end(args);
7738 }
7739 #endif
7740
7741 void
7742 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7743 {
7744     OP *veop, *imop;
7745     OP * modname;
7746     I32 floor;
7747
7748     PERL_ARGS_ASSERT_VLOAD_MODULE;
7749
7750     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7751      * that it has a PL_parser to play with while doing that, and also
7752      * that it doesn't mess with any existing parser, by creating a tmp
7753      * new parser with lex_start(). This won't actually be used for much,
7754      * since pp_require() will create another parser for the real work.
7755      * The ENTER/LEAVE pair protect callers from any side effects of use.
7756      *
7757      * start_subparse() creates a new PL_compcv. This means that any ops
7758      * allocated below will be allocated from that CV's op slab, and so
7759      * will be automatically freed if the utilise() fails
7760      */
7761
7762     ENTER;
7763     SAVEVPTR(PL_curcop);
7764     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7765     floor = start_subparse(FALSE, 0);
7766
7767     modname = newSVOP(OP_CONST, 0, name);
7768     modname->op_private |= OPpCONST_BARE;
7769     if (ver) {
7770         veop = newSVOP(OP_CONST, 0, ver);
7771     }
7772     else
7773         veop = NULL;
7774     if (flags & PERL_LOADMOD_NOIMPORT) {
7775         imop = sawparens(newNULLLIST());
7776     }
7777     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7778         imop = va_arg(*args, OP*);
7779     }
7780     else {
7781         SV *sv;
7782         imop = NULL;
7783         sv = va_arg(*args, SV*);
7784         while (sv) {
7785             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7786             sv = va_arg(*args, SV*);
7787         }
7788     }
7789
7790     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
7791     LEAVE;
7792 }
7793
7794 PERL_STATIC_INLINE OP *
7795 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7796 {
7797     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7798                    newLISTOP(OP_LIST, 0, arg,
7799                              newUNOP(OP_RV2CV, 0,
7800                                      newGVOP(OP_GV, 0, gv))));
7801 }
7802
7803 OP *
7804 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7805 {
7806     OP *doop;
7807     GV *gv;
7808
7809     PERL_ARGS_ASSERT_DOFILE;
7810
7811     if (!force_builtin && (gv = gv_override("do", 2))) {
7812         doop = S_new_entersubop(aTHX_ gv, term);
7813     }
7814     else {
7815         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7816     }
7817     return doop;
7818 }
7819
7820 /*
7821 =head1 Optree construction
7822
7823 =for apidoc newSLICEOP
7824
7825 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7826 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7827 be set automatically, and, shifted up eight bits, the eight bits of
7828 C<op_private>, except that the bit with value 1 or 2 is automatically
7829 set as required.  C<listval> and C<subscript> supply the parameters of
7830 the slice; they are consumed by this function and become part of the
7831 constructed op tree.
7832
7833 =cut
7834 */
7835
7836 OP *
7837 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7838 {
7839     return newBINOP(OP_LSLICE, flags,
7840             list(force_list(subscript, 1)),
7841             list(force_list(listval,   1)) );
7842 }
7843
7844 #define ASSIGN_LIST   1
7845 #define ASSIGN_REF    2
7846
7847 STATIC I32
7848 S_assignment_type(pTHX_ const OP *o)
7849 {
7850     unsigned type;
7851     U8 flags;
7852     U8 ret;
7853
7854     if (!o)
7855         return TRUE;
7856
7857     if (o->op_type == OP_SREFGEN)
7858     {
7859         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7860         type = kid->op_type;
7861         flags = o->op_flags | kid->op_flags;
7862         if (!(flags & OPf_PARENS)
7863           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7864               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7865             return ASSIGN_REF;
7866         ret = ASSIGN_REF;
7867     } else {
7868         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7869             o = cUNOPo->op_first;
7870         flags = o->op_flags;
7871         type = o->op_type;
7872         ret = 0;
7873     }
7874
7875     if (type == OP_COND_EXPR) {
7876         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7877         const I32 t = assignment_type(sib);
7878         const I32 f = assignment_type(OpSIBLING(sib));
7879
7880         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7881             return ASSIGN_LIST;
7882         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7883             yyerror("Assignment to both a list and a scalar");
7884         return FALSE;
7885     }
7886
7887     if (type == OP_LIST &&
7888         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7889         o->op_private & OPpLVAL_INTRO)
7890         return ret;
7891
7892     if (type == OP_LIST || flags & OPf_PARENS ||
7893         type == OP_RV2AV || type == OP_RV2HV ||
7894         type == OP_ASLICE || type == OP_HSLICE ||
7895         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7896         return TRUE;
7897
7898     if (type == OP_PADAV || type == OP_PADHV)
7899         return TRUE;
7900
7901     if (type == OP_RV2SV)
7902         return ret;
7903
7904     return ret;
7905 }
7906
7907 static OP *
7908 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7909 {
7910     dVAR;
7911     const PADOFFSET target = padop->op_targ;
7912     OP *const other = newOP(OP_PADSV,
7913                             padop->op_flags
7914                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7915     OP *const first = newOP(OP_NULL, 0);
7916     OP *const nullop = newCONDOP(0, first, initop, other);
7917     /* XXX targlex disabled for now; see ticket #124160
7918         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7919      */
7920     OP *const condop = first->op_next;
7921
7922     OpTYPE_set(condop, OP_ONCE);
7923     other->op_targ = target;
7924     nullop->op_flags |= OPf_WANT_SCALAR;
7925
7926     /* Store the initializedness of state vars in a separate
7927        pad entry.  */
7928     condop->op_targ =
7929       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7930     /* hijacking PADSTALE for uninitialized state variables */
7931     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7932
7933     return nullop;
7934 }
7935
7936 /*
7937 =for apidoc newASSIGNOP
7938
7939 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7940 supply the parameters of the assignment; they are consumed by this
7941 function and become part of the constructed op tree.
7942
7943 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7944 a suitable conditional optree is constructed.  If C<optype> is the opcode
7945 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7946 performs the binary operation and assigns the result to the left argument.
7947 Either way, if C<optype> is non-zero then C<flags> has no effect.
7948
7949 If C<optype> is zero, then a plain scalar or list assignment is
7950 constructed.  Which type of assignment it is is automatically determined.
7951 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7952 will be set automatically, and, shifted up eight bits, the eight bits
7953 of C<op_private>, except that the bit with value 1 or 2 is automatically
7954 set as required.
7955
7956 =cut
7957 */
7958
7959 OP *
7960 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7961 {
7962     OP *o;
7963     I32 assign_type;
7964
7965     if (optype) {
7966         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7967             right = scalar(right);
7968             return newLOGOP(optype, 0,
7969                 op_lvalue(scalar(left), optype),
7970                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7971         }
7972         else {
7973             return newBINOP(optype, OPf_STACKED,
7974                 op_lvalue(scalar(left), optype), scalar(right));
7975         }
7976     }
7977
7978     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7979         OP *state_var_op = NULL;
7980         static const char no_list_state[] = "Initialization of state variables"
7981             " in list currently forbidden";
7982         OP *curop;
7983
7984         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7985             left->op_private &= ~ OPpSLICEWARNING;
7986
7987         PL_modcount = 0;
7988         left = op_lvalue(left, OP_AASSIGN);
7989         curop = list(force_list(left, 1));
7990         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7991         o->op_private = (U8)(0 | (flags >> 8));
7992
7993         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7994         {
7995             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7996             if (!(left->op_flags & OPf_PARENS) &&
7997                     lop->op_type == OP_PUSHMARK &&
7998                     (vop = OpSIBLING(lop)) &&
7999                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8000                     !(vop->op_flags & OPf_PARENS) &&
8001                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8002                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
8003                     (eop = OpSIBLING(vop)) &&
8004                     eop->op_type == OP_ENTERSUB &&
8005                     !OpHAS_SIBLING(eop)) {
8006                 state_var_op = vop;
8007             } else {
8008                 while (lop) {
8009                     if ((lop->op_type == OP_PADSV ||
8010                          lop->op_type == OP_PADAV ||
8011                          lop->op_type == OP_PADHV ||
8012                          lop->op_type == OP_PADANY)
8013                       && (lop->op_private & OPpPAD_STATE)
8014                     )
8015                         yyerror(no_list_state);
8016                     lop = OpSIBLING(lop);
8017                 }
8018             }
8019         }
8020         else if (  (left->op_private & OPpLVAL_INTRO)
8021                 && (left->op_private & OPpPAD_STATE)
8022                 && (   left->op_type == OP_PADSV
8023                     || left->op_type == OP_PADAV
8024                     || left->op_type == OP_PADHV
8025                     || left->op_type == OP_PADANY)
8026         ) {
8027                 /* All single variable list context state assignments, hence
8028                    state ($a) = ...
8029                    (state $a) = ...
8030                    state @a = ...
8031                    state (@a) = ...
8032                    (state @a) = ...
8033                    state %a = ...
8034                    state (%a) = ...
8035                    (state %a) = ...
8036                 */
8037                 if (left->op_flags & OPf_PARENS)
8038                     yyerror(no_list_state);
8039                 else
8040                     state_var_op = left;
8041         }
8042
8043         /* optimise @a = split(...) into:
8044         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8045         * @a, my @a, local @a:  split(...)          (where @a is attached to
8046         *                                            the split op itself)
8047         */
8048
8049         if (   right
8050             && right->op_type == OP_SPLIT
8051             /* don't do twice, e.g. @b = (@a = split) */
8052             && !(right->op_private & OPpSPLIT_ASSIGN))
8053         {
8054             OP *gvop = NULL;
8055
8056             if (   (  left->op_type == OP_RV2AV
8057                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8058                 || left->op_type == OP_PADAV)
8059             {
8060                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8061                 OP *tmpop;
8062                 if (gvop) {
8063 #ifdef USE_ITHREADS
8064                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8065                         = cPADOPx(gvop)->op_padix;
8066                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
8067 #else
8068                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8069                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8070                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
8071 #endif
8072                     right->op_private |=
8073                         left->op_private & OPpOUR_INTRO;
8074                 }
8075                 else {
8076                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8077                     left->op_targ = 0;  /* steal it */
8078                     right->op_private |= OPpSPLIT_LEX;
8079                 }
8080                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8081
8082               detach_split:
8083                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
8084                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8085                 assert(OpSIBLING(tmpop) == right);
8086                 assert(!OpHAS_SIBLING(right));
8087                 /* detach the split subtreee from the o tree,
8088                  * then free the residual o tree */
8089                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8090                 op_free(o);                     /* blow off assign */
8091                 right->op_private |= OPpSPLIT_ASSIGN;
8092                 right->op_flags &= ~OPf_WANT;
8093                         /* "I don't know and I don't care." */
8094                 return right;
8095             }
8096             else if (left->op_type == OP_RV2AV) {
8097                 /* @{expr} */
8098
8099                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8100                 assert(OpSIBLING(pushop) == left);
8101                 /* Detach the array ...  */
8102                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8103                 /* ... and attach it to the split.  */
8104                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8105                                   0, left);
8106                 right->op_flags |= OPf_STACKED;
8107                 /* Detach split and expunge aassign as above.  */
8108                 goto detach_split;
8109             }
8110             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8111                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8112             {
8113                 /* convert split(...,0) to split(..., PL_modcount+1) */
8114                 SV ** const svp =
8115                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8116                 SV * const sv = *svp;
8117                 if (SvIOK(sv) && SvIVX(sv) == 0)
8118                 {
8119                   if (right->op_private & OPpSPLIT_IMPLIM) {
8120                     /* our own SV, created in ck_split */
8121                     SvREADONLY_off(sv);
8122                     sv_setiv(sv, PL_modcount+1);
8123                   }
8124                   else {
8125                     /* SV may belong to someone else */
8126                     SvREFCNT_dec(sv);
8127                     *svp = newSViv(PL_modcount+1);
8128                   }
8129                 }
8130             }
8131         }
8132
8133         if (state_var_op)
8134             o = S_newONCEOP(aTHX_ o, state_var_op);
8135         return o;
8136     }
8137     if (assign_type == ASSIGN_REF)
8138         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8139     if (!right)
8140         right = newOP(OP_UNDEF, 0);
8141     if (right->op_type == OP_READLINE) {
8142         right->op_flags |= OPf_STACKED;
8143         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8144                 scalar(right));
8145     }
8146     else {
8147         o = newBINOP(OP_SASSIGN, flags,
8148             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8149     }
8150     return o;
8151 }
8152
8153 /*
8154 =for apidoc newSTATEOP
8155
8156 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8157 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8158 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8159 If C<label> is non-null, it supplies the name of a label to attach to
8160 the state op; this function takes ownership of the memory pointed at by
8161 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8162 for the state op.
8163
8164 If C<o> is null, the state op is returned.  Otherwise the state op is
8165 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8166 is consumed by this function and becomes part of the returned op tree.
8167
8168 =cut
8169 */
8170
8171 OP *
8172 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8173 {
8174     dVAR;
8175     const U32 seq = intro_my();
8176     const U32 utf8 = flags & SVf_UTF8;
8177     COP *cop;
8178
8179     PL_parser->parsed_sub = 0;
8180
8181     flags &= ~SVf_UTF8;
8182
8183     NewOp(1101, cop, 1, COP);
8184     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8185         OpTYPE_set(cop, OP_DBSTATE);
8186     }
8187     else {
8188         OpTYPE_set(cop, OP_NEXTSTATE);
8189     }
8190     cop->op_flags = (U8)flags;
8191     CopHINTS_set(cop, PL_hints);
8192 #ifdef VMS
8193     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8194 #endif
8195     cop->op_next = (OP*)cop;
8196
8197     cop->cop_seq = seq;
8198     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8199     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8200     if (label) {
8201         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8202
8203         PL_hints |= HINT_BLOCK_SCOPE;
8204         /* It seems that we need to defer freeing this pointer, as other parts
8205            of the grammar end up wanting to copy it after this op has been
8206            created. */
8207         SAVEFREEPV(label);
8208     }
8209
8210     if (PL_parser->preambling != NOLINE) {
8211         CopLINE_set(cop, PL_parser->preambling);
8212         PL_parser->copline = NOLINE;
8213     }
8214     else if (PL_parser->copline == NOLINE)
8215         CopLINE_set(cop, CopLINE(PL_curcop));
8216     else {
8217         CopLINE_set(cop, PL_parser->copline);
8218         PL_parser->copline = NOLINE;
8219     }
8220 #ifdef USE_ITHREADS
8221     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8222 #else
8223     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8224 #endif
8225     CopSTASH_set(cop, PL_curstash);
8226
8227     if (cop->op_type == OP_DBSTATE) {
8228         /* this line can have a breakpoint - store the cop in IV */
8229         AV *av = CopFILEAVx(PL_curcop);
8230         if (av) {
8231             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8232             if (svp && *svp != &PL_sv_undef ) {
8233                 (void)SvIOK_on(*svp);
8234                 SvIV_set(*svp, PTR2IV(cop));
8235             }
8236         }
8237     }
8238
8239     if (flags & OPf_SPECIAL)
8240         op_null((OP*)cop);
8241     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8242 }
8243
8244 /*
8245 =for apidoc newLOGOP
8246
8247 Constructs, checks, and returns a logical (flow control) op.  C<type>
8248 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8249 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8250 the eight bits of C<op_private>, except that the bit with value 1 is
8251 automatically set.  C<first> supplies the expression controlling the
8252 flow, and C<other> supplies the side (alternate) chain of ops; they are
8253 consumed by this function and become part of the constructed op tree.
8254
8255 =cut
8256 */
8257
8258 OP *
8259 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8260 {
8261     PERL_ARGS_ASSERT_NEWLOGOP;
8262
8263     return new_logop(type, flags, &first, &other);
8264 }
8265
8266 STATIC OP *
8267 S_search_const(pTHX_ OP *o)
8268 {
8269     PERL_ARGS_ASSERT_SEARCH_CONST;
8270
8271     switch (o->op_type) {
8272         case OP_CONST:
8273             return o;
8274         case OP_NULL:
8275             if (o->op_flags & OPf_KIDS)
8276                 return search_const(cUNOPo->op_first);
8277             break;
8278         case OP_LEAVE:
8279         case OP_SCOPE:
8280         case OP_LINESEQ:
8281         {
8282             OP *kid;
8283             if (!(o->op_flags & OPf_KIDS))
8284                 return NULL;
8285             kid = cLISTOPo->op_first;
8286             do {
8287                 switch (kid->op_type) {
8288                     case OP_ENTER:
8289                     case OP_NULL:
8290                     case OP_NEXTSTATE:
8291                         kid = OpSIBLING(kid);
8292                         break;
8293                     default:
8294                         if (kid != cLISTOPo->op_last)
8295                             return NULL;
8296                         goto last;
8297                 }
8298             } while (kid);
8299             if (!kid)
8300                 kid = cLISTOPo->op_last;
8301           last:
8302             return search_const(kid);
8303         }
8304     }
8305
8306     return NULL;
8307 }
8308
8309 STATIC OP *
8310 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8311 {
8312     dVAR;
8313     LOGOP *logop;
8314     OP *o;
8315     OP *first;
8316     OP *other;
8317     OP *cstop = NULL;
8318     int prepend_not = 0;
8319
8320     PERL_ARGS_ASSERT_NEW_LOGOP;
8321
8322     first = *firstp;
8323     other = *otherp;
8324
8325     /* [perl #59802]: Warn about things like "return $a or $b", which
8326        is parsed as "(return $a) or $b" rather than "return ($a or
8327        $b)".  NB: This also applies to xor, which is why we do it
8328        here.
8329      */
8330     switch (first->op_type) {
8331     case OP_NEXT:
8332     case OP_LAST:
8333     case OP_REDO:
8334         /* XXX: Perhaps we should emit a stronger warning for these.
8335            Even with the high-precedence operator they don't seem to do
8336            anything sensible.
8337
8338            But until we do, fall through here.
8339          */
8340     case OP_RETURN:
8341     case OP_EXIT:
8342     case OP_DIE:
8343     case OP_GOTO:
8344         /* XXX: Currently we allow people to "shoot themselves in the
8345            foot" by explicitly writing "(return $a) or $b".
8346
8347            Warn unless we are looking at the result from folding or if
8348            the programmer explicitly grouped the operators like this.
8349            The former can occur with e.g.
8350
8351                 use constant FEATURE => ( $] >= ... );
8352                 sub { not FEATURE and return or do_stuff(); }
8353          */
8354         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8355             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8356                            "Possible precedence issue with control flow operator");
8357         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8358            the "or $b" part)?
8359         */
8360         break;
8361     }
8362
8363     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8364         return newBINOP(type, flags, scalar(first), scalar(other));
8365
8366     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8367         || type == OP_CUSTOM);
8368
8369     scalarboolean(first);
8370
8371     /* search for a constant op that could let us fold the test */
8372     if ((cstop = search_const(first))) {
8373         if (cstop->op_private & OPpCONST_STRICT)
8374             no_bareword_allowed(cstop);
8375         else if ((cstop->op_private & OPpCONST_BARE))
8376                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8377         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8378             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8379             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8380             /* Elide the (constant) lhs, since it can't affect the outcome */
8381             *firstp = NULL;
8382             if (other->op_type == OP_CONST)
8383                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8384             op_free(first);
8385             if (other->op_type == OP_LEAVE)
8386                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8387             else if (other->op_type == OP_MATCH
8388                   || other->op_type == OP_SUBST
8389                   || other->op_type == OP_TRANSR
8390                   || other->op_type == OP_TRANS)
8391                 /* Mark the op as being unbindable with =~ */
8392                 other->op_flags |= OPf_SPECIAL;
8393
8394             other->op_folded = 1;
8395             return other;
8396         }
8397         else {
8398             /* Elide the rhs, since the outcome is entirely determined by
8399              * the (constant) lhs */
8400
8401             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8402             const OP *o2 = other;
8403             if ( ! (o2->op_type == OP_LIST
8404                     && (( o2 = cUNOPx(o2)->op_first))
8405                     && o2->op_type == OP_PUSHMARK
8406                     && (( o2 = OpSIBLING(o2))) )
8407             )
8408                 o2 = other;
8409             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8410                         || o2->op_type == OP_PADHV)
8411                 && o2->op_private & OPpLVAL_INTRO
8412                 && !(o2->op_private & OPpPAD_STATE))
8413             {
8414         Perl_croak(aTHX_ "This use of my() in false conditional is "
8415                           "no longer allowed");
8416             }
8417
8418             *otherp = NULL;
8419             if (cstop->op_type == OP_CONST)
8420                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8421             op_free(other);
8422             return first;
8423         }
8424     }
8425     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8426         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8427     {
8428         const OP * const k1 = ((UNOP*)first)->op_first;
8429         const OP * const k2 = OpSIBLING(k1);
8430         OPCODE warnop = 0;
8431         switch (first->op_type)
8432         {
8433         case OP_NULL:
8434             if (k2 && k2->op_type == OP_READLINE
8435                   && (k2->op_flags & OPf_STACKED)
8436                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8437             {
8438                 warnop = k2->op_type;
8439             }
8440             break;
8441
8442         case OP_SASSIGN:
8443             if (k1->op_type == OP_READDIR
8444                   || k1->op_type == OP_GLOB
8445                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8446                  || k1->op_type == OP_EACH
8447                  || k1->op_type == OP_AEACH)
8448             {
8449                 warnop = ((k1->op_type == OP_NULL)
8450                           ? (OPCODE)k1->op_targ : k1->op_type);
8451             }
8452             break;
8453         }
8454         if (warnop) {
8455             const line_t oldline = CopLINE(PL_curcop);
8456             /* This ensures that warnings are reported at the first line
8457                of the construction, not the last.  */
8458             CopLINE_set(PL_curcop, PL_parser->copline);
8459             Perl_warner(aTHX_ packWARN(WARN_MISC),
8460                  "Value of %s%s can be \"0\"; test with defined()",
8461                  PL_op_desc[warnop],
8462                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8463                   ? " construct" : "() operator"));
8464             CopLINE_set(PL_curcop, oldline);
8465         }
8466     }
8467
8468     /* optimize AND and OR ops that have NOTs as children */
8469     if (first->op_type == OP_NOT
8470         && (first->op_flags & OPf_KIDS)
8471         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8472             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8473         ) {
8474         if (type == OP_AND || type == OP_OR) {
8475             if (type == OP_AND)
8476                 type = OP_OR;
8477             else
8478                 type = OP_AND;
8479             op_null(first);
8480             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8481                 op_null(other);
8482                 prepend_not = 1; /* prepend a NOT op later */
8483             }
8484         }
8485     }
8486
8487     logop = alloc_LOGOP(type, first, LINKLIST(other));
8488     logop->op_flags |= (U8)flags;
8489     logop->op_private = (U8)(1 | (flags >> 8));
8490
8491     /* establish postfix order */
8492     logop->op_next = LINKLIST(first);
8493     first->op_next = (OP*)logop;
8494     assert(!OpHAS_SIBLING(first));
8495     op_sibling_splice((OP*)logop, first, 0, other);
8496
8497     CHECKOP(type,logop);
8498
8499     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8500                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8501                 (OP*)logop);
8502     other->op_next = o;
8503
8504     return o;
8505 }
8506
8507 /*
8508 =for apidoc newCONDOP
8509
8510 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8511 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8512 will be set automatically, and, shifted up eight bits, the eight bits of
8513 C<op_private>, except that the bit with value 1 is automatically set.
8514 C<first> supplies the expression selecting between the two branches,
8515 and C<trueop> and C<falseop> supply the branches; they are consumed by
8516 this function and become part of the constructed op tree.
8517
8518 =cut
8519 */
8520
8521 OP *
8522 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8523 {
8524     dVAR;
8525     LOGOP *logop;
8526     OP *start;
8527     OP *o;
8528     OP *cstop;
8529
8530     PERL_ARGS_ASSERT_NEWCONDOP;
8531
8532     if (!falseop)
8533         return newLOGOP(OP_AND, 0, first, trueop);
8534     if (!trueop)
8535         return newLOGOP(OP_OR, 0, first, falseop);
8536
8537     scalarboolean(first);
8538     if ((cstop = search_const(first))) {
8539         /* Left or right arm of the conditional?  */
8540         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8541         OP *live = left ? trueop : falseop;
8542         OP *const dead = left ? falseop : trueop;
8543         if (cstop->op_private & OPpCONST_BARE &&
8544             cstop->op_private & OPpCONST_STRICT) {
8545             no_bareword_allowed(cstop);
8546         }
8547         op_free(first);
8548         op_free(dead);
8549         if (live->op_type == OP_LEAVE)
8550             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8551         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8552               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8553             /* Mark the op as being unbindable with =~ */
8554             live->op_flags |= OPf_SPECIAL;
8555         live->op_folded = 1;
8556         return live;
8557     }
8558     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8559     logop->op_flags |= (U8)flags;
8560     logop->op_private = (U8)(1 | (flags >> 8));
8561     logop->op_next = LINKLIST(falseop);
8562
8563     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8564             logop);
8565
8566     /* establish postfix order */
8567     start = LINKLIST(first);
8568     first->op_next = (OP*)logop;
8569
8570     /* make first, trueop, falseop siblings */
8571     op_sibling_splice((OP*)logop, first,  0, trueop);
8572     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8573
8574     o = newUNOP(OP_NULL, 0, (OP*)logop);
8575
8576     trueop->op_next = falseop->op_next = o;
8577
8578     o->op_next = start;
8579     return o;
8580 }
8581
8582 /*
8583 =for apidoc newRANGE
8584
8585 Constructs and returns a C<range> op, with subordinate C<flip> and
8586 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8587 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8588 for both the C<flip> and C<range> ops, except that the bit with value
8589 1 is automatically set.  C<left> and C<right> supply the expressions
8590 controlling the endpoints of the range; they are consumed by this function
8591 and become part of the constructed op tree.
8592
8593 =cut
8594 */
8595
8596 OP *
8597 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8598 {
8599     LOGOP *range;
8600     OP *flip;
8601     OP *flop;
8602     OP *leftstart;
8603     OP *o;
8604
8605     PERL_ARGS_ASSERT_NEWRANGE;
8606
8607     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8608     range->op_flags = OPf_KIDS;
8609     leftstart = LINKLIST(left);
8610     range->op_private = (U8)(1 | (flags >> 8));
8611
8612     /* make left and right siblings */
8613     op_sibling_splice((OP*)range, left, 0, right);
8614
8615     range->op_next = (OP*)range;
8616     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8617     flop = newUNOP(OP_FLOP, 0, flip);
8618     o = newUNOP(OP_NULL, 0, flop);
8619     LINKLIST(flop);
8620     range->op_next = leftstart;
8621
8622     left->op_next = flip;
8623     right->op_next = flop;
8624
8625     range->op_targ =
8626         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8627     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8628     flip->op_targ =
8629         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8630     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8631     SvPADTMP_on(PAD_SV(flip->op_targ));
8632
8633     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8634     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8635
8636     /* check barewords before they might be optimized aways */
8637     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8638         no_bareword_allowed(left);
8639     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8640         no_bareword_allowed(right);
8641
8642     flip->op_next = o;
8643     if (!flip->op_private || !flop->op_private)
8644         LINKLIST(o);            /* blow off optimizer unless constant */
8645
8646     return o;
8647 }
8648
8649 /*
8650 =for apidoc newLOOPOP
8651
8652 Constructs, checks, and returns an op tree expressing a loop.  This is
8653 only a loop in the control flow through the op tree; it does not have
8654 the heavyweight loop structure that allows exiting the loop by C<last>
8655 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8656 top-level op, except that some bits will be set automatically as required.
8657 C<expr> supplies the expression controlling loop iteration, and C<block>
8658 supplies the body of the loop; they are consumed by this function and
8659 become part of the constructed op tree.  C<debuggable> is currently
8660 unused and should always be 1.
8661
8662 =cut
8663 */
8664
8665 OP *
8666 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8667 {
8668     OP* listop;
8669     OP* o;
8670     const bool once = block && block->op_flags & OPf_SPECIAL &&
8671                       block->op_type == OP_NULL;
8672
8673     PERL_UNUSED_ARG(debuggable);
8674
8675     if (expr) {
8676         if (once && (
8677               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8678            || (  expr->op_type == OP_NOT
8679               && cUNOPx(expr)->op_first->op_type == OP_CONST
8680               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8681               )
8682            ))
8683             /* Return the block now, so that S_new_logop does not try to
8684                fold it away. */
8685         {
8686             op_free(expr);
8687             return block;       /* do {} while 0 does once */
8688         }
8689
8690         if (expr->op_type == OP_READLINE
8691             || expr->op_type == OP_READDIR
8692             || expr->op_type == OP_GLOB
8693             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8694             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8695             expr = newUNOP(OP_DEFINED, 0,
8696                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8697         } else if (expr->op_flags & OPf_KIDS) {
8698             const OP * const k1 = ((UNOP*)expr)->op_first;
8699             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8700             switch (expr->op_type) {
8701               case OP_NULL:
8702                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8703                       && (k2->op_flags & OPf_STACKED)
8704                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8705                     expr = newUNOP(OP_DEFINED, 0, expr);
8706                 break;
8707
8708               case OP_SASSIGN:
8709                 if (k1 && (k1->op_type == OP_READDIR
8710                       || k1->op_type == OP_GLOB
8711                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8712                      || k1->op_type == OP_EACH
8713                      || k1->op_type == OP_AEACH))
8714                     expr = newUNOP(OP_DEFINED, 0, expr);
8715                 break;
8716             }
8717         }
8718     }
8719
8720     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8721      * op, in listop. This is wrong. [perl #27024] */
8722     if (!block)
8723         block = newOP(OP_NULL, 0);
8724     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8725     o = new_logop(OP_AND, 0, &expr, &listop);
8726
8727     if (once) {
8728         ASSUME(listop);
8729     }
8730
8731     if (listop)
8732         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8733
8734     if (once && o != listop)
8735     {
8736         assert(cUNOPo->op_first->op_type == OP_AND
8737             || cUNOPo->op_first->op_type == OP_OR);
8738         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8739     }
8740
8741     if (o == listop)
8742         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8743
8744     o->op_flags |= flags;
8745     o = op_scope(o);
8746     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8747     return o;
8748 }
8749
8750 /*
8751 =for apidoc newWHILEOP
8752
8753 Constructs, checks, and returns an op tree expressing a C<while> loop.
8754 This is a heavyweight loop, with structure that allows exiting the loop
8755 by C<last> and suchlike.
8756
8757 C<loop> is an optional preconstructed C<enterloop> op to use in the
8758 loop; if it is null then a suitable op will be constructed automatically.
8759 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8760 main body of the loop, and C<cont> optionally supplies a C<continue> block
8761 that operates as a second half of the body.  All of these optree inputs
8762 are consumed by this function and become part of the constructed op tree.
8763
8764 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8765 op and, shifted up eight bits, the eight bits of C<op_private> for
8766 the C<leaveloop> op, except that (in both cases) some bits will be set
8767 automatically.  C<debuggable> is currently unused and should always be 1.
8768 C<has_my> can be supplied as true to force the
8769 loop body to be enclosed in its own scope.
8770
8771 =cut
8772 */
8773
8774 OP *
8775 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8776         OP *expr, OP *block, OP *cont, I32 has_my)
8777 {
8778     dVAR;
8779     OP *redo;
8780     OP *next = NULL;
8781     OP *listop;
8782     OP *o;
8783     U8 loopflags = 0;
8784
8785     PERL_UNUSED_ARG(debuggable);
8786
8787     if (expr) {
8788         if (expr->op_type == OP_READLINE
8789          || expr->op_type == OP_READDIR
8790          || expr->op_type == OP_GLOB
8791          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8792                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8793             expr = newUNOP(OP_DEFINED, 0,
8794                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8795         } else if (expr->op_flags & OPf_KIDS) {
8796             const OP * const k1 = ((UNOP*)expr)->op_first;
8797             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8798             switch (expr->op_type) {
8799               case OP_NULL:
8800                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8801                       && (k2->op_flags & OPf_STACKED)
8802                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8803                     expr = newUNOP(OP_DEFINED, 0, expr);
8804                 break;
8805
8806               case OP_SASSIGN:
8807                 if (k1 && (k1->op_type == OP_READDIR
8808                       || k1->op_type == OP_GLOB
8809                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8810                      || k1->op_type == OP_EACH
8811                      || k1->op_type == OP_AEACH))
8812                     expr = newUNOP(OP_DEFINED, 0, expr);
8813                 break;
8814             }
8815         }
8816     }
8817
8818     if (!block)
8819         block = newOP(OP_NULL, 0);
8820     else if (cont || has_my) {
8821         block = op_scope(block);
8822     }
8823
8824     if (cont) {
8825         next = LINKLIST(cont);
8826     }
8827     if (expr) {
8828         OP * const unstack = newOP(OP_UNSTACK, 0);
8829         if (!next)
8830             next = unstack;
8831         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8832     }
8833
8834     assert(block);
8835     listop = op_append_list(OP_LINESEQ, block, cont);
8836     assert(listop);
8837     redo = LINKLIST(listop);
8838
8839     if (expr) {
8840         scalar(listop);
8841         o = new_logop(OP_AND, 0, &expr, &listop);
8842         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8843             op_free((OP*)loop);
8844             return expr;                /* listop already freed by new_logop */
8845         }
8846         if (listop)
8847             ((LISTOP*)listop)->op_last->op_next =
8848                 (o == listop ? redo : LINKLIST(o));
8849     }
8850     else
8851         o = listop;
8852
8853     if (!loop) {
8854         NewOp(1101,loop,1,LOOP);
8855         OpTYPE_set(loop, OP_ENTERLOOP);
8856         loop->op_private = 0;
8857         loop->op_next = (OP*)loop;
8858     }
8859
8860     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8861
8862     loop->op_redoop = redo;
8863     loop->op_lastop = o;
8864     o->op_private |= loopflags;
8865
8866     if (next)
8867         loop->op_nextop = next;
8868     else
8869         loop->op_nextop = o;
8870
8871     o->op_flags |= flags;
8872     o->op_private |= (flags >> 8);
8873     return o;
8874 }
8875
8876 /*
8877 =for apidoc newFOROP
8878
8879 Constructs, checks, and returns an op tree expressing a C<foreach>
8880 loop (iteration through a list of values).  This is a heavyweight loop,
8881 with structure that allows exiting the loop by C<last> and suchlike.
8882
8883 C<sv> optionally supplies the variable that will be aliased to each
8884 item in turn; if null, it defaults to C<$_>.
8885 C<expr> supplies the list of values to iterate over.  C<block> supplies
8886 the main body of the loop, and C<cont> optionally supplies a C<continue>
8887 block that operates as a second half of the body.  All of these optree
8888 inputs are consumed by this function and become part of the constructed
8889 op tree.
8890
8891 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8892 op and, shifted up eight bits, the eight bits of C<op_private> for
8893 the C<leaveloop> op, except that (in both cases) some bits will be set
8894 automatically.
8895
8896 =cut
8897 */
8898
8899 OP *
8900 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8901 {
8902     dVAR;
8903     LOOP *loop;
8904     OP *wop;
8905     PADOFFSET padoff = 0;
8906     I32 iterflags = 0;
8907     I32 iterpflags = 0;
8908
8909     PERL_ARGS_ASSERT_NEWFOROP;
8910
8911     if (sv) {
8912         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8913             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8914             OpTYPE_set(sv, OP_RV2GV);
8915
8916             /* The op_type check is needed to prevent a possible segfault
8917              * if the loop variable is undeclared and 'strict vars' is in
8918              * effect. This is illegal but is nonetheless parsed, so we
8919              * may reach this point with an OP_CONST where we're expecting
8920              * an OP_GV.
8921              */
8922             if (cUNOPx(sv)->op_first->op_type == OP_GV
8923              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8924                 iterpflags |= OPpITER_DEF;
8925         }
8926         else if (sv->op_type == OP_PADSV) { /* private variable */
8927             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8928             padoff = sv->op_targ;
8929             sv->op_targ = 0;
8930             op_free(sv);
8931             sv = NULL;
8932             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8933         }
8934         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8935             NOOP;
8936         else
8937             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8938         if (padoff) {
8939             PADNAME * const pn = PAD_COMPNAME(padoff);
8940             const char * const name = PadnamePV(pn);
8941
8942             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8943                 iterpflags |= OPpITER_DEF;
8944         }
8945     }
8946     else {
8947         sv = newGVOP(OP_GV, 0, PL_defgv);
8948         iterpflags |= OPpITER_DEF;
8949     }
8950
8951     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8952         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8953         iterflags |= OPf_STACKED;
8954     }
8955     else if (expr->op_type == OP_NULL &&
8956              (expr->op_flags & OPf_KIDS) &&
8957              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8958     {
8959         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8960          * set the STACKED flag to indicate that these values are to be
8961          * treated as min/max values by 'pp_enteriter'.
8962          */
8963         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8964         LOGOP* const range = (LOGOP*) flip->op_first;
8965         OP* const left  = range->op_first;
8966         OP* const right = OpSIBLING(left);
8967         LISTOP* listop;
8968
8969         range->op_flags &= ~OPf_KIDS;
8970         /* detach range's children */
8971         op_sibling_splice((OP*)range, NULL, -1, NULL);
8972
8973         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8974         listop->op_first->op_next = range->op_next;
8975         left->op_next = range->op_other;
8976         right->op_next = (OP*)listop;
8977         listop->op_next = listop->op_first;
8978
8979         op_free(expr);
8980         expr = (OP*)(listop);
8981         op_null(expr);
8982         iterflags |= OPf_STACKED;
8983     }
8984     else {
8985         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8986     }
8987
8988     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8989                                   op_append_elem(OP_LIST, list(expr),
8990                                                  scalar(sv)));
8991     assert(!loop->op_next);
8992     /* for my  $x () sets OPpLVAL_INTRO;
8993      * for our $x () sets OPpOUR_INTRO */
8994     loop->op_private = (U8)iterpflags;
8995     if (loop->op_slabbed
8996      && DIFF(loop, OpSLOT(loop)->opslot_next)
8997          < SIZE_TO_PSIZE(sizeof(LOOP)))
8998     {
8999         LOOP *tmp;
9000         NewOp(1234,tmp,1,LOOP);
9001         Copy(loop,tmp,1,LISTOP);
9002         assert(loop->op_last->op_sibparent == (OP*)loop);
9003         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9004         S_op_destroy(aTHX_ (OP*)loop);
9005         loop = tmp;
9006     }
9007     else if (!loop->op_slabbed)
9008     {
9009         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9010         OpLASTSIB_set(loop->op_last, (OP*)loop);
9011     }
9012     loop->op_targ = padoff;
9013     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
9014     return wop;
9015 }
9016
9017 /*
9018 =for apidoc newLOOPEX
9019
9020 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9021 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
9022 determining the target of the op; it is consumed by this function and
9023 becomes part of the constructed op tree.
9024
9025 =cut
9026 */
9027
9028 OP*
9029 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9030 {
9031     OP *o = NULL;
9032
9033     PERL_ARGS_ASSERT_NEWLOOPEX;
9034
9035     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9036         || type == OP_CUSTOM);
9037
9038     if (type != OP_GOTO) {
9039         /* "last()" means "last" */
9040         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9041             o = newOP(type, OPf_SPECIAL);
9042         }
9043     }
9044     else {
9045         /* Check whether it's going to be a goto &function */
9046         if (label->op_type == OP_ENTERSUB
9047                 && !(label->op_flags & OPf_STACKED))
9048             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9049     }
9050
9051     /* Check for a constant argument */
9052     if (label->op_type == OP_CONST) {
9053             SV * const sv = ((SVOP *)label)->op_sv;
9054             STRLEN l;
9055             const char *s = SvPV_const(sv,l);
9056             if (l == strlen(s)) {
9057                 o = newPVOP(type,
9058                             SvUTF8(((SVOP*)label)->op_sv),
9059                             savesharedpv(
9060                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9061             }
9062     }
9063
9064     /* If we have already created an op, we do not need the label. */
9065     if (o)
9066                 op_free(label);
9067     else o = newUNOP(type, OPf_STACKED, label);
9068
9069     PL_hints |= HINT_BLOCK_SCOPE;
9070     return o;
9071 }
9072
9073 /* if the condition is a literal array or hash
9074    (or @{ ... } etc), make a reference to it.
9075  */
9076 STATIC OP *
9077 S_ref_array_or_hash(pTHX_ OP *cond)
9078 {
9079     if (cond
9080     && (cond->op_type == OP_RV2AV
9081     ||  cond->op_type == OP_PADAV
9082     ||  cond->op_type == OP_RV2HV
9083     ||  cond->op_type == OP_PADHV))
9084
9085         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9086
9087     else if(cond
9088     && (cond->op_type == OP_ASLICE
9089     ||  cond->op_type == OP_KVASLICE
9090     ||  cond->op_type == OP_HSLICE
9091     ||  cond->op_type == OP_KVHSLICE)) {
9092
9093         /* anonlist now needs a list from this op, was previously used in
9094          * scalar context */
9095         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9096         cond->op_flags |= OPf_WANT_LIST;
9097
9098         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9099     }
9100
9101     else
9102         return cond;
9103 }
9104
9105 /* These construct the optree fragments representing given()
9106    and when() blocks.
9107
9108    entergiven and enterwhen are LOGOPs; the op_other pointer
9109    points up to the associated leave op. We need this so we
9110    can put it in the context and make break/continue work.
9111    (Also, of course, pp_enterwhen will jump straight to
9112    op_other if the match fails.)
9113  */
9114
9115 STATIC OP *
9116 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9117                    I32 enter_opcode, I32 leave_opcode,
9118                    PADOFFSET entertarg)
9119 {
9120     dVAR;
9121     LOGOP *enterop;
9122     OP *o;
9123
9124     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9125     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9126
9127     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9128     enterop->op_targ = 0;
9129     enterop->op_private = 0;
9130
9131     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9132
9133     if (cond) {
9134         /* prepend cond if we have one */
9135         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9136
9137         o->op_next = LINKLIST(cond);
9138         cond->op_next = (OP *) enterop;
9139     }
9140     else {
9141         /* This is a default {} block */
9142         enterop->op_flags |= OPf_SPECIAL;
9143         o      ->op_flags |= OPf_SPECIAL;
9144
9145         o->op_next = (OP *) enterop;
9146     }
9147
9148     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9149                                        entergiven and enterwhen both
9150                                        use ck_null() */
9151
9152     enterop->op_next = LINKLIST(block);
9153     block->op_next = enterop->op_other = o;
9154
9155     return o;
9156 }
9157
9158 /* Does this look like a boolean operation? For these purposes
9159    a boolean operation is:
9160      - a subroutine call [*]
9161      - a logical connective
9162      - a comparison operator
9163      - a filetest operator, with the exception of -s -M -A -C
9164      - defined(), exists() or eof()
9165      - /$re/ or $foo =~ /$re/
9166
9167    [*] possibly surprising
9168  */
9169 STATIC bool
9170 S_looks_like_bool(pTHX_ const OP *o)
9171 {
9172     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9173
9174     switch(o->op_type) {
9175         case OP_OR:
9176         case OP_DOR:
9177             return looks_like_bool(cLOGOPo->op_first);
9178
9179         case OP_AND:
9180         {
9181             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9182             ASSUME(sibl);
9183             return (
9184                 looks_like_bool(cLOGOPo->op_first)
9185              && looks_like_bool(sibl));
9186         }
9187
9188         case OP_NULL:
9189         case OP_SCALAR:
9190             return (
9191                 o->op_flags & OPf_KIDS
9192             && looks_like_bool(cUNOPo->op_first));
9193
9194         case OP_ENTERSUB:
9195
9196         case OP_NOT:    case OP_XOR:
9197
9198         case OP_EQ:     case OP_NE:     case OP_LT:
9199         case OP_GT:     case OP_LE:     case OP_GE:
9200
9201         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9202         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9203
9204         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9205         case OP_SGT:    case OP_SLE:    case OP_SGE:
9206
9207         case OP_SMARTMATCH:
9208
9209         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9210         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9211         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9212         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9213         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9214         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9215         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9216         case OP_FTTEXT:   case OP_FTBINARY:
9217
9218         case OP_DEFINED: case OP_EXISTS:
9219         case OP_MATCH:   case OP_EOF:
9220
9221         case OP_FLOP:
9222
9223             return TRUE;
9224
9225         case OP_INDEX:
9226         case OP_RINDEX:
9227             /* optimised-away (index() != -1) or similar comparison */
9228             if (o->op_private & OPpTRUEBOOL)
9229                 return TRUE;
9230             return FALSE;
9231
9232         case OP_CONST:
9233             /* Detect comparisons that have been optimized away */
9234             if (cSVOPo->op_sv == &PL_sv_yes
9235             ||  cSVOPo->op_sv == &PL_sv_no)
9236
9237                 return TRUE;
9238             else
9239                 return FALSE;
9240         /* FALLTHROUGH */
9241         default:
9242             return FALSE;
9243     }
9244 }
9245
9246 /*
9247 =for apidoc newGIVENOP
9248
9249 Constructs, checks, and returns an op tree expressing a C<given> block.
9250 C<cond> supplies the expression to whose value C<$_> will be locally
9251 aliased, and C<block> supplies the body of the C<given> construct; they
9252 are consumed by this function and become part of the constructed op tree.
9253 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9254
9255 =cut
9256 */
9257
9258 OP *
9259 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9260 {
9261     PERL_ARGS_ASSERT_NEWGIVENOP;
9262     PERL_UNUSED_ARG(defsv_off);
9263
9264     assert(!defsv_off);
9265     return newGIVWHENOP(
9266         ref_array_or_hash(cond),
9267         block,
9268         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9269         0);
9270 }
9271
9272 /*
9273 =for apidoc newWHENOP
9274
9275 Constructs, checks, and returns an op tree expressing a C<when> block.
9276 C<cond> supplies the test expression, and C<block> supplies the block
9277 that will be executed if the test evaluates to true; they are consumed
9278 by this function and become part of the constructed op tree.  C<cond>
9279 will be interpreted DWIMically, often as a comparison against C<$_>,
9280 and may be null to generate a C<default> block.
9281
9282 =cut
9283 */
9284
9285 OP *
9286 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9287 {
9288     const bool cond_llb = (!cond || looks_like_bool(cond));
9289     OP *cond_op;
9290
9291     PERL_ARGS_ASSERT_NEWWHENOP;
9292
9293     if (cond_llb)
9294         cond_op = cond;
9295     else {
9296         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9297                 newDEFSVOP(),
9298                 scalar(ref_array_or_hash(cond)));
9299     }
9300
9301     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9302 }
9303
9304 /* must not conflict with SVf_UTF8 */
9305 #define CV_CKPROTO_CURSTASH     0x1
9306
9307 void
9308 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9309                     const STRLEN len, const U32 flags)
9310 {
9311     SV *name = NULL, *msg;
9312     const char * cvp = SvROK(cv)
9313                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9314                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9315                            : ""
9316                         : CvPROTO(cv);
9317     STRLEN clen = CvPROTOLEN(cv), plen = len;
9318
9319     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9320
9321     if (p == NULL && cvp == NULL)
9322         return;
9323
9324     if (!ckWARN_d(WARN_PROTOTYPE))
9325         return;
9326
9327     if (p && cvp) {
9328         p = S_strip_spaces(aTHX_ p, &plen);
9329         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9330         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9331             if (plen == clen && memEQ(cvp, p, plen))
9332                 return;
9333         } else {
9334             if (flags & SVf_UTF8) {
9335                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9336                     return;
9337             }
9338             else {
9339                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9340                     return;
9341             }
9342         }
9343     }
9344
9345     msg = sv_newmortal();
9346
9347     if (gv)
9348     {
9349         if (isGV(gv))
9350             gv_efullname3(name = sv_newmortal(), gv, NULL);
9351         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9352             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9353         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9354             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9355             sv_catpvs(name, "::");
9356             if (SvROK(gv)) {
9357                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9358                 assert (CvNAMED(SvRV_const(gv)));
9359                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9360             }
9361             else sv_catsv(name, (SV *)gv);
9362         }
9363         else name = (SV *)gv;
9364     }
9365     sv_setpvs(msg, "Prototype mismatch:");
9366     if (name)
9367         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9368     if (cvp)
9369         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9370             UTF8fARG(SvUTF8(cv),clen,cvp)
9371         );
9372     else
9373         sv_catpvs(msg, ": none");
9374     sv_catpvs(msg, " vs ");
9375     if (p)
9376         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9377     else
9378         sv_catpvs(msg, "none");
9379     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9380 }
9381
9382 static void const_sv_xsub(pTHX_ CV* cv);
9383 static void const_av_xsub(pTHX_ CV* cv);
9384
9385 /*
9386
9387 =head1 Optree Manipulation Functions
9388
9389 =for apidoc cv_const_sv
9390
9391 If C<cv> is a constant sub eligible for inlining, returns the constant
9392 value returned by the sub.  Otherwise, returns C<NULL>.
9393
9394 Constant subs can be created with C<newCONSTSUB> or as described in
9395 L<perlsub/"Constant Functions">.
9396
9397 =cut
9398 */
9399 SV *
9400 Perl_cv_const_sv(const CV *const cv)
9401 {
9402     SV *sv;
9403     if (!cv)
9404         return NULL;
9405     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9406         return NULL;
9407     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9408     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9409     return sv;
9410 }
9411
9412 SV *
9413 Perl_cv_const_sv_or_av(const CV * const cv)
9414 {
9415     if (!cv)
9416         return NULL;
9417     if (SvROK(cv)) return SvRV((SV *)cv);
9418     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9419     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9420 }
9421
9422 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9423  * Can be called in 2 ways:
9424  *
9425  * !allow_lex
9426  *      look for a single OP_CONST with attached value: return the value
9427  *
9428  * allow_lex && !CvCONST(cv);
9429  *
9430  *      examine the clone prototype, and if contains only a single
9431  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9432  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9433  *      a candidate for "constizing" at clone time, and return NULL.
9434  */
9435
9436 static SV *
9437 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9438 {
9439     SV *sv = NULL;
9440     bool padsv = FALSE;
9441
9442     assert(o);
9443     assert(cv);
9444
9445     for (; o; o = o->op_next) {
9446         const OPCODE type = o->op_type;
9447
9448         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9449              || type == OP_NULL
9450              || type == OP_PUSHMARK)
9451                 continue;
9452         if (type == OP_DBSTATE)
9453                 continue;
9454         if (type == OP_LEAVESUB)
9455             break;
9456         if (sv)
9457             return NULL;
9458         if (type == OP_CONST && cSVOPo->op_sv)
9459             sv = cSVOPo->op_sv;
9460         else if (type == OP_UNDEF && !o->op_private) {
9461             sv = newSV(0);
9462             SAVEFREESV(sv);
9463         }
9464         else if (allow_lex && type == OP_PADSV) {
9465                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9466                 {
9467                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9468                     padsv = TRUE;
9469                 }
9470                 else
9471                     return NULL;
9472         }
9473         else {
9474             return NULL;
9475         }
9476     }
9477     if (padsv) {
9478         CvCONST_on(cv);
9479         return NULL;
9480     }
9481     return sv;
9482 }
9483
9484 static void
9485 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9486                         PADNAME * const name, SV ** const const_svp)
9487 {
9488     assert (cv);
9489     assert (o || name);
9490     assert (const_svp);
9491     if (!block) {
9492         if (CvFLAGS(PL_compcv)) {
9493             /* might have had built-in attrs applied */
9494             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9495             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9496              && ckWARN(WARN_MISC))
9497             {
9498                 /* protect against fatal warnings leaking compcv */
9499                 SAVEFREESV(PL_compcv);
9500                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9501                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9502             }
9503             CvFLAGS(cv) |=
9504                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9505                   & ~(CVf_LVALUE * pureperl));
9506         }
9507         return;
9508     }
9509
9510     /* redundant check for speed: */
9511     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9512         const line_t oldline = CopLINE(PL_curcop);
9513         SV *namesv = o
9514             ? cSVOPo->op_sv
9515             : sv_2mortal(newSVpvn_utf8(
9516                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9517               ));
9518         if (PL_parser && PL_parser->copline != NOLINE)
9519             /* This ensures that warnings are reported at the first
9520                line of a redefinition, not the last.  */
9521             CopLINE_set(PL_curcop, PL_parser->copline);
9522         /* protect against fatal warnings leaking compcv */
9523         SAVEFREESV(PL_compcv);
9524         report_redefined_cv(namesv, cv, const_svp);
9525         SvREFCNT_inc_simple_void_NN(PL_compcv);
9526         CopLINE_set(PL_curcop, oldline);
9527     }
9528     SAVEFREESV(cv);
9529     return;
9530 }
9531
9532 CV *
9533 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9534 {
9535     CV **spot;
9536     SV **svspot;
9537     const char *ps;
9538     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9539     U32 ps_utf8 = 0;
9540     CV *cv = NULL;
9541     CV *compcv = PL_compcv;
9542     SV *const_sv;
9543     PADNAME *name;
9544     PADOFFSET pax = o->op_targ;
9545     CV *outcv = CvOUTSIDE(PL_compcv);
9546     CV *clonee = NULL;
9547     HEK *hek = NULL;
9548     bool reusable = FALSE;
9549     OP *start = NULL;
9550 #ifdef PERL_DEBUG_READONLY_OPS
9551     OPSLAB *slab = NULL;
9552 #endif
9553
9554     PERL_ARGS_ASSERT_NEWMYSUB;
9555
9556     PL_hints |= HINT_BLOCK_SCOPE;
9557
9558     /* Find the pad slot for storing the new sub.
9559        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9560        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9561        ing sub.  And then we need to dig deeper if this is a lexical from
9562        outside, as in:
9563            my sub foo; sub { sub foo { } }
9564      */
9565   redo:
9566     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9567     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9568         pax = PARENT_PAD_INDEX(name);
9569         outcv = CvOUTSIDE(outcv);
9570         assert(outcv);
9571         goto redo;
9572     }
9573     svspot =
9574         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9575                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9576     spot = (CV **)svspot;
9577
9578     if (!(PL_parser && PL_parser->error_count))
9579         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9580
9581     if (proto) {
9582         assert(proto->op_type == OP_CONST);
9583         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9584         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9585     }
9586     else
9587         ps = NULL;
9588
9589     if (proto)
9590         SAVEFREEOP(proto);
9591     if (attrs)
9592         SAVEFREEOP(attrs);
9593
9594     if (PL_parser && PL_parser->error_count) {
9595         op_free(block);
9596         SvREFCNT_dec(PL_compcv);
9597         PL_compcv = 0;
9598         goto done;
9599     }
9600
9601     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9602         cv = *spot;
9603         svspot = (SV **)(spot = &clonee);
9604     }
9605     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9606         cv = *spot;
9607     else {
9608         assert (SvTYPE(*spot) == SVt_PVCV);
9609         if (CvNAMED(*spot))
9610             hek = CvNAME_HEK(*spot);
9611         else {
9612             dVAR;
9613             U32 hash;
9614             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9615             CvNAME_HEK_set(*spot, hek =
9616                 share_hek(
9617                     PadnamePV(name)+1,
9618                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9619                     hash
9620                 )
9621             );
9622             CvLEXICAL_on(*spot);
9623         }
9624         cv = PadnamePROTOCV(name);
9625         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9626     }
9627
9628     if (block) {
9629         /* This makes sub {}; work as expected.  */
9630         if (block->op_type == OP_STUB) {
9631             const line_t l = PL_parser->copline;
9632             op_free(block);
9633             block = newSTATEOP(0, NULL, 0);
9634             PL_parser->copline = l;
9635         }
9636         block = CvLVALUE(compcv)
9637              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9638                    ? newUNOP(OP_LEAVESUBLV, 0,
9639                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9640                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9641         start = LINKLIST(block);
9642         block->op_next = 0;
9643         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9644             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9645         else
9646             const_sv = NULL;
9647     }
9648     else
9649         const_sv = NULL;
9650
9651     if (cv) {
9652         const bool exists = CvROOT(cv) || CvXSUB(cv);
9653
9654         /* if the subroutine doesn't exist and wasn't pre-declared
9655          * with a prototype, assume it will be AUTOLOADed,
9656          * skipping the prototype check
9657          */
9658         if (exists || SvPOK(cv))
9659             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9660                                  ps_utf8);
9661         /* already defined? */
9662         if (exists) {
9663             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9664             if (block)
9665                 cv = NULL;
9666             else {
9667                 if (attrs)
9668                     goto attrs;
9669                 /* just a "sub foo;" when &foo is already defined */
9670                 SAVEFREESV(compcv);
9671                 goto done;
9672             }
9673         }
9674         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9675             cv = NULL;
9676             reusable = TRUE;
9677         }
9678     }
9679
9680     if (const_sv) {
9681         SvREFCNT_inc_simple_void_NN(const_sv);
9682         SvFLAGS(const_sv) |= SVs_PADTMP;
9683         if (cv) {
9684             assert(!CvROOT(cv) && !CvCONST(cv));
9685             cv_forget_slab(cv);
9686         }
9687         else {
9688             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9689             CvFILE_set_from_cop(cv, PL_curcop);
9690             CvSTASH_set(cv, PL_curstash);
9691             *spot = cv;
9692         }
9693         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9694         CvXSUBANY(cv).any_ptr = const_sv;
9695         CvXSUB(cv) = const_sv_xsub;
9696         CvCONST_on(cv);
9697         CvISXSUB_on(cv);
9698         PoisonPADLIST(cv);
9699         CvFLAGS(cv) |= CvMETHOD(compcv);
9700         op_free(block);
9701         SvREFCNT_dec(compcv);
9702         PL_compcv = NULL;
9703         goto setname;
9704     }
9705
9706     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9707        determine whether this sub definition is in the same scope as its
9708        declaration.  If this sub definition is inside an inner named pack-
9709        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9710        the package sub.  So check PadnameOUTER(name) too.
9711      */
9712     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9713         assert(!CvWEAKOUTSIDE(compcv));
9714         SvREFCNT_dec(CvOUTSIDE(compcv));
9715         CvWEAKOUTSIDE_on(compcv);
9716     }
9717     /* XXX else do we have a circular reference? */
9718
9719     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9720         /* transfer PL_compcv to cv */
9721         if (block) {
9722             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
9723             cv_flags_t preserved_flags =
9724                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9725             PADLIST *const temp_padl = CvPADLIST(cv);
9726             CV *const temp_cv = CvOUTSIDE(cv);
9727             const cv_flags_t other_flags =
9728                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9729             OP * const cvstart = CvSTART(cv);
9730
9731             SvPOK_off(cv);
9732             CvFLAGS(cv) =
9733                 CvFLAGS(compcv) | preserved_flags;
9734             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9735             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9736             CvPADLIST_set(cv, CvPADLIST(compcv));
9737             CvOUTSIDE(compcv) = temp_cv;
9738             CvPADLIST_set(compcv, temp_padl);
9739             CvSTART(cv) = CvSTART(compcv);
9740             CvSTART(compcv) = cvstart;
9741             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9742             CvFLAGS(compcv) |= other_flags;
9743
9744             if (free_file) {
9745                 Safefree(CvFILE(cv));
9746                 CvFILE(cv) = NULL;
9747             }
9748
9749             /* inner references to compcv must be fixed up ... */
9750             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9751             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9752                 ++PL_sub_generation;
9753         }
9754         else {
9755             /* Might have had built-in attributes applied -- propagate them. */
9756             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9757         }
9758         /* ... before we throw it away */
9759         SvREFCNT_dec(compcv);
9760         PL_compcv = compcv = cv;
9761     }
9762     else {
9763         cv = compcv;
9764         *spot = cv;
9765     }
9766
9767   setname:
9768     CvLEXICAL_on(cv);
9769     if (!CvNAME_HEK(cv)) {
9770         if (hek) (void)share_hek_hek(hek);
9771         else {
9772             dVAR;
9773             U32 hash;
9774             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9775             hek = share_hek(PadnamePV(name)+1,
9776                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9777                       hash);
9778         }
9779         CvNAME_HEK_set(cv, hek);
9780     }
9781
9782     if (const_sv)
9783         goto clone;
9784
9785     if (CvFILE(cv) && CvDYNFILE(cv))
9786         Safefree(CvFILE(cv));
9787     CvFILE_set_from_cop(cv, PL_curcop);
9788     CvSTASH_set(cv, PL_curstash);
9789
9790     if (ps) {
9791         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9792         if (ps_utf8)
9793             SvUTF8_on(MUTABLE_SV(cv));
9794     }
9795
9796     if (block) {
9797         /* If we assign an optree to a PVCV, then we've defined a
9798          * subroutine that the debugger could be able to set a breakpoint
9799          * in, so signal to pp_entereval that it should not throw away any
9800          * saved lines at scope exit.  */
9801
9802         PL_breakable_sub_gen++;
9803         CvROOT(cv) = block;
9804         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9805            itself has a refcount. */
9806         CvSLABBED_off(cv);
9807         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9808 #ifdef PERL_DEBUG_READONLY_OPS
9809         slab = (OPSLAB *)CvSTART(cv);
9810 #endif
9811         S_process_optree(aTHX_ cv, block, start);
9812     }
9813
9814   attrs:
9815     if (attrs) {
9816         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9817         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9818     }
9819
9820     if (block) {
9821         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9822             SV * const tmpstr = sv_newmortal();
9823             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9824                                                   GV_ADDMULTI, SVt_PVHV);
9825             HV *hv;
9826             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9827                                           CopFILE(PL_curcop),
9828                                           (long)PL_subline,
9829                                           (long)CopLINE(PL_curcop));
9830             if (HvNAME_HEK(PL_curstash)) {
9831                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9832                 sv_catpvs(tmpstr, "::");
9833             }
9834             else
9835                 sv_setpvs(tmpstr, "__ANON__::");
9836
9837             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9838                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9839             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9840                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9841             hv = GvHVn(db_postponed);
9842             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9843                 CV * const pcv = GvCV(db_postponed);
9844                 if (pcv) {
9845                     dSP;
9846                     PUSHMARK(SP);
9847                     XPUSHs(tmpstr);
9848                     PUTBACK;
9849                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9850                 }
9851             }
9852         }
9853     }
9854
9855   clone:
9856     if (clonee) {
9857         assert(CvDEPTH(outcv));
9858         spot = (CV **)
9859             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9860         if (reusable)
9861             cv_clone_into(clonee, *spot);
9862         else *spot = cv_clone(clonee);
9863         SvREFCNT_dec_NN(clonee);
9864         cv = *spot;
9865     }
9866
9867     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9868         PADOFFSET depth = CvDEPTH(outcv);
9869         while (--depth) {
9870             SV *oldcv;
9871             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9872             oldcv = *svspot;
9873             *svspot = SvREFCNT_inc_simple_NN(cv);
9874             SvREFCNT_dec(oldcv);
9875         }
9876     }
9877
9878   done:
9879     if (PL_parser)
9880         PL_parser->copline = NOLINE;
9881     LEAVE_SCOPE(floor);
9882 #ifdef PERL_DEBUG_READONLY_OPS
9883     if (slab)
9884         Slab_to_ro(slab);
9885 #endif
9886     op_free(o);
9887     return cv;
9888 }
9889
9890 /*
9891 =for apidoc newATTRSUB_x
9892
9893 Construct a Perl subroutine, also performing some surrounding jobs.
9894
9895 This function is expected to be called in a Perl compilation context,
9896 and some aspects of the subroutine are taken from global variables
9897 associated with compilation.  In particular, C<PL_compcv> represents
9898 the subroutine that is currently being compiled.  It must be non-null
9899 when this function is called, and some aspects of the subroutine being
9900 constructed are taken from it.  The constructed subroutine may actually
9901 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9902
9903 If C<block> is null then the subroutine will have no body, and for the
9904 time being it will be an error to call it.  This represents a forward
9905 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9906 non-null then it provides the Perl code of the subroutine body, which
9907 will be executed when the subroutine is called.  This body includes
9908 any argument unwrapping code resulting from a subroutine signature or
9909 similar.  The pad use of the code must correspond to the pad attached
9910 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9911 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9912 by this function and will become part of the constructed subroutine.
9913
9914 C<proto> specifies the subroutine's prototype, unless one is supplied
9915 as an attribute (see below).  If C<proto> is null, then the subroutine
9916 will not have a prototype.  If C<proto> is non-null, it must point to a
9917 C<const> op whose value is a string, and the subroutine will have that
9918 string as its prototype.  If a prototype is supplied as an attribute, the
9919 attribute takes precedence over C<proto>, but in that case C<proto> should
9920 preferably be null.  In any case, C<proto> is consumed by this function.
9921
9922 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9923 attributes take effect by built-in means, being applied to C<PL_compcv>
9924 immediately when seen.  Other attributes are collected up and attached
9925 to the subroutine by this route.  C<attrs> may be null to supply no
9926 attributes, or point to a C<const> op for a single attribute, or point
9927 to a C<list> op whose children apart from the C<pushmark> are C<const>
9928 ops for one or more attributes.  Each C<const> op must be a string,
9929 giving the attribute name optionally followed by parenthesised arguments,
9930 in the manner in which attributes appear in Perl source.  The attributes
9931 will be applied to the sub by this function.  C<attrs> is consumed by
9932 this function.
9933
9934 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9935 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9936 must point to a C<const> op, which will be consumed by this function,
9937 and its string value supplies a name for the subroutine.  The name may
9938 be qualified or unqualified, and if it is unqualified then a default
9939 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9940 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9941 by which the subroutine will be named.
9942
9943 If there is already a subroutine of the specified name, then the new
9944 sub will either replace the existing one in the glob or be merged with
9945 the existing one.  A warning may be generated about redefinition.
9946
9947 If the subroutine has one of a few special names, such as C<BEGIN> or
9948 C<END>, then it will be claimed by the appropriate queue for automatic
9949 running of phase-related subroutines.  In this case the relevant glob will
9950 be left not containing any subroutine, even if it did contain one before.
9951 In the case of C<BEGIN>, the subroutine will be executed and the reference
9952 to it disposed of before this function returns.
9953
9954 The function returns a pointer to the constructed subroutine.  If the sub
9955 is anonymous then ownership of one counted reference to the subroutine
9956 is transferred to the caller.  If the sub is named then the caller does
9957 not get ownership of a reference.  In most such cases, where the sub
9958 has a non-phase name, the sub will be alive at the point it is returned
9959 by virtue of being contained in the glob that names it.  A phase-named
9960 subroutine will usually be alive by virtue of the reference owned by the
9961 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9962 been executed, will quite likely have been destroyed already by the
9963 time this function returns, making it erroneous for the caller to make
9964 any use of the returned pointer.  It is the caller's responsibility to
9965 ensure that it knows which of these situations applies.
9966
9967 =cut
9968 */
9969
9970 /* _x = extended */
9971 CV *
9972 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9973                             OP *block, bool o_is_gv)
9974 {
9975     GV *gv;
9976     const char *ps;
9977     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9978     U32 ps_utf8 = 0;
9979     CV *cv = NULL;     /* the previous CV with this name, if any */
9980     SV *const_sv;
9981     const bool ec = PL_parser && PL_parser->error_count;
9982     /* If the subroutine has no body, no attributes, and no builtin attributes
9983        then it's just a sub declaration, and we may be able to get away with
9984        storing with a placeholder scalar in the symbol table, rather than a
9985        full CV.  If anything is present then it will take a full CV to
9986        store it.  */
9987     const I32 gv_fetch_flags
9988         = ec ? GV_NOADD_NOINIT :
9989         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9990         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9991     STRLEN namlen = 0;
9992     const char * const name =
9993          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9994     bool has_name;
9995     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9996     bool evanescent = FALSE;
9997     OP *start = NULL;
9998 #ifdef PERL_DEBUG_READONLY_OPS
9999     OPSLAB *slab = NULL;
10000 #endif
10001
10002     if (o_is_gv) {
10003         gv = (GV*)o;
10004         o = NULL;
10005         has_name = TRUE;
10006     } else if (name) {
10007         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
10008            hek and CvSTASH pointer together can imply the GV.  If the name
10009            contains a package name, then GvSTASH(CvGV(cv)) may differ from
10010            CvSTASH, so forego the optimisation if we find any.
10011            Also, we may be called from load_module at run time, so
10012            PL_curstash (which sets CvSTASH) may not point to the stash the
10013            sub is stored in.  */
10014         /* XXX This optimization is currently disabled for packages other
10015                than main, since there was too much CPAN breakage.  */
10016         const I32 flags =
10017            ec ? GV_NOADD_NOINIT
10018               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10019                || PL_curstash != PL_defstash
10020                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10021                     ? gv_fetch_flags
10022                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10023         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10024         has_name = TRUE;
10025     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10026         SV * const sv = sv_newmortal();
10027         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10028                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10029                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10030         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10031         has_name = TRUE;
10032     } else if (PL_curstash) {
10033         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10034         has_name = FALSE;
10035     } else {
10036         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10037         has_name = FALSE;
10038     }
10039
10040     if (!ec) {
10041         if (isGV(gv)) {
10042             move_proto_attr(&proto, &attrs, gv, 0);
10043         } else {
10044             assert(cSVOPo);
10045             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10046         }
10047     }
10048
10049     if (proto) {
10050         assert(proto->op_type == OP_CONST);
10051         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10052         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10053     }
10054     else
10055         ps = NULL;
10056
10057     if (o)
10058         SAVEFREEOP(o);
10059     if (proto)
10060         SAVEFREEOP(proto);
10061     if (attrs)
10062         SAVEFREEOP(attrs);
10063
10064     if (ec) {
10065         op_free(block);
10066
10067         if (name)
10068             SvREFCNT_dec(PL_compcv);
10069         else
10070             cv = PL_compcv;
10071
10072         PL_compcv = 0;
10073         if (name && block) {
10074             const char *s = (char *) my_memrchr(name, ':', namlen);
10075             s = s ? s+1 : name;
10076             if (strEQ(s, "BEGIN")) {
10077                 if (PL_in_eval & EVAL_KEEPERR)
10078                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10079                 else {
10080                     SV * const errsv = ERRSV;
10081                     /* force display of errors found but not reported */
10082                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10083                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10084                 }
10085             }
10086         }
10087         goto done;
10088     }
10089
10090     if (!block && SvTYPE(gv) != SVt_PVGV) {
10091         /* If we are not defining a new sub and the existing one is not a
10092            full GV + CV... */
10093         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10094             /* We are applying attributes to an existing sub, so we need it
10095                upgraded if it is a constant.  */
10096             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10097                 gv_init_pvn(gv, PL_curstash, name, namlen,
10098                             SVf_UTF8 * name_is_utf8);
10099         }
10100         else {                  /* Maybe prototype now, and had at maximum
10101                                    a prototype or const/sub ref before.  */
10102             if (SvTYPE(gv) > SVt_NULL) {
10103                 cv_ckproto_len_flags((const CV *)gv,
10104                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10105                                     ps_len, ps_utf8);
10106             }
10107
10108             if (!SvROK(gv)) {
10109                 if (ps) {
10110                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10111                     if (ps_utf8)
10112                         SvUTF8_on(MUTABLE_SV(gv));
10113                 }
10114                 else
10115                     sv_setiv(MUTABLE_SV(gv), -1);
10116             }
10117
10118             SvREFCNT_dec(PL_compcv);
10119             cv = PL_compcv = NULL;
10120             goto done;
10121         }
10122     }
10123
10124     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10125         ? NULL
10126         : isGV(gv)
10127             ? GvCV(gv)
10128             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10129                 ? (CV *)SvRV(gv)
10130                 : NULL;
10131
10132     if (block) {
10133         assert(PL_parser);
10134         /* This makes sub {}; work as expected.  */
10135         if (block->op_type == OP_STUB) {
10136             const line_t l = PL_parser->copline;
10137             op_free(block);
10138             block = newSTATEOP(0, NULL, 0);
10139             PL_parser->copline = l;
10140         }
10141         block = CvLVALUE(PL_compcv)
10142              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10143                     && (!isGV(gv) || !GvASSUMECV(gv)))
10144                    ? newUNOP(OP_LEAVESUBLV, 0,
10145                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10146                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10147         start = LINKLIST(block);
10148         block->op_next = 0;
10149         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10150             const_sv =
10151                 S_op_const_sv(aTHX_ start, PL_compcv,
10152                                         cBOOL(CvCLONE(PL_compcv)));
10153         else
10154             const_sv = NULL;
10155     }
10156     else
10157         const_sv = NULL;
10158
10159     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10160         cv_ckproto_len_flags((const CV *)gv,
10161                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10162                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10163         if (SvROK(gv)) {
10164             /* All the other code for sub redefinition warnings expects the
10165                clobbered sub to be a CV.  Instead of making all those code
10166                paths more complex, just inline the RV version here.  */
10167             const line_t oldline = CopLINE(PL_curcop);
10168             assert(IN_PERL_COMPILETIME);
10169             if (PL_parser && PL_parser->copline != NOLINE)
10170                 /* This ensures that warnings are reported at the first
10171                    line of a redefinition, not the last.  */
10172                 CopLINE_set(PL_curcop, PL_parser->copline);
10173             /* protect against fatal warnings leaking compcv */
10174             SAVEFREESV(PL_compcv);
10175
10176             if (ckWARN(WARN_REDEFINE)
10177              || (  ckWARN_d(WARN_REDEFINE)
10178                 && (  !const_sv || SvRV(gv) == const_sv
10179                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10180                 assert(cSVOPo);
10181                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10182                           "Constant subroutine %" SVf " redefined",
10183                           SVfARG(cSVOPo->op_sv));
10184             }
10185
10186             SvREFCNT_inc_simple_void_NN(PL_compcv);
10187             CopLINE_set(PL_curcop, oldline);
10188             SvREFCNT_dec(SvRV(gv));
10189         }
10190     }
10191
10192     if (cv) {
10193         const bool exists = CvROOT(cv) || CvXSUB(cv);
10194
10195         /* if the subroutine doesn't exist and wasn't pre-declared
10196          * with a prototype, assume it will be AUTOLOADed,
10197          * skipping the prototype check
10198          */
10199         if (exists || SvPOK(cv))
10200             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10201         /* already defined (or promised)? */
10202         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10203             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10204             if (block)
10205                 cv = NULL;
10206             else {
10207                 if (attrs)
10208                     goto attrs;
10209                 /* just a "sub foo;" when &foo is already defined */
10210                 SAVEFREESV(PL_compcv);
10211                 goto done;
10212             }
10213         }
10214     }
10215
10216     if (const_sv) {
10217         SvREFCNT_inc_simple_void_NN(const_sv);
10218         SvFLAGS(const_sv) |= SVs_PADTMP;
10219         if (cv) {
10220             assert(!CvROOT(cv) && !CvCONST(cv));
10221             cv_forget_slab(cv);
10222             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10223             CvXSUBANY(cv).any_ptr = const_sv;
10224             CvXSUB(cv) = const_sv_xsub;
10225             CvCONST_on(cv);
10226             CvISXSUB_on(cv);
10227             PoisonPADLIST(cv);
10228             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10229         }
10230         else {
10231             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10232                 if (name && isGV(gv))
10233                     GvCV_set(gv, NULL);
10234                 cv = newCONSTSUB_flags(
10235                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10236                     const_sv
10237                 );
10238                 assert(cv);
10239                 assert(SvREFCNT((SV*)cv) != 0);
10240                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10241             }
10242             else {
10243                 if (!SvROK(gv)) {
10244                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10245                     prepare_SV_for_RV((SV *)gv);
10246                     SvOK_off((SV *)gv);
10247                     SvROK_on(gv);
10248                 }
10249                 SvRV_set(gv, const_sv);
10250             }
10251         }
10252         op_free(block);
10253         SvREFCNT_dec(PL_compcv);
10254         PL_compcv = NULL;
10255         goto done;
10256     }
10257
10258     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10259     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10260         cv = NULL;
10261
10262     if (cv) {                           /* must reuse cv if autoloaded */
10263         /* transfer PL_compcv to cv */
10264         if (block) {
10265             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10266             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10267             PADLIST *const temp_av = CvPADLIST(cv);
10268             CV *const temp_cv = CvOUTSIDE(cv);
10269             const cv_flags_t other_flags =
10270                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10271             OP * const cvstart = CvSTART(cv);
10272
10273             if (isGV(gv)) {
10274                 CvGV_set(cv,gv);
10275                 assert(!CvCVGV_RC(cv));
10276                 assert(CvGV(cv) == gv);
10277             }
10278             else {
10279                 dVAR;
10280                 U32 hash;
10281                 PERL_HASH(hash, name, namlen);
10282                 CvNAME_HEK_set(cv,
10283                                share_hek(name,
10284                                          name_is_utf8
10285                                             ? -(SSize_t)namlen
10286                                             :  (SSize_t)namlen,
10287                                          hash));
10288             }
10289
10290             SvPOK_off(cv);
10291             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10292                                              | CvNAMED(cv);
10293             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10294             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10295             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10296             CvOUTSIDE(PL_compcv) = temp_cv;
10297             CvPADLIST_set(PL_compcv, temp_av);
10298             CvSTART(cv) = CvSTART(PL_compcv);
10299             CvSTART(PL_compcv) = cvstart;
10300             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10301             CvFLAGS(PL_compcv) |= other_flags;
10302
10303             if (free_file) {
10304                 Safefree(CvFILE(cv));
10305             }
10306             CvFILE_set_from_cop(cv, PL_curcop);
10307             CvSTASH_set(cv, PL_curstash);
10308
10309             /* inner references to PL_compcv must be fixed up ... */
10310             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10311             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10312                 ++PL_sub_generation;
10313         }
10314         else {
10315             /* Might have had built-in attributes applied -- propagate them. */
10316             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10317         }
10318         /* ... before we throw it away */
10319         SvREFCNT_dec(PL_compcv);
10320         PL_compcv = cv;
10321     }
10322     else {
10323         cv = PL_compcv;
10324         if (name && isGV(gv)) {
10325             GvCV_set(gv, cv);
10326             GvCVGEN(gv) = 0;
10327             if (HvENAME_HEK(GvSTASH(gv)))
10328                 /* sub Foo::bar { (shift)+1 } */
10329                 gv_method_changed(gv);
10330         }
10331         else if (name) {
10332             if (!SvROK(gv)) {
10333                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10334                 prepare_SV_for_RV((SV *)gv);
10335                 SvOK_off((SV *)gv);
10336                 SvROK_on(gv);
10337             }
10338             SvRV_set(gv, (SV *)cv);
10339             if (HvENAME_HEK(PL_curstash))
10340                 mro_method_changed_in(PL_curstash);
10341         }
10342     }
10343     assert(cv);
10344     assert(SvREFCNT((SV*)cv) != 0);
10345
10346     if (!CvHASGV(cv)) {
10347         if (isGV(gv))
10348             CvGV_set(cv, gv);
10349         else {
10350             dVAR;
10351             U32 hash;
10352             PERL_HASH(hash, name, namlen);
10353             CvNAME_HEK_set(cv, share_hek(name,
10354                                          name_is_utf8
10355                                             ? -(SSize_t)namlen
10356                                             :  (SSize_t)namlen,
10357                                          hash));
10358         }
10359         CvFILE_set_from_cop(cv, PL_curcop);
10360         CvSTASH_set(cv, PL_curstash);
10361     }
10362
10363     if (ps) {
10364         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10365         if ( ps_utf8 )
10366             SvUTF8_on(MUTABLE_SV(cv));
10367     }
10368
10369     if (block) {
10370         /* If we assign an optree to a PVCV, then we've defined a
10371          * subroutine that the debugger could be able to set a breakpoint
10372          * in, so signal to pp_entereval that it should not throw away any
10373          * saved lines at scope exit.  */
10374
10375         PL_breakable_sub_gen++;
10376         CvROOT(cv) = block;
10377         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10378            itself has a refcount. */
10379         CvSLABBED_off(cv);
10380         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10381 #ifdef PERL_DEBUG_READONLY_OPS
10382         slab = (OPSLAB *)CvSTART(cv);
10383 #endif
10384         S_process_optree(aTHX_ cv, block, start);
10385     }
10386
10387   attrs:
10388     if (attrs) {
10389         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10390         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10391                         ? GvSTASH(CvGV(cv))
10392                         : PL_curstash;
10393         if (!name)
10394             SAVEFREESV(cv);
10395         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10396         if (!name)
10397             SvREFCNT_inc_simple_void_NN(cv);
10398     }
10399
10400     if (block && has_name) {
10401         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10402             SV * const tmpstr = cv_name(cv,NULL,0);
10403             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10404                                                   GV_ADDMULTI, SVt_PVHV);
10405             HV *hv;
10406             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10407                                           CopFILE(PL_curcop),
10408                                           (long)PL_subline,
10409                                           (long)CopLINE(PL_curcop));
10410             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10411                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10412             hv = GvHVn(db_postponed);
10413             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10414                 CV * const pcv = GvCV(db_postponed);
10415                 if (pcv) {
10416                     dSP;
10417                     PUSHMARK(SP);
10418                     XPUSHs(tmpstr);
10419                     PUTBACK;
10420                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10421                 }
10422             }
10423         }
10424
10425         if (name) {
10426             if (PL_parser && PL_parser->error_count)
10427                 clear_special_blocks(name, gv, cv);
10428             else
10429                 evanescent =
10430                     process_special_blocks(floor, name, gv, cv);
10431         }
10432     }
10433     assert(cv);
10434
10435   done:
10436     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10437     if (PL_parser)
10438         PL_parser->copline = NOLINE;
10439     LEAVE_SCOPE(floor);
10440
10441     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10442     if (!evanescent) {
10443 #ifdef PERL_DEBUG_READONLY_OPS
10444     if (slab)
10445         Slab_to_ro(slab);
10446 #endif
10447     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10448         pad_add_weakref(cv);
10449     }
10450     return cv;
10451 }
10452
10453 STATIC void
10454 S_clear_special_blocks(pTHX_ const char *const fullname,
10455                        GV *const gv, CV *const cv) {
10456     const char *colon;
10457     const char *name;
10458
10459     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10460
10461     colon = strrchr(fullname,':');
10462     name = colon ? colon + 1 : fullname;
10463
10464     if ((*name == 'B' && strEQ(name, "BEGIN"))
10465         || (*name == 'E' && strEQ(name, "END"))
10466         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10467         || (*name == 'C' && strEQ(name, "CHECK"))
10468         || (*name == 'I' && strEQ(name, "INIT"))) {
10469         if (!isGV(gv)) {
10470             (void)CvGV(cv);
10471             assert(isGV(gv));
10472         }
10473         GvCV_set(gv, NULL);
10474         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10475     }
10476 }
10477
10478 /* Returns true if the sub has been freed.  */
10479 STATIC bool
10480 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10481                          GV *const gv,
10482                          CV *const cv)
10483 {
10484     const char *const colon = strrchr(fullname,':');
10485     const char *const name = colon ? colon + 1 : fullname;
10486
10487     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10488
10489     if (*name == 'B') {
10490         if (strEQ(name, "BEGIN")) {
10491             const I32 oldscope = PL_scopestack_ix;
10492             dSP;
10493             (void)CvGV(cv);
10494             if (floor) LEAVE_SCOPE(floor);
10495             ENTER;
10496             PUSHSTACKi(PERLSI_REQUIRE);
10497             SAVECOPFILE(&PL_compiling);
10498             SAVECOPLINE(&PL_compiling);
10499             SAVEVPTR(PL_curcop);
10500
10501             DEBUG_x( dump_sub(gv) );
10502             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10503             GvCV_set(gv,0);             /* cv has been hijacked */
10504             call_list(oldscope, PL_beginav);
10505
10506             POPSTACK;
10507             LEAVE;
10508             return !PL_savebegin;
10509         }
10510         else
10511             return FALSE;
10512     } else {
10513         if (*name == 'E') {
10514             if (strEQ(name, "END")) {
10515                 DEBUG_x( dump_sub(gv) );
10516                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10517             } else
10518                 return FALSE;
10519         } else if (*name == 'U') {
10520             if (strEQ(name, "UNITCHECK")) {
10521                 /* It's never too late to run a unitcheck block */
10522                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10523             }
10524             else
10525                 return FALSE;
10526         } else if (*name == 'C') {
10527             if (strEQ(name, "CHECK")) {
10528                 if (PL_main_start)
10529                     /* diag_listed_as: Too late to run %s block */
10530                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10531                                    "Too late to run CHECK block");
10532                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10533             }
10534             else
10535                 return FALSE;
10536         } else if (*name == 'I') {
10537             if (strEQ(name, "INIT")) {
10538                 if (PL_main_start)
10539                     /* diag_listed_as: Too late to run %s block */
10540                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10541                                    "Too late to run INIT block");
10542                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10543             }
10544             else
10545                 return FALSE;
10546         } else
10547             return FALSE;
10548         DEBUG_x( dump_sub(gv) );
10549         (void)CvGV(cv);
10550         GvCV_set(gv,0);         /* cv has been hijacked */
10551         return FALSE;
10552     }
10553 }
10554
10555 /*
10556 =for apidoc newCONSTSUB
10557
10558 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10559 rather than of counted length, and no flags are set.  (This means that
10560 C<name> is always interpreted as Latin-1.)
10561
10562 =cut
10563 */
10564
10565 CV *
10566 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10567 {
10568     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10569 }
10570
10571 /*
10572 =for apidoc newCONSTSUB_flags
10573
10574 Construct a constant subroutine, also performing some surrounding
10575 jobs.  A scalar constant-valued subroutine is eligible for inlining
10576 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10577 123 }>>.  Other kinds of constant subroutine have other treatment.
10578
10579 The subroutine will have an empty prototype and will ignore any arguments
10580 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10581 is null, the subroutine will yield an empty list.  If C<sv> points to a
10582 scalar, the subroutine will always yield that scalar.  If C<sv> points
10583 to an array, the subroutine will always yield a list of the elements of
10584 that array in list context, or the number of elements in the array in
10585 scalar context.  This function takes ownership of one counted reference
10586 to the scalar or array, and will arrange for the object to live as long
10587 as the subroutine does.  If C<sv> points to a scalar then the inlining
10588 assumes that the value of the scalar will never change, so the caller
10589 must ensure that the scalar is not subsequently written to.  If C<sv>
10590 points to an array then no such assumption is made, so it is ostensibly
10591 safe to mutate the array or its elements, but whether this is really
10592 supported has not been determined.
10593
10594 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10595 Other aspects of the subroutine will be left in their default state.
10596 The caller is free to mutate the subroutine beyond its initial state
10597 after this function has returned.
10598
10599 If C<name> is null then the subroutine will be anonymous, with its
10600 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10601 subroutine will be named accordingly, referenced by the appropriate glob.
10602 C<name> is a string of length C<len> bytes giving a sigilless symbol
10603 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10604 otherwise.  The name may be either qualified or unqualified.  If the
10605 name is unqualified then it defaults to being in the stash specified by
10606 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10607 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10608 semantics.
10609
10610 C<flags> should not have bits set other than C<SVf_UTF8>.
10611
10612 If there is already a subroutine of the specified name, then the new sub
10613 will replace the existing one in the glob.  A warning may be generated
10614 about the redefinition.
10615
10616 If the subroutine has one of a few special names, such as C<BEGIN> or
10617 C<END>, then it will be claimed by the appropriate queue for automatic
10618 running of phase-related subroutines.  In this case the relevant glob will
10619 be left not containing any subroutine, even if it did contain one before.
10620 Execution of the subroutine will likely be a no-op, unless C<sv> was
10621 a tied array or the caller modified the subroutine in some interesting
10622 way before it was executed.  In the case of C<BEGIN>, the treatment is
10623 buggy: the sub will be executed when only half built, and may be deleted
10624 prematurely, possibly causing a crash.
10625
10626 The function returns a pointer to the constructed subroutine.  If the sub
10627 is anonymous then ownership of one counted reference to the subroutine
10628 is transferred to the caller.  If the sub is named then the caller does
10629 not get ownership of a reference.  In most such cases, where the sub
10630 has a non-phase name, the sub will be alive at the point it is returned
10631 by virtue of being contained in the glob that names it.  A phase-named
10632 subroutine will usually be alive by virtue of the reference owned by
10633 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10634 destroyed already by the time this function returns, but currently bugs
10635 occur in that case before the caller gets control.  It is the caller's
10636 responsibility to ensure that it knows which of these situations applies.
10637
10638 =cut
10639 */
10640
10641 CV *
10642 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10643                              U32 flags, SV *sv)
10644 {
10645     CV* cv;
10646     const char *const file = CopFILE(PL_curcop);
10647
10648     ENTER;
10649
10650     if (IN_PERL_RUNTIME) {
10651         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10652          * an op shared between threads. Use a non-shared COP for our
10653          * dirty work */
10654          SAVEVPTR(PL_curcop);
10655          SAVECOMPILEWARNINGS();
10656          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10657          PL_curcop = &PL_compiling;
10658     }
10659     SAVECOPLINE(PL_curcop);
10660     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10661
10662     SAVEHINTS();
10663     PL_hints &= ~HINT_BLOCK_SCOPE;
10664
10665     if (stash) {
10666         SAVEGENERICSV(PL_curstash);
10667         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10668     }
10669
10670     /* Protect sv against leakage caused by fatal warnings. */
10671     if (sv) SAVEFREESV(sv);
10672
10673     /* file becomes the CvFILE. For an XS, it's usually static storage,
10674        and so doesn't get free()d.  (It's expected to be from the C pre-
10675        processor __FILE__ directive). But we need a dynamically allocated one,
10676        and we need it to get freed.  */
10677     cv = newXS_len_flags(name, len,
10678                          sv && SvTYPE(sv) == SVt_PVAV
10679                              ? const_av_xsub
10680                              : const_sv_xsub,
10681                          file ? file : "", "",
10682                          &sv, XS_DYNAMIC_FILENAME | flags);
10683     assert(cv);
10684     assert(SvREFCNT((SV*)cv) != 0);
10685     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10686     CvCONST_on(cv);
10687
10688     LEAVE;
10689
10690     return cv;
10691 }
10692
10693 /*
10694 =for apidoc newXS
10695
10696 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10697 static storage, as it is used directly as CvFILE(), without a copy being made.
10698
10699 =cut
10700 */
10701
10702 CV *
10703 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10704 {
10705     PERL_ARGS_ASSERT_NEWXS;
10706     return newXS_len_flags(
10707         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10708     );
10709 }
10710
10711 CV *
10712 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10713                  const char *const filename, const char *const proto,
10714                  U32 flags)
10715 {
10716     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10717     return newXS_len_flags(
10718        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10719     );
10720 }
10721
10722 CV *
10723 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10724 {
10725     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10726     return newXS_len_flags(
10727         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10728     );
10729 }
10730
10731 /*
10732 =for apidoc newXS_len_flags
10733
10734 Construct an XS subroutine, also performing some surrounding jobs.
10735
10736 The subroutine will have the entry point C<subaddr>.  It will have
10737 the prototype specified by the nul-terminated string C<proto>, or
10738 no prototype if C<proto> is null.  The prototype string is copied;
10739 the caller can mutate the supplied string afterwards.  If C<filename>
10740 is non-null, it must be a nul-terminated filename, and the subroutine
10741 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10742 point directly to the supplied string, which must be static.  If C<flags>
10743 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10744 be taken instead.
10745
10746 Other aspects of the subroutine will be left in their default state.
10747 If anything else needs to be done to the subroutine for it to function
10748 correctly, it is the caller's responsibility to do that after this
10749 function has constructed it.  However, beware of the subroutine
10750 potentially being destroyed before this function returns, as described
10751 below.
10752
10753 If C<name> is null then the subroutine will be anonymous, with its
10754 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10755 subroutine will be named accordingly, referenced by the appropriate glob.
10756 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10757 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10758 The name may be either qualified or unqualified, with the stash defaulting
10759 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10760 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10761 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10762 the stash if necessary, with C<GV_ADDMULTI> semantics.
10763
10764 If there is already a subroutine of the specified name, then the new sub
10765 will replace the existing one in the glob.  A warning may be generated
10766 about the redefinition.  If the old subroutine was C<CvCONST> then the
10767 decision about whether to warn is influenced by an expectation about
10768 whether the new subroutine will become a constant of similar value.
10769 That expectation is determined by C<const_svp>.  (Note that the call to
10770 this function doesn't make the new subroutine C<CvCONST> in any case;
10771 that is left to the caller.)  If C<const_svp> is null then it indicates
10772 that the new subroutine will not become a constant.  If C<const_svp>
10773 is non-null then it indicates that the new subroutine will become a
10774 constant, and it points to an C<SV*> that provides the constant value
10775 that the subroutine will have.
10776
10777 If the subroutine has one of a few special names, such as C<BEGIN> or
10778 C<END>, then it will be claimed by the appropriate queue for automatic
10779 running of phase-related subroutines.  In this case the relevant glob will
10780 be left not containing any subroutine, even if it did contain one before.
10781 In the case of C<BEGIN>, the subroutine will be executed and the reference
10782 to it disposed of before this function returns, and also before its
10783 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10784 constructed by this function to be ready for execution then the caller
10785 must prevent this happening by giving the subroutine a different name.
10786
10787 The function returns a pointer to the constructed subroutine.  If the sub
10788 is anonymous then ownership of one counted reference to the subroutine
10789 is transferred to the caller.  If the sub is named then the caller does
10790 not get ownership of a reference.  In most such cases, where the sub
10791 has a non-phase name, the sub will be alive at the point it is returned
10792 by virtue of being contained in the glob that names it.  A phase-named
10793 subroutine will usually be alive by virtue of the reference owned by the
10794 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10795 been executed, will quite likely have been destroyed already by the
10796 time this function returns, making it erroneous for the caller to make
10797 any use of the returned pointer.  It is the caller's responsibility to
10798 ensure that it knows which of these situations applies.
10799
10800 =cut
10801 */
10802
10803 CV *
10804 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10805                            XSUBADDR_t subaddr, const char *const filename,
10806                            const char *const proto, SV **const_svp,
10807                            U32 flags)
10808 {
10809     CV *cv;
10810     bool interleave = FALSE;
10811     bool evanescent = FALSE;
10812
10813     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10814
10815     {
10816         GV * const gv = gv_fetchpvn(
10817                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10818                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10819                                 sizeof("__ANON__::__ANON__") - 1,
10820                             GV_ADDMULTI | flags, SVt_PVCV);
10821
10822         if ((cv = (name ? GvCV(gv) : NULL))) {
10823             if (GvCVGEN(gv)) {
10824                 /* just a cached method */
10825                 SvREFCNT_dec(cv);
10826                 cv = NULL;
10827             }
10828             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10829                 /* already defined (or promised) */
10830                 /* Redundant check that allows us to avoid creating an SV
10831                    most of the time: */
10832                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10833                     report_redefined_cv(newSVpvn_flags(
10834                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10835                                         ),
10836                                         cv, const_svp);
10837                 }
10838                 interleave = TRUE;
10839                 ENTER;
10840                 SAVEFREESV(cv);
10841                 cv = NULL;
10842             }
10843         }
10844
10845         if (cv)                         /* must reuse cv if autoloaded */
10846             cv_undef(cv);
10847         else {
10848             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10849             if (name) {
10850                 GvCV_set(gv,cv);
10851                 GvCVGEN(gv) = 0;
10852                 if (HvENAME_HEK(GvSTASH(gv)))
10853                     gv_method_changed(gv); /* newXS */
10854             }
10855         }
10856         assert(cv);
10857         assert(SvREFCNT((SV*)cv) != 0);
10858
10859         CvGV_set(cv, gv);
10860         if(filename) {
10861             /* XSUBs can't be perl lang/perl5db.pl debugged
10862             if (PERLDB_LINE_OR_SAVESRC)
10863                 (void)gv_fetchfile(filename); */
10864             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10865             if (flags & XS_DYNAMIC_FILENAME) {
10866                 CvDYNFILE_on(cv);
10867                 CvFILE(cv) = savepv(filename);
10868             } else {
10869             /* NOTE: not copied, as it is expected to be an external constant string */
10870                 CvFILE(cv) = (char *)filename;
10871             }
10872         } else {
10873             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10874             CvFILE(cv) = (char*)PL_xsubfilename;
10875         }
10876         CvISXSUB_on(cv);
10877         CvXSUB(cv) = subaddr;
10878 #ifndef PERL_IMPLICIT_CONTEXT
10879         CvHSCXT(cv) = &PL_stack_sp;
10880 #else
10881         PoisonPADLIST(cv);
10882 #endif
10883
10884         if (name)
10885             evanescent = process_special_blocks(0, name, gv, cv);
10886         else
10887             CvANON_on(cv);
10888     } /* <- not a conditional branch */
10889
10890     assert(cv);
10891     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10892
10893     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10894     if (interleave) LEAVE;
10895     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10896     return cv;
10897 }
10898
10899 /* Add a stub CV to a typeglob.
10900  * This is the implementation of a forward declaration, 'sub foo';'
10901  */
10902
10903 CV *
10904 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10905 {
10906     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10907     GV *cvgv;
10908     PERL_ARGS_ASSERT_NEWSTUB;
10909     assert(!GvCVu(gv));
10910     GvCV_set(gv, cv);
10911     GvCVGEN(gv) = 0;
10912     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10913         gv_method_changed(gv);
10914     if (SvFAKE(gv)) {
10915         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10916         SvFAKE_off(cvgv);
10917     }
10918     else cvgv = gv;
10919     CvGV_set(cv, cvgv);
10920     CvFILE_set_from_cop(cv, PL_curcop);
10921     CvSTASH_set(cv, PL_curstash);
10922     GvMULTI_on(gv);
10923     return cv;
10924 }
10925
10926 void
10927 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10928 {
10929     CV *cv;
10930     GV *gv;
10931     OP *root;
10932     OP *start;
10933
10934     if (PL_parser && PL_parser->error_count) {
10935         op_free(block);
10936         goto finish;
10937     }
10938
10939     gv = o
10940         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10941         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10942
10943     GvMULTI_on(gv);
10944     if ((cv = GvFORM(gv))) {
10945         if (ckWARN(WARN_REDEFINE)) {
10946             const line_t oldline = CopLINE(PL_curcop);
10947             if (PL_parser && PL_parser->copline != NOLINE)
10948                 CopLINE_set(PL_curcop, PL_parser->copline);
10949             if (o) {
10950                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10951                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10952             } else {
10953                 /* diag_listed_as: Format %s redefined */
10954                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10955                             "Format STDOUT redefined");
10956             }
10957             CopLINE_set(PL_curcop, oldline);
10958         }
10959         SvREFCNT_dec(cv);
10960     }
10961     cv = PL_compcv;
10962     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10963     CvGV_set(cv, gv);
10964     CvFILE_set_from_cop(cv, PL_curcop);
10965
10966
10967     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10968     CvROOT(cv) = root;
10969     start = LINKLIST(root);
10970     root->op_next = 0;
10971     S_process_optree(aTHX_ cv, root, start);
10972     cv_forget_slab(cv);
10973
10974   finish:
10975     op_free(o);
10976     if (PL_parser)
10977         PL_parser->copline = NOLINE;
10978     LEAVE_SCOPE(floor);
10979     PL_compiling.cop_seq = 0;
10980 }
10981
10982 OP *
10983 Perl_newANONLIST(pTHX_ OP *o)
10984 {
10985     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10986 }
10987
10988 OP *
10989 Perl_newANONHASH(pTHX_ OP *o)
10990 {
10991     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10992 }
10993
10994 OP *
10995 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10996 {
10997     return newANONATTRSUB(floor, proto, NULL, block);
10998 }
10999
11000 OP *
11001 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11002 {
11003     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11004     OP * anoncode =
11005         newSVOP(OP_ANONCODE, 0,
11006                 cv);
11007     if (CvANONCONST(cv))
11008         anoncode = newUNOP(OP_ANONCONST, 0,
11009                            op_convert_list(OP_ENTERSUB,
11010                                            OPf_STACKED|OPf_WANT_SCALAR,
11011                                            anoncode));
11012     return newUNOP(OP_REFGEN, 0, anoncode);
11013 }
11014
11015 OP *
11016 Perl_oopsAV(pTHX_ OP *o)
11017 {
11018     dVAR;
11019
11020     PERL_ARGS_ASSERT_OOPSAV;
11021
11022     switch (o->op_type) {
11023     case OP_PADSV:
11024     case OP_PADHV:
11025         OpTYPE_set(o, OP_PADAV);
11026         return ref(o, OP_RV2AV);
11027
11028     case OP_RV2SV:
11029     case OP_RV2HV:
11030         OpTYPE_set(o, OP_RV2AV);
11031         ref(o, OP_RV2AV);
11032         break;
11033
11034     default:
11035         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11036         break;
11037     }
11038     return o;
11039 }
11040
11041 OP *
11042 Perl_oopsHV(pTHX_ OP *o)
11043 {
11044     dVAR;
11045
11046     PERL_ARGS_ASSERT_OOPSHV;
11047
11048     switch (o->op_type) {
11049     case OP_PADSV:
11050     case OP_PADAV:
11051         OpTYPE_set(o, OP_PADHV);
11052         return ref(o, OP_RV2HV);
11053
11054     case OP_RV2SV:
11055     case OP_RV2AV:
11056         OpTYPE_set(o, OP_RV2HV);
11057         /* rv2hv steals the bottom bit for its own uses */
11058         o->op_private &= ~OPpARG1_MASK;
11059         ref(o, OP_RV2HV);
11060         break;
11061
11062     default:
11063         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11064         break;
11065     }
11066     return o;
11067 }
11068
11069 OP *
11070 Perl_newAVREF(pTHX_ OP *o)
11071 {
11072     dVAR;
11073
11074     PERL_ARGS_ASSERT_NEWAVREF;
11075
11076     if (o->op_type == OP_PADANY) {
11077         OpTYPE_set(o, OP_PADAV);
11078         return o;
11079     }
11080     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11081         Perl_croak(aTHX_ "Can't use an array as a reference");
11082     }
11083     return newUNOP(OP_RV2AV, 0, scalar(o));
11084 }
11085
11086 OP *
11087 Perl_newGVREF(pTHX_ I32 type, OP *o)
11088 {
11089     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11090         return newUNOP(OP_NULL, 0, o);
11091     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11092 }
11093
11094 OP *
11095 Perl_newHVREF(pTHX_ OP *o)
11096 {
11097     dVAR;
11098
11099     PERL_ARGS_ASSERT_NEWHVREF;
11100
11101     if (o->op_type == OP_PADANY) {
11102         OpTYPE_set(o, OP_PADHV);
11103         return o;
11104     }
11105     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11106         Perl_croak(aTHX_ "Can't use a hash as a reference");
11107     }
11108     return newUNOP(OP_RV2HV, 0, scalar(o));
11109 }
11110
11111 OP *
11112 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11113 {
11114     if (o->op_type == OP_PADANY) {
11115         dVAR;
11116         OpTYPE_set(o, OP_PADCV);
11117     }
11118     return newUNOP(OP_RV2CV, flags, scalar(o));
11119 }
11120
11121 OP *
11122 Perl_newSVREF(pTHX_ OP *o)
11123 {
11124     dVAR;
11125
11126     PERL_ARGS_ASSERT_NEWSVREF;
11127
11128     if (o->op_type == OP_PADANY) {
11129         OpTYPE_set(o, OP_PADSV);
11130         scalar(o);
11131         return o;
11132     }
11133     return newUNOP(OP_RV2SV, 0, scalar(o));
11134 }
11135
11136 /* Check routines. See the comments at the top of this file for details
11137  * on when these are called */
11138
11139 OP *
11140 Perl_ck_anoncode(pTHX_ OP *o)
11141 {
11142     PERL_ARGS_ASSERT_CK_ANONCODE;
11143
11144     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11145     cSVOPo->op_sv = NULL;
11146     return o;
11147 }
11148
11149 static void
11150 S_io_hints(pTHX_ OP *o)
11151 {
11152 #if O_BINARY != 0 || O_TEXT != 0
11153     HV * const table =
11154         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11155     if (table) {
11156         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11157         if (svp && *svp) {
11158             STRLEN len = 0;
11159             const char *d = SvPV_const(*svp, len);
11160             const I32 mode = mode_from_discipline(d, len);
11161             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11162 #  if O_BINARY != 0
11163             if (mode & O_BINARY)
11164                 o->op_private |= OPpOPEN_IN_RAW;
11165 #  endif
11166 #  if O_TEXT != 0
11167             if (mode & O_TEXT)
11168                 o->op_private |= OPpOPEN_IN_CRLF;
11169 #  endif
11170         }
11171
11172         svp = hv_fetchs(table, "open_OUT", FALSE);
11173         if (svp && *svp) {
11174             STRLEN len = 0;
11175             const char *d = SvPV_const(*svp, len);
11176             const I32 mode = mode_from_discipline(d, len);
11177             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11178 #  if O_BINARY != 0
11179             if (mode & O_BINARY)
11180                 o->op_private |= OPpOPEN_OUT_RAW;
11181 #  endif
11182 #  if O_TEXT != 0
11183             if (mode & O_TEXT)
11184                 o->op_private |= OPpOPEN_OUT_CRLF;
11185 #  endif
11186         }
11187     }
11188 #else
11189     PERL_UNUSED_CONTEXT;
11190     PERL_UNUSED_ARG(o);
11191 #endif
11192 }
11193
11194 OP *
11195 Perl_ck_backtick(pTHX_ OP *o)
11196 {
11197     GV *gv;
11198     OP *newop = NULL;
11199     OP *sibl;
11200     PERL_ARGS_ASSERT_CK_BACKTICK;
11201     o = ck_fun(o);
11202     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11203     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11204      && (gv = gv_override("readpipe",8)))
11205     {
11206         /* detach rest of siblings from o and its first child */
11207         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11208         newop = S_new_entersubop(aTHX_ gv, sibl);
11209     }
11210     else if (!(o->op_flags & OPf_KIDS))
11211         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11212     if (newop) {
11213         op_free(o);
11214         return newop;
11215     }
11216     S_io_hints(aTHX_ o);
11217     return o;
11218 }
11219
11220 OP *
11221 Perl_ck_bitop(pTHX_ OP *o)
11222 {
11223     PERL_ARGS_ASSERT_CK_BITOP;
11224
11225     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11226
11227     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11228             && OP_IS_INFIX_BIT(o->op_type))
11229     {
11230         const OP * const left = cBINOPo->op_first;
11231         const OP * const right = OpSIBLING(left);
11232         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11233                 (left->op_flags & OPf_PARENS) == 0) ||
11234             (OP_IS_NUMCOMPARE(right->op_type) &&
11235                 (right->op_flags & OPf_PARENS) == 0))
11236             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11237                           "Possible precedence problem on bitwise %s operator",
11238                            o->op_type ==  OP_BIT_OR
11239                          ||o->op_type == OP_NBIT_OR  ? "|"
11240                         :  o->op_type ==  OP_BIT_AND
11241                          ||o->op_type == OP_NBIT_AND ? "&"
11242                         :  o->op_type ==  OP_BIT_XOR
11243                          ||o->op_type == OP_NBIT_XOR ? "^"
11244                         :  o->op_type == OP_SBIT_OR  ? "|."
11245                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11246                            );
11247     }
11248     return o;
11249 }
11250
11251 PERL_STATIC_INLINE bool
11252 is_dollar_bracket(pTHX_ const OP * const o)
11253 {
11254     const OP *kid;
11255     PERL_UNUSED_CONTEXT;
11256     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11257         && (kid = cUNOPx(o)->op_first)
11258         && kid->op_type == OP_GV
11259         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11260 }
11261
11262 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11263
11264 OP *
11265 Perl_ck_cmp(pTHX_ OP *o)
11266 {
11267     bool is_eq;
11268     bool neg;
11269     bool reverse;
11270     bool iv0;
11271     OP *indexop, *constop, *start;
11272     SV *sv;
11273     IV iv;
11274
11275     PERL_ARGS_ASSERT_CK_CMP;
11276
11277     is_eq = (   o->op_type == OP_EQ
11278              || o->op_type == OP_NE
11279              || o->op_type == OP_I_EQ
11280              || o->op_type == OP_I_NE);
11281
11282     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11283         const OP *kid = cUNOPo->op_first;
11284         if (kid &&
11285             (
11286                 (   is_dollar_bracket(aTHX_ kid)
11287                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11288                 )
11289              || (   kid->op_type == OP_CONST
11290                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11291                 )
11292            )
11293         )
11294             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11295                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11296     }
11297
11298     /* convert (index(...) == -1) and variations into
11299      *   (r)index/BOOL(,NEG)
11300      */
11301
11302     reverse = FALSE;
11303
11304     indexop = cUNOPo->op_first;
11305     constop = OpSIBLING(indexop);
11306     start = NULL;
11307     if (indexop->op_type == OP_CONST) {
11308         constop = indexop;
11309         indexop = OpSIBLING(constop);
11310         start = constop;
11311         reverse = TRUE;
11312     }
11313
11314     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11315         return o;
11316
11317     /* ($lex = index(....)) == -1 */
11318     if (indexop->op_private & OPpTARGET_MY)
11319         return o;
11320
11321     if (constop->op_type != OP_CONST)
11322         return o;
11323
11324     sv = cSVOPx_sv(constop);
11325     if (!(sv && SvIOK_notUV(sv)))
11326         return o;
11327
11328     iv = SvIVX(sv);
11329     if (iv != -1 && iv != 0)
11330         return o;
11331     iv0 = (iv == 0);
11332
11333     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11334         if (!(iv0 ^ reverse))
11335             return o;
11336         neg = iv0;
11337     }
11338     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11339         if (iv0 ^ reverse)
11340             return o;
11341         neg = !iv0;
11342     }
11343     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11344         if (!(iv0 ^ reverse))
11345             return o;
11346         neg = !iv0;
11347     }
11348     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11349         if (iv0 ^ reverse)
11350             return o;
11351         neg = iv0;
11352     }
11353     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11354         if (iv0)
11355             return o;
11356         neg = TRUE;
11357     }
11358     else {
11359         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11360         if (iv0)
11361             return o;
11362         neg = FALSE;
11363     }
11364
11365     indexop->op_flags &= ~OPf_PARENS;
11366     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11367     indexop->op_private |= OPpTRUEBOOL;
11368     if (neg)
11369         indexop->op_private |= OPpINDEX_BOOLNEG;
11370     /* cut out the index op and free the eq,const ops */
11371     (void)op_sibling_splice(o, start, 1, NULL);
11372     op_free(o);
11373
11374     return indexop;
11375 }
11376
11377
11378 OP *
11379 Perl_ck_concat(pTHX_ OP *o)
11380 {
11381     const OP * const kid = cUNOPo->op_first;
11382
11383     PERL_ARGS_ASSERT_CK_CONCAT;
11384     PERL_UNUSED_CONTEXT;
11385
11386     /* reuse the padtmp returned by the concat child */
11387     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11388             !(kUNOP->op_first->op_flags & OPf_MOD))
11389     {
11390         o->op_flags |= OPf_STACKED;
11391         o->op_private |= OPpCONCAT_NESTED;
11392     }
11393     return o;
11394 }
11395
11396 OP *
11397 Perl_ck_spair(pTHX_ OP *o)
11398 {
11399     dVAR;
11400
11401     PERL_ARGS_ASSERT_CK_SPAIR;
11402
11403     if (o->op_flags & OPf_KIDS) {
11404         OP* newop;
11405         OP* kid;
11406         OP* kidkid;
11407         const OPCODE type = o->op_type;
11408         o = modkids(ck_fun(o), type);
11409         kid    = cUNOPo->op_first;
11410         kidkid = kUNOP->op_first;
11411         newop = OpSIBLING(kidkid);
11412         if (newop) {
11413             const OPCODE type = newop->op_type;
11414             if (OpHAS_SIBLING(newop))
11415                 return o;
11416             if (o->op_type == OP_REFGEN
11417              && (  type == OP_RV2CV
11418                 || (  !(newop->op_flags & OPf_PARENS)
11419                    && (  type == OP_RV2AV || type == OP_PADAV
11420                       || type == OP_RV2HV || type == OP_PADHV))))
11421                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11422             else if (OP_GIMME(newop,0) != G_SCALAR)
11423                 return o;
11424         }
11425         /* excise first sibling */
11426         op_sibling_splice(kid, NULL, 1, NULL);
11427         op_free(kidkid);
11428     }
11429     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11430      * and OP_CHOMP into OP_SCHOMP */
11431     o->op_ppaddr = PL_ppaddr[++o->op_type];
11432     return ck_fun(o);
11433 }
11434
11435 OP *
11436 Perl_ck_delete(pTHX_ OP *o)
11437 {
11438     PERL_ARGS_ASSERT_CK_DELETE;
11439
11440     o = ck_fun(o);
11441     o->op_private = 0;
11442     if (o->op_flags & OPf_KIDS) {
11443         OP * const kid = cUNOPo->op_first;
11444         switch (kid->op_type) {
11445         case OP_ASLICE:
11446             o->op_flags |= OPf_SPECIAL;
11447             /* FALLTHROUGH */
11448         case OP_HSLICE:
11449             o->op_private |= OPpSLICE;
11450             break;
11451         case OP_AELEM:
11452             o->op_flags |= OPf_SPECIAL;
11453             /* FALLTHROUGH */
11454         case OP_HELEM:
11455             break;
11456         case OP_KVASLICE:
11457             o->op_flags |= OPf_SPECIAL;
11458             /* FALLTHROUGH */
11459         case OP_KVHSLICE:
11460             o->op_private |= OPpKVSLICE;
11461             break;
11462         default:
11463             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11464                              "element or slice");
11465         }
11466         if (kid->op_private & OPpLVAL_INTRO)
11467             o->op_private |= OPpLVAL_INTRO;
11468         op_null(kid);
11469     }
11470     return o;
11471 }
11472
11473 OP *
11474 Perl_ck_eof(pTHX_ OP *o)
11475 {
11476     PERL_ARGS_ASSERT_CK_EOF;
11477
11478     if (o->op_flags & OPf_KIDS) {
11479         OP *kid;
11480         if (cLISTOPo->op_first->op_type == OP_STUB) {
11481             OP * const newop
11482                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11483             op_free(o);
11484             o = newop;
11485         }
11486         o = ck_fun(o);
11487         kid = cLISTOPo->op_first;
11488         if (kid->op_type == OP_RV2GV)
11489             kid->op_private |= OPpALLOW_FAKE;
11490     }
11491     return o;
11492 }
11493
11494
11495 OP *
11496 Perl_ck_eval(pTHX_ OP *o)
11497 {
11498     dVAR;
11499
11500     PERL_ARGS_ASSERT_CK_EVAL;
11501
11502     PL_hints |= HINT_BLOCK_SCOPE;
11503     if (o->op_flags & OPf_KIDS) {
11504         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11505         assert(kid);
11506
11507         if (o->op_type == OP_ENTERTRY) {
11508             LOGOP *enter;
11509
11510             /* cut whole sibling chain free from o */
11511             op_sibling_splice(o, NULL, -1, NULL);
11512             op_free(o);
11513
11514             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11515
11516             /* establish postfix order */
11517             enter->op_next = (OP*)enter;
11518
11519             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11520             OpTYPE_set(o, OP_LEAVETRY);
11521             enter->op_other = o;
11522             return o;
11523         }
11524         else {
11525             scalar((OP*)kid);
11526             S_set_haseval(aTHX);
11527         }
11528     }
11529     else {
11530         const U8 priv = o->op_private;
11531         op_free(o);
11532         /* the newUNOP will recursively call ck_eval(), which will handle
11533          * all the stuff at the end of this function, like adding
11534          * OP_HINTSEVAL
11535          */
11536         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11537     }
11538     o->op_targ = (PADOFFSET)PL_hints;
11539     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11540     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11541      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11542         /* Store a copy of %^H that pp_entereval can pick up. */
11543         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11544                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11545         /* append hhop to only child  */
11546         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11547
11548         o->op_private |= OPpEVAL_HAS_HH;
11549     }
11550     if (!(o->op_private & OPpEVAL_BYTES)
11551          && FEATURE_UNIEVAL_IS_ENABLED)
11552             o->op_private |= OPpEVAL_UNICODE;
11553     return o;
11554 }
11555
11556 OP *
11557 Perl_ck_exec(pTHX_ OP *o)
11558 {
11559     PERL_ARGS_ASSERT_CK_EXEC;
11560
11561     if (o->op_flags & OPf_STACKED) {
11562         OP *kid;
11563         o = ck_fun(o);
11564         kid = OpSIBLING(cUNOPo->op_first);
11565         if (kid->op_type == OP_RV2GV)
11566             op_null(kid);
11567     }
11568     else
11569         o = listkids(o);
11570     return o;
11571 }
11572
11573 OP *
11574 Perl_ck_exists(pTHX_ OP *o)
11575 {
11576     PERL_ARGS_ASSERT_CK_EXISTS;
11577
11578     o = ck_fun(o);
11579     if (o->op_flags & OPf_KIDS) {
11580         OP * const kid = cUNOPo->op_first;
11581         if (kid->op_type == OP_ENTERSUB) {
11582             (void) ref(kid, o->op_type);
11583             if (kid->op_type != OP_RV2CV
11584                         && !(PL_parser && PL_parser->error_count))
11585                 Perl_croak(aTHX_
11586                           "exists argument is not a subroutine name");
11587             o->op_private |= OPpEXISTS_SUB;
11588         }
11589         else if (kid->op_type == OP_AELEM)
11590             o->op_flags |= OPf_SPECIAL;
11591         else if (kid->op_type != OP_HELEM)
11592             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11593                              "element or a subroutine");
11594         op_null(kid);
11595     }
11596     return o;
11597 }
11598
11599 OP *
11600 Perl_ck_rvconst(pTHX_ OP *o)
11601 {
11602     dVAR;
11603     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11604
11605     PERL_ARGS_ASSERT_CK_RVCONST;
11606
11607     if (o->op_type == OP_RV2HV)
11608         /* rv2hv steals the bottom bit for its own uses */
11609         o->op_private &= ~OPpARG1_MASK;
11610
11611     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11612
11613     if (kid->op_type == OP_CONST) {
11614         int iscv;
11615         GV *gv;
11616         SV * const kidsv = kid->op_sv;
11617
11618         /* Is it a constant from cv_const_sv()? */
11619         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11620             return o;
11621         }
11622         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11623         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11624             const char *badthing;
11625             switch (o->op_type) {
11626             case OP_RV2SV:
11627                 badthing = "a SCALAR";
11628                 break;
11629             case OP_RV2AV:
11630                 badthing = "an ARRAY";
11631                 break;
11632             case OP_RV2HV:
11633                 badthing = "a HASH";
11634                 break;
11635             default:
11636                 badthing = NULL;
11637                 break;
11638             }
11639             if (badthing)
11640                 Perl_croak(aTHX_
11641                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11642                            SVfARG(kidsv), badthing);
11643         }
11644         /*
11645          * This is a little tricky.  We only want to add the symbol if we
11646          * didn't add it in the lexer.  Otherwise we get duplicate strict
11647          * warnings.  But if we didn't add it in the lexer, we must at
11648          * least pretend like we wanted to add it even if it existed before,
11649          * or we get possible typo warnings.  OPpCONST_ENTERED says
11650          * whether the lexer already added THIS instance of this symbol.
11651          */
11652         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11653         gv = gv_fetchsv(kidsv,
11654                 o->op_type == OP_RV2CV
11655                         && o->op_private & OPpMAY_RETURN_CONSTANT
11656                     ? GV_NOEXPAND
11657                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11658                 iscv
11659                     ? SVt_PVCV
11660                     : o->op_type == OP_RV2SV
11661                         ? SVt_PV
11662                         : o->op_type == OP_RV2AV
11663                             ? SVt_PVAV
11664                             : o->op_type == OP_RV2HV
11665                                 ? SVt_PVHV
11666                                 : SVt_PVGV);
11667         if (gv) {
11668             if (!isGV(gv)) {
11669                 assert(iscv);
11670                 assert(SvROK(gv));
11671                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11672                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11673                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11674             }
11675             OpTYPE_set(kid, OP_GV);
11676             SvREFCNT_dec(kid->op_sv);
11677 #ifdef USE_ITHREADS
11678             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11679             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11680             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11681             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11682             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11683 #else
11684             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11685 #endif
11686             kid->op_private = 0;
11687             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11688             SvFAKE_off(gv);
11689         }
11690     }
11691     return o;
11692 }
11693
11694 OP *
11695 Perl_ck_ftst(pTHX_ OP *o)
11696 {
11697     dVAR;
11698     const I32 type = o->op_type;
11699
11700     PERL_ARGS_ASSERT_CK_FTST;
11701
11702     if (o->op_flags & OPf_REF) {
11703         NOOP;
11704     }
11705     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11706         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11707         const OPCODE kidtype = kid->op_type;
11708
11709         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11710          && !kid->op_folded) {
11711             OP * const newop = newGVOP(type, OPf_REF,
11712                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11713             op_free(o);
11714             return newop;
11715         }
11716
11717         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11718             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11719             if (name) {
11720                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11721                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11722                             array_passed_to_stat, name);
11723             }
11724             else {
11725                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11726                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11727             }
11728        }
11729         scalar((OP *) kid);
11730         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11731             o->op_private |= OPpFT_ACCESS;
11732         if (OP_IS_FILETEST(type)
11733             && OP_IS_FILETEST(kidtype)
11734         ) {
11735             o->op_private |= OPpFT_STACKED;
11736             kid->op_private |= OPpFT_STACKING;
11737             if (kidtype == OP_FTTTY && (
11738                    !(kid->op_private & OPpFT_STACKED)
11739                 || kid->op_private & OPpFT_AFTER_t
11740                ))
11741                 o->op_private |= OPpFT_AFTER_t;
11742         }
11743     }
11744     else {
11745         op_free(o);
11746         if (type == OP_FTTTY)
11747             o = newGVOP(type, OPf_REF, PL_stdingv);
11748         else
11749             o = newUNOP(type, 0, newDEFSVOP());
11750     }
11751     return o;
11752 }
11753
11754 OP *
11755 Perl_ck_fun(pTHX_ OP *o)
11756 {
11757     const int type = o->op_type;
11758     I32 oa = PL_opargs[type] >> OASHIFT;
11759
11760     PERL_ARGS_ASSERT_CK_FUN;
11761
11762     if (o->op_flags & OPf_STACKED) {
11763         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11764             oa &= ~OA_OPTIONAL;
11765         else
11766             return no_fh_allowed(o);
11767     }
11768
11769     if (o->op_flags & OPf_KIDS) {
11770         OP *prev_kid = NULL;
11771         OP *kid = cLISTOPo->op_first;
11772         I32 numargs = 0;
11773         bool seen_optional = FALSE;
11774
11775         if (kid->op_type == OP_PUSHMARK ||
11776             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11777         {
11778             prev_kid = kid;
11779             kid = OpSIBLING(kid);
11780         }
11781         if (kid && kid->op_type == OP_COREARGS) {
11782             bool optional = FALSE;
11783             while (oa) {
11784                 numargs++;
11785                 if (oa & OA_OPTIONAL) optional = TRUE;
11786                 oa = oa >> 4;
11787             }
11788             if (optional) o->op_private |= numargs;
11789             return o;
11790         }
11791
11792         while (oa) {
11793             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11794                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11795                     kid = newDEFSVOP();
11796                     /* append kid to chain */
11797                     op_sibling_splice(o, prev_kid, 0, kid);
11798                 }
11799                 seen_optional = TRUE;
11800             }
11801             if (!kid) break;
11802
11803             numargs++;
11804             switch (oa & 7) {
11805             case OA_SCALAR:
11806                 /* list seen where single (scalar) arg expected? */
11807                 if (numargs == 1 && !(oa >> 4)
11808                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11809                 {
11810                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11811                 }
11812                 if (type != OP_DELETE) scalar(kid);
11813                 break;
11814             case OA_LIST:
11815                 if (oa < 16) {
11816                     kid = 0;
11817                     continue;
11818                 }
11819                 else
11820                     list(kid);
11821                 break;
11822             case OA_AVREF:
11823                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11824                     && !OpHAS_SIBLING(kid))
11825                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11826                                    "Useless use of %s with no values",
11827                                    PL_op_desc[type]);
11828
11829                 if (kid->op_type == OP_CONST
11830                       && (  !SvROK(cSVOPx_sv(kid))
11831                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11832                         )
11833                     bad_type_pv(numargs, "array", o, kid);
11834                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11835                          || kid->op_type == OP_RV2GV) {
11836                     bad_type_pv(1, "array", o, kid);
11837                 }
11838                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11839                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11840                                          PL_op_desc[type]), 0);
11841                 }
11842                 else {
11843                     op_lvalue(kid, type);
11844                 }
11845                 break;
11846             case OA_HVREF:
11847                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11848                     bad_type_pv(numargs, "hash", o, kid);
11849                 op_lvalue(kid, type);
11850                 break;
11851             case OA_CVREF:
11852                 {
11853                     /* replace kid with newop in chain */
11854                     OP * const newop =
11855                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11856                     newop->op_next = newop;
11857                     kid = newop;
11858                 }
11859                 break;
11860             case OA_FILEREF:
11861                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11862                     if (kid->op_type == OP_CONST &&
11863                         (kid->op_private & OPpCONST_BARE))
11864                     {
11865                         OP * const newop = newGVOP(OP_GV, 0,
11866                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11867                         /* replace kid with newop in chain */
11868                         op_sibling_splice(o, prev_kid, 1, newop);
11869                         op_free(kid);
11870                         kid = newop;
11871                     }
11872                     else if (kid->op_type == OP_READLINE) {
11873                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11874                         bad_type_pv(numargs, "HANDLE", o, kid);
11875                     }
11876                     else {
11877                         I32 flags = OPf_SPECIAL;
11878                         I32 priv = 0;
11879                         PADOFFSET targ = 0;
11880
11881                         /* is this op a FH constructor? */
11882                         if (is_handle_constructor(o,numargs)) {
11883                             const char *name = NULL;
11884                             STRLEN len = 0;
11885                             U32 name_utf8 = 0;
11886                             bool want_dollar = TRUE;
11887
11888                             flags = 0;
11889                             /* Set a flag to tell rv2gv to vivify
11890                              * need to "prove" flag does not mean something
11891                              * else already - NI-S 1999/05/07
11892                              */
11893                             priv = OPpDEREF;
11894                             if (kid->op_type == OP_PADSV) {
11895                                 PADNAME * const pn
11896                                     = PAD_COMPNAME_SV(kid->op_targ);
11897                                 name = PadnamePV (pn);
11898                                 len  = PadnameLEN(pn);
11899                                 name_utf8 = PadnameUTF8(pn);
11900                             }
11901                             else if (kid->op_type == OP_RV2SV
11902                                      && kUNOP->op_first->op_type == OP_GV)
11903                             {
11904                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11905                                 name = GvNAME(gv);
11906                                 len = GvNAMELEN(gv);
11907                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11908                             }
11909                             else if (kid->op_type == OP_AELEM
11910                                      || kid->op_type == OP_HELEM)
11911                             {
11912                                  OP *firstop;
11913                                  OP *op = ((BINOP*)kid)->op_first;
11914                                  name = NULL;
11915                                  if (op) {
11916                                       SV *tmpstr = NULL;
11917                                       const char * const a =
11918                                            kid->op_type == OP_AELEM ?
11919                                            "[]" : "{}";
11920                                       if (((op->op_type == OP_RV2AV) ||
11921                                            (op->op_type == OP_RV2HV)) &&
11922                                           (firstop = ((UNOP*)op)->op_first) &&
11923                                           (firstop->op_type == OP_GV)) {
11924                                            /* packagevar $a[] or $h{} */
11925                                            GV * const gv = cGVOPx_gv(firstop);
11926                                            if (gv)
11927                                                 tmpstr =
11928                                                      Perl_newSVpvf(aTHX_
11929                                                                    "%s%c...%c",
11930                                                                    GvNAME(gv),
11931                                                                    a[0], a[1]);
11932                                       }
11933                                       else if (op->op_type == OP_PADAV
11934                                                || op->op_type == OP_PADHV) {
11935                                            /* lexicalvar $a[] or $h{} */
11936                                            const char * const padname =
11937                                                 PAD_COMPNAME_PV(op->op_targ);
11938                                            if (padname)
11939                                                 tmpstr =
11940                                                      Perl_newSVpvf(aTHX_
11941                                                                    "%s%c...%c",
11942                                                                    padname + 1,
11943                                                                    a[0], a[1]);
11944                                       }
11945                                       if (tmpstr) {
11946                                            name = SvPV_const(tmpstr, len);
11947                                            name_utf8 = SvUTF8(tmpstr);
11948                                            sv_2mortal(tmpstr);
11949                                       }
11950                                  }
11951                                  if (!name) {
11952                                       name = "__ANONIO__";
11953                                       len = 10;
11954                                       want_dollar = FALSE;
11955                                  }
11956                                  op_lvalue(kid, type);
11957                             }
11958                             if (name) {
11959                                 SV *namesv;
11960                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11961                                 namesv = PAD_SVl(targ);
11962                                 if (want_dollar && *name != '$')
11963                                     sv_setpvs(namesv, "$");
11964                                 else
11965                                     SvPVCLEAR(namesv);
11966                                 sv_catpvn(namesv, name, len);
11967                                 if ( name_utf8 ) SvUTF8_on(namesv);
11968                             }
11969                         }
11970                         scalar(kid);
11971                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11972                                     OP_RV2GV, flags);
11973                         kid->op_targ = targ;
11974                         kid->op_private |= priv;
11975                     }
11976                 }
11977                 scalar(kid);
11978                 break;
11979             case OA_SCALARREF:
11980                 if ((type == OP_UNDEF || type == OP_POS)
11981                     && numargs == 1 && !(oa >> 4)
11982                     && kid->op_type == OP_LIST)
11983                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11984                 op_lvalue(scalar(kid), type);
11985                 break;
11986             }
11987             oa >>= 4;
11988             prev_kid = kid;
11989             kid = OpSIBLING(kid);
11990         }
11991         /* FIXME - should the numargs or-ing move after the too many
11992          * arguments check? */
11993         o->op_private |= numargs;
11994         if (kid)
11995             return too_many_arguments_pv(o,OP_DESC(o), 0);
11996         listkids(o);
11997     }
11998     else if (PL_opargs[type] & OA_DEFGV) {
11999         /* Ordering of these two is important to keep f_map.t passing.  */
12000         op_free(o);
12001         return newUNOP(type, 0, newDEFSVOP());
12002     }
12003
12004     if (oa) {
12005         while (oa & OA_OPTIONAL)
12006             oa >>= 4;
12007         if (oa && oa != OA_LIST)
12008             return too_few_arguments_pv(o,OP_DESC(o), 0);
12009     }
12010     return o;
12011 }
12012
12013 OP *
12014 Perl_ck_glob(pTHX_ OP *o)
12015 {
12016     GV *gv;
12017
12018     PERL_ARGS_ASSERT_CK_GLOB;
12019
12020     o = ck_fun(o);
12021     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12022         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12023
12024     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12025     {
12026         /* convert
12027          *     glob
12028          *       \ null - const(wildcard)
12029          * into
12030          *     null
12031          *       \ enter
12032          *            \ list
12033          *                 \ mark - glob - rv2cv
12034          *                             |        \ gv(CORE::GLOBAL::glob)
12035          *                             |
12036          *                              \ null - const(wildcard)
12037          */
12038         o->op_flags |= OPf_SPECIAL;
12039         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12040         o = S_new_entersubop(aTHX_ gv, o);
12041         o = newUNOP(OP_NULL, 0, o);
12042         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12043         return o;
12044     }
12045     else o->op_flags &= ~OPf_SPECIAL;
12046 #if !defined(PERL_EXTERNAL_GLOB)
12047     if (!PL_globhook) {
12048         ENTER;
12049         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12050                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12051         LEAVE;
12052     }
12053 #endif /* !PERL_EXTERNAL_GLOB */
12054     gv = (GV *)newSV(0);
12055     gv_init(gv, 0, "", 0, 0);
12056     gv_IOadd(gv);
12057     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12058     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12059     scalarkids(o);
12060     return o;
12061 }
12062
12063 OP *
12064 Perl_ck_grep(pTHX_ OP *o)
12065 {
12066     LOGOP *gwop;
12067     OP *kid;
12068     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12069
12070     PERL_ARGS_ASSERT_CK_GREP;
12071
12072     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12073
12074     if (o->op_flags & OPf_STACKED) {
12075         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12076         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12077             return no_fh_allowed(o);
12078         o->op_flags &= ~OPf_STACKED;
12079     }
12080     kid = OpSIBLING(cLISTOPo->op_first);
12081     if (type == OP_MAPWHILE)
12082         list(kid);
12083     else
12084         scalar(kid);
12085     o = ck_fun(o);
12086     if (PL_parser && PL_parser->error_count)
12087         return o;
12088     kid = OpSIBLING(cLISTOPo->op_first);
12089     if (kid->op_type != OP_NULL)
12090         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12091     kid = kUNOP->op_first;
12092
12093     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12094     kid->op_next = (OP*)gwop;
12095     o->op_private = gwop->op_private = 0;
12096     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12097
12098     kid = OpSIBLING(cLISTOPo->op_first);
12099     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12100         op_lvalue(kid, OP_GREPSTART);
12101
12102     return (OP*)gwop;
12103 }
12104
12105 OP *
12106 Perl_ck_index(pTHX_ OP *o)
12107 {
12108     PERL_ARGS_ASSERT_CK_INDEX;
12109
12110     if (o->op_flags & OPf_KIDS) {
12111         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12112         if (kid)
12113             kid = OpSIBLING(kid);                       /* get past "big" */
12114         if (kid && kid->op_type == OP_CONST) {
12115             const bool save_taint = TAINT_get;
12116             SV *sv = kSVOP->op_sv;
12117             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12118                 && SvOK(sv) && !SvROK(sv))
12119             {
12120                 sv = newSV(0);
12121                 sv_copypv(sv, kSVOP->op_sv);
12122                 SvREFCNT_dec_NN(kSVOP->op_sv);
12123                 kSVOP->op_sv = sv;
12124             }
12125             if (SvOK(sv)) fbm_compile(sv, 0);
12126             TAINT_set(save_taint);
12127 #ifdef NO_TAINT_SUPPORT
12128             PERL_UNUSED_VAR(save_taint);
12129 #endif
12130         }
12131     }
12132     return ck_fun(o);
12133 }
12134
12135 OP *
12136 Perl_ck_lfun(pTHX_ OP *o)
12137 {
12138     const OPCODE type = o->op_type;
12139
12140     PERL_ARGS_ASSERT_CK_LFUN;
12141
12142     return modkids(ck_fun(o), type);
12143 }
12144
12145 OP *
12146 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12147 {
12148     PERL_ARGS_ASSERT_CK_DEFINED;
12149
12150     if ((o->op_flags & OPf_KIDS)) {
12151         switch (cUNOPo->op_first->op_type) {
12152         case OP_RV2AV:
12153         case OP_PADAV:
12154             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12155                              " (Maybe you should just omit the defined()?)");
12156             NOT_REACHED; /* NOTREACHED */
12157             break;
12158         case OP_RV2HV:
12159         case OP_PADHV:
12160             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12161                              " (Maybe you should just omit the defined()?)");
12162             NOT_REACHED; /* NOTREACHED */
12163             break;
12164         default:
12165             /* no warning */
12166             break;
12167         }
12168     }
12169     return ck_rfun(o);
12170 }
12171
12172 OP *
12173 Perl_ck_readline(pTHX_ OP *o)
12174 {
12175     PERL_ARGS_ASSERT_CK_READLINE;
12176
12177     if (o->op_flags & OPf_KIDS) {
12178          OP *kid = cLISTOPo->op_first;
12179          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12180          scalar(kid);
12181     }
12182     else {
12183         OP * const newop
12184             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12185         op_free(o);
12186         return newop;
12187     }
12188     return o;
12189 }
12190
12191 OP *
12192 Perl_ck_rfun(pTHX_ OP *o)
12193 {
12194     const OPCODE type = o->op_type;
12195
12196     PERL_ARGS_ASSERT_CK_RFUN;
12197
12198     return refkids(ck_fun(o), type);
12199 }
12200
12201 OP *
12202 Perl_ck_listiob(pTHX_ OP *o)
12203 {
12204     OP *kid;
12205
12206     PERL_ARGS_ASSERT_CK_LISTIOB;
12207
12208     kid = cLISTOPo->op_first;
12209     if (!kid) {
12210         o = force_list(o, 1);
12211         kid = cLISTOPo->op_first;
12212     }
12213     if (kid->op_type == OP_PUSHMARK)
12214         kid = OpSIBLING(kid);
12215     if (kid && o->op_flags & OPf_STACKED)
12216         kid = OpSIBLING(kid);
12217     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12218         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12219          && !kid->op_folded) {
12220             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12221             scalar(kid);
12222             /* replace old const op with new OP_RV2GV parent */
12223             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12224                                         OP_RV2GV, OPf_REF);
12225             kid = OpSIBLING(kid);
12226         }
12227     }
12228
12229     if (!kid)
12230         op_append_elem(o->op_type, o, newDEFSVOP());
12231
12232     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12233     return listkids(o);
12234 }
12235
12236 OP *
12237 Perl_ck_smartmatch(pTHX_ OP *o)
12238 {
12239     dVAR;
12240     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12241     if (0 == (o->op_flags & OPf_SPECIAL)) {
12242         OP *first  = cBINOPo->op_first;
12243         OP *second = OpSIBLING(first);
12244
12245         /* Implicitly take a reference to an array or hash */
12246
12247         /* remove the original two siblings, then add back the
12248          * (possibly different) first and second sibs.
12249          */
12250         op_sibling_splice(o, NULL, 1, NULL);
12251         op_sibling_splice(o, NULL, 1, NULL);
12252         first  = ref_array_or_hash(first);
12253         second = ref_array_or_hash(second);
12254         op_sibling_splice(o, NULL, 0, second);
12255         op_sibling_splice(o, NULL, 0, first);
12256
12257         /* Implicitly take a reference to a regular expression */
12258         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12259             OpTYPE_set(first, OP_QR);
12260         }
12261         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12262             OpTYPE_set(second, OP_QR);
12263         }
12264     }
12265
12266     return o;
12267 }
12268
12269
12270 static OP *
12271 S_maybe_targlex(pTHX_ OP *o)
12272 {
12273     OP * const kid = cLISTOPo->op_first;
12274     /* has a disposable target? */
12275     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12276         && !(kid->op_flags & OPf_STACKED)
12277         /* Cannot steal the second time! */
12278         && !(kid->op_private & OPpTARGET_MY)
12279         )
12280     {
12281         OP * const kkid = OpSIBLING(kid);
12282
12283         /* Can just relocate the target. */
12284         if (kkid && kkid->op_type == OP_PADSV
12285             && (!(kkid->op_private & OPpLVAL_INTRO)
12286                || kkid->op_private & OPpPAD_STATE))
12287         {
12288             kid->op_targ = kkid->op_targ;
12289             kkid->op_targ = 0;
12290             /* Now we do not need PADSV and SASSIGN.
12291              * Detach kid and free the rest. */
12292             op_sibling_splice(o, NULL, 1, NULL);
12293             op_free(o);
12294             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12295             return kid;
12296         }
12297     }
12298     return o;
12299 }
12300
12301 OP *
12302 Perl_ck_sassign(pTHX_ OP *o)
12303 {
12304     dVAR;
12305     OP * const kid = cBINOPo->op_first;
12306
12307     PERL_ARGS_ASSERT_CK_SASSIGN;
12308
12309     if (OpHAS_SIBLING(kid)) {
12310         OP *kkid = OpSIBLING(kid);
12311         /* For state variable assignment with attributes, kkid is a list op
12312            whose op_last is a padsv. */
12313         if ((kkid->op_type == OP_PADSV ||
12314              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12315               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12316              )
12317             )
12318                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12319                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12320             return S_newONCEOP(aTHX_ o, kkid);
12321         }
12322     }
12323     return S_maybe_targlex(aTHX_ o);
12324 }
12325
12326
12327 OP *
12328 Perl_ck_match(pTHX_ OP *o)
12329 {
12330     PERL_UNUSED_CONTEXT;
12331     PERL_ARGS_ASSERT_CK_MATCH;
12332
12333     return o;
12334 }
12335
12336 OP *
12337 Perl_ck_method(pTHX_ OP *o)
12338 {
12339     SV *sv, *methsv, *rclass;
12340     const char* method;
12341     char* compatptr;
12342     int utf8;
12343     STRLEN len, nsplit = 0, i;
12344     OP* new_op;
12345     OP * const kid = cUNOPo->op_first;
12346
12347     PERL_ARGS_ASSERT_CK_METHOD;
12348     if (kid->op_type != OP_CONST) return o;
12349
12350     sv = kSVOP->op_sv;
12351
12352     /* replace ' with :: */
12353     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12354                                         SvEND(sv) - SvPVX(sv) )))
12355     {
12356         *compatptr = ':';
12357         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12358     }
12359
12360     method = SvPVX_const(sv);
12361     len = SvCUR(sv);
12362     utf8 = SvUTF8(sv) ? -1 : 1;
12363
12364     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12365         nsplit = i+1;
12366         break;
12367     }
12368
12369     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12370
12371     if (!nsplit) { /* $proto->method() */
12372         op_free(o);
12373         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12374     }
12375
12376     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12377         op_free(o);
12378         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12379     }
12380
12381     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12382     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12383         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12384         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12385     } else {
12386         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12387         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12388     }
12389 #ifdef USE_ITHREADS
12390     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12391 #else
12392     cMETHOPx(new_op)->op_rclass_sv = rclass;
12393 #endif
12394     op_free(o);
12395     return new_op;
12396 }
12397
12398 OP *
12399 Perl_ck_null(pTHX_ OP *o)
12400 {
12401     PERL_ARGS_ASSERT_CK_NULL;
12402     PERL_UNUSED_CONTEXT;
12403     return o;
12404 }
12405
12406 OP *
12407 Perl_ck_open(pTHX_ OP *o)
12408 {
12409     PERL_ARGS_ASSERT_CK_OPEN;
12410
12411     S_io_hints(aTHX_ o);
12412     {
12413          /* In case of three-arg dup open remove strictness
12414           * from the last arg if it is a bareword. */
12415          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12416          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12417          OP *oa;
12418          const char *mode;
12419
12420          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12421              (last->op_private & OPpCONST_BARE) &&
12422              (last->op_private & OPpCONST_STRICT) &&
12423              (oa = OpSIBLING(first)) &&         /* The fh. */
12424              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12425              (oa->op_type == OP_CONST) &&
12426              SvPOK(((SVOP*)oa)->op_sv) &&
12427              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12428              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12429              (last == OpSIBLING(oa)))                   /* The bareword. */
12430               last->op_private &= ~OPpCONST_STRICT;
12431     }
12432     return ck_fun(o);
12433 }
12434
12435 OP *
12436 Perl_ck_prototype(pTHX_ OP *o)
12437 {
12438     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12439     if (!(o->op_flags & OPf_KIDS)) {
12440         op_free(o);
12441         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12442     }
12443     return o;
12444 }
12445
12446 OP *
12447 Perl_ck_refassign(pTHX_ OP *o)
12448 {
12449     OP * const right = cLISTOPo->op_first;
12450     OP * const left = OpSIBLING(right);
12451     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12452     bool stacked = 0;
12453
12454     PERL_ARGS_ASSERT_CK_REFASSIGN;
12455     assert (left);
12456     assert (left->op_type == OP_SREFGEN);
12457
12458     o->op_private = 0;
12459     /* we use OPpPAD_STATE in refassign to mean either of those things,
12460      * and the code assumes the two flags occupy the same bit position
12461      * in the various ops below */
12462     assert(OPpPAD_STATE == OPpOUR_INTRO);
12463
12464     switch (varop->op_type) {
12465     case OP_PADAV:
12466         o->op_private |= OPpLVREF_AV;
12467         goto settarg;
12468     case OP_PADHV:
12469         o->op_private |= OPpLVREF_HV;
12470         /* FALLTHROUGH */
12471     case OP_PADSV:
12472       settarg:
12473         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12474         o->op_targ = varop->op_targ;
12475         varop->op_targ = 0;
12476         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12477         break;
12478
12479     case OP_RV2AV:
12480         o->op_private |= OPpLVREF_AV;
12481         goto checkgv;
12482         NOT_REACHED; /* NOTREACHED */
12483     case OP_RV2HV:
12484         o->op_private |= OPpLVREF_HV;
12485         /* FALLTHROUGH */
12486     case OP_RV2SV:
12487       checkgv:
12488         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12489         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12490       detach_and_stack:
12491         /* Point varop to its GV kid, detached.  */
12492         varop = op_sibling_splice(varop, NULL, -1, NULL);
12493         stacked = TRUE;
12494         break;
12495     case OP_RV2CV: {
12496         OP * const kidparent =
12497             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12498         OP * const kid = cUNOPx(kidparent)->op_first;
12499         o->op_private |= OPpLVREF_CV;
12500         if (kid->op_type == OP_GV) {
12501             SV *sv = (SV*)cGVOPx_gv(kid);
12502             varop = kidparent;
12503             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12504                 /* a CVREF here confuses pp_refassign, so make sure
12505                    it gets a GV */
12506                 CV *const cv = (CV*)SvRV(sv);
12507                 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
12508                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12509                 assert(SvTYPE(sv) == SVt_PVGV);
12510             }
12511             goto detach_and_stack;
12512         }
12513         if (kid->op_type != OP_PADCV)   goto bad;
12514         o->op_targ = kid->op_targ;
12515         kid->op_targ = 0;
12516         break;
12517     }
12518     case OP_AELEM:
12519     case OP_HELEM:
12520         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12521         o->op_private |= OPpLVREF_ELEM;
12522         op_null(varop);
12523         stacked = TRUE;
12524         /* Detach varop.  */
12525         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12526         break;
12527     default:
12528       bad:
12529         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12530         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12531                                 "assignment",
12532                                  OP_DESC(varop)));
12533         return o;
12534     }
12535     if (!FEATURE_REFALIASING_IS_ENABLED)
12536         Perl_croak(aTHX_
12537                   "Experimental aliasing via reference not enabled");
12538     Perl_ck_warner_d(aTHX_
12539                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12540                     "Aliasing via reference is experimental");
12541     if (stacked) {
12542         o->op_flags |= OPf_STACKED;
12543         op_sibling_splice(o, right, 1, varop);
12544     }
12545     else {
12546         o->op_flags &=~ OPf_STACKED;
12547         op_sibling_splice(o, right, 1, NULL);
12548     }
12549     op_free(left);
12550     return o;
12551 }
12552
12553 OP *
12554 Perl_ck_repeat(pTHX_ OP *o)
12555 {
12556     PERL_ARGS_ASSERT_CK_REPEAT;
12557
12558     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12559         OP* kids;
12560         o->op_private |= OPpREPEAT_DOLIST;
12561         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12562         kids = force_list(kids, 1); /* promote it to a list */
12563         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12564     }
12565     else
12566         scalar(o);
12567     return o;
12568 }
12569
12570 OP *
12571 Perl_ck_require(pTHX_ OP *o)
12572 {
12573     GV* gv;
12574
12575     PERL_ARGS_ASSERT_CK_REQUIRE;
12576
12577     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12578         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12579         U32 hash;
12580         char *s;
12581         STRLEN len;
12582         if (kid->op_type == OP_CONST) {
12583           SV * const sv = kid->op_sv;
12584           U32 const was_readonly = SvREADONLY(sv);
12585           if (kid->op_private & OPpCONST_BARE) {
12586             dVAR;
12587             const char *end;
12588             HEK *hek;
12589
12590             if (was_readonly) {
12591                     SvREADONLY_off(sv);
12592             }
12593             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12594
12595             s = SvPVX(sv);
12596             len = SvCUR(sv);
12597             end = s + len;
12598             /* treat ::foo::bar as foo::bar */
12599             if (len >= 2 && s[0] == ':' && s[1] == ':')
12600                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12601             if (s == end)
12602                 DIE(aTHX_ "Bareword in require maps to empty filename");
12603
12604             for (; s < end; s++) {
12605                 if (*s == ':' && s[1] == ':') {
12606                     *s = '/';
12607                     Move(s+2, s+1, end - s - 1, char);
12608                     --end;
12609                 }
12610             }
12611             SvEND_set(sv, end);
12612             sv_catpvs(sv, ".pm");
12613             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12614             hek = share_hek(SvPVX(sv),
12615                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12616                             hash);
12617             sv_sethek(sv, hek);
12618             unshare_hek(hek);
12619             SvFLAGS(sv) |= was_readonly;
12620           }
12621           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12622                 && !SvVOK(sv)) {
12623             s = SvPV(sv, len);
12624             if (SvREFCNT(sv) > 1) {
12625                 kid->op_sv = newSVpvn_share(
12626                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12627                 SvREFCNT_dec_NN(sv);
12628             }
12629             else {
12630                 dVAR;
12631                 HEK *hek;
12632                 if (was_readonly) SvREADONLY_off(sv);
12633                 PERL_HASH(hash, s, len);
12634                 hek = share_hek(s,
12635                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12636                                 hash);
12637                 sv_sethek(sv, hek);
12638                 unshare_hek(hek);
12639                 SvFLAGS(sv) |= was_readonly;
12640             }
12641           }
12642         }
12643     }
12644
12645     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12646         /* handle override, if any */
12647      && (gv = gv_override("require", 7))) {
12648         OP *kid, *newop;
12649         if (o->op_flags & OPf_KIDS) {
12650             kid = cUNOPo->op_first;
12651             op_sibling_splice(o, NULL, -1, NULL);
12652         }
12653         else {
12654             kid = newDEFSVOP();
12655         }
12656         op_free(o);
12657         newop = S_new_entersubop(aTHX_ gv, kid);
12658         return newop;
12659     }
12660
12661     return ck_fun(o);
12662 }
12663
12664 OP *
12665 Perl_ck_return(pTHX_ OP *o)
12666 {
12667     OP *kid;
12668
12669     PERL_ARGS_ASSERT_CK_RETURN;
12670
12671     kid = OpSIBLING(cLISTOPo->op_first);
12672     if (PL_compcv && CvLVALUE(PL_compcv)) {
12673         for (; kid; kid = OpSIBLING(kid))
12674             op_lvalue(kid, OP_LEAVESUBLV);
12675     }
12676
12677     return o;
12678 }
12679
12680 OP *
12681 Perl_ck_select(pTHX_ OP *o)
12682 {
12683     dVAR;
12684     OP* kid;
12685
12686     PERL_ARGS_ASSERT_CK_SELECT;
12687
12688     if (o->op_flags & OPf_KIDS) {
12689         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12690         if (kid && OpHAS_SIBLING(kid)) {
12691             OpTYPE_set(o, OP_SSELECT);
12692             o = ck_fun(o);
12693             return fold_constants(op_integerize(op_std_init(o)));
12694         }
12695     }
12696     o = ck_fun(o);
12697     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12698     if (kid && kid->op_type == OP_RV2GV)
12699         kid->op_private &= ~HINT_STRICT_REFS;
12700     return o;
12701 }
12702
12703 OP *
12704 Perl_ck_shift(pTHX_ OP *o)
12705 {
12706     const I32 type = o->op_type;
12707
12708     PERL_ARGS_ASSERT_CK_SHIFT;
12709
12710     if (!(o->op_flags & OPf_KIDS)) {
12711         OP *argop;
12712
12713         if (!CvUNIQUE(PL_compcv)) {
12714             o->op_flags |= OPf_SPECIAL;
12715             return o;
12716         }
12717
12718         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12719         op_free(o);
12720         return newUNOP(type, 0, scalar(argop));
12721     }
12722     return scalar(ck_fun(o));
12723 }
12724
12725 OP *
12726 Perl_ck_sort(pTHX_ OP *o)
12727 {
12728     OP *firstkid;
12729     OP *kid;
12730     HV * const hinthv =
12731         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12732     U8 stacked;
12733
12734     PERL_ARGS_ASSERT_CK_SORT;
12735
12736     if (hinthv) {
12737             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12738             if (svp) {
12739                 const I32 sorthints = (I32)SvIV(*svp);
12740                 if ((sorthints & HINT_SORT_STABLE) != 0)
12741                     o->op_private |= OPpSORT_STABLE;
12742                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12743                     o->op_private |= OPpSORT_UNSTABLE;
12744             }
12745     }
12746
12747     if (o->op_flags & OPf_STACKED)
12748         simplify_sort(o);
12749     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12750
12751     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12752         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12753
12754         /* if the first arg is a code block, process it and mark sort as
12755          * OPf_SPECIAL */
12756         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12757             LINKLIST(kid);
12758             if (kid->op_type == OP_LEAVE)
12759                     op_null(kid);                       /* wipe out leave */
12760             /* Prevent execution from escaping out of the sort block. */
12761             kid->op_next = 0;
12762
12763             /* provide scalar context for comparison function/block */
12764             kid = scalar(firstkid);
12765             kid->op_next = kid;
12766             o->op_flags |= OPf_SPECIAL;
12767         }
12768         else if (kid->op_type == OP_CONST
12769               && kid->op_private & OPpCONST_BARE) {
12770             char tmpbuf[256];
12771             STRLEN len;
12772             PADOFFSET off;
12773             const char * const name = SvPV(kSVOP_sv, len);
12774             *tmpbuf = '&';
12775             assert (len < 256);
12776             Copy(name, tmpbuf+1, len, char);
12777             off = pad_findmy_pvn(tmpbuf, len+1, 0);
12778             if (off != NOT_IN_PAD) {
12779                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12780                     SV * const fq =
12781                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12782                     sv_catpvs(fq, "::");
12783                     sv_catsv(fq, kSVOP_sv);
12784                     SvREFCNT_dec_NN(kSVOP_sv);
12785                     kSVOP->op_sv = fq;
12786                 }
12787                 else {
12788                     OP * const padop = newOP(OP_PADCV, 0);
12789                     padop->op_targ = off;
12790                     /* replace the const op with the pad op */
12791                     op_sibling_splice(firstkid, NULL, 1, padop);
12792                     op_free(kid);
12793                 }
12794             }
12795         }
12796
12797         firstkid = OpSIBLING(firstkid);
12798     }
12799
12800     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12801         /* provide list context for arguments */
12802         list(kid);
12803         if (stacked)
12804             op_lvalue(kid, OP_GREPSTART);
12805     }
12806
12807     return o;
12808 }
12809
12810 /* for sort { X } ..., where X is one of
12811  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12812  * elide the second child of the sort (the one containing X),
12813  * and set these flags as appropriate
12814         OPpSORT_NUMERIC;
12815         OPpSORT_INTEGER;
12816         OPpSORT_DESCEND;
12817  * Also, check and warn on lexical $a, $b.
12818  */
12819
12820 STATIC void
12821 S_simplify_sort(pTHX_ OP *o)
12822 {
12823     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12824     OP *k;
12825     int descending;
12826     GV *gv;
12827     const char *gvname;
12828     bool have_scopeop;
12829
12830     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12831
12832     kid = kUNOP->op_first;                              /* get past null */
12833     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12834      && kid->op_type != OP_LEAVE)
12835         return;
12836     kid = kLISTOP->op_last;                             /* get past scope */
12837     switch(kid->op_type) {
12838         case OP_NCMP:
12839         case OP_I_NCMP:
12840         case OP_SCMP:
12841             if (!have_scopeop) goto padkids;
12842             break;
12843         default:
12844             return;
12845     }
12846     k = kid;                                            /* remember this node*/
12847     if (kBINOP->op_first->op_type != OP_RV2SV
12848      || kBINOP->op_last ->op_type != OP_RV2SV)
12849     {
12850         /*
12851            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12852            then used in a comparison.  This catches most, but not
12853            all cases.  For instance, it catches
12854                sort { my($a); $a <=> $b }
12855            but not
12856                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12857            (although why you'd do that is anyone's guess).
12858         */
12859
12860        padkids:
12861         if (!ckWARN(WARN_SYNTAX)) return;
12862         kid = kBINOP->op_first;
12863         do {
12864             if (kid->op_type == OP_PADSV) {
12865                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12866                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12867                  && (  PadnamePV(name)[1] == 'a'
12868                     || PadnamePV(name)[1] == 'b'  ))
12869                     /* diag_listed_as: "my %s" used in sort comparison */
12870                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12871                                      "\"%s %s\" used in sort comparison",
12872                                       PadnameIsSTATE(name)
12873                                         ? "state"
12874                                         : "my",
12875                                       PadnamePV(name));
12876             }
12877         } while ((kid = OpSIBLING(kid)));
12878         return;
12879     }
12880     kid = kBINOP->op_first;                             /* get past cmp */
12881     if (kUNOP->op_first->op_type != OP_GV)
12882         return;
12883     kid = kUNOP->op_first;                              /* get past rv2sv */
12884     gv = kGVOP_gv;
12885     if (GvSTASH(gv) != PL_curstash)
12886         return;
12887     gvname = GvNAME(gv);
12888     if (*gvname == 'a' && gvname[1] == '\0')
12889         descending = 0;
12890     else if (*gvname == 'b' && gvname[1] == '\0')
12891         descending = 1;
12892     else
12893         return;
12894
12895     kid = k;                                            /* back to cmp */
12896     /* already checked above that it is rv2sv */
12897     kid = kBINOP->op_last;                              /* down to 2nd arg */
12898     if (kUNOP->op_first->op_type != OP_GV)
12899         return;
12900     kid = kUNOP->op_first;                              /* get past rv2sv */
12901     gv = kGVOP_gv;
12902     if (GvSTASH(gv) != PL_curstash)
12903         return;
12904     gvname = GvNAME(gv);
12905     if ( descending
12906          ? !(*gvname == 'a' && gvname[1] == '\0')
12907          : !(*gvname == 'b' && gvname[1] == '\0'))
12908         return;
12909     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12910     if (descending)
12911         o->op_private |= OPpSORT_DESCEND;
12912     if (k->op_type == OP_NCMP)
12913         o->op_private |= OPpSORT_NUMERIC;
12914     if (k->op_type == OP_I_NCMP)
12915         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12916     kid = OpSIBLING(cLISTOPo->op_first);
12917     /* cut out and delete old block (second sibling) */
12918     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12919     op_free(kid);
12920 }
12921
12922 OP *
12923 Perl_ck_split(pTHX_ OP *o)
12924 {
12925     dVAR;
12926     OP *kid;
12927     OP *sibs;
12928
12929     PERL_ARGS_ASSERT_CK_SPLIT;
12930
12931     assert(o->op_type == OP_LIST);
12932
12933     if (o->op_flags & OPf_STACKED)
12934         return no_fh_allowed(o);
12935
12936     kid = cLISTOPo->op_first;
12937     /* delete leading NULL node, then add a CONST if no other nodes */
12938     assert(kid->op_type == OP_NULL);
12939     op_sibling_splice(o, NULL, 1,
12940         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12941     op_free(kid);
12942     kid = cLISTOPo->op_first;
12943
12944     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12945         /* remove match expression, and replace with new optree with
12946          * a match op at its head */
12947         op_sibling_splice(o, NULL, 1, NULL);
12948         /* pmruntime will handle split " " behavior with flag==2 */
12949         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12950         op_sibling_splice(o, NULL, 0, kid);
12951     }
12952
12953     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12954
12955     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12956       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12957                      "Use of /g modifier is meaningless in split");
12958     }
12959
12960     /* eliminate the split op, and move the match op (plus any children)
12961      * into its place, then convert the match op into a split op. i.e.
12962      *
12963      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12964      *    |                        |                     |
12965      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12966      *    |                        |                     |
12967      *    R                        X - Y                 X - Y
12968      *    |
12969      *    X - Y
12970      *
12971      * (R, if it exists, will be a regcomp op)
12972      */
12973
12974     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12975     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12976     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12977     OpTYPE_set(kid, OP_SPLIT);
12978     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12979     kid->op_private = o->op_private;
12980     op_free(o);
12981     o = kid;
12982     kid = sibs; /* kid is now the string arg of the split */
12983
12984     if (!kid) {
12985         kid = newDEFSVOP();
12986         op_append_elem(OP_SPLIT, o, kid);
12987     }
12988     scalar(kid);
12989
12990     kid = OpSIBLING(kid);
12991     if (!kid) {
12992         kid = newSVOP(OP_CONST, 0, newSViv(0));
12993         op_append_elem(OP_SPLIT, o, kid);
12994         o->op_private |= OPpSPLIT_IMPLIM;
12995     }
12996     scalar(kid);
12997
12998     if (OpHAS_SIBLING(kid))
12999         return too_many_arguments_pv(o,OP_DESC(o), 0);
13000
13001     return o;
13002 }
13003
13004 OP *
13005 Perl_ck_stringify(pTHX_ OP *o)
13006 {
13007     OP * const kid = OpSIBLING(cUNOPo->op_first);
13008     PERL_ARGS_ASSERT_CK_STRINGIFY;
13009     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13010          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
13011          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
13012         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13013     {
13014         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13015         op_free(o);
13016         return kid;
13017     }
13018     return ck_fun(o);
13019 }
13020
13021 OP *
13022 Perl_ck_join(pTHX_ OP *o)
13023 {
13024     OP * const kid = OpSIBLING(cLISTOPo->op_first);
13025
13026     PERL_ARGS_ASSERT_CK_JOIN;
13027
13028     if (kid && kid->op_type == OP_MATCH) {
13029         if (ckWARN(WARN_SYNTAX)) {
13030             const REGEXP *re = PM_GETRE(kPMOP);
13031             const SV *msg = re
13032                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13033                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13034                     : newSVpvs_flags( "STRING", SVs_TEMP );
13035             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13036                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
13037                         SVfARG(msg), SVfARG(msg));
13038         }
13039     }
13040     if (kid
13041      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13042         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13043         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13044            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13045     {
13046         const OP * const bairn = OpSIBLING(kid); /* the list */
13047         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13048          && OP_GIMME(bairn,0) == G_SCALAR)
13049         {
13050             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13051                                      op_sibling_splice(o, kid, 1, NULL));
13052             op_free(o);
13053             return ret;
13054         }
13055     }
13056
13057     return ck_fun(o);
13058 }
13059
13060 /*
13061 =for apidoc rv2cv_op_cv
13062
13063 Examines an op, which is expected to identify a subroutine at runtime,
13064 and attempts to determine at compile time which subroutine it identifies.
13065 This is normally used during Perl compilation to determine whether
13066 a prototype can be applied to a function call.  C<cvop> is the op
13067 being considered, normally an C<rv2cv> op.  A pointer to the identified
13068 subroutine is returned, if it could be determined statically, and a null
13069 pointer is returned if it was not possible to determine statically.
13070
13071 Currently, the subroutine can be identified statically if the RV that the
13072 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13073 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13074 suitable if the constant value must be an RV pointing to a CV.  Details of
13075 this process may change in future versions of Perl.  If the C<rv2cv> op
13076 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13077 the subroutine statically: this flag is used to suppress compile-time
13078 magic on a subroutine call, forcing it to use default runtime behaviour.
13079
13080 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13081 of a GV reference is modified.  If a GV was examined and its CV slot was
13082 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13083 If the op is not optimised away, and the CV slot is later populated with
13084 a subroutine having a prototype, that flag eventually triggers the warning
13085 "called too early to check prototype".
13086
13087 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13088 of returning a pointer to the subroutine it returns a pointer to the
13089 GV giving the most appropriate name for the subroutine in this context.
13090 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13091 (C<CvANON>) subroutine that is referenced through a GV it will be the
13092 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13093 A null pointer is returned as usual if there is no statically-determinable
13094 subroutine.
13095
13096 =cut
13097 */
13098
13099 /* shared by toke.c:yylex */
13100 CV *
13101 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13102 {
13103     PADNAME *name = PAD_COMPNAME(off);
13104     CV *compcv = PL_compcv;
13105     while (PadnameOUTER(name)) {
13106         assert(PARENT_PAD_INDEX(name));
13107         compcv = CvOUTSIDE(compcv);
13108         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13109                 [off = PARENT_PAD_INDEX(name)];
13110     }
13111     assert(!PadnameIsOUR(name));
13112     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13113         return PadnamePROTOCV(name);
13114     }
13115     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13116 }
13117
13118 CV *
13119 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13120 {
13121     OP *rvop;
13122     CV *cv;
13123     GV *gv;
13124     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13125     if (flags & ~RV2CVOPCV_FLAG_MASK)
13126         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13127     if (cvop->op_type != OP_RV2CV)
13128         return NULL;
13129     if (cvop->op_private & OPpENTERSUB_AMPER)
13130         return NULL;
13131     if (!(cvop->op_flags & OPf_KIDS))
13132         return NULL;
13133     rvop = cUNOPx(cvop)->op_first;
13134     switch (rvop->op_type) {
13135         case OP_GV: {
13136             gv = cGVOPx_gv(rvop);
13137             if (!isGV(gv)) {
13138                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13139                     cv = MUTABLE_CV(SvRV(gv));
13140                     gv = NULL;
13141                     break;
13142                 }
13143                 if (flags & RV2CVOPCV_RETURN_STUB)
13144                     return (CV *)gv;
13145                 else return NULL;
13146             }
13147             cv = GvCVu(gv);
13148             if (!cv) {
13149                 if (flags & RV2CVOPCV_MARK_EARLY)
13150                     rvop->op_private |= OPpEARLY_CV;
13151                 return NULL;
13152             }
13153         } break;
13154         case OP_CONST: {
13155             SV *rv = cSVOPx_sv(rvop);
13156             if (!SvROK(rv))
13157                 return NULL;
13158             cv = (CV*)SvRV(rv);
13159             gv = NULL;
13160         } break;
13161         case OP_PADCV: {
13162             cv = find_lexical_cv(rvop->op_targ);
13163             gv = NULL;
13164         } break;
13165         default: {
13166             return NULL;
13167         } NOT_REACHED; /* NOTREACHED */
13168     }
13169     if (SvTYPE((SV*)cv) != SVt_PVCV)
13170         return NULL;
13171     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13172         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13173             gv = CvGV(cv);
13174         return (CV*)gv;
13175     }
13176     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13177         if (CvLEXICAL(cv) || CvNAMED(cv))
13178             return NULL;
13179         if (!CvANON(cv) || !gv)
13180             gv = CvGV(cv);
13181         return (CV*)gv;
13182
13183     } else {
13184         return cv;
13185     }
13186 }
13187
13188 /*
13189 =for apidoc ck_entersub_args_list
13190
13191 Performs the default fixup of the arguments part of an C<entersub>
13192 op tree.  This consists of applying list context to each of the
13193 argument ops.  This is the standard treatment used on a call marked
13194 with C<&>, or a method call, or a call through a subroutine reference,
13195 or any other call where the callee can't be identified at compile time,
13196 or a call where the callee has no prototype.
13197
13198 =cut
13199 */
13200
13201 OP *
13202 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13203 {
13204     OP *aop;
13205
13206     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13207
13208     aop = cUNOPx(entersubop)->op_first;
13209     if (!OpHAS_SIBLING(aop))
13210         aop = cUNOPx(aop)->op_first;
13211     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13212         /* skip the extra attributes->import() call implicitly added in
13213          * something like foo(my $x : bar)
13214          */
13215         if (   aop->op_type == OP_ENTERSUB
13216             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13217         )
13218             continue;
13219         list(aop);
13220         op_lvalue(aop, OP_ENTERSUB);
13221     }
13222     return entersubop;
13223 }
13224
13225 /*
13226 =for apidoc ck_entersub_args_proto
13227
13228 Performs the fixup of the arguments part of an C<entersub> op tree
13229 based on a subroutine prototype.  This makes various modifications to
13230 the argument ops, from applying context up to inserting C<refgen> ops,
13231 and checking the number and syntactic types of arguments, as directed by
13232 the prototype.  This is the standard treatment used on a subroutine call,
13233 not marked with C<&>, where the callee can be identified at compile time
13234 and has a prototype.
13235
13236 C<protosv> supplies the subroutine prototype to be applied to the call.
13237 It may be a normal defined scalar, of which the string value will be used.
13238 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13239 that has been cast to C<SV*>) which has a prototype.  The prototype
13240 supplied, in whichever form, does not need to match the actual callee
13241 referenced by the op tree.
13242
13243 If the argument ops disagree with the prototype, for example by having
13244 an unacceptable number of arguments, a valid op tree is returned anyway.
13245 The error is reflected in the parser state, normally resulting in a single
13246 exception at the top level of parsing which covers all the compilation
13247 errors that occurred.  In the error message, the callee is referred to
13248 by the name defined by the C<namegv> parameter.
13249
13250 =cut
13251 */
13252
13253 OP *
13254 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13255 {
13256     STRLEN proto_len;
13257     const char *proto, *proto_end;
13258     OP *aop, *prev, *cvop, *parent;
13259     int optional = 0;
13260     I32 arg = 0;
13261     I32 contextclass = 0;
13262     const char *e = NULL;
13263     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13264     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13265         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13266                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13267     if (SvTYPE(protosv) == SVt_PVCV)
13268          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13269     else proto = SvPV(protosv, proto_len);
13270     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13271     proto_end = proto + proto_len;
13272     parent = entersubop;
13273     aop = cUNOPx(entersubop)->op_first;
13274     if (!OpHAS_SIBLING(aop)) {
13275         parent = aop;
13276         aop = cUNOPx(aop)->op_first;
13277     }
13278     prev = aop;
13279     aop = OpSIBLING(aop);
13280     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13281     while (aop != cvop) {
13282         OP* o3 = aop;
13283
13284         if (proto >= proto_end)
13285         {
13286             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13287             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13288                                         SVfARG(namesv)), SvUTF8(namesv));
13289             return entersubop;
13290         }
13291
13292         switch (*proto) {
13293             case ';':
13294                 optional = 1;
13295                 proto++;
13296                 continue;
13297             case '_':
13298                 /* _ must be at the end */
13299                 if (proto[1] && !strchr(";@%", proto[1]))
13300                     goto oops;
13301                 /* FALLTHROUGH */
13302             case '$':
13303                 proto++;
13304                 arg++;
13305                 scalar(aop);
13306                 break;
13307             case '%':
13308             case '@':
13309                 list(aop);
13310                 arg++;
13311                 break;
13312             case '&':
13313                 proto++;
13314                 arg++;
13315                 if (    o3->op_type != OP_UNDEF
13316                     && (o3->op_type != OP_SREFGEN
13317                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13318                                 != OP_ANONCODE
13319                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13320                                 != OP_RV2CV)))
13321                     bad_type_gv(arg, namegv, o3,
13322                             arg == 1 ? "block or sub {}" : "sub {}");
13323                 break;
13324             case '*':
13325                 /* '*' allows any scalar type, including bareword */
13326                 proto++;
13327                 arg++;
13328                 if (o3->op_type == OP_RV2GV)
13329                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13330                 else if (o3->op_type == OP_CONST)
13331                     o3->op_private &= ~OPpCONST_STRICT;
13332                 scalar(aop);
13333                 break;
13334             case '+':
13335                 proto++;
13336                 arg++;
13337                 if (o3->op_type == OP_RV2AV ||
13338                     o3->op_type == OP_PADAV ||
13339                     o3->op_type == OP_RV2HV ||
13340                     o3->op_type == OP_PADHV
13341                 ) {
13342                     goto wrapref;
13343                 }
13344                 scalar(aop);
13345                 break;
13346             case '[': case ']':
13347                 goto oops;
13348
13349             case '\\':
13350                 proto++;
13351                 arg++;
13352             again:
13353                 switch (*proto++) {
13354                     case '[':
13355                         if (contextclass++ == 0) {
13356                             e = (char *) memchr(proto, ']', proto_end - proto);
13357                             if (!e || e == proto)
13358                                 goto oops;
13359                         }
13360                         else
13361                             goto oops;
13362                         goto again;
13363
13364                     case ']':
13365                         if (contextclass) {
13366                             const char *p = proto;
13367                             const char *const end = proto;
13368                             contextclass = 0;
13369                             while (*--p != '[')
13370                                 /* \[$] accepts any scalar lvalue */
13371                                 if (*p == '$'
13372                                  && Perl_op_lvalue_flags(aTHX_
13373                                      scalar(o3),
13374                                      OP_READ, /* not entersub */
13375                                      OP_LVALUE_NO_CROAK
13376                                     )) goto wrapref;
13377                             bad_type_gv(arg, namegv, o3,
13378                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13379                         } else
13380                             goto oops;
13381                         break;
13382                     case '*':
13383                         if (o3->op_type == OP_RV2GV)
13384                             goto wrapref;
13385                         if (!contextclass)
13386                             bad_type_gv(arg, namegv, o3, "symbol");
13387                         break;
13388                     case '&':
13389                         if (o3->op_type == OP_ENTERSUB
13390                          && !(o3->op_flags & OPf_STACKED))
13391                             goto wrapref;
13392                         if (!contextclass)
13393                             bad_type_gv(arg, namegv, o3, "subroutine");
13394                         break;
13395                     case '$':
13396                         if (o3->op_type == OP_RV2SV ||
13397                                 o3->op_type == OP_PADSV ||
13398                                 o3->op_type == OP_HELEM ||
13399                                 o3->op_type == OP_AELEM)
13400                             goto wrapref;
13401                         if (!contextclass) {
13402                             /* \$ accepts any scalar lvalue */
13403                             if (Perl_op_lvalue_flags(aTHX_
13404                                     scalar(o3),
13405                                     OP_READ,  /* not entersub */
13406                                     OP_LVALUE_NO_CROAK
13407                                )) goto wrapref;
13408                             bad_type_gv(arg, namegv, o3, "scalar");
13409                         }
13410                         break;
13411                     case '@':
13412                         if (o3->op_type == OP_RV2AV ||
13413                                 o3->op_type == OP_PADAV)
13414                         {
13415                             o3->op_flags &=~ OPf_PARENS;
13416                             goto wrapref;
13417                         }
13418                         if (!contextclass)
13419                             bad_type_gv(arg, namegv, o3, "array");
13420                         break;
13421                     case '%':
13422                         if (o3->op_type == OP_RV2HV ||
13423                                 o3->op_type == OP_PADHV)
13424                         {
13425                             o3->op_flags &=~ OPf_PARENS;
13426                             goto wrapref;
13427                         }
13428                         if (!contextclass)
13429                             bad_type_gv(arg, namegv, o3, "hash");
13430                         break;
13431                     wrapref:
13432                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13433                                                 OP_REFGEN, 0);
13434                         if (contextclass && e) {
13435                             proto = e + 1;
13436                             contextclass = 0;
13437                         }
13438                         break;
13439                     default: goto oops;
13440                 }
13441                 if (contextclass)
13442                     goto again;
13443                 break;
13444             case ' ':
13445                 proto++;
13446                 continue;
13447             default:
13448             oops: {
13449                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13450                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13451                                   SVfARG(protosv));
13452             }
13453         }
13454
13455         op_lvalue(aop, OP_ENTERSUB);
13456         prev = aop;
13457         aop = OpSIBLING(aop);
13458     }
13459     if (aop == cvop && *proto == '_') {
13460         /* generate an access to $_ */
13461         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13462     }
13463     if (!optional && proto_end > proto &&
13464         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13465     {
13466         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13467         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13468                                     SVfARG(namesv)), SvUTF8(namesv));
13469     }
13470     return entersubop;
13471 }
13472
13473 /*
13474 =for apidoc ck_entersub_args_proto_or_list
13475
13476 Performs the fixup of the arguments part of an C<entersub> op tree either
13477 based on a subroutine prototype or using default list-context processing.
13478 This is the standard treatment used on a subroutine call, not marked
13479 with C<&>, where the callee can be identified at compile time.
13480
13481 C<protosv> supplies the subroutine prototype to be applied to the call,
13482 or indicates that there is no prototype.  It may be a normal scalar,
13483 in which case if it is defined then the string value will be used
13484 as a prototype, and if it is undefined then there is no prototype.
13485 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13486 that has been cast to C<SV*>), of which the prototype will be used if it
13487 has one.  The prototype (or lack thereof) supplied, in whichever form,
13488 does not need to match the actual callee referenced by the op tree.
13489
13490 If the argument ops disagree with the prototype, for example by having
13491 an unacceptable number of arguments, a valid op tree is returned anyway.
13492 The error is reflected in the parser state, normally resulting in a single
13493 exception at the top level of parsing which covers all the compilation
13494 errors that occurred.  In the error message, the callee is referred to
13495 by the name defined by the C<namegv> parameter.
13496
13497 =cut
13498 */
13499
13500 OP *
13501 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13502         GV *namegv, SV *protosv)
13503 {
13504     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13505     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13506         return ck_entersub_args_proto(entersubop, namegv, protosv);
13507     else
13508         return ck_entersub_args_list(entersubop);
13509 }
13510
13511 OP *
13512 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13513 {
13514     IV cvflags = SvIVX(protosv);
13515     int opnum = cvflags & 0xffff;
13516     OP *aop = cUNOPx(entersubop)->op_first;
13517
13518     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13519
13520     if (!opnum) {
13521         OP *cvop;
13522         if (!OpHAS_SIBLING(aop))
13523             aop = cUNOPx(aop)->op_first;
13524         aop = OpSIBLING(aop);
13525         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13526         if (aop != cvop) {
13527             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13528             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13529                 SVfARG(namesv)), SvUTF8(namesv));
13530         }
13531
13532         op_free(entersubop);
13533         switch(cvflags >> 16) {
13534         case 'F': return newSVOP(OP_CONST, 0,
13535                                         newSVpv(CopFILE(PL_curcop),0));
13536         case 'L': return newSVOP(
13537                            OP_CONST, 0,
13538                            Perl_newSVpvf(aTHX_
13539                              "%" IVdf, (IV)CopLINE(PL_curcop)
13540                            )
13541                          );
13542         case 'P': return newSVOP(OP_CONST, 0,
13543                                    (PL_curstash
13544                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13545                                      : &PL_sv_undef
13546                                    )
13547                                 );
13548         }
13549         NOT_REACHED; /* NOTREACHED */
13550     }
13551     else {
13552         OP *prev, *cvop, *first, *parent;
13553         U32 flags = 0;
13554
13555         parent = entersubop;
13556         if (!OpHAS_SIBLING(aop)) {
13557             parent = aop;
13558             aop = cUNOPx(aop)->op_first;
13559         }
13560
13561         first = prev = aop;
13562         aop = OpSIBLING(aop);
13563         /* find last sibling */
13564         for (cvop = aop;
13565              OpHAS_SIBLING(cvop);
13566              prev = cvop, cvop = OpSIBLING(cvop))
13567             ;
13568         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13569             /* Usually, OPf_SPECIAL on an op with no args means that it had
13570              * parens, but these have their own meaning for that flag: */
13571             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13572             && opnum != OP_DELETE && opnum != OP_EXISTS)
13573                 flags |= OPf_SPECIAL;
13574         /* excise cvop from end of sibling chain */
13575         op_sibling_splice(parent, prev, 1, NULL);
13576         op_free(cvop);
13577         if (aop == cvop) aop = NULL;
13578
13579         /* detach remaining siblings from the first sibling, then
13580          * dispose of original optree */
13581
13582         if (aop)
13583             op_sibling_splice(parent, first, -1, NULL);
13584         op_free(entersubop);
13585
13586         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13587             flags |= OPpEVAL_BYTES <<8;
13588
13589         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13590         case OA_UNOP:
13591         case OA_BASEOP_OR_UNOP:
13592         case OA_FILESTATOP:
13593             if (!aop)
13594                 return newOP(opnum,flags);       /* zero args */
13595             if (aop == prev)
13596                 return newUNOP(opnum,flags,aop); /* one arg */
13597             /* too many args */
13598             /* FALLTHROUGH */
13599         case OA_BASEOP:
13600             if (aop) {
13601                 SV *namesv;
13602                 OP *nextop;
13603
13604                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13605                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13606                     SVfARG(namesv)), SvUTF8(namesv));
13607                 while (aop) {
13608                     nextop = OpSIBLING(aop);
13609                     op_free(aop);
13610                     aop = nextop;
13611                 }
13612
13613             }
13614             return opnum == OP_RUNCV
13615                 ? newPVOP(OP_RUNCV,0,NULL)
13616                 : newOP(opnum,0);
13617         default:
13618             return op_convert_list(opnum,0,aop);
13619         }
13620     }
13621     NOT_REACHED; /* NOTREACHED */
13622     return entersubop;
13623 }
13624
13625 /*
13626 =for apidoc cv_get_call_checker_flags
13627
13628 Retrieves the function that will be used to fix up a call to C<cv>.
13629 Specifically, the function is applied to an C<entersub> op tree for a
13630 subroutine call, not marked with C<&>, where the callee can be identified
13631 at compile time as C<cv>.
13632
13633 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13634 for it is returned in C<*ckobj_p>, and control flags are returned in
13635 C<*ckflags_p>.  The function is intended to be called in this manner:
13636
13637  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13638
13639 In this call, C<entersubop> is a pointer to the C<entersub> op,
13640 which may be replaced by the check function, and C<namegv> supplies
13641 the name that should be used by the check function to refer
13642 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13643 It is permitted to apply the check function in non-standard situations,
13644 such as to a call to a different subroutine or to a method call.
13645
13646 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13647 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13648 instead, anything that can be used as the first argument to L</cv_name>.
13649 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13650 check function requires C<namegv> to be a genuine GV.
13651
13652 By default, the check function is
13653 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13654 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13655 flag is clear.  This implements standard prototype processing.  It can
13656 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13657
13658 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13659 indicates that the caller only knows about the genuine GV version of
13660 C<namegv>, and accordingly the corresponding bit will always be set in
13661 C<*ckflags_p>, regardless of the check function's recorded requirements.
13662 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13663 indicates the caller knows about the possibility of passing something
13664 other than a GV as C<namegv>, and accordingly the corresponding bit may
13665 be either set or clear in C<*ckflags_p>, indicating the check function's
13666 recorded requirements.
13667
13668 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13669 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13670 (for which see above).  All other bits should be clear.
13671
13672 =for apidoc cv_get_call_checker
13673
13674 The original form of L</cv_get_call_checker_flags>, which does not return
13675 checker flags.  When using a checker function returned by this function,
13676 it is only safe to call it with a genuine GV as its C<namegv> argument.
13677
13678 =cut
13679 */
13680
13681 void
13682 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13683         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13684 {
13685     MAGIC *callmg;
13686     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13687     PERL_UNUSED_CONTEXT;
13688     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13689     if (callmg) {
13690         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13691         *ckobj_p = callmg->mg_obj;
13692         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13693     } else {
13694         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13695         *ckobj_p = (SV*)cv;
13696         *ckflags_p = gflags & MGf_REQUIRE_GV;
13697     }
13698 }
13699
13700 void
13701 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13702 {
13703     U32 ckflags;
13704     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13705     PERL_UNUSED_CONTEXT;
13706     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13707         &ckflags);
13708 }
13709
13710 /*
13711 =for apidoc cv_set_call_checker_flags
13712
13713 Sets the function that will be used to fix up a call to C<cv>.
13714 Specifically, the function is applied to an C<entersub> op tree for a
13715 subroutine call, not marked with C<&>, where the callee can be identified
13716 at compile time as C<cv>.
13717
13718 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13719 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13720 The function should be defined like this:
13721
13722     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13723
13724 It is intended to be called in this manner:
13725
13726     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13727
13728 In this call, C<entersubop> is a pointer to the C<entersub> op,
13729 which may be replaced by the check function, and C<namegv> supplies
13730 the name that should be used by the check function to refer
13731 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13732 It is permitted to apply the check function in non-standard situations,
13733 such as to a call to a different subroutine or to a method call.
13734
13735 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13736 CV or other SV instead.  Whatever is passed can be used as the first
13737 argument to L</cv_name>.  You can force perl to pass a GV by including
13738 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13739
13740 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13741 bit currently has a defined meaning (for which see above).  All other
13742 bits should be clear.
13743
13744 The current setting for a particular CV can be retrieved by
13745 L</cv_get_call_checker_flags>.
13746
13747 =for apidoc cv_set_call_checker
13748
13749 The original form of L</cv_set_call_checker_flags>, which passes it the
13750 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13751 of that flag setting is that the check function is guaranteed to get a
13752 genuine GV as its C<namegv> argument.
13753
13754 =cut
13755 */
13756
13757 void
13758 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13759 {
13760     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13761     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13762 }
13763
13764 void
13765 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13766                                      SV *ckobj, U32 ckflags)
13767 {
13768     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13769     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13770         if (SvMAGICAL((SV*)cv))
13771             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13772     } else {
13773         MAGIC *callmg;
13774         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13775         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13776         assert(callmg);
13777         if (callmg->mg_flags & MGf_REFCOUNTED) {
13778             SvREFCNT_dec(callmg->mg_obj);
13779             callmg->mg_flags &= ~MGf_REFCOUNTED;
13780         }
13781         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13782         callmg->mg_obj = ckobj;
13783         if (ckobj != (SV*)cv) {
13784             SvREFCNT_inc_simple_void_NN(ckobj);
13785             callmg->mg_flags |= MGf_REFCOUNTED;
13786         }
13787         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13788                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13789     }
13790 }
13791
13792 static void
13793 S_entersub_alloc_targ(pTHX_ OP * const o)
13794 {
13795     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13796     o->op_private |= OPpENTERSUB_HASTARG;
13797 }
13798
13799 OP *
13800 Perl_ck_subr(pTHX_ OP *o)
13801 {
13802     OP *aop, *cvop;
13803     CV *cv;
13804     GV *namegv;
13805     SV **const_class = NULL;
13806
13807     PERL_ARGS_ASSERT_CK_SUBR;
13808
13809     aop = cUNOPx(o)->op_first;
13810     if (!OpHAS_SIBLING(aop))
13811         aop = cUNOPx(aop)->op_first;
13812     aop = OpSIBLING(aop);
13813     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13814     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13815     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13816
13817     o->op_private &= ~1;
13818     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13819     if (PERLDB_SUB && PL_curstash != PL_debstash)
13820         o->op_private |= OPpENTERSUB_DB;
13821     switch (cvop->op_type) {
13822         case OP_RV2CV:
13823             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13824             op_null(cvop);
13825             break;
13826         case OP_METHOD:
13827         case OP_METHOD_NAMED:
13828         case OP_METHOD_SUPER:
13829         case OP_METHOD_REDIR:
13830         case OP_METHOD_REDIR_SUPER:
13831             o->op_flags |= OPf_REF;
13832             if (aop->op_type == OP_CONST) {
13833                 aop->op_private &= ~OPpCONST_STRICT;
13834                 const_class = &cSVOPx(aop)->op_sv;
13835             }
13836             else if (aop->op_type == OP_LIST) {
13837                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13838                 if (sib && sib->op_type == OP_CONST) {
13839                     sib->op_private &= ~OPpCONST_STRICT;
13840                     const_class = &cSVOPx(sib)->op_sv;
13841                 }
13842             }
13843             /* make class name a shared cow string to speedup method calls */
13844             /* constant string might be replaced with object, f.e. bigint */
13845             if (const_class && SvPOK(*const_class)) {
13846                 STRLEN len;
13847                 const char* str = SvPV(*const_class, len);
13848                 if (len) {
13849                     SV* const shared = newSVpvn_share(
13850                         str, SvUTF8(*const_class)
13851                                     ? -(SSize_t)len : (SSize_t)len,
13852                         0
13853                     );
13854                     if (SvREADONLY(*const_class))
13855                         SvREADONLY_on(shared);
13856                     SvREFCNT_dec(*const_class);
13857                     *const_class = shared;
13858                 }
13859             }
13860             break;
13861     }
13862
13863     if (!cv) {
13864         S_entersub_alloc_targ(aTHX_ o);
13865         return ck_entersub_args_list(o);
13866     } else {
13867         Perl_call_checker ckfun;
13868         SV *ckobj;
13869         U32 ckflags;
13870         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13871         if (CvISXSUB(cv) || !CvROOT(cv))
13872             S_entersub_alloc_targ(aTHX_ o);
13873         if (!namegv) {
13874             /* The original call checker API guarantees that a GV will be
13875                be provided with the right name.  So, if the old API was
13876                used (or the REQUIRE_GV flag was passed), we have to reify
13877                the CV’s GV, unless this is an anonymous sub.  This is not
13878                ideal for lexical subs, as its stringification will include
13879                the package.  But it is the best we can do.  */
13880             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13881                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13882                     namegv = CvGV(cv);
13883             }
13884             else namegv = MUTABLE_GV(cv);
13885             /* After a syntax error in a lexical sub, the cv that
13886                rv2cv_op_cv returns may be a nameless stub. */
13887             if (!namegv) return ck_entersub_args_list(o);
13888
13889         }
13890         return ckfun(aTHX_ o, namegv, ckobj);
13891     }
13892 }
13893
13894 OP *
13895 Perl_ck_svconst(pTHX_ OP *o)
13896 {
13897     SV * const sv = cSVOPo->op_sv;
13898     PERL_ARGS_ASSERT_CK_SVCONST;
13899     PERL_UNUSED_CONTEXT;
13900 #ifdef PERL_COPY_ON_WRITE
13901     /* Since the read-only flag may be used to protect a string buffer, we
13902        cannot do copy-on-write with existing read-only scalars that are not
13903        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13904        that constant, mark the constant as COWable here, if it is not
13905        already read-only. */
13906     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13907         SvIsCOW_on(sv);
13908         CowREFCNT(sv) = 0;
13909 # ifdef PERL_DEBUG_READONLY_COW
13910         sv_buf_to_ro(sv);
13911 # endif
13912     }
13913 #endif
13914     SvREADONLY_on(sv);
13915     return o;
13916 }
13917
13918 OP *
13919 Perl_ck_trunc(pTHX_ OP *o)
13920 {
13921     PERL_ARGS_ASSERT_CK_TRUNC;
13922
13923     if (o->op_flags & OPf_KIDS) {
13924         SVOP *kid = (SVOP*)cUNOPo->op_first;
13925
13926         if (kid->op_type == OP_NULL)
13927             kid = (SVOP*)OpSIBLING(kid);
13928         if (kid && kid->op_type == OP_CONST &&
13929             (kid->op_private & OPpCONST_BARE) &&
13930             !kid->op_folded)
13931         {
13932             o->op_flags |= OPf_SPECIAL;
13933             kid->op_private &= ~OPpCONST_STRICT;
13934         }
13935     }
13936     return ck_fun(o);
13937 }
13938
13939 OP *
13940 Perl_ck_substr(pTHX_ OP *o)
13941 {
13942     PERL_ARGS_ASSERT_CK_SUBSTR;
13943
13944     o = ck_fun(o);
13945     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13946         OP *kid = cLISTOPo->op_first;
13947
13948         if (kid->op_type == OP_NULL)
13949             kid = OpSIBLING(kid);
13950         if (kid)
13951             /* Historically, substr(delete $foo{bar},...) has been allowed
13952                with 4-arg substr.  Keep it working by applying entersub
13953                lvalue context.  */
13954             op_lvalue(kid, OP_ENTERSUB);
13955
13956     }
13957     return o;
13958 }
13959
13960 OP *
13961 Perl_ck_tell(pTHX_ OP *o)
13962 {
13963     PERL_ARGS_ASSERT_CK_TELL;
13964     o = ck_fun(o);
13965     if (o->op_flags & OPf_KIDS) {
13966      OP *kid = cLISTOPo->op_first;
13967      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13968      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13969     }
13970     return o;
13971 }
13972
13973 OP *
13974 Perl_ck_each(pTHX_ OP *o)
13975 {
13976     dVAR;
13977     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13978     const unsigned orig_type  = o->op_type;
13979
13980     PERL_ARGS_ASSERT_CK_EACH;
13981
13982     if (kid) {
13983         switch (kid->op_type) {
13984             case OP_PADHV:
13985             case OP_RV2HV:
13986                 break;
13987             case OP_PADAV:
13988             case OP_RV2AV:
13989                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13990                             : orig_type == OP_KEYS ? OP_AKEYS
13991                             :                        OP_AVALUES);
13992                 break;
13993             case OP_CONST:
13994                 if (kid->op_private == OPpCONST_BARE
13995                  || !SvROK(cSVOPx_sv(kid))
13996                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13997                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13998                    )
13999                     goto bad;
14000                 /* FALLTHROUGH */
14001             default:
14002                 qerror(Perl_mess(aTHX_
14003                     "Experimental %s on scalar is now forbidden",
14004                      PL_op_desc[orig_type]));
14005                bad:
14006                 bad_type_pv(1, "hash or array", o, kid);
14007                 return o;
14008         }
14009     }
14010     return ck_fun(o);
14011 }
14012
14013 OP *
14014 Perl_ck_length(pTHX_ OP *o)
14015 {
14016     PERL_ARGS_ASSERT_CK_LENGTH;
14017
14018     o = ck_fun(o);
14019
14020     if (ckWARN(WARN_SYNTAX)) {
14021         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14022
14023         if (kid) {
14024             SV *name = NULL;
14025             const bool hash = kid->op_type == OP_PADHV
14026                            || kid->op_type == OP_RV2HV;
14027             switch (kid->op_type) {
14028                 case OP_PADHV:
14029                 case OP_PADAV:
14030                 case OP_RV2HV:
14031                 case OP_RV2AV:
14032                     name = S_op_varname(aTHX_ kid);
14033                     break;
14034                 default:
14035                     return o;
14036             }
14037             if (name)
14038                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14039                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14040                     ")\"?)",
14041                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
14042                 );
14043             else if (hash)
14044      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14045                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14046                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14047             else
14048      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14049                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14050                     "length() used on @array (did you mean \"scalar(@array)\"?)");
14051         }
14052     }
14053
14054     return o;
14055 }
14056
14057
14058
14059 /*
14060    ---------------------------------------------------------
14061
14062    Common vars in list assignment
14063
14064    There now follows some enums and static functions for detecting
14065    common variables in list assignments. Here is a little essay I wrote
14066    for myself when trying to get my head around this. DAPM.
14067
14068    ----
14069
14070    First some random observations:
14071
14072    * If a lexical var is an alias of something else, e.g.
14073        for my $x ($lex, $pkg, $a[0]) {...}
14074      then the act of aliasing will increase the reference count of the SV
14075
14076    * If a package var is an alias of something else, it may still have a
14077      reference count of 1, depending on how the alias was created, e.g.
14078      in *a = *b, $a may have a refcount of 1 since the GP is shared
14079      with a single GvSV pointer to the SV. So If it's an alias of another
14080      package var, then RC may be 1; if it's an alias of another scalar, e.g.
14081      a lexical var or an array element, then it will have RC > 1.
14082
14083    * There are many ways to create a package alias; ultimately, XS code
14084      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14085      run-time tracing mechanisms are unlikely to be able to catch all cases.
14086
14087    * When the LHS is all my declarations, the same vars can't appear directly
14088      on the RHS, but they can indirectly via closures, aliasing and lvalue
14089      subs. But those techniques all involve an increase in the lexical
14090      scalar's ref count.
14091
14092    * When the LHS is all lexical vars (but not necessarily my declarations),
14093      it is possible for the same lexicals to appear directly on the RHS, and
14094      without an increased ref count, since the stack isn't refcounted.
14095      This case can be detected at compile time by scanning for common lex
14096      vars with PL_generation.
14097
14098    * lvalue subs defeat common var detection, but they do at least
14099      return vars with a temporary ref count increment. Also, you can't
14100      tell at compile time whether a sub call is lvalue.
14101
14102
14103    So...
14104
14105    A: There are a few circumstances where there definitely can't be any
14106      commonality:
14107
14108        LHS empty:  () = (...);
14109        RHS empty:  (....) = ();
14110        RHS contains only constants or other 'can't possibly be shared'
14111            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
14112            i.e. they only contain ops not marked as dangerous, whose children
14113            are also not dangerous;
14114        LHS ditto;
14115        LHS contains a single scalar element: e.g. ($x) = (....); because
14116            after $x has been modified, it won't be used again on the RHS;
14117        RHS contains a single element with no aggregate on LHS: e.g.
14118            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
14119            won't be used again.
14120
14121    B: If LHS are all 'my' lexical var declarations (or safe ops, which
14122      we can ignore):
14123
14124        my ($a, $b, @c) = ...;
14125
14126        Due to closure and goto tricks, these vars may already have content.
14127        For the same reason, an element on the RHS may be a lexical or package
14128        alias of one of the vars on the left, or share common elements, for
14129        example:
14130
14131            my ($x,$y) = f(); # $x and $y on both sides
14132            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14133
14134        and
14135
14136            my $ra = f();
14137            my @a = @$ra;  # elements of @a on both sides
14138            sub f { @a = 1..4; \@a }
14139
14140
14141        First, just consider scalar vars on LHS:
14142
14143            RHS is safe only if (A), or in addition,
14144                * contains only lexical *scalar* vars, where neither side's
14145                  lexicals have been flagged as aliases
14146
14147            If RHS is not safe, then it's always legal to check LHS vars for
14148            RC==1, since the only RHS aliases will always be associated
14149            with an RC bump.
14150
14151            Note that in particular, RHS is not safe if:
14152
14153                * it contains package scalar vars; e.g.:
14154
14155                    f();
14156                    my ($x, $y) = (2, $x_alias);
14157                    sub f { $x = 1; *x_alias = \$x; }
14158
14159                * It contains other general elements, such as flattened or
14160                * spliced or single array or hash elements, e.g.
14161
14162                    f();
14163                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14164
14165                    sub f {
14166                        ($x, $y) = (1,2);
14167                        use feature 'refaliasing';
14168                        \($a[0], $a[1]) = \($y,$x);
14169                    }
14170
14171                  It doesn't matter if the array/hash is lexical or package.
14172
14173                * it contains a function call that happens to be an lvalue
14174                  sub which returns one or more of the above, e.g.
14175
14176                    f();
14177                    my ($x,$y) = f();
14178
14179                    sub f : lvalue {
14180                        ($x, $y) = (1,2);
14181                        *x1 = \$x;
14182                        $y, $x1;
14183                    }
14184
14185                    (so a sub call on the RHS should be treated the same
14186                    as having a package var on the RHS).
14187
14188                * any other "dangerous" thing, such an op or built-in that
14189                  returns one of the above, e.g. pp_preinc
14190
14191
14192            If RHS is not safe, what we can do however is at compile time flag
14193            that the LHS are all my declarations, and at run time check whether
14194            all the LHS have RC == 1, and if so skip the full scan.
14195
14196        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14197
14198            Here the issue is whether there can be elements of @a on the RHS
14199            which will get prematurely freed when @a is cleared prior to
14200            assignment. This is only a problem if the aliasing mechanism
14201            is one which doesn't increase the refcount - only if RC == 1
14202            will the RHS element be prematurely freed.
14203
14204            Because the array/hash is being INTROed, it or its elements
14205            can't directly appear on the RHS:
14206
14207                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14208
14209            but can indirectly, e.g.:
14210
14211                my $r = f();
14212                my (@a) = @$r;
14213                sub f { @a = 1..3; \@a }
14214
14215            So if the RHS isn't safe as defined by (A), we must always
14216            mortalise and bump the ref count of any remaining RHS elements
14217            when assigning to a non-empty LHS aggregate.
14218
14219            Lexical scalars on the RHS aren't safe if they've been involved in
14220            aliasing, e.g.
14221
14222                use feature 'refaliasing';
14223
14224                f();
14225                \(my $lex) = \$pkg;
14226                my @a = ($lex,3); # equivalent to ($a[0],3)
14227
14228                sub f {
14229                    @a = (1,2);
14230                    \$pkg = \$a[0];
14231                }
14232
14233            Similarly with lexical arrays and hashes on the RHS:
14234
14235                f();
14236                my @b;
14237                my @a = (@b);
14238
14239                sub f {
14240                    @a = (1,2);
14241                    \$b[0] = \$a[1];
14242                    \$b[1] = \$a[0];
14243                }
14244
14245
14246
14247    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14248        my $a; ($a, my $b) = (....);
14249
14250        The difference between (B) and (C) is that it is now physically
14251        possible for the LHS vars to appear on the RHS too, where they
14252        are not reference counted; but in this case, the compile-time
14253        PL_generation sweep will detect such common vars.
14254
14255        So the rules for (C) differ from (B) in that if common vars are
14256        detected, the runtime "test RC==1" optimisation can no longer be used,
14257        and a full mark and sweep is required
14258
14259    D: As (C), but in addition the LHS may contain package vars.
14260
14261        Since package vars can be aliased without a corresponding refcount
14262        increase, all bets are off. It's only safe if (A). E.g.
14263
14264            my ($x, $y) = (1,2);
14265
14266            for $x_alias ($x) {
14267                ($x_alias, $y) = (3, $x); # whoops
14268            }
14269
14270        Ditto for LHS aggregate package vars.
14271
14272    E: Any other dangerous ops on LHS, e.g.
14273            (f(), $a[0], @$r) = (...);
14274
14275        this is similar to (E) in that all bets are off. In addition, it's
14276        impossible to determine at compile time whether the LHS
14277        contains a scalar or an aggregate, e.g.
14278
14279            sub f : lvalue { @a }
14280            (f()) = 1..3;
14281
14282 * ---------------------------------------------------------
14283 */
14284
14285
14286 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14287  * that at least one of the things flagged was seen.
14288  */
14289
14290 enum {
14291     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14292     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14293     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14294     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14295     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14296     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14297     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14298     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14299                                          that's flagged OA_DANGEROUS */
14300     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14301                                         not in any of the categories above */
14302     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14303 };
14304
14305
14306
14307 /* helper function for S_aassign_scan().
14308  * check a PAD-related op for commonality and/or set its generation number.
14309  * Returns a boolean indicating whether its shared */
14310
14311 static bool
14312 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14313 {
14314     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14315         /* lexical used in aliasing */
14316         return TRUE;
14317
14318     if (rhs)
14319         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14320     else
14321         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14322
14323     return FALSE;
14324 }
14325
14326
14327 /*
14328   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14329   It scans the left or right hand subtree of the aassign op, and returns a
14330   set of flags indicating what sorts of things it found there.
14331   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14332   set PL_generation on lexical vars; if the latter, we see if
14333   PL_generation matches.
14334   'top' indicates whether we're recursing or at the top level.
14335   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14336   This fn will increment it by the number seen. It's not intended to
14337   be an accurate count (especially as many ops can push a variable
14338   number of SVs onto the stack); rather it's used as to test whether there
14339   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14340 */
14341
14342 static int
14343 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14344 {
14345     int flags = 0;
14346     bool kid_top = FALSE;
14347
14348     /* first, look for a solitary @_ on the RHS */
14349     if (   rhs
14350         && top
14351         && (o->op_flags & OPf_KIDS)
14352         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14353     ) {
14354         OP *kid = cUNOPo->op_first;
14355         if (   (   kid->op_type == OP_PUSHMARK
14356                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14357             && ((kid = OpSIBLING(kid)))
14358             && !OpHAS_SIBLING(kid)
14359             && kid->op_type == OP_RV2AV
14360             && !(kid->op_flags & OPf_REF)
14361             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14362             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14363             && ((kid = cUNOPx(kid)->op_first))
14364             && kid->op_type == OP_GV
14365             && cGVOPx_gv(kid) == PL_defgv
14366         )
14367             flags |= AAS_DEFAV;
14368     }
14369
14370     switch (o->op_type) {
14371     case OP_GVSV:
14372         (*scalars_p)++;
14373         return AAS_PKG_SCALAR;
14374
14375     case OP_PADAV:
14376     case OP_PADHV:
14377         (*scalars_p) += 2;
14378         /* if !top, could be e.g. @a[0,1] */
14379         if (top && (o->op_flags & OPf_REF))
14380             return (o->op_private & OPpLVAL_INTRO)
14381                 ? AAS_MY_AGG : AAS_LEX_AGG;
14382         return AAS_DANGEROUS;
14383
14384     case OP_PADSV:
14385         {
14386             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14387                         ?  AAS_LEX_SCALAR_COMM : 0;
14388             (*scalars_p)++;
14389             return (o->op_private & OPpLVAL_INTRO)
14390                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14391         }
14392
14393     case OP_RV2AV:
14394     case OP_RV2HV:
14395         (*scalars_p) += 2;
14396         if (cUNOPx(o)->op_first->op_type != OP_GV)
14397             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14398         /* @pkg, %pkg */
14399         /* if !top, could be e.g. @a[0,1] */
14400         if (top && (o->op_flags & OPf_REF))
14401             return AAS_PKG_AGG;
14402         return AAS_DANGEROUS;
14403
14404     case OP_RV2SV:
14405         (*scalars_p)++;
14406         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14407             (*scalars_p) += 2;
14408             return AAS_DANGEROUS; /* ${expr} */
14409         }
14410         return AAS_PKG_SCALAR; /* $pkg */
14411
14412     case OP_SPLIT:
14413         if (o->op_private & OPpSPLIT_ASSIGN) {
14414             /* the assign in @a = split() has been optimised away
14415              * and the @a attached directly to the split op
14416              * Treat the array as appearing on the RHS, i.e.
14417              *    ... = (@a = split)
14418              * is treated like
14419              *    ... = @a;
14420              */
14421
14422             if (o->op_flags & OPf_STACKED)
14423                 /* @{expr} = split() - the array expression is tacked
14424                  * on as an extra child to split - process kid */
14425                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14426                                         top, scalars_p);
14427
14428             /* ... else array is directly attached to split op */
14429             (*scalars_p) += 2;
14430             if (PL_op->op_private & OPpSPLIT_LEX)
14431                 return (o->op_private & OPpLVAL_INTRO)
14432                     ? AAS_MY_AGG : AAS_LEX_AGG;
14433             else
14434                 return AAS_PKG_AGG;
14435         }
14436         (*scalars_p)++;
14437         /* other args of split can't be returned */
14438         return AAS_SAFE_SCALAR;
14439
14440     case OP_UNDEF:
14441         /* undef counts as a scalar on the RHS:
14442          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14443          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14444          */
14445         if (rhs)
14446             (*scalars_p)++;
14447         flags = AAS_SAFE_SCALAR;
14448         break;
14449
14450     case OP_PUSHMARK:
14451     case OP_STUB:
14452         /* these are all no-ops; they don't push a potentially common SV
14453          * onto the stack, so they are neither AAS_DANGEROUS nor
14454          * AAS_SAFE_SCALAR */
14455         return 0;
14456
14457     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14458         break;
14459
14460     case OP_NULL:
14461     case OP_LIST:
14462         /* these do nothing but may have children; but their children
14463          * should also be treated as top-level */
14464         kid_top = top;
14465         break;
14466
14467     default:
14468         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14469             (*scalars_p) += 2;
14470             flags = AAS_DANGEROUS;
14471             break;
14472         }
14473
14474         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14475             && (o->op_private & OPpTARGET_MY))
14476         {
14477             (*scalars_p)++;
14478             return S_aassign_padcheck(aTHX_ o, rhs)
14479                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14480         }
14481
14482         /* if its an unrecognised, non-dangerous op, assume that it
14483          * it the cause of at least one safe scalar */
14484         (*scalars_p)++;
14485         flags = AAS_SAFE_SCALAR;
14486         break;
14487     }
14488
14489     /* XXX this assumes that all other ops are "transparent" - i.e. that
14490      * they can return some of their children. While this true for e.g.
14491      * sort and grep, it's not true for e.g. map. We really need a
14492      * 'transparent' flag added to regen/opcodes
14493      */
14494     if (o->op_flags & OPf_KIDS) {
14495         OP *kid;
14496         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14497             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14498     }
14499     return flags;
14500 }
14501
14502
14503 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14504    and modify the optree to make them work inplace */
14505
14506 STATIC void
14507 S_inplace_aassign(pTHX_ OP *o) {
14508
14509     OP *modop, *modop_pushmark;
14510     OP *oright;
14511     OP *oleft, *oleft_pushmark;
14512
14513     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14514
14515     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14516
14517     assert(cUNOPo->op_first->op_type == OP_NULL);
14518     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14519     assert(modop_pushmark->op_type == OP_PUSHMARK);
14520     modop = OpSIBLING(modop_pushmark);
14521
14522     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14523         return;
14524
14525     /* no other operation except sort/reverse */
14526     if (OpHAS_SIBLING(modop))
14527         return;
14528
14529     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14530     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14531
14532     if (modop->op_flags & OPf_STACKED) {
14533         /* skip sort subroutine/block */
14534         assert(oright->op_type == OP_NULL);
14535         oright = OpSIBLING(oright);
14536     }
14537
14538     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14539     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14540     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14541     oleft = OpSIBLING(oleft_pushmark);
14542
14543     /* Check the lhs is an array */
14544     if (!oleft ||
14545         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14546         || OpHAS_SIBLING(oleft)
14547         || (oleft->op_private & OPpLVAL_INTRO)
14548     )
14549         return;
14550
14551     /* Only one thing on the rhs */
14552     if (OpHAS_SIBLING(oright))
14553         return;
14554
14555     /* check the array is the same on both sides */
14556     if (oleft->op_type == OP_RV2AV) {
14557         if (oright->op_type != OP_RV2AV
14558             || !cUNOPx(oright)->op_first
14559             || cUNOPx(oright)->op_first->op_type != OP_GV
14560             || cUNOPx(oleft )->op_first->op_type != OP_GV
14561             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14562                cGVOPx_gv(cUNOPx(oright)->op_first)
14563         )
14564             return;
14565     }
14566     else if (oright->op_type != OP_PADAV
14567         || oright->op_targ != oleft->op_targ
14568     )
14569         return;
14570
14571     /* This actually is an inplace assignment */
14572
14573     modop->op_private |= OPpSORT_INPLACE;
14574
14575     /* transfer MODishness etc from LHS arg to RHS arg */
14576     oright->op_flags = oleft->op_flags;
14577
14578     /* remove the aassign op and the lhs */
14579     op_null(o);
14580     op_null(oleft_pushmark);
14581     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14582         op_null(cUNOPx(oleft)->op_first);
14583     op_null(oleft);
14584 }
14585
14586
14587
14588 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14589  * that potentially represent a series of one or more aggregate derefs
14590  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14591  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14592  * additional ops left in too).
14593  *
14594  * The caller will have already verified that the first few ops in the
14595  * chain following 'start' indicate a multideref candidate, and will have
14596  * set 'orig_o' to the point further on in the chain where the first index
14597  * expression (if any) begins.  'orig_action' specifies what type of
14598  * beginning has already been determined by the ops between start..orig_o
14599  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14600  *
14601  * 'hints' contains any hints flags that need adding (currently just
14602  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14603  */
14604
14605 STATIC void
14606 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14607 {
14608     dVAR;
14609     int pass;
14610     UNOP_AUX_item *arg_buf = NULL;
14611     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14612     int index_skip         = -1;    /* don't output index arg on this action */
14613
14614     /* similar to regex compiling, do two passes; the first pass
14615      * determines whether the op chain is convertible and calculates the
14616      * buffer size; the second pass populates the buffer and makes any
14617      * changes necessary to ops (such as moving consts to the pad on
14618      * threaded builds).
14619      *
14620      * NB: for things like Coverity, note that both passes take the same
14621      * path through the logic tree (except for 'if (pass)' bits), since
14622      * both passes are following the same op_next chain; and in
14623      * particular, if it would return early on the second pass, it would
14624      * already have returned early on the first pass.
14625      */
14626     for (pass = 0; pass < 2; pass++) {
14627         OP *o                = orig_o;
14628         UV action            = orig_action;
14629         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14630         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14631         int action_count     = 0;     /* number of actions seen so far */
14632         int action_ix        = 0;     /* action_count % (actions per IV) */
14633         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14634         bool is_last         = FALSE; /* no more derefs to follow */
14635         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14636         UNOP_AUX_item *arg     = arg_buf;
14637         UNOP_AUX_item *action_ptr = arg_buf;
14638
14639         if (pass)
14640             action_ptr->uv = 0;
14641         arg++;
14642
14643         switch (action) {
14644         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14645         case MDEREF_HV_gvhv_helem:
14646             next_is_hash = TRUE;
14647             /* FALLTHROUGH */
14648         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14649         case MDEREF_AV_gvav_aelem:
14650             if (pass) {
14651 #ifdef USE_ITHREADS
14652                 arg->pad_offset = cPADOPx(start)->op_padix;
14653                 /* stop it being swiped when nulled */
14654                 cPADOPx(start)->op_padix = 0;
14655 #else
14656                 arg->sv = cSVOPx(start)->op_sv;
14657                 cSVOPx(start)->op_sv = NULL;
14658 #endif
14659             }
14660             arg++;
14661             break;
14662
14663         case MDEREF_HV_padhv_helem:
14664         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14665             next_is_hash = TRUE;
14666             /* FALLTHROUGH */
14667         case MDEREF_AV_padav_aelem:
14668         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14669             if (pass) {
14670                 arg->pad_offset = start->op_targ;
14671                 /* we skip setting op_targ = 0 for now, since the intact
14672                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14673                 reset_start_targ = TRUE;
14674             }
14675             arg++;
14676             break;
14677
14678         case MDEREF_HV_pop_rv2hv_helem:
14679             next_is_hash = TRUE;
14680             /* FALLTHROUGH */
14681         case MDEREF_AV_pop_rv2av_aelem:
14682             break;
14683
14684         default:
14685             NOT_REACHED; /* NOTREACHED */
14686             return;
14687         }
14688
14689         while (!is_last) {
14690             /* look for another (rv2av/hv; get index;
14691              * aelem/helem/exists/delele) sequence */
14692
14693             OP *kid;
14694             bool is_deref;
14695             bool ok;
14696             UV index_type = MDEREF_INDEX_none;
14697
14698             if (action_count) {
14699                 /* if this is not the first lookup, consume the rv2av/hv  */
14700
14701                 /* for N levels of aggregate lookup, we normally expect
14702                  * that the first N-1 [ah]elem ops will be flagged as
14703                  * /DEREF (so they autovivifiy if necessary), and the last
14704                  * lookup op not to be.
14705                  * For other things (like @{$h{k1}{k2}}) extra scope or
14706                  * leave ops can appear, so abandon the effort in that
14707                  * case */
14708                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14709                     return;
14710
14711                 /* rv2av or rv2hv sKR/1 */
14712
14713                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14714                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14715                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14716                     return;
14717
14718                 /* at this point, we wouldn't expect any of these
14719                  * possible private flags:
14720                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14721                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14722                  */
14723                 ASSUME(!(o->op_private &
14724                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14725
14726                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14727
14728                 /* make sure the type of the previous /DEREF matches the
14729                  * type of the next lookup */
14730                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14731                 top_op = o;
14732
14733                 action = next_is_hash
14734                             ? MDEREF_HV_vivify_rv2hv_helem
14735                             : MDEREF_AV_vivify_rv2av_aelem;
14736                 o = o->op_next;
14737             }
14738
14739             /* if this is the second pass, and we're at the depth where
14740              * previously we encountered a non-simple index expression,
14741              * stop processing the index at this point */
14742             if (action_count != index_skip) {
14743
14744                 /* look for one or more simple ops that return an array
14745                  * index or hash key */
14746
14747                 switch (o->op_type) {
14748                 case OP_PADSV:
14749                     /* it may be a lexical var index */
14750                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14751                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14752                     ASSUME(!(o->op_private &
14753                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14754
14755                     if (   OP_GIMME(o,0) == G_SCALAR
14756                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14757                         && o->op_private == 0)
14758                     {
14759                         if (pass)
14760                             arg->pad_offset = o->op_targ;
14761                         arg++;
14762                         index_type = MDEREF_INDEX_padsv;
14763                         o = o->op_next;
14764                     }
14765                     break;
14766
14767                 case OP_CONST:
14768                     if (next_is_hash) {
14769                         /* it's a constant hash index */
14770                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14771                             /* "use constant foo => FOO; $h{+foo}" for
14772                              * some weird FOO, can leave you with constants
14773                              * that aren't simple strings. It's not worth
14774                              * the extra hassle for those edge cases */
14775                             break;
14776
14777                         {
14778                             UNOP *rop = NULL;
14779                             OP * helem_op = o->op_next;
14780
14781                             ASSUME(   helem_op->op_type == OP_HELEM
14782                                    || helem_op->op_type == OP_NULL
14783                                    || pass == 0);
14784                             if (helem_op->op_type == OP_HELEM) {
14785                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14786                                 if (   helem_op->op_private & OPpLVAL_INTRO
14787                                     || rop->op_type != OP_RV2HV
14788                                 )
14789                                     rop = NULL;
14790                             }
14791                             /* on first pass just check; on second pass
14792                              * hekify */
14793                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
14794                                                             pass);
14795                         }
14796
14797                         if (pass) {
14798 #ifdef USE_ITHREADS
14799                             /* Relocate sv to the pad for thread safety */
14800                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14801                             arg->pad_offset = o->op_targ;
14802                             o->op_targ = 0;
14803 #else
14804                             arg->sv = cSVOPx_sv(o);
14805 #endif
14806                         }
14807                     }
14808                     else {
14809                         /* it's a constant array index */
14810                         IV iv;
14811                         SV *ix_sv = cSVOPo->op_sv;
14812                         if (!SvIOK(ix_sv))
14813                             break;
14814                         iv = SvIV(ix_sv);
14815
14816                         if (   action_count == 0
14817                             && iv >= -128
14818                             && iv <= 127
14819                             && (   action == MDEREF_AV_padav_aelem
14820                                 || action == MDEREF_AV_gvav_aelem)
14821                         )
14822                             maybe_aelemfast = TRUE;
14823
14824                         if (pass) {
14825                             arg->iv = iv;
14826                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14827                         }
14828                     }
14829                     if (pass)
14830                         /* we've taken ownership of the SV */
14831                         cSVOPo->op_sv = NULL;
14832                     arg++;
14833                     index_type = MDEREF_INDEX_const;
14834                     o = o->op_next;
14835                     break;
14836
14837                 case OP_GV:
14838                     /* it may be a package var index */
14839
14840                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14841                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14842                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14843                         || o->op_private != 0
14844                     )
14845                         break;
14846
14847                     kid = o->op_next;
14848                     if (kid->op_type != OP_RV2SV)
14849                         break;
14850
14851                     ASSUME(!(kid->op_flags &
14852                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14853                              |OPf_SPECIAL|OPf_PARENS)));
14854                     ASSUME(!(kid->op_private &
14855                                     ~(OPpARG1_MASK
14856                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14857                                      |OPpDEREF|OPpLVAL_INTRO)));
14858                     if(   (kid->op_flags &~ OPf_PARENS)
14859                             != (OPf_WANT_SCALAR|OPf_KIDS)
14860                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14861                     )
14862                         break;
14863
14864                     if (pass) {
14865 #ifdef USE_ITHREADS
14866                         arg->pad_offset = cPADOPx(o)->op_padix;
14867                         /* stop it being swiped when nulled */
14868                         cPADOPx(o)->op_padix = 0;
14869 #else
14870                         arg->sv = cSVOPx(o)->op_sv;
14871                         cSVOPo->op_sv = NULL;
14872 #endif
14873                     }
14874                     arg++;
14875                     index_type = MDEREF_INDEX_gvsv;
14876                     o = kid->op_next;
14877                     break;
14878
14879                 } /* switch */
14880             } /* action_count != index_skip */
14881
14882             action |= index_type;
14883
14884
14885             /* at this point we have either:
14886              *   * detected what looks like a simple index expression,
14887              *     and expect the next op to be an [ah]elem, or
14888              *     an nulled  [ah]elem followed by a delete or exists;
14889              *  * found a more complex expression, so something other
14890              *    than the above follows.
14891              */
14892
14893             /* possibly an optimised away [ah]elem (where op_next is
14894              * exists or delete) */
14895             if (o->op_type == OP_NULL)
14896                 o = o->op_next;
14897
14898             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14899              * OP_EXISTS or OP_DELETE */
14900
14901             /* if a custom array/hash access checker is in scope,
14902              * abandon optimisation attempt */
14903             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14904                && PL_check[o->op_type] != Perl_ck_null)
14905                 return;
14906             /* similarly for customised exists and delete */
14907             if (  (o->op_type == OP_EXISTS)
14908                && PL_check[o->op_type] != Perl_ck_exists)
14909                 return;
14910             if (  (o->op_type == OP_DELETE)
14911                && PL_check[o->op_type] != Perl_ck_delete)
14912                 return;
14913
14914             if (   o->op_type != OP_AELEM
14915                 || (o->op_private &
14916                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14917                 )
14918                 maybe_aelemfast = FALSE;
14919
14920             /* look for aelem/helem/exists/delete. If it's not the last elem
14921              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14922              * flags; if it's the last, then it mustn't have
14923              * OPpDEREF_AV/HV, but may have lots of other flags, like
14924              * OPpLVAL_INTRO etc
14925              */
14926
14927             if (   index_type == MDEREF_INDEX_none
14928                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14929                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14930             )
14931                 ok = FALSE;
14932             else {
14933                 /* we have aelem/helem/exists/delete with valid simple index */
14934
14935                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14936                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14937                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14938
14939                 /* This doesn't make much sense but is legal:
14940                  *    @{ local $x[0][0] } = 1
14941                  * Since scope exit will undo the autovivification,
14942                  * don't bother in the first place. The OP_LEAVE
14943                  * assertion is in case there are other cases of both
14944                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14945                  * exit that would undo the local - in which case this
14946                  * block of code would need rethinking.
14947                  */
14948                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14949 #ifdef DEBUGGING
14950                     OP *n = o->op_next;
14951                     while (n && (  n->op_type == OP_NULL
14952                                 || n->op_type == OP_LIST
14953                                 || n->op_type == OP_SCALAR))
14954                         n = n->op_next;
14955                     assert(n && n->op_type == OP_LEAVE);
14956 #endif
14957                     o->op_private &= ~OPpDEREF;
14958                     is_deref = FALSE;
14959                 }
14960
14961                 if (is_deref) {
14962                     ASSUME(!(o->op_flags &
14963                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14964                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14965
14966                     ok =    (o->op_flags &~ OPf_PARENS)
14967                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14968                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14969                 }
14970                 else if (o->op_type == OP_EXISTS) {
14971                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14972                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14973                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14974                     ok =  !(o->op_private & ~OPpARG1_MASK);
14975                 }
14976                 else if (o->op_type == OP_DELETE) {
14977                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14978                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14979                     ASSUME(!(o->op_private &
14980                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14981                     /* don't handle slices or 'local delete'; the latter
14982                      * is fairly rare, and has a complex runtime */
14983                     ok =  !(o->op_private & ~OPpARG1_MASK);
14984                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14985                         /* skip handling run-tome error */
14986                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14987                 }
14988                 else {
14989                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14990                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14991                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14992                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14993                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14994                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14995                 }
14996             }
14997
14998             if (ok) {
14999                 if (!first_elem_op)
15000                     first_elem_op = o;
15001                 top_op = o;
15002                 if (is_deref) {
15003                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
15004                     o = o->op_next;
15005                 }
15006                 else {
15007                     is_last = TRUE;
15008                     action |= MDEREF_FLAG_last;
15009                 }
15010             }
15011             else {
15012                 /* at this point we have something that started
15013                  * promisingly enough (with rv2av or whatever), but failed
15014                  * to find a simple index followed by an
15015                  * aelem/helem/exists/delete. If this is the first action,
15016                  * give up; but if we've already seen at least one
15017                  * aelem/helem, then keep them and add a new action with
15018                  * MDEREF_INDEX_none, which causes it to do the vivify
15019                  * from the end of the previous lookup, and do the deref,
15020                  * but stop at that point. So $a[0][expr] will do one
15021                  * av_fetch, vivify and deref, then continue executing at
15022                  * expr */
15023                 if (!action_count)
15024                     return;
15025                 is_last = TRUE;
15026                 index_skip = action_count;
15027                 action |= MDEREF_FLAG_last;
15028                 if (index_type != MDEREF_INDEX_none)
15029                     arg--;
15030             }
15031
15032             if (pass)
15033                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
15034             action_ix++;
15035             action_count++;
15036             /* if there's no space for the next action, create a new slot
15037              * for it *before* we start adding args for that action */
15038             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
15039                 action_ptr = arg;
15040                 if (pass)
15041                     arg->uv = 0;
15042                 arg++;
15043                 action_ix = 0;
15044             }
15045         } /* while !is_last */
15046
15047         /* success! */
15048
15049         if (pass) {
15050             OP *mderef;
15051             OP *p, *q;
15052
15053             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15054             if (index_skip == -1) {
15055                 mderef->op_flags = o->op_flags
15056                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15057                 if (o->op_type == OP_EXISTS)
15058                     mderef->op_private = OPpMULTIDEREF_EXISTS;
15059                 else if (o->op_type == OP_DELETE)
15060                     mderef->op_private = OPpMULTIDEREF_DELETE;
15061                 else
15062                     mderef->op_private = o->op_private
15063                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15064             }
15065             /* accumulate strictness from every level (although I don't think
15066              * they can actually vary) */
15067             mderef->op_private |= hints;
15068
15069             /* integrate the new multideref op into the optree and the
15070              * op_next chain.
15071              *
15072              * In general an op like aelem or helem has two child
15073              * sub-trees: the aggregate expression (a_expr) and the
15074              * index expression (i_expr):
15075              *
15076              *     aelem
15077              *       |
15078              *     a_expr - i_expr
15079              *
15080              * The a_expr returns an AV or HV, while the i-expr returns an
15081              * index. In general a multideref replaces most or all of a
15082              * multi-level tree, e.g.
15083              *
15084              *     exists
15085              *       |
15086              *     ex-aelem
15087              *       |
15088              *     rv2av  - i_expr1
15089              *       |
15090              *     helem
15091              *       |
15092              *     rv2hv  - i_expr2
15093              *       |
15094              *     aelem
15095              *       |
15096              *     a_expr - i_expr3
15097              *
15098              * With multideref, all the i_exprs will be simple vars or
15099              * constants, except that i_expr1 may be arbitrary in the case
15100              * of MDEREF_INDEX_none.
15101              *
15102              * The bottom-most a_expr will be either:
15103              *   1) a simple var (so padXv or gv+rv2Xv);
15104              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
15105              *      so a simple var with an extra rv2Xv;
15106              *   3) or an arbitrary expression.
15107              *
15108              * 'start', the first op in the execution chain, will point to
15109              *   1),2): the padXv or gv op;
15110              *   3):    the rv2Xv which forms the last op in the a_expr
15111              *          execution chain, and the top-most op in the a_expr
15112              *          subtree.
15113              *
15114              * For all cases, the 'start' node is no longer required,
15115              * but we can't free it since one or more external nodes
15116              * may point to it. E.g. consider
15117              *     $h{foo} = $a ? $b : $c
15118              * Here, both the op_next and op_other branches of the
15119              * cond_expr point to the gv[*h] of the hash expression, so
15120              * we can't free the 'start' op.
15121              *
15122              * For expr->[...], we need to save the subtree containing the
15123              * expression; for the other cases, we just need to save the
15124              * start node.
15125              * So in all cases, we null the start op and keep it around by
15126              * making it the child of the multideref op; for the expr->
15127              * case, the expr will be a subtree of the start node.
15128              *
15129              * So in the simple 1,2 case the  optree above changes to
15130              *
15131              *     ex-exists
15132              *       |
15133              *     multideref
15134              *       |
15135              *     ex-gv (or ex-padxv)
15136              *
15137              *  with the op_next chain being
15138              *
15139              *  -> ex-gv -> multideref -> op-following-ex-exists ->
15140              *
15141              *  In the 3 case, we have
15142              *
15143              *     ex-exists
15144              *       |
15145              *     multideref
15146              *       |
15147              *     ex-rv2xv
15148              *       |
15149              *    rest-of-a_expr
15150              *      subtree
15151              *
15152              *  and
15153              *
15154              *  -> rest-of-a_expr subtree ->
15155              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15156              *
15157              *
15158              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15159              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15160              * multideref attached as the child, e.g.
15161              *
15162              *     exists
15163              *       |
15164              *     ex-aelem
15165              *       |
15166              *     ex-rv2av  - i_expr1
15167              *       |
15168              *     multideref
15169              *       |
15170              *     ex-whatever
15171              *
15172              */
15173
15174             /* if we free this op, don't free the pad entry */
15175             if (reset_start_targ)
15176                 start->op_targ = 0;
15177
15178
15179             /* Cut the bit we need to save out of the tree and attach to
15180              * the multideref op, then free the rest of the tree */
15181
15182             /* find parent of node to be detached (for use by splice) */
15183             p = first_elem_op;
15184             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15185                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15186             {
15187                 /* there is an arbitrary expression preceding us, e.g.
15188                  * expr->[..]? so we need to save the 'expr' subtree */
15189                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15190                     p = cUNOPx(p)->op_first;
15191                 ASSUME(   start->op_type == OP_RV2AV
15192                        || start->op_type == OP_RV2HV);
15193             }
15194             else {
15195                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15196                  * above for exists/delete. */
15197                 while (   (p->op_flags & OPf_KIDS)
15198                        && cUNOPx(p)->op_first != start
15199                 )
15200                     p = cUNOPx(p)->op_first;
15201             }
15202             ASSUME(cUNOPx(p)->op_first == start);
15203
15204             /* detach from main tree, and re-attach under the multideref */
15205             op_sibling_splice(mderef, NULL, 0,
15206                     op_sibling_splice(p, NULL, 1, NULL));
15207             op_null(start);
15208
15209             start->op_next = mderef;
15210
15211             mderef->op_next = index_skip == -1 ? o->op_next : o;
15212
15213             /* excise and free the original tree, and replace with
15214              * the multideref op */
15215             p = op_sibling_splice(top_op, NULL, -1, mderef);
15216             while (p) {
15217                 q = OpSIBLING(p);
15218                 op_free(p);
15219                 p = q;
15220             }
15221             op_null(top_op);
15222         }
15223         else {
15224             Size_t size = arg - arg_buf;
15225
15226             if (maybe_aelemfast && action_count == 1)
15227                 return;
15228
15229             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15230                                 sizeof(UNOP_AUX_item) * (size + 1));
15231             /* for dumping etc: store the length in a hidden first slot;
15232              * we set the op_aux pointer to the second slot */
15233             arg_buf->uv = size;
15234             arg_buf++;
15235         }
15236     } /* for (pass = ...) */
15237 }
15238
15239 /* See if the ops following o are such that o will always be executed in
15240  * boolean context: that is, the SV which o pushes onto the stack will
15241  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15242  * If so, set a suitable private flag on o. Normally this will be
15243  * bool_flag; but see below why maybe_flag is needed too.
15244  *
15245  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15246  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15247  * already be taken, so you'll have to give that op two different flags.
15248  *
15249  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15250  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15251  * those underlying ops) short-circuit, which means that rather than
15252  * necessarily returning a truth value, they may return the LH argument,
15253  * which may not be boolean. For example in $x = (keys %h || -1), keys
15254  * should return a key count rather than a boolean, even though its
15255  * sort-of being used in boolean context.
15256  *
15257  * So we only consider such logical ops to provide boolean context to
15258  * their LH argument if they themselves are in void or boolean context.
15259  * However, sometimes the context isn't known until run-time. In this
15260  * case the op is marked with the maybe_flag flag it.
15261  *
15262  * Consider the following.
15263  *
15264  *     sub f { ....;  if (%h) { .... } }
15265  *
15266  * This is actually compiled as
15267  *
15268  *     sub f { ....;  %h && do { .... } }
15269  *
15270  * Here we won't know until runtime whether the final statement (and hence
15271  * the &&) is in void context and so is safe to return a boolean value.
15272  * So mark o with maybe_flag rather than the bool_flag.
15273  * Note that there is cost associated with determining context at runtime
15274  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15275  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15276  * boolean costs savings are marginal.
15277  *
15278  * However, we can do slightly better with && (compared to || and //):
15279  * this op only returns its LH argument when that argument is false. In
15280  * this case, as long as the op promises to return a false value which is
15281  * valid in both boolean and scalar contexts, we can mark an op consumed
15282  * by && with bool_flag rather than maybe_flag.
15283  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15284  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15285  * op which promises to handle this case is indicated by setting safe_and
15286  * to true.
15287  */
15288
15289 static void
15290 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15291 {
15292     OP *lop;
15293     U8 flag = 0;
15294
15295     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15296
15297     /* OPpTARGET_MY and boolean context probably don't mix well.
15298      * If someone finds a valid use case, maybe add an extra flag to this
15299      * function which indicates its safe to do so for this op? */
15300     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15301              && (o->op_private & OPpTARGET_MY)));
15302
15303     lop = o->op_next;
15304
15305     while (lop) {
15306         switch (lop->op_type) {
15307         case OP_NULL:
15308         case OP_SCALAR:
15309             break;
15310
15311         /* these two consume the stack argument in the scalar case,
15312          * and treat it as a boolean in the non linenumber case */
15313         case OP_FLIP:
15314         case OP_FLOP:
15315             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15316                 || (lop->op_private & OPpFLIP_LINENUM))
15317             {
15318                 lop = NULL;
15319                 break;
15320             }
15321             /* FALLTHROUGH */
15322         /* these never leave the original value on the stack */
15323         case OP_NOT:
15324         case OP_XOR:
15325         case OP_COND_EXPR:
15326         case OP_GREPWHILE:
15327             flag = bool_flag;
15328             lop = NULL;
15329             break;
15330
15331         /* OR DOR and AND evaluate their arg as a boolean, but then may
15332          * leave the original scalar value on the stack when following the
15333          * op_next route. If not in void context, we need to ensure
15334          * that whatever follows consumes the arg only in boolean context
15335          * too.
15336          */
15337         case OP_AND:
15338             if (safe_and) {
15339                 flag = bool_flag;
15340                 lop = NULL;
15341                 break;
15342             }
15343             /* FALLTHROUGH */
15344         case OP_OR:
15345         case OP_DOR:
15346             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15347                 flag = bool_flag;
15348                 lop = NULL;
15349             }
15350             else if (!(lop->op_flags & OPf_WANT)) {
15351                 /* unknown context - decide at runtime */
15352                 flag = maybe_flag;
15353                 lop = NULL;
15354             }
15355             break;
15356
15357         default:
15358             lop = NULL;
15359             break;
15360         }
15361
15362         if (lop)
15363             lop = lop->op_next;
15364     }
15365
15366     o->op_private |= flag;
15367 }
15368
15369
15370
15371 /* mechanism for deferring recursion in rpeep() */
15372
15373 #define MAX_DEFERRED 4
15374
15375 #define DEFER(o) \
15376   STMT_START { \
15377     if (defer_ix == (MAX_DEFERRED-1)) { \
15378         OP **defer = defer_queue[defer_base]; \
15379         CALL_RPEEP(*defer); \
15380         S_prune_chain_head(defer); \
15381         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15382         defer_ix--; \
15383     } \
15384     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15385   } STMT_END
15386
15387 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15388 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15389
15390
15391 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15392  * See the comments at the top of this file for more details about when
15393  * peep() is called */
15394
15395 void
15396 Perl_rpeep(pTHX_ OP *o)
15397 {
15398     dVAR;
15399     OP* oldop = NULL;
15400     OP* oldoldop = NULL;
15401     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15402     int defer_base = 0;
15403     int defer_ix = -1;
15404
15405     if (!o || o->op_opt)
15406         return;
15407
15408     assert(o->op_type != OP_FREED);
15409
15410     ENTER;
15411     SAVEOP();
15412     SAVEVPTR(PL_curcop);
15413     for (;; o = o->op_next) {
15414         if (o && o->op_opt)
15415             o = NULL;
15416         if (!o) {
15417             while (defer_ix >= 0) {
15418                 OP **defer =
15419                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15420                 CALL_RPEEP(*defer);
15421                 S_prune_chain_head(defer);
15422             }
15423             break;
15424         }
15425
15426       redo:
15427
15428         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15429         assert(!oldoldop || oldoldop->op_next == oldop);
15430         assert(!oldop    || oldop->op_next    == o);
15431
15432         /* By default, this op has now been optimised. A couple of cases below
15433            clear this again.  */
15434         o->op_opt = 1;
15435         PL_op = o;
15436
15437         /* look for a series of 1 or more aggregate derefs, e.g.
15438          *   $a[1]{foo}[$i]{$k}
15439          * and replace with a single OP_MULTIDEREF op.
15440          * Each index must be either a const, or a simple variable,
15441          *
15442          * First, look for likely combinations of starting ops,
15443          * corresponding to (global and lexical variants of)
15444          *     $a[...]   $h{...}
15445          *     $r->[...] $r->{...}
15446          *     (preceding expression)->[...]
15447          *     (preceding expression)->{...}
15448          * and if so, call maybe_multideref() to do a full inspection
15449          * of the op chain and if appropriate, replace with an
15450          * OP_MULTIDEREF
15451          */
15452         {
15453             UV action;
15454             OP *o2 = o;
15455             U8 hints = 0;
15456
15457             switch (o2->op_type) {
15458             case OP_GV:
15459                 /* $pkg[..]   :   gv[*pkg]
15460                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15461
15462                 /* Fail if there are new op flag combinations that we're
15463                  * not aware of, rather than:
15464                  *  * silently failing to optimise, or
15465                  *  * silently optimising the flag away.
15466                  * If this ASSUME starts failing, examine what new flag
15467                  * has been added to the op, and decide whether the
15468                  * optimisation should still occur with that flag, then
15469                  * update the code accordingly. This applies to all the
15470                  * other ASSUMEs in the block of code too.
15471                  */
15472                 ASSUME(!(o2->op_flags &
15473                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15474                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15475
15476                 o2 = o2->op_next;
15477
15478                 if (o2->op_type == OP_RV2AV) {
15479                     action = MDEREF_AV_gvav_aelem;
15480                     goto do_deref;
15481                 }
15482
15483                 if (o2->op_type == OP_RV2HV) {
15484                     action = MDEREF_HV_gvhv_helem;
15485                     goto do_deref;
15486                 }
15487
15488                 if (o2->op_type != OP_RV2SV)
15489                     break;
15490
15491                 /* at this point we've seen gv,rv2sv, so the only valid
15492                  * construct left is $pkg->[] or $pkg->{} */
15493
15494                 ASSUME(!(o2->op_flags & OPf_STACKED));
15495                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15496                             != (OPf_WANT_SCALAR|OPf_MOD))
15497                     break;
15498
15499                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15500                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15501                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15502                     break;
15503                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15504                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15505                     break;
15506
15507                 o2 = o2->op_next;
15508                 if (o2->op_type == OP_RV2AV) {
15509                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15510                     goto do_deref;
15511                 }
15512                 if (o2->op_type == OP_RV2HV) {
15513                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15514                     goto do_deref;
15515                 }
15516                 break;
15517
15518             case OP_PADSV:
15519                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15520
15521                 ASSUME(!(o2->op_flags &
15522                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15523                 if ((o2->op_flags &
15524                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15525                      != (OPf_WANT_SCALAR|OPf_MOD))
15526                     break;
15527
15528                 ASSUME(!(o2->op_private &
15529                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15530                 /* skip if state or intro, or not a deref */
15531                 if (      o2->op_private != OPpDEREF_AV
15532                        && o2->op_private != OPpDEREF_HV)
15533                     break;
15534
15535                 o2 = o2->op_next;
15536                 if (o2->op_type == OP_RV2AV) {
15537                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15538                     goto do_deref;
15539                 }
15540                 if (o2->op_type == OP_RV2HV) {
15541                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15542                     goto do_deref;
15543                 }
15544                 break;
15545
15546             case OP_PADAV:
15547             case OP_PADHV:
15548                 /*    $lex[..]:  padav[@lex:1,2] sR *
15549                  * or $lex{..}:  padhv[%lex:1,2] sR */
15550                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15551                                             OPf_REF|OPf_SPECIAL)));
15552                 if ((o2->op_flags &
15553                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15554                      != (OPf_WANT_SCALAR|OPf_REF))
15555                     break;
15556                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15557                     break;
15558                 /* OPf_PARENS isn't currently used in this case;
15559                  * if that changes, let us know! */
15560                 ASSUME(!(o2->op_flags & OPf_PARENS));
15561
15562                 /* at this point, we wouldn't expect any of the remaining
15563                  * possible private flags:
15564                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15565                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15566                  *
15567                  * OPpSLICEWARNING shouldn't affect runtime
15568                  */
15569                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15570
15571                 action = o2->op_type == OP_PADAV
15572                             ? MDEREF_AV_padav_aelem
15573                             : MDEREF_HV_padhv_helem;
15574                 o2 = o2->op_next;
15575                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15576                 break;
15577
15578
15579             case OP_RV2AV:
15580             case OP_RV2HV:
15581                 action = o2->op_type == OP_RV2AV
15582                             ? MDEREF_AV_pop_rv2av_aelem
15583                             : MDEREF_HV_pop_rv2hv_helem;
15584                 /* FALLTHROUGH */
15585             do_deref:
15586                 /* (expr)->[...]:  rv2av sKR/1;
15587                  * (expr)->{...}:  rv2hv sKR/1; */
15588
15589                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15590
15591                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15592                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15593                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15594                     break;
15595
15596                 /* at this point, we wouldn't expect any of these
15597                  * possible private flags:
15598                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15599                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15600                  */
15601                 ASSUME(!(o2->op_private &
15602                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15603                      |OPpOUR_INTRO)));
15604                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15605
15606                 o2 = o2->op_next;
15607
15608                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15609                 break;
15610
15611             default:
15612                 break;
15613             }
15614         }
15615
15616
15617         switch (o->op_type) {
15618         case OP_DBSTATE:
15619             PL_curcop = ((COP*)o);              /* for warnings */
15620             break;
15621         case OP_NEXTSTATE:
15622             PL_curcop = ((COP*)o);              /* for warnings */
15623
15624             /* Optimise a "return ..." at the end of a sub to just be "...".
15625              * This saves 2 ops. Before:
15626              * 1  <;> nextstate(main 1 -e:1) v ->2
15627              * 4  <@> return K ->5
15628              * 2    <0> pushmark s ->3
15629              * -    <1> ex-rv2sv sK/1 ->4
15630              * 3      <#> gvsv[*cat] s ->4
15631              *
15632              * After:
15633              * -  <@> return K ->-
15634              * -    <0> pushmark s ->2
15635              * -    <1> ex-rv2sv sK/1 ->-
15636              * 2      <$> gvsv(*cat) s ->3
15637              */
15638             {
15639                 OP *next = o->op_next;
15640                 OP *sibling = OpSIBLING(o);
15641                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15642                     && OP_TYPE_IS(sibling, OP_RETURN)
15643                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15644                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15645                        ||OP_TYPE_IS(sibling->op_next->op_next,
15646                                     OP_LEAVESUBLV))
15647                     && cUNOPx(sibling)->op_first == next
15648                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15649                     && next->op_next
15650                 ) {
15651                     /* Look through the PUSHMARK's siblings for one that
15652                      * points to the RETURN */
15653                     OP *top = OpSIBLING(next);
15654                     while (top && top->op_next) {
15655                         if (top->op_next == sibling) {
15656                             top->op_next = sibling->op_next;
15657                             o->op_next = next->op_next;
15658                             break;
15659                         }
15660                         top = OpSIBLING(top);
15661                     }
15662                 }
15663             }
15664
15665             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15666              *
15667              * This latter form is then suitable for conversion into padrange
15668              * later on. Convert:
15669              *
15670              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15671              *
15672              * into:
15673              *
15674              *   nextstate1 ->     listop     -> nextstate3
15675              *                 /            \
15676              *         pushmark -> padop1 -> padop2
15677              */
15678             if (o->op_next && (
15679                     o->op_next->op_type == OP_PADSV
15680                  || o->op_next->op_type == OP_PADAV
15681                  || o->op_next->op_type == OP_PADHV
15682                 )
15683                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15684                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15685                 && o->op_next->op_next->op_next && (
15686                     o->op_next->op_next->op_next->op_type == OP_PADSV
15687                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15688                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15689                 )
15690                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15691                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15692                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15693                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15694             ) {
15695                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15696
15697                 pad1 =    o->op_next;
15698                 ns2  = pad1->op_next;
15699                 pad2 =  ns2->op_next;
15700                 ns3  = pad2->op_next;
15701
15702                 /* we assume here that the op_next chain is the same as
15703                  * the op_sibling chain */
15704                 assert(OpSIBLING(o)    == pad1);
15705                 assert(OpSIBLING(pad1) == ns2);
15706                 assert(OpSIBLING(ns2)  == pad2);
15707                 assert(OpSIBLING(pad2) == ns3);
15708
15709                 /* excise and delete ns2 */
15710                 op_sibling_splice(NULL, pad1, 1, NULL);
15711                 op_free(ns2);
15712
15713                 /* excise pad1 and pad2 */
15714                 op_sibling_splice(NULL, o, 2, NULL);
15715
15716                 /* create new listop, with children consisting of:
15717                  * a new pushmark, pad1, pad2. */
15718                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15719                 newop->op_flags |= OPf_PARENS;
15720                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15721
15722                 /* insert newop between o and ns3 */
15723                 op_sibling_splice(NULL, o, 0, newop);
15724
15725                 /*fixup op_next chain */
15726                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15727                 o    ->op_next = newpm;
15728                 newpm->op_next = pad1;
15729                 pad1 ->op_next = pad2;
15730                 pad2 ->op_next = newop; /* listop */
15731                 newop->op_next = ns3;
15732
15733                 /* Ensure pushmark has this flag if padops do */
15734                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15735                     newpm->op_flags |= OPf_MOD;
15736                 }
15737
15738                 break;
15739             }
15740
15741             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15742                to carry two labels. For now, take the easier option, and skip
15743                this optimisation if the first NEXTSTATE has a label.  */
15744             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15745                 OP *nextop = o->op_next;
15746                 while (nextop && nextop->op_type == OP_NULL)
15747                     nextop = nextop->op_next;
15748
15749                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15750                     op_null(o);
15751                     if (oldop)
15752                         oldop->op_next = nextop;
15753                     o = nextop;
15754                     /* Skip (old)oldop assignment since the current oldop's
15755                        op_next already points to the next op.  */
15756                     goto redo;
15757                 }
15758             }
15759             break;
15760
15761         case OP_CONCAT:
15762             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15763                 if (o->op_next->op_private & OPpTARGET_MY) {
15764                     if (o->op_flags & OPf_STACKED) /* chained concats */
15765                         break; /* ignore_optimization */
15766                     else {
15767                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15768                         o->op_targ = o->op_next->op_targ;
15769                         o->op_next->op_targ = 0;
15770                         o->op_private |= OPpTARGET_MY;
15771                     }
15772                 }
15773                 op_null(o->op_next);
15774             }
15775             break;
15776         case OP_STUB:
15777             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15778                 break; /* Scalar stub must produce undef.  List stub is noop */
15779             }
15780             goto nothin;
15781         case OP_NULL:
15782             if (o->op_targ == OP_NEXTSTATE
15783                 || o->op_targ == OP_DBSTATE)
15784             {
15785                 PL_curcop = ((COP*)o);
15786             }
15787             /* XXX: We avoid setting op_seq here to prevent later calls
15788                to rpeep() from mistakenly concluding that optimisation
15789                has already occurred. This doesn't fix the real problem,
15790                though (See 20010220.007 (#5874)). AMS 20010719 */
15791             /* op_seq functionality is now replaced by op_opt */
15792             o->op_opt = 0;
15793             /* FALLTHROUGH */
15794         case OP_SCALAR:
15795         case OP_LINESEQ:
15796         case OP_SCOPE:
15797         nothin:
15798             if (oldop) {
15799                 oldop->op_next = o->op_next;
15800                 o->op_opt = 0;
15801                 continue;
15802             }
15803             break;
15804
15805         case OP_PUSHMARK:
15806
15807             /* Given
15808                  5 repeat/DOLIST
15809                  3   ex-list
15810                  1     pushmark
15811                  2     scalar or const
15812                  4   const[0]
15813                convert repeat into a stub with no kids.
15814              */
15815             if (o->op_next->op_type == OP_CONST
15816              || (  o->op_next->op_type == OP_PADSV
15817                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15818              || (  o->op_next->op_type == OP_GV
15819                 && o->op_next->op_next->op_type == OP_RV2SV
15820                 && !(o->op_next->op_next->op_private
15821                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15822             {
15823                 const OP *kid = o->op_next->op_next;
15824                 if (o->op_next->op_type == OP_GV)
15825                    kid = kid->op_next;
15826                 /* kid is now the ex-list.  */
15827                 if (kid->op_type == OP_NULL
15828                  && (kid = kid->op_next)->op_type == OP_CONST
15829                     /* kid is now the repeat count.  */
15830                  && kid->op_next->op_type == OP_REPEAT
15831                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15832                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15833                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15834                  && oldop)
15835                 {
15836                     o = kid->op_next; /* repeat */
15837                     oldop->op_next = o;
15838                     op_free(cBINOPo->op_first);
15839                     op_free(cBINOPo->op_last );
15840                     o->op_flags &=~ OPf_KIDS;
15841                     /* stub is a baseop; repeat is a binop */
15842                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15843                     OpTYPE_set(o, OP_STUB);
15844                     o->op_private = 0;
15845                     break;
15846                 }
15847             }
15848
15849             /* Convert a series of PAD ops for my vars plus support into a
15850              * single padrange op. Basically
15851              *
15852              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15853              *
15854              * becomes, depending on circumstances, one of
15855              *
15856              *    padrange  ----------------------------------> (list) -> rest
15857              *    padrange  --------------------------------------------> rest
15858              *
15859              * where all the pad indexes are sequential and of the same type
15860              * (INTRO or not).
15861              * We convert the pushmark into a padrange op, then skip
15862              * any other pad ops, and possibly some trailing ops.
15863              * Note that we don't null() the skipped ops, to make it
15864              * easier for Deparse to undo this optimisation (and none of
15865              * the skipped ops are holding any resourses). It also makes
15866              * it easier for find_uninit_var(), as it can just ignore
15867              * padrange, and examine the original pad ops.
15868              */
15869         {
15870             OP *p;
15871             OP *followop = NULL; /* the op that will follow the padrange op */
15872             U8 count = 0;
15873             U8 intro = 0;
15874             PADOFFSET base = 0; /* init only to stop compiler whining */
15875             bool gvoid = 0;     /* init only to stop compiler whining */
15876             bool defav = 0;  /* seen (...) = @_ */
15877             bool reuse = 0;  /* reuse an existing padrange op */
15878
15879             /* look for a pushmark -> gv[_] -> rv2av */
15880
15881             {
15882                 OP *rv2av, *q;
15883                 p = o->op_next;
15884                 if (   p->op_type == OP_GV
15885                     && cGVOPx_gv(p) == PL_defgv
15886                     && (rv2av = p->op_next)
15887                     && rv2av->op_type == OP_RV2AV
15888                     && !(rv2av->op_flags & OPf_REF)
15889                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15890                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15891                 ) {
15892                     q = rv2av->op_next;
15893                     if (q->op_type == OP_NULL)
15894                         q = q->op_next;
15895                     if (q->op_type == OP_PUSHMARK) {
15896                         defav = 1;
15897                         p = q;
15898                     }
15899                 }
15900             }
15901             if (!defav) {
15902                 p = o;
15903             }
15904
15905             /* scan for PAD ops */
15906
15907             for (p = p->op_next; p; p = p->op_next) {
15908                 if (p->op_type == OP_NULL)
15909                     continue;
15910
15911                 if ((     p->op_type != OP_PADSV
15912                        && p->op_type != OP_PADAV
15913                        && p->op_type != OP_PADHV
15914                     )
15915                       /* any private flag other than INTRO? e.g. STATE */
15916                    || (p->op_private & ~OPpLVAL_INTRO)
15917                 )
15918                     break;
15919
15920                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15921                  * instead */
15922                 if (   p->op_type == OP_PADAV
15923                     && p->op_next
15924                     && p->op_next->op_type == OP_CONST
15925                     && p->op_next->op_next
15926                     && p->op_next->op_next->op_type == OP_AELEM
15927                 )
15928                     break;
15929
15930                 /* for 1st padop, note what type it is and the range
15931                  * start; for the others, check that it's the same type
15932                  * and that the targs are contiguous */
15933                 if (count == 0) {
15934                     intro = (p->op_private & OPpLVAL_INTRO);
15935                     base = p->op_targ;
15936                     gvoid = OP_GIMME(p,0) == G_VOID;
15937                 }
15938                 else {
15939                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15940                         break;
15941                     /* Note that you'd normally  expect targs to be
15942                      * contiguous in my($a,$b,$c), but that's not the case
15943                      * when external modules start doing things, e.g.
15944                      * Function::Parameters */
15945                     if (p->op_targ != base + count)
15946                         break;
15947                     assert(p->op_targ == base + count);
15948                     /* Either all the padops or none of the padops should
15949                        be in void context.  Since we only do the optimisa-
15950                        tion for av/hv when the aggregate itself is pushed
15951                        on to the stack (one item), there is no need to dis-
15952                        tinguish list from scalar context.  */
15953                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15954                         break;
15955                 }
15956
15957                 /* for AV, HV, only when we're not flattening */
15958                 if (   p->op_type != OP_PADSV
15959                     && !gvoid
15960                     && !(p->op_flags & OPf_REF)
15961                 )
15962                     break;
15963
15964                 if (count >= OPpPADRANGE_COUNTMASK)
15965                     break;
15966
15967                 /* there's a biggest base we can fit into a
15968                  * SAVEt_CLEARPADRANGE in pp_padrange.
15969                  * (The sizeof() stuff will be constant-folded, and is
15970                  * intended to avoid getting "comparison is always false"
15971                  * compiler warnings. See the comments above
15972                  * MEM_WRAP_CHECK for more explanation on why we do this
15973                  * in a weird way to avoid compiler warnings.)
15974                  */
15975                 if (   intro
15976                     && (8*sizeof(base) >
15977                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15978                         ? (Size_t)base
15979                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15980                         ) >
15981                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15982                 )
15983                     break;
15984
15985                 /* Success! We've got another valid pad op to optimise away */
15986                 count++;
15987                 followop = p->op_next;
15988             }
15989
15990             if (count < 1 || (count == 1 && !defav))
15991                 break;
15992
15993             /* pp_padrange in specifically compile-time void context
15994              * skips pushing a mark and lexicals; in all other contexts
15995              * (including unknown till runtime) it pushes a mark and the
15996              * lexicals. We must be very careful then, that the ops we
15997              * optimise away would have exactly the same effect as the
15998              * padrange.
15999              * In particular in void context, we can only optimise to
16000              * a padrange if we see the complete sequence
16001              *     pushmark, pad*v, ...., list
16002              * which has the net effect of leaving the markstack as it
16003              * was.  Not pushing onto the stack (whereas padsv does touch
16004              * the stack) makes no difference in void context.
16005              */
16006             assert(followop);
16007             if (gvoid) {
16008                 if (followop->op_type == OP_LIST
16009                         && OP_GIMME(followop,0) == G_VOID
16010                    )
16011                 {
16012                     followop = followop->op_next; /* skip OP_LIST */
16013
16014                     /* consolidate two successive my(...);'s */
16015
16016                     if (   oldoldop
16017                         && oldoldop->op_type == OP_PADRANGE
16018                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
16019                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
16020                         && !(oldoldop->op_flags & OPf_SPECIAL)
16021                     ) {
16022                         U8 old_count;
16023                         assert(oldoldop->op_next == oldop);
16024                         assert(   oldop->op_type == OP_NEXTSTATE
16025                                || oldop->op_type == OP_DBSTATE);
16026                         assert(oldop->op_next == o);
16027
16028                         old_count
16029                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
16030
16031                        /* Do not assume pad offsets for $c and $d are con-
16032                           tiguous in
16033                             my ($a,$b,$c);
16034                             my ($d,$e,$f);
16035                         */
16036                         if (  oldoldop->op_targ + old_count == base
16037                            && old_count < OPpPADRANGE_COUNTMASK - count) {
16038                             base = oldoldop->op_targ;
16039                             count += old_count;
16040                             reuse = 1;
16041                         }
16042                     }
16043
16044                     /* if there's any immediately following singleton
16045                      * my var's; then swallow them and the associated
16046                      * nextstates; i.e.
16047                      *    my ($a,$b); my $c; my $d;
16048                      * is treated as
16049                      *    my ($a,$b,$c,$d);
16050                      */
16051
16052                     while (    ((p = followop->op_next))
16053                             && (  p->op_type == OP_PADSV
16054                                || p->op_type == OP_PADAV
16055                                || p->op_type == OP_PADHV)
16056                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16057                             && (p->op_private & OPpLVAL_INTRO) == intro
16058                             && !(p->op_private & ~OPpLVAL_INTRO)
16059                             && p->op_next
16060                             && (   p->op_next->op_type == OP_NEXTSTATE
16061                                 || p->op_next->op_type == OP_DBSTATE)
16062                             && count < OPpPADRANGE_COUNTMASK
16063                             && base + count == p->op_targ
16064                     ) {
16065                         count++;
16066                         followop = p->op_next;
16067                     }
16068                 }
16069                 else
16070                     break;
16071             }
16072
16073             if (reuse) {
16074                 assert(oldoldop->op_type == OP_PADRANGE);
16075                 oldoldop->op_next = followop;
16076                 oldoldop->op_private = (intro | count);
16077                 o = oldoldop;
16078                 oldop = NULL;
16079                 oldoldop = NULL;
16080             }
16081             else {
16082                 /* Convert the pushmark into a padrange.
16083                  * To make Deparse easier, we guarantee that a padrange was
16084                  * *always* formerly a pushmark */
16085                 assert(o->op_type == OP_PUSHMARK);
16086                 o->op_next = followop;
16087                 OpTYPE_set(o, OP_PADRANGE);
16088                 o->op_targ = base;
16089                 /* bit 7: INTRO; bit 6..0: count */
16090                 o->op_private = (intro | count);
16091                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16092                               | gvoid * OPf_WANT_VOID
16093                               | (defav ? OPf_SPECIAL : 0));
16094             }
16095             break;
16096         }
16097
16098         case OP_RV2AV:
16099             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16100                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16101             break;
16102
16103         case OP_RV2HV:
16104         case OP_PADHV:
16105             /*'keys %h' in void or scalar context: skip the OP_KEYS
16106              * and perform the functionality directly in the RV2HV/PADHV
16107              * op
16108              */
16109             if (o->op_flags & OPf_REF) {
16110                 OP *k = o->op_next;
16111                 U8 want = (k->op_flags & OPf_WANT);
16112                 if (   k
16113                     && k->op_type == OP_KEYS
16114                     && (   want == OPf_WANT_VOID
16115                         || want == OPf_WANT_SCALAR)
16116                     && !(k->op_private & OPpMAYBE_LVSUB)
16117                     && !(k->op_flags & OPf_MOD)
16118                 ) {
16119                     o->op_next     = k->op_next;
16120                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
16121                     o->op_flags   |= want;
16122                     o->op_private |= (o->op_type == OP_PADHV ?
16123                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16124                     /* for keys(%lex), hold onto the OP_KEYS's targ
16125                      * since padhv doesn't have its own targ to return
16126                      * an int with */
16127                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16128                         op_null(k);
16129                 }
16130             }
16131
16132             /* see if %h is used in boolean context */
16133             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16134                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16135
16136
16137             if (o->op_type != OP_PADHV)
16138                 break;
16139             /* FALLTHROUGH */
16140         case OP_PADAV:
16141             if (   o->op_type == OP_PADAV
16142                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16143             )
16144                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16145             /* FALLTHROUGH */
16146         case OP_PADSV:
16147             /* Skip over state($x) in void context.  */
16148             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16149              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16150             {
16151                 oldop->op_next = o->op_next;
16152                 goto redo_nextstate;
16153             }
16154             if (o->op_type != OP_PADAV)
16155                 break;
16156             /* FALLTHROUGH */
16157         case OP_GV:
16158             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16159                 OP* const pop = (o->op_type == OP_PADAV) ?
16160                             o->op_next : o->op_next->op_next;
16161                 IV i;
16162                 if (pop && pop->op_type == OP_CONST &&
16163                     ((PL_op = pop->op_next)) &&
16164                     pop->op_next->op_type == OP_AELEM &&
16165                     !(pop->op_next->op_private &
16166                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16167                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16168                 {
16169                     GV *gv;
16170                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16171                         no_bareword_allowed(pop);
16172                     if (o->op_type == OP_GV)
16173                         op_null(o->op_next);
16174                     op_null(pop->op_next);
16175                     op_null(pop);
16176                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16177                     o->op_next = pop->op_next->op_next;
16178                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16179                     o->op_private = (U8)i;
16180                     if (o->op_type == OP_GV) {
16181                         gv = cGVOPo_gv;
16182                         GvAVn(gv);
16183                         o->op_type = OP_AELEMFAST;
16184                     }
16185                     else
16186                         o->op_type = OP_AELEMFAST_LEX;
16187                 }
16188                 if (o->op_type != OP_GV)
16189                     break;
16190             }
16191
16192             /* Remove $foo from the op_next chain in void context.  */
16193             if (oldop
16194              && (  o->op_next->op_type == OP_RV2SV
16195                 || o->op_next->op_type == OP_RV2AV
16196                 || o->op_next->op_type == OP_RV2HV  )
16197              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16198              && !(o->op_next->op_private & OPpLVAL_INTRO))
16199             {
16200                 oldop->op_next = o->op_next->op_next;
16201                 /* Reprocess the previous op if it is a nextstate, to
16202                    allow double-nextstate optimisation.  */
16203               redo_nextstate:
16204                 if (oldop->op_type == OP_NEXTSTATE) {
16205                     oldop->op_opt = 0;
16206                     o = oldop;
16207                     oldop = oldoldop;
16208                     oldoldop = NULL;
16209                     goto redo;
16210                 }
16211                 o = oldop->op_next;
16212                 goto redo;
16213             }
16214             else if (o->op_next->op_type == OP_RV2SV) {
16215                 if (!(o->op_next->op_private & OPpDEREF)) {
16216                     op_null(o->op_next);
16217                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16218                                                                | OPpOUR_INTRO);
16219                     o->op_next = o->op_next->op_next;
16220                     OpTYPE_set(o, OP_GVSV);
16221                 }
16222             }
16223             else if (o->op_next->op_type == OP_READLINE
16224                     && o->op_next->op_next->op_type == OP_CONCAT
16225                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16226             {
16227                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16228                 OpTYPE_set(o, OP_RCATLINE);
16229                 o->op_flags |= OPf_STACKED;
16230                 op_null(o->op_next->op_next);
16231                 op_null(o->op_next);
16232             }
16233
16234             break;
16235
16236         case OP_NOT:
16237             break;
16238
16239         case OP_AND:
16240         case OP_OR:
16241         case OP_DOR:
16242             while (cLOGOP->op_other->op_type == OP_NULL)
16243                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16244             while (o->op_next && (   o->op_type == o->op_next->op_type
16245                                   || o->op_next->op_type == OP_NULL))
16246                 o->op_next = o->op_next->op_next;
16247
16248             /* If we're an OR and our next is an AND in void context, we'll
16249                follow its op_other on short circuit, same for reverse.
16250                We can't do this with OP_DOR since if it's true, its return
16251                value is the underlying value which must be evaluated
16252                by the next op. */
16253             if (o->op_next &&
16254                 (
16255                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16256                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16257                 )
16258                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16259             ) {
16260                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16261             }
16262             DEFER(cLOGOP->op_other);
16263             o->op_opt = 1;
16264             break;
16265
16266         case OP_GREPWHILE:
16267             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16268                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16269             /* FALLTHROUGH */
16270         case OP_COND_EXPR:
16271         case OP_MAPWHILE:
16272         case OP_ANDASSIGN:
16273         case OP_ORASSIGN:
16274         case OP_DORASSIGN:
16275         case OP_RANGE:
16276         case OP_ONCE:
16277         case OP_ARGDEFELEM:
16278             while (cLOGOP->op_other->op_type == OP_NULL)
16279                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16280             DEFER(cLOGOP->op_other);
16281             break;
16282
16283         case OP_ENTERLOOP:
16284         case OP_ENTERITER:
16285             while (cLOOP->op_redoop->op_type == OP_NULL)
16286                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16287             while (cLOOP->op_nextop->op_type == OP_NULL)
16288                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16289             while (cLOOP->op_lastop->op_type == OP_NULL)
16290                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16291             /* a while(1) loop doesn't have an op_next that escapes the
16292              * loop, so we have to explicitly follow the op_lastop to
16293              * process the rest of the code */
16294             DEFER(cLOOP->op_lastop);
16295             break;
16296
16297         case OP_ENTERTRY:
16298             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16299             DEFER(cLOGOPo->op_other);
16300             break;
16301
16302         case OP_SUBST:
16303             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16304                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16305             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16306             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16307                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16308                 cPMOP->op_pmstashstartu.op_pmreplstart
16309                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16310             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16311             break;
16312
16313         case OP_SORT: {
16314             OP *oright;
16315
16316             if (o->op_flags & OPf_SPECIAL) {
16317                 /* first arg is a code block */
16318                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16319                 OP * kid          = cUNOPx(nullop)->op_first;
16320
16321                 assert(nullop->op_type == OP_NULL);
16322                 assert(kid->op_type == OP_SCOPE
16323                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16324                 /* since OP_SORT doesn't have a handy op_other-style
16325                  * field that can point directly to the start of the code
16326                  * block, store it in the otherwise-unused op_next field
16327                  * of the top-level OP_NULL. This will be quicker at
16328                  * run-time, and it will also allow us to remove leading
16329                  * OP_NULLs by just messing with op_nexts without
16330                  * altering the basic op_first/op_sibling layout. */
16331                 kid = kLISTOP->op_first;
16332                 assert(
16333                       (kid->op_type == OP_NULL
16334                       && (  kid->op_targ == OP_NEXTSTATE
16335                          || kid->op_targ == OP_DBSTATE  ))
16336                     || kid->op_type == OP_STUB
16337                     || kid->op_type == OP_ENTER
16338                     || (PL_parser && PL_parser->error_count));
16339                 nullop->op_next = kid->op_next;
16340                 DEFER(nullop->op_next);
16341             }
16342
16343             /* check that RHS of sort is a single plain array */
16344             oright = cUNOPo->op_first;
16345             if (!oright || oright->op_type != OP_PUSHMARK)
16346                 break;
16347
16348             if (o->op_private & OPpSORT_INPLACE)
16349                 break;
16350
16351             /* reverse sort ... can be optimised.  */
16352             if (!OpHAS_SIBLING(cUNOPo)) {
16353                 /* Nothing follows us on the list. */
16354                 OP * const reverse = o->op_next;
16355
16356                 if (reverse->op_type == OP_REVERSE &&
16357                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16358                     OP * const pushmark = cUNOPx(reverse)->op_first;
16359                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16360                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16361                         /* reverse -> pushmark -> sort */
16362                         o->op_private |= OPpSORT_REVERSE;
16363                         op_null(reverse);
16364                         pushmark->op_next = oright->op_next;
16365                         op_null(oright);
16366                     }
16367                 }
16368             }
16369
16370             break;
16371         }
16372
16373         case OP_REVERSE: {
16374             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16375             OP *gvop = NULL;
16376             LISTOP *enter, *exlist;
16377
16378             if (o->op_private & OPpSORT_INPLACE)
16379                 break;
16380
16381             enter = (LISTOP *) o->op_next;
16382             if (!enter)
16383                 break;
16384             if (enter->op_type == OP_NULL) {
16385                 enter = (LISTOP *) enter->op_next;
16386                 if (!enter)
16387                     break;
16388             }
16389             /* for $a (...) will have OP_GV then OP_RV2GV here.
16390                for (...) just has an OP_GV.  */
16391             if (enter->op_type == OP_GV) {
16392                 gvop = (OP *) enter;
16393                 enter = (LISTOP *) enter->op_next;
16394                 if (!enter)
16395                     break;
16396                 if (enter->op_type == OP_RV2GV) {
16397                   enter = (LISTOP *) enter->op_next;
16398                   if (!enter)
16399                     break;
16400                 }
16401             }
16402
16403             if (enter->op_type != OP_ENTERITER)
16404                 break;
16405
16406             iter = enter->op_next;
16407             if (!iter || iter->op_type != OP_ITER)
16408                 break;
16409
16410             expushmark = enter->op_first;
16411             if (!expushmark || expushmark->op_type != OP_NULL
16412                 || expushmark->op_targ != OP_PUSHMARK)
16413                 break;
16414
16415             exlist = (LISTOP *) OpSIBLING(expushmark);
16416             if (!exlist || exlist->op_type != OP_NULL
16417                 || exlist->op_targ != OP_LIST)
16418                 break;
16419
16420             if (exlist->op_last != o) {
16421                 /* Mmm. Was expecting to point back to this op.  */
16422                 break;
16423             }
16424             theirmark = exlist->op_first;
16425             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16426                 break;
16427
16428             if (OpSIBLING(theirmark) != o) {
16429                 /* There's something between the mark and the reverse, eg
16430                    for (1, reverse (...))
16431                    so no go.  */
16432                 break;
16433             }
16434
16435             ourmark = ((LISTOP *)o)->op_first;
16436             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16437                 break;
16438
16439             ourlast = ((LISTOP *)o)->op_last;
16440             if (!ourlast || ourlast->op_next != o)
16441                 break;
16442
16443             rv2av = OpSIBLING(ourmark);
16444             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16445                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16446                 /* We're just reversing a single array.  */
16447                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16448                 enter->op_flags |= OPf_STACKED;
16449             }
16450
16451             /* We don't have control over who points to theirmark, so sacrifice
16452                ours.  */
16453             theirmark->op_next = ourmark->op_next;
16454             theirmark->op_flags = ourmark->op_flags;
16455             ourlast->op_next = gvop ? gvop : (OP *) enter;
16456             op_null(ourmark);
16457             op_null(o);
16458             enter->op_private |= OPpITER_REVERSED;
16459             iter->op_private |= OPpITER_REVERSED;
16460
16461             oldoldop = NULL;
16462             oldop    = ourlast;
16463             o        = oldop->op_next;
16464             goto redo;
16465             NOT_REACHED; /* NOTREACHED */
16466             break;
16467         }
16468
16469         case OP_QR:
16470         case OP_MATCH:
16471             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16472                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16473             }
16474             break;
16475
16476         case OP_RUNCV:
16477             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16478              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16479             {
16480                 SV *sv;
16481                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16482                 else {
16483                     sv = newRV((SV *)PL_compcv);
16484                     sv_rvweaken(sv);
16485                     SvREADONLY_on(sv);
16486                 }
16487                 OpTYPE_set(o, OP_CONST);
16488                 o->op_flags |= OPf_SPECIAL;
16489                 cSVOPo->op_sv = sv;
16490             }
16491             break;
16492
16493         case OP_SASSIGN:
16494             if (OP_GIMME(o,0) == G_VOID
16495              || (  o->op_next->op_type == OP_LINESEQ
16496                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16497                    || (  o->op_next->op_next->op_type == OP_RETURN
16498                       && !CvLVALUE(PL_compcv)))))
16499             {
16500                 OP *right = cBINOP->op_first;
16501                 if (right) {
16502                     /*   sassign
16503                     *      RIGHT
16504                     *      substr
16505                     *         pushmark
16506                     *         arg1
16507                     *         arg2
16508                     *         ...
16509                     * becomes
16510                     *
16511                     *  ex-sassign
16512                     *     substr
16513                     *        pushmark
16514                     *        RIGHT
16515                     *        arg1
16516                     *        arg2
16517                     *        ...
16518                     */
16519                     OP *left = OpSIBLING(right);
16520                     if (left->op_type == OP_SUBSTR
16521                          && (left->op_private & 7) < 4) {
16522                         op_null(o);
16523                         /* cut out right */
16524                         op_sibling_splice(o, NULL, 1, NULL);
16525                         /* and insert it as second child of OP_SUBSTR */
16526                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16527                                     right);
16528                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16529                         left->op_flags =
16530                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16531                     }
16532                 }
16533             }
16534             break;
16535
16536         case OP_AASSIGN: {
16537             int l, r, lr, lscalars, rscalars;
16538
16539             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16540                Note that we do this now rather than in newASSIGNOP(),
16541                since only by now are aliased lexicals flagged as such
16542
16543                See the essay "Common vars in list assignment" above for
16544                the full details of the rationale behind all the conditions
16545                below.
16546
16547                PL_generation sorcery:
16548                To detect whether there are common vars, the global var
16549                PL_generation is incremented for each assign op we scan.
16550                Then we run through all the lexical variables on the LHS,
16551                of the assignment, setting a spare slot in each of them to
16552                PL_generation.  Then we scan the RHS, and if any lexicals
16553                already have that value, we know we've got commonality.
16554                Also, if the generation number is already set to
16555                PERL_INT_MAX, then the variable is involved in aliasing, so
16556                we also have potential commonality in that case.
16557              */
16558
16559             PL_generation++;
16560             /* scan LHS */
16561             lscalars = 0;
16562             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16563             /* scan RHS */
16564             rscalars = 0;
16565             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16566             lr = (l|r);
16567
16568
16569             /* After looking for things which are *always* safe, this main
16570              * if/else chain selects primarily based on the type of the
16571              * LHS, gradually working its way down from the more dangerous
16572              * to the more restrictive and thus safer cases */
16573
16574             if (   !l                      /* () = ....; */
16575                 || !r                      /* .... = (); */
16576                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16577                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16578                 || (lscalars < 2)          /* ($x, undef) = ... */
16579             ) {
16580                 NOOP; /* always safe */
16581             }
16582             else if (l & AAS_DANGEROUS) {
16583                 /* always dangerous */
16584                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16585                 o->op_private |= OPpASSIGN_COMMON_AGG;
16586             }
16587             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16588                 /* package vars are always dangerous - too many
16589                  * aliasing possibilities */
16590                 if (l & AAS_PKG_SCALAR)
16591                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16592                 if (l & AAS_PKG_AGG)
16593                     o->op_private |= OPpASSIGN_COMMON_AGG;
16594             }
16595             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16596                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16597             {
16598                 /* LHS contains only lexicals and safe ops */
16599
16600                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16601                     o->op_private |= OPpASSIGN_COMMON_AGG;
16602
16603                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16604                     if (lr & AAS_LEX_SCALAR_COMM)
16605                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16606                     else if (   !(l & AAS_LEX_SCALAR)
16607                              && (r & AAS_DEFAV))
16608                     {
16609                         /* falsely mark
16610                          *    my (...) = @_
16611                          * as scalar-safe for performance reasons.
16612                          * (it will still have been marked _AGG if necessary */
16613                         NOOP;
16614                     }
16615                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16616                         /* if there are only lexicals on the LHS and no
16617                          * common ones on the RHS, then we assume that the
16618                          * only way those lexicals could also get
16619                          * on the RHS is via some sort of dereffing or
16620                          * closure, e.g.
16621                          *    $r = \$lex;
16622                          *    ($lex, $x) = (1, $$r)
16623                          * and in this case we assume the var must have
16624                          *  a bumped ref count. So if its ref count is 1,
16625                          *  it must only be on the LHS.
16626                          */
16627                         o->op_private |= OPpASSIGN_COMMON_RC1;
16628                 }
16629             }
16630
16631             /* ... = ($x)
16632              * may have to handle aggregate on LHS, but we can't
16633              * have common scalars. */
16634             if (rscalars < 2)
16635                 o->op_private &=
16636                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16637
16638             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16639                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16640             break;
16641         }
16642
16643         case OP_REF:
16644             /* see if ref() is used in boolean context */
16645             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16646                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16647             break;
16648
16649         case OP_LENGTH:
16650             /* see if the op is used in known boolean context,
16651              * but not if OA_TARGLEX optimisation is enabled */
16652             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16653                 && !(o->op_private & OPpTARGET_MY)
16654             )
16655                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16656             break;
16657
16658         case OP_POS:
16659             /* see if the op is used in known boolean context */
16660             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16661                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16662             break;
16663
16664         case OP_CUSTOM: {
16665             Perl_cpeep_t cpeep =
16666                 XopENTRYCUSTOM(o, xop_peep);
16667             if (cpeep)
16668                 cpeep(aTHX_ o, oldop);
16669             break;
16670         }
16671
16672         }
16673         /* did we just null the current op? If so, re-process it to handle
16674          * eliding "empty" ops from the chain */
16675         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16676             o->op_opt = 0;
16677             o = oldop;
16678         }
16679         else {
16680             oldoldop = oldop;
16681             oldop = o;
16682         }
16683     }
16684     LEAVE;
16685 }
16686
16687 void
16688 Perl_peep(pTHX_ OP *o)
16689 {
16690     CALL_RPEEP(o);
16691 }
16692
16693 /*
16694 =head1 Custom Operators
16695
16696 =for apidoc custom_op_xop
16697 Return the XOP structure for a given custom op.  This macro should be
16698 considered internal to C<OP_NAME> and the other access macros: use them instead.
16699 This macro does call a function.  Prior
16700 to 5.19.6, this was implemented as a
16701 function.
16702
16703 =cut
16704 */
16705
16706
16707 /* use PERL_MAGIC_ext to call a function to free the xop structure when
16708  * freeing PL_custom_ops */
16709
16710 static int
16711 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
16712 {
16713     XOP *xop;
16714
16715     PERL_UNUSED_ARG(mg);
16716     xop = INT2PTR(XOP *, SvIV(sv));
16717     Safefree(xop->xop_name);
16718     Safefree(xop->xop_desc);
16719     Safefree(xop);
16720     return 0;
16721 }
16722
16723
16724 static const MGVTBL custom_op_register_vtbl = {
16725     0,                          /* get */
16726     0,                          /* set */
16727     0,                          /* len */
16728     0,                          /* clear */
16729     custom_op_register_free,     /* free */
16730     0,                          /* copy */
16731     0,                          /* dup */
16732 #ifdef MGf_LOCAL
16733     0,                          /* local */
16734 #endif
16735 };
16736
16737
16738 XOPRETANY
16739 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16740 {
16741     SV *keysv;
16742     HE *he = NULL;
16743     XOP *xop;
16744
16745     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16746
16747     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16748     assert(o->op_type == OP_CUSTOM);
16749
16750     /* This is wrong. It assumes a function pointer can be cast to IV,
16751      * which isn't guaranteed, but this is what the old custom OP code
16752      * did. In principle it should be safer to Copy the bytes of the
16753      * pointer into a PV: since the new interface is hidden behind
16754      * functions, this can be changed later if necessary.  */
16755     /* Change custom_op_xop if this ever happens */
16756     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16757
16758     if (PL_custom_ops)
16759         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16760
16761     /* See if the op isn't registered, but its name *is* registered.
16762      * That implies someone is using the pre-5.14 API,where only name and
16763      * description could be registered. If so, fake up a real
16764      * registration.
16765      * We only check for an existing name, and assume no one will have
16766      * just registered a desc */
16767     if (!he && PL_custom_op_names &&
16768         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16769     ) {
16770         const char *pv;
16771         STRLEN l;
16772
16773         /* XXX does all this need to be shared mem? */
16774         Newxz(xop, 1, XOP);
16775         pv = SvPV(HeVAL(he), l);
16776         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16777         if (PL_custom_op_descs &&
16778             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16779         ) {
16780             pv = SvPV(HeVAL(he), l);
16781             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16782         }
16783         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16784         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16785         /* add magic to the SV so that the xop struct (pointed to by
16786          * SvIV(sv)) is freed. Normally a static xop is registered, but
16787          * for this backcompat hack, we've alloced one */
16788         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
16789                 &custom_op_register_vtbl, NULL, 0);
16790
16791     }
16792     else {
16793         if (!he)
16794             xop = (XOP *)&xop_null;
16795         else
16796             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16797     }
16798     {
16799         XOPRETANY any;
16800         if(field == XOPe_xop_ptr) {
16801             any.xop_ptr = xop;
16802         } else {
16803             const U32 flags = XopFLAGS(xop);
16804             if(flags & field) {
16805                 switch(field) {
16806                 case XOPe_xop_name:
16807                     any.xop_name = xop->xop_name;
16808                     break;
16809                 case XOPe_xop_desc:
16810                     any.xop_desc = xop->xop_desc;
16811                     break;
16812                 case XOPe_xop_class:
16813                     any.xop_class = xop->xop_class;
16814                     break;
16815                 case XOPe_xop_peep:
16816                     any.xop_peep = xop->xop_peep;
16817                     break;
16818                 default:
16819                     NOT_REACHED; /* NOTREACHED */
16820                     break;
16821                 }
16822             } else {
16823                 switch(field) {
16824                 case XOPe_xop_name:
16825                     any.xop_name = XOPd_xop_name;
16826                     break;
16827                 case XOPe_xop_desc:
16828                     any.xop_desc = XOPd_xop_desc;
16829                     break;
16830                 case XOPe_xop_class:
16831                     any.xop_class = XOPd_xop_class;
16832                     break;
16833                 case XOPe_xop_peep:
16834                     any.xop_peep = XOPd_xop_peep;
16835                     break;
16836                 default:
16837                     NOT_REACHED; /* NOTREACHED */
16838                     break;
16839                 }
16840             }
16841         }
16842         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16843          * op.c: In function 'Perl_custom_op_get_field':
16844          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16845          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16846          * expands to assert(0), which expands to ((0) ? (void)0 :
16847          * __assert(...)), and gcc doesn't know that __assert can never return. */
16848         return any;
16849     }
16850 }
16851
16852 /*
16853 =for apidoc custom_op_register
16854 Register a custom op.  See L<perlguts/"Custom Operators">.
16855
16856 =cut
16857 */
16858
16859 void
16860 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16861 {
16862     SV *keysv;
16863
16864     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16865
16866     /* see the comment in custom_op_xop */
16867     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16868
16869     if (!PL_custom_ops)
16870         PL_custom_ops = newHV();
16871
16872     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16873         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16874 }
16875
16876 /*
16877
16878 =for apidoc core_prototype
16879
16880 This function assigns the prototype of the named core function to C<sv>, or
16881 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16882 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16883 by C<keyword()>.  It must not be equal to 0.
16884
16885 =cut
16886 */
16887
16888 SV *
16889 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16890                           int * const opnum)
16891 {
16892     int i = 0, n = 0, seen_question = 0, defgv = 0;
16893     I32 oa;
16894 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16895     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16896     bool nullret = FALSE;
16897
16898     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16899
16900     assert (code);
16901
16902     if (!sv) sv = sv_newmortal();
16903
16904 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16905
16906     switch (code < 0 ? -code : code) {
16907     case KEY_and   : case KEY_chop: case KEY_chomp:
16908     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16909     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16910     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16911     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16912     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16913     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16914     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16915     case KEY_x     : case KEY_xor    :
16916         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16917     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16918     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16919     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16920     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16921     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16922     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16923         retsetpvs("", 0);
16924     case KEY_evalbytes:
16925         name = "entereval"; break;
16926     case KEY_readpipe:
16927         name = "backtick";
16928     }
16929
16930 #undef retsetpvs
16931
16932   findopnum:
16933     while (i < MAXO) {  /* The slow way. */
16934         if (strEQ(name, PL_op_name[i])
16935             || strEQ(name, PL_op_desc[i]))
16936         {
16937             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16938             goto found;
16939         }
16940         i++;
16941     }
16942     return NULL;
16943   found:
16944     defgv = PL_opargs[i] & OA_DEFGV;
16945     oa = PL_opargs[i] >> OASHIFT;
16946     while (oa) {
16947         if (oa & OA_OPTIONAL && !seen_question && (
16948               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16949         )) {
16950             seen_question = 1;
16951             str[n++] = ';';
16952         }
16953         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16954             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16955             /* But globs are already references (kinda) */
16956             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16957         ) {
16958             str[n++] = '\\';
16959         }
16960         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16961          && !scalar_mod_type(NULL, i)) {
16962             str[n++] = '[';
16963             str[n++] = '$';
16964             str[n++] = '@';
16965             str[n++] = '%';
16966             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16967             str[n++] = '*';
16968             str[n++] = ']';
16969         }
16970         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16971         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16972             str[n-1] = '_'; defgv = 0;
16973         }
16974         oa = oa >> 4;
16975     }
16976     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16977     str[n++] = '\0';
16978     sv_setpvn(sv, str, n - 1);
16979     if (opnum) *opnum = i;
16980     return sv;
16981 }
16982
16983 OP *
16984 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16985                       const int opnum)
16986 {
16987     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
16988                                         newSVOP(OP_COREARGS,0,coreargssv);
16989     OP *o;
16990
16991     PERL_ARGS_ASSERT_CORESUB_OP;
16992
16993     switch(opnum) {
16994     case 0:
16995         return op_append_elem(OP_LINESEQ,
16996                        argop,
16997                        newSLICEOP(0,
16998                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16999                                   newOP(OP_CALLER,0)
17000                        )
17001                );
17002     case OP_EACH:
17003     case OP_KEYS:
17004     case OP_VALUES:
17005         o = newUNOP(OP_AVHVSWITCH,0,argop);
17006         o->op_private = opnum-OP_EACH;
17007         return o;
17008     case OP_SELECT: /* which represents OP_SSELECT as well */
17009         if (code)
17010             return newCONDOP(
17011                          0,
17012                          newBINOP(OP_GT, 0,
17013                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
17014                                   newSVOP(OP_CONST, 0, newSVuv(1))
17015                                  ),
17016                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
17017                                     OP_SSELECT),
17018                          coresub_op(coreargssv, 0, OP_SELECT)
17019                    );
17020         /* FALLTHROUGH */
17021     default:
17022         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
17023         case OA_BASEOP:
17024             return op_append_elem(
17025                         OP_LINESEQ, argop,
17026                         newOP(opnum,
17027                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
17028                                 ? OPpOFFBYONE << 8 : 0)
17029                    );
17030         case OA_BASEOP_OR_UNOP:
17031             if (opnum == OP_ENTEREVAL) {
17032                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
17033                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
17034             }
17035             else o = newUNOP(opnum,0,argop);
17036             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
17037             else {
17038           onearg:
17039               if (is_handle_constructor(o, 1))
17040                 argop->op_private |= OPpCOREARGS_DEREF1;
17041               if (scalar_mod_type(NULL, opnum))
17042                 argop->op_private |= OPpCOREARGS_SCALARMOD;
17043             }
17044             return o;
17045         default:
17046             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17047             if (is_handle_constructor(o, 2))
17048                 argop->op_private |= OPpCOREARGS_DEREF2;
17049             if (opnum == OP_SUBSTR) {
17050                 o->op_private |= OPpMAYBE_LVSUB;
17051                 return o;
17052             }
17053             else goto onearg;
17054         }
17055     }
17056 }
17057
17058 void
17059 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17060                                SV * const *new_const_svp)
17061 {
17062     const char *hvname;
17063     bool is_const = !!CvCONST(old_cv);
17064     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17065
17066     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17067
17068     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17069         return;
17070         /* They are 2 constant subroutines generated from
17071            the same constant. This probably means that
17072            they are really the "same" proxy subroutine
17073            instantiated in 2 places. Most likely this is
17074            when a constant is exported twice.  Don't warn.
17075         */
17076     if (
17077         (ckWARN(WARN_REDEFINE)
17078          && !(
17079                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17080              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17081              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17082                  strEQ(hvname, "autouse"))
17083              )
17084         )
17085      || (is_const
17086          && ckWARN_d(WARN_REDEFINE)
17087          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17088         )
17089     )
17090         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17091                           is_const
17092                             ? "Constant subroutine %" SVf " redefined"
17093                             : "Subroutine %" SVf " redefined",
17094                           SVfARG(name));
17095 }
17096
17097 /*
17098 =head1 Hook manipulation
17099
17100 These functions provide convenient and thread-safe means of manipulating
17101 hook variables.
17102
17103 =cut
17104 */
17105
17106 /*
17107 =for apidoc wrap_op_checker
17108
17109 Puts a C function into the chain of check functions for a specified op
17110 type.  This is the preferred way to manipulate the L</PL_check> array.
17111 C<opcode> specifies which type of op is to be affected.  C<new_checker>
17112 is a pointer to the C function that is to be added to that opcode's
17113 check chain, and C<old_checker_p> points to the storage location where a
17114 pointer to the next function in the chain will be stored.  The value of
17115 C<new_checker> is written into the L</PL_check> array, while the value
17116 previously stored there is written to C<*old_checker_p>.
17117
17118 L</PL_check> is global to an entire process, and a module wishing to
17119 hook op checking may find itself invoked more than once per process,
17120 typically in different threads.  To handle that situation, this function
17121 is idempotent.  The location C<*old_checker_p> must initially (once
17122 per process) contain a null pointer.  A C variable of static duration
17123 (declared at file scope, typically also marked C<static> to give
17124 it internal linkage) will be implicitly initialised appropriately,
17125 if it does not have an explicit initialiser.  This function will only
17126 actually modify the check chain if it finds C<*old_checker_p> to be null.
17127 This function is also thread safe on the small scale.  It uses appropriate
17128 locking to avoid race conditions in accessing L</PL_check>.
17129
17130 When this function is called, the function referenced by C<new_checker>
17131 must be ready to be called, except for C<*old_checker_p> being unfilled.
17132 In a threading situation, C<new_checker> may be called immediately,
17133 even before this function has returned.  C<*old_checker_p> will always
17134 be appropriately set before C<new_checker> is called.  If C<new_checker>
17135 decides not to do anything special with an op that it is given (which
17136 is the usual case for most uses of op check hooking), it must chain the
17137 check function referenced by C<*old_checker_p>.
17138
17139 Taken all together, XS code to hook an op checker should typically look
17140 something like this:
17141
17142     static Perl_check_t nxck_frob;
17143     static OP *myck_frob(pTHX_ OP *op) {
17144         ...
17145         op = nxck_frob(aTHX_ op);
17146         ...
17147         return op;
17148     }
17149     BOOT:
17150         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17151
17152 If you want to influence compilation of calls to a specific subroutine,
17153 then use L</cv_set_call_checker_flags> rather than hooking checking of
17154 all C<entersub> ops.
17155
17156 =cut
17157 */
17158
17159 void
17160 Perl_wrap_op_checker(pTHX_ Optype opcode,
17161     Perl_check_t new_checker, Perl_check_t *old_checker_p)
17162 {
17163     dVAR;
17164
17165     PERL_UNUSED_CONTEXT;
17166     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17167     if (*old_checker_p) return;
17168     OP_CHECK_MUTEX_LOCK;
17169     if (!*old_checker_p) {
17170         *old_checker_p = PL_check[opcode];
17171         PL_check[opcode] = new_checker;
17172     }
17173     OP_CHECK_MUTEX_UNLOCK;
17174 }
17175
17176 #include "XSUB.h"
17177
17178 /* Efficient sub that returns a constant scalar value. */
17179 static void
17180 const_sv_xsub(pTHX_ CV* cv)
17181 {
17182     dXSARGS;
17183     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17184     PERL_UNUSED_ARG(items);
17185     if (!sv) {
17186         XSRETURN(0);
17187     }
17188     EXTEND(sp, 1);
17189     ST(0) = sv;
17190     XSRETURN(1);
17191 }
17192
17193 static void
17194 const_av_xsub(pTHX_ CV* cv)
17195 {
17196     dXSARGS;
17197     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17198     SP -= items;
17199     assert(av);
17200 #ifndef DEBUGGING
17201     if (!av) {
17202         XSRETURN(0);
17203     }
17204 #endif
17205     if (SvRMAGICAL(av))
17206         Perl_croak(aTHX_ "Magical list constants are not supported");
17207     if (GIMME_V != G_ARRAY) {
17208         EXTEND(SP, 1);
17209         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17210         XSRETURN(1);
17211     }
17212     EXTEND(SP, AvFILLp(av)+1);
17213     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17214     XSRETURN(AvFILLp(av)+1);
17215 }
17216
17217 /* Copy an existing cop->cop_warnings field.
17218  * If it's one of the standard addresses, just re-use the address.
17219  * This is the e implementation for the DUP_WARNINGS() macro
17220  */
17221
17222 STRLEN*
17223 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17224 {
17225     Size_t size;
17226     STRLEN *new_warnings;
17227
17228     if (warnings == NULL || specialWARN(warnings))
17229         return warnings;
17230
17231     size = sizeof(*warnings) + *warnings;
17232
17233     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17234     Copy(warnings, new_warnings, size, char);
17235     return new_warnings;
17236 }
17237
17238 /*
17239  * ex: set ts=8 sts=4 sw=4 et:
17240  */