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 #include "invlist_inline.h"
 168
 169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 172
 173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 174
 175 /* remove any leading "empty" ops from the op_next chain whose first
 176  * node's address is stored in op_p. Store the updated address of the
 177  * first node in op_p.
 178  */
 179
 180 STATIC void
 181 S_prune_chain_head(OP** op_p)
 182 {
 183     while (*op_p
 184         && (   (*op_p)->op_type == OP_NULL
 185             || (*op_p)->op_type == OP_SCOPE
 186             || (*op_p)->op_type == OP_SCALAR
 187             || (*op_p)->op_type == OP_LINESEQ)
 188     )
 189         *op_p = (*op_p)->op_next;
 190 }
 191
 192
 193 /* See the explanatory comments above struct opslab in op.h. */
 194
 195 #ifdef PERL_DEBUG_READONLY_OPS
 196 #  define PERL_SLAB_SIZE 128
 197 #  define PERL_MAX_SLAB_SIZE 4096
 198 #  include <sys/mman.h>
 199 #endif
 200
 201 #ifndef PERL_SLAB_SIZE
 202 #  define PERL_SLAB_SIZE 64
 203 #endif
 204 #ifndef PERL_MAX_SLAB_SIZE
 205 #  define PERL_MAX_SLAB_SIZE 2048
 206 #endif
 207
 208 /* rounds up to nearest pointer */
 209 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 210 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 211
 212 /* requires double parens and aTHX_ */
 213 #define DEBUG_S_warn(args)                                             \
 214     DEBUG_S(                                                            \
 215         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 216     )
 217
 218
 219 /* malloc a new op slab (suitable for attaching to PL_compcv).
 220  * sz is in units of pointers */
 221
 222 static OPSLAB *
 223 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
 224 {
 225     OPSLAB *slab;
 226
 227     /* opslot_offset is only U16 */
 228     assert(sz  < U16_MAX);
 229
 230 #ifdef PERL_DEBUG_READONLY_OPS
 231     slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 232                                    PROT_READ|PROT_WRITE,
 233                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 234     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 235                           (unsigned long) sz, slab));
 236     if (slab == MAP_FAILED) {
 237         perror("mmap failed");
 238         abort();
 239     }
 240 #else
 241     slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 242 #endif
 243     slab->opslab_size = (U16)sz;
 244
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
 250     slab->opslab_head = head ? head : slab;
 251     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
 252         (unsigned int)slab->opslab_size, (void*)slab,
 253         (void*)(slab->opslab_head)));
 254     return slab;
 255 }
 256
 257 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
 258 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 259 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
 260
 261 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
 262 static void
 263 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
 264     U16 sz = OpSLOT(o)->opslot_size;
 265     U16 index = OPSLOT_SIZE_TO_INDEX(sz);
 266
 267     assert(sz >= OPSLOT_SIZE_BASE);
 268     /* make sure the array is large enough to include ops this large */
 269     if (!slab->opslab_freed) {
 270         /* we don't have a free list array yet, make a new one */
 271         slab->opslab_freed_size = index+1;
 272         slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
 273
 274         if (!slab->opslab_freed)
 275             croak_no_mem();
 276     }
 277     else if (index >= slab->opslab_freed_size) {
 278         /* It's probably not worth doing exponential expansion here, the number of op sizes
 279            is small.
 280         */
 281         /* We already have a list that isn't large enough, expand it */
 282         size_t newsize = index+1;
 283         OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
 284
 285         if (!p)
 286             croak_no_mem();
 287
 288         Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
 289
 290         slab->opslab_freed = p;
 291         slab->opslab_freed_size = newsize;
 292     }
 293
 294     o->op_next = slab->opslab_freed[index];
 295     slab->opslab_freed[index] = o;
 296 }
 297
 298 /* Returns a sz-sized block of memory (suitable for holding an op) from
 299  * a free slot in the chain of op slabs attached to PL_compcv.
 300  * Allocates a new slab if necessary.
 301  * if PL_compcv isn't compiling, malloc() instead.
 302  */
 303
 304 void *
 305 Perl_Slab_Alloc(pTHX_ size_t sz)
 306 {
 307     OPSLAB *head_slab; /* first slab in the chain */
 308     OPSLAB *slab2;
 309     OPSLOT *slot;
 310     OP *o;
 311     size_t opsz;
 312
 313     /* We only allocate ops from the slab during subroutine compilation.
 314        We find the slab via PL_compcv, hence that must be non-NULL. It could
 315        also be pointing to a subroutine which is now fully set up (CvROOT()
 316        pointing to the top of the optree for that sub), or a subroutine
 317        which isn't using the slab allocator. If our sanity checks aren't met,
 318        don't use a slab, but allocate the OP directly from the heap.  */
 319     if (!PL_compcv || CvROOT(PL_compcv)
 320      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 321     {
 322         o = (OP*)PerlMemShared_calloc(1, sz);
 323         goto gotit;
 324     }
 325
 326     /* While the subroutine is under construction, the slabs are accessed via
 327        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 328        unneeded at runtime. Once a subroutine is constructed, the slabs are
 329        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 330        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 331        details.  */
 332     if (!CvSTART(PL_compcv)) {
 333         CvSTART(PL_compcv) =
 334             (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
 335         CvSLABBED_on(PL_compcv);
 336         head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 337     }
 338     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 339
 340     opsz = SIZE_TO_PSIZE(sz);
 341     sz = opsz + OPSLOT_HEADER_P;
 342
 343     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
 344        will free up OPs, so it makes sense to re-use them where possible. A
 345        freed up slot is used in preference to a new allocation.  */
 346     if (head_slab->opslab_freed &&
 347         OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) {
 348         U16 base_index;
 349
 350         /* look for a large enough size with any freed ops */
 351         for (base_index = OPSLOT_SIZE_TO_INDEX(sz);
 352              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
 353              ++base_index) {
 354         }
 355
 356         if (base_index < head_slab->opslab_freed_size) {
 357             /* found a freed op */
 358             o = head_slab->opslab_freed[base_index];
 359
 360             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
 361                 (void*)o,
 362                 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
 363                 (void*)head_slab));
 364             head_slab->opslab_freed[base_index] = o->op_next;
 365             Zero(o, opsz, I32 *);
 366             o->op_slabbed = 1;
 367             goto gotit;
 368         }
 369     }
 370
 371 #define INIT_OPSLOT(s) \
 372             slot->opslot_offset = DIFF(slab2, slot) ;   \
 373             slot->opslot_size = s;                      \
 374             slab2->opslab_free_space -= s;              \
 375             o = &slot->opslot_op;                       \
 376             o->op_slabbed = 1
 377
 378     /* The partially-filled slab is next in the chain. */
 379     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
 380     if (slab2->opslab_free_space  < sz) {
 381         /* Remaining space is too small. */
 382         /* If we can fit a BASEOP, add it to the free chain, so as not
 383            to waste it. */
 384         if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 385             slot = &slab2->opslab_slots;
 386             INIT_OPSLOT(slab2->opslab_free_space);
 387             o->op_type = OP_FREED;
 388             link_freed_op(head_slab, o);
 389         }
 390
 391         /* Create a new slab.  Make this one twice as big. */
 392         slab2 = S_new_slab(aTHX_ head_slab,
 393                             slab2->opslab_size  > PERL_MAX_SLAB_SIZE / 2
 394                                 ? PERL_MAX_SLAB_SIZE
 395                                 : slab2->opslab_size * 2);
 396         slab2->opslab_next = head_slab->opslab_next;
 397         head_slab->opslab_next = slab2;
 398     }
 399     assert(slab2->opslab_size >= sz);
 400
 401     /* Create a new op slot */
 402     slot = (OPSLOT *)
 403                 ((I32 **)&slab2->opslab_slots
 404                                 + slab2->opslab_free_space - sz);
 405     assert(slot >= &slab2->opslab_slots);
 406     INIT_OPSLOT(sz);
 407     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
 408         (void*)o, (void*)slab2, (void*)head_slab));
 409
 410   gotit:
 411     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 412     assert(!o->op_moresib);
 413     assert(!o->op_sibparent);
 414
 415     return (void *)o;
 416 }
 417
 418 #undef INIT_OPSLOT
 419
 420 #ifdef PERL_DEBUG_READONLY_OPS
 421 void
 422 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 423 {
 424     PERL_ARGS_ASSERT_SLAB_TO_RO;
 425
 426     if (slab->opslab_readonly) return;
 427     slab->opslab_readonly = 1;
 428     for (; slab; slab = slab->opslab_next) {
 429         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 430                               (unsigned long) slab->opslab_size, slab));*/
 431         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 432             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 433                              (unsigned long)slab->opslab_size, errno);
 434     }
 435 }
 436
 437 void
 438 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 439 {
 440     OPSLAB *slab2;
 441
 442     PERL_ARGS_ASSERT_SLAB_TO_RW;
 443
 444     if (!slab->opslab_readonly) return;
 445     slab2 = slab;
 446     for (; slab2; slab2 = slab2->opslab_next) {
 447         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 448                               (unsigned long) size, slab2));*/
 449         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 450                      PROT_READ|PROT_WRITE)) {
 451             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 452                              (unsigned long)slab2->opslab_size, errno);
 453         }
 454     }
 455     slab->opslab_readonly = 0;
 456 }
 457
 458 #else
 459 #  define Slab_to_rw(op)    NOOP
 460 #endif
 461
 462 /* This cannot possibly be right, but it was copied from the old slab
 463    allocator, to which it was originally added, without explanation, in
 464    commit 083fcd5. */
 465 #ifdef NETWARE
 466 #    define PerlMemShared PerlMem
 467 #endif
 468
 469 /* make freed ops die if they're inadvertently executed */
 470 #ifdef DEBUGGING
 471 static OP *
 472 S_pp_freed(pTHX)
 473 {
 474     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 475 }
 476 #endif
 477
 478
 479 /* Return the block of memory used by an op to the free list of
 480  * the OP slab associated with that op.
 481  */
 482
 483 void
 484 Perl_Slab_Free(pTHX_ void *op)
 485 {
 486     OP * const o = (OP *)op;
 487     OPSLAB *slab;
 488
 489     PERL_ARGS_ASSERT_SLAB_FREE;
 490
 491 #ifdef DEBUGGING
 492     o->op_ppaddr = S_pp_freed;
 493 #endif
 494
 495     if (!o->op_slabbed) {
 496         if (!o->op_static)
 497             PerlMemShared_free(op);
 498         return;
 499     }
 500
 501     slab = OpSLAB(o);
 502     /* If this op is already freed, our refcount will get screwy. */
 503     assert(o->op_type != OP_FREED);
 504     o->op_type = OP_FREED;
 505     link_freed_op(slab, o);
 506     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
 507         (void*)o,
 508         (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
 509         (void*)slab));
 510     OpslabREFCNT_dec_padok(slab);
 511 }
 512
 513 void
 514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 515 {
 516     const bool havepad = !!PL_comppad;
 517     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 518     if (havepad) {
 519         ENTER;
 520         PAD_SAVE_SETNULLPAD();
 521     }
 522     opslab_free(slab);
 523     if (havepad) LEAVE;
 524 }
 525
 526 /* Free a chain of OP slabs. Should only be called after all ops contained
 527  * in it have been freed. At this point, its reference count should be 1,
 528  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
 529  * and just directly calls opslab_free().
 530  * (Note that the reference count which PL_compcv held on the slab should
 531  * have been removed once compilation of the sub was complete).
 532  *
 533  *
 534  */
 535
 536 void
 537 Perl_opslab_free(pTHX_ OPSLAB *slab)
 538 {
 539     OPSLAB *slab2;
 540     PERL_ARGS_ASSERT_OPSLAB_FREE;
 541     PERL_UNUSED_CONTEXT;
 542     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 543     assert(slab->opslab_refcnt == 1);
 544     PerlMemShared_free(slab->opslab_freed);
 545     do {
 546         slab2 = slab->opslab_next;
 547 #ifdef DEBUGGING
 548         slab->opslab_refcnt = ~(size_t)0;
 549 #endif
 550 #ifdef PERL_DEBUG_READONLY_OPS
 551         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 552                                                (void*)slab));
 553         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 554             perror("munmap failed");
 555             abort();
 556         }
 557 #else
 558         PerlMemShared_free(slab);
 559 #endif
 560         slab = slab2;
 561     } while (slab);
 562 }
 563
 564 /* like opslab_free(), but first calls op_free() on any ops in the slab
 565  * not marked as OP_FREED
 566  */
 567
 568 void
 569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 570 {
 571     OPSLAB *slab2;
 572 #ifdef DEBUGGING
 573     size_t savestack_count = 0;
 574 #endif
 575     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 576     slab2 = slab;
 577     do {
 578         OPSLOT *slot = (OPSLOT*)
 579                     ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
 580         OPSLOT *end  = (OPSLOT*)
 581                         ((I32**)slab2 + slab2->opslab_size);
 582         for (; slot < end;
 583                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
 584         {
 585             if (slot->opslot_op.op_type != OP_FREED
 586              && !(slot->opslot_op.op_savefree
 587 #ifdef DEBUGGING
 588                   && ++savestack_count
 589 #endif
 590                  )
 591             ) {
 592                 assert(slot->opslot_op.op_slabbed);
 593                 op_free(&slot->opslot_op);
 594                 if (slab->opslab_refcnt == 1) goto free;
 595             }
 596         }
 597     } while ((slab2 = slab2->opslab_next));
 598     /* > 1 because the CV still holds a reference count. */
 599     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 600 #ifdef DEBUGGING
 601         assert(savestack_count == slab->opslab_refcnt-1);
 602 #endif
 603         /* Remove the CV’s reference count. */
 604         slab->opslab_refcnt--;
 605         return;
 606     }
 607    free:
 608     opslab_free(slab);
 609 }
 610
 611 #ifdef PERL_DEBUG_READONLY_OPS
 612 OP *
 613 Perl_op_refcnt_inc(pTHX_ OP *o)
 614 {
 615     if(o) {
 616         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 617         if (slab && slab->opslab_readonly) {
 618             Slab_to_rw(slab);
 619             ++o->op_targ;
 620             Slab_to_ro(slab);
 621         } else {
 622             ++o->op_targ;
 623         }
 624     }
 625     return o;
 626
 627 }
 628
 629 PADOFFSET
 630 Perl_op_refcnt_dec(pTHX_ OP *o)
 631 {
 632     PADOFFSET result;
 633     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 634
 635     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 636
 637     if (slab && slab->opslab_readonly) {
 638         Slab_to_rw(slab);
 639         result = --o->op_targ;
 640         Slab_to_ro(slab);
 641     } else {
 642         result = --o->op_targ;
 643     }
 644     return result;
 645 }
 646 #endif
 647 /*
 648  * In the following definition, the ", (OP*)0" is just to make the compiler
 649  * think the expression is of the right type: croak actually does a Siglongjmp.
 650  */
 651 #define CHECKOP(type,o) \
 652     ((PL_op_mask && PL_op_mask[type])                           \
 653      ? ( op_free((OP*)o),                                       \
 654          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 655          (OP*)0 )                                               \
 656      : PL_check[type](aTHX_ (OP*)o))
 657
 658 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 659
 660 #define OpTYPE_set(o,type) \
 661     STMT_START {                                \
 662         o->op_type = (OPCODE)type;              \
 663         o->op_ppaddr = PL_ppaddr[type];         \
 664     } STMT_END
 665
 666 STATIC OP *
 667 S_no_fh_allowed(pTHX_ OP *o)
 668 {
 669     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 670
 671     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 672                  OP_DESC(o)));
 673     return o;
 674 }
 675
 676 STATIC OP *
 677 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 678 {
 679     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 680     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 681     return o;
 682 }
 683
 684 STATIC OP *
 685 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 686 {
 687     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 688
 689     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 690     return o;
 691 }
 692
 693 STATIC void
 694 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 695 {
 696     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 697
 698     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 699                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 700 }
 701
 702 /* remove flags var, its unused in all callers, move to to right end since gv
 703   and kid are always the same */
 704 STATIC void
 705 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 706 {
 707     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 708     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 709
 710     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 711                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 712 }
 713
 714 STATIC void
 715 S_no_bareword_allowed(pTHX_ OP *o)
 716 {
 717     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 718
 719     qerror(Perl_mess(aTHX_
 720                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 721                      SVfARG(cSVOPo_sv)));
 722     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 723 }
 724
 725 /* "register" allocation */
 726
 727 PADOFFSET
 728 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 729 {
 730     PADOFFSET off;
 731     const bool is_our = (PL_parser->in_my == KEY_our);
 732
 733     PERL_ARGS_ASSERT_ALLOCMY;
 734
 735     if (flags & ~SVf_UTF8)
 736         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 737                    (UV)flags);
 738
 739     /* complain about "my $<special_var>" etc etc */
 740     if (   len
 741         && !(  is_our
 742             || isALPHA(name[1])
 743             || (   (flags & SVf_UTF8)
 744                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 745             || (name[1] == '_' && len > 2)))
 746     {
 747         const char * const type =
 748               PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
 749               PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";
 750
 751         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 752          && isASCII(name[1])
 753          && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
 754             /* diag_listed_as: Can't use global %s in %s */
 755             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
 756                               name[0], toCTRL(name[1]),
 757                               (int)(len - 2), name + 2,
 758                               type));
 759         } else {
 760             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
 761                               (int) len, name,
 762                               type), flags & SVf_UTF8);
 763         }
 764     }
 765
 766     /* allocate a spare slot and store the name in that slot */
 767
 768     off = pad_add_name_pvn(name, len,
 769                        (is_our ? padadd_OUR :
 770                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 771                     PL_parser->in_my_stash,
 772                     (is_our
 773                         /* $_ is always in main::, even with our */
 774                         ? (PL_curstash && !memEQs(name,len,"$_")
 775                             ? PL_curstash
 776                             : PL_defstash)
 777                         : NULL
 778                     )
 779     );
 780     /* anon sub prototypes contains state vars should always be cloned,
 781      * otherwise the state var would be shared between anon subs */
 782
 783     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 784         CvCLONE_on(PL_compcv);
 785
 786     return off;
 787 }
 788
 789 /*
 790 =head1 Optree Manipulation Functions
 791
 792 =for apidoc alloccopstash
 793
 794 Available only under threaded builds, this function allocates an entry in
 795 C<PL_stashpad> for the stash passed to it.
 796
 797 =cut
 798 */
 799
 800 #ifdef USE_ITHREADS
 801 PADOFFSET
 802 Perl_alloccopstash(pTHX_ HV *hv)
 803 {
 804     PADOFFSET off = 0, o = 1;
 805     bool found_slot = FALSE;
 806
 807     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 808
 809     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 810
 811     for (; o < PL_stashpadmax; ++o) {
 812         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 813         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 814             found_slot = TRUE, off = o;
 815     }
 816     if (!found_slot) {
 817         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 818         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 819         off = PL_stashpadmax;
 820         PL_stashpadmax += 10;
 821     }
 822
 823     PL_stashpad[PL_stashpadix = off] = hv;
 824     return off;
 825 }
 826 #endif
 827
 828 /* free the body of an op without examining its contents.
 829  * Always use this rather than FreeOp directly */
 830
 831 static void
 832 S_op_destroy(pTHX_ OP *o)
 833 {
 834     FreeOp(o);
 835 }
 836
 837 /* Destructor */
 838
 839 /*
 840 =for apidoc op_free
 841
 842 Free an op and its children. Only use this when an op is no longer linked
 843 to from any optree.
 844
 845 =cut
 846 */
 847
 848 void
 849 Perl_op_free(pTHX_ OP *o)
 850 {
 851     dVAR;
 852     OPCODE type;
 853     OP *top_op = o;
 854     OP *next_op = o;
 855     bool went_up = FALSE; /* whether we reached the current node by
 856                             following the parent pointer from a child, and
 857                             so have already seen this node */
 858
 859     if (!o || o->op_type == OP_FREED)
 860         return;
 861
 862     if (o->op_private & OPpREFCOUNTED) {
 863         /* if base of tree is refcounted, just decrement */
 864         switch (o->op_type) {
 865         case OP_LEAVESUB:
 866         case OP_LEAVESUBLV:
 867         case OP_LEAVEEVAL:
 868         case OP_LEAVE:
 869         case OP_SCOPE:
 870         case OP_LEAVEWRITE:
 871             {
 872                 PADOFFSET refcnt;
 873                 OP_REFCNT_LOCK;
 874                 refcnt = OpREFCNT_dec(o);
 875                 OP_REFCNT_UNLOCK;
 876                 if (refcnt) {
 877                     /* Need to find and remove any pattern match ops from
 878                      * the list we maintain for reset().  */
 879                     find_and_forget_pmops(o);
 880                     return;
 881                 }
 882             }
 883             break;
 884         default:
 885             break;
 886         }
 887     }
 888
 889     while (next_op) {
 890         o = next_op;
 891
 892         /* free child ops before ourself, (then free ourself "on the
 893          * way back up") */
 894
 895         if (!went_up && o->op_flags & OPf_KIDS) {
 896             next_op = cUNOPo->op_first;
 897             continue;
 898         }
 899
 900         /* find the next node to visit, *then* free the current node
 901          * (can't rely on o->op_* fields being valid after o has been
 902          * freed) */
 903
 904         /* The next node to visit will be either the sibling, or the
 905          * parent if no siblings left, or NULL if we've worked our way
 906          * back up to the top node in the tree */
 907         next_op = (o == top_op) ? NULL : o->op_sibparent;
 908         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
 909
 910         /* Now process the current node */
 911
 912         /* Though ops may be freed twice, freeing the op after its slab is a
 913            big no-no. */
 914         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 915         /* During the forced freeing of ops after compilation failure, kidops
 916            may be freed before their parents. */
 917         if (!o || o->op_type == OP_FREED)
 918             continue;
 919
 920         type = o->op_type;
 921
 922         /* an op should only ever acquire op_private flags that we know about.
 923          * If this fails, you may need to fix something in regen/op_private.
 924          * Don't bother testing if:
 925          *   * the op_ppaddr doesn't match the op; someone may have
 926          *     overridden the op and be doing strange things with it;
 927          *   * we've errored, as op flags are often left in an
 928          *     inconsistent state then. Note that an error when
 929          *     compiling the main program leaves PL_parser NULL, so
 930          *     we can't spot faults in the main code, only
 931          *     evaled/required code */
 932 #ifdef DEBUGGING
 933         if (   o->op_ppaddr == PL_ppaddr[type]
 934             && PL_parser
 935             && !PL_parser->error_count)
 936         {
 937             assert(!(o->op_private & ~PL_op_private_valid[type]));
 938         }
 939 #endif
 940
 941
 942         /* Call the op_free hook if it has been set. Do it now so that it's called
 943          * at the right time for refcounted ops, but still before all of the kids
 944          * are freed. */
 945         CALL_OPFREEHOOK(o);
 946
 947         if (type == OP_NULL)
 948             type = (OPCODE)o->op_targ;
 949
 950         if (o->op_slabbed)
 951             Slab_to_rw(OpSLAB(o));
 952
 953         /* COP* is not cleared by op_clear() so that we may track line
 954          * numbers etc even after null() */
 955         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 956             cop_free((COP*)o);
 957         }
 958
 959         op_clear(o);
 960         FreeOp(o);
 961         if (PL_op == o)
 962             PL_op = NULL;
 963     }
 964 }
 965
 966
 967 /* S_op_clear_gv(): free a GV attached to an OP */
 968
 969 STATIC
 970 #ifdef USE_ITHREADS
 971 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 972 #else
 973 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 974 #endif
 975 {
 976
 977     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 978             || o->op_type == OP_MULTIDEREF)
 979 #ifdef USE_ITHREADS
 980                 && PL_curpad
 981                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 982 #else
 983                 ? (GV*)(*svp) : NULL;
 984 #endif
 985     /* It's possible during global destruction that the GV is freed
 986        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 987        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 988        will trigger an assertion failure, because the entry to sv_clear
 989        checks that the scalar is not already freed.  A check of for
 990        !SvIS_FREED(gv) turns out to be invalid, because during global
 991        destruction the reference count can be forced down to zero
 992        (with SVf_BREAK set).  In which case raising to 1 and then
 993        dropping to 0 triggers cleanup before it should happen.  I
 994        *think* that this might actually be a general, systematic,
 995        weakness of the whole idea of SVf_BREAK, in that code *is*
 996        allowed to raise and lower references during global destruction,
 997        so any *valid* code that happens to do this during global
 998        destruction might well trigger premature cleanup.  */
 999     bool still_valid = gv && SvREFCNT(gv);
1000
1001     if (still_valid)
1002         SvREFCNT_inc_simple_void(gv);
1003 #ifdef USE_ITHREADS
1004     if (*ixp > 0) {
1005         pad_swipe(*ixp, TRUE);
1006         *ixp = 0;
1007     }
1008 #else
1009     SvREFCNT_dec(*svp);
1010     *svp = NULL;
1011 #endif
1012     if (still_valid) {
1013         int try_downgrade = SvREFCNT(gv) == 2;
1014         SvREFCNT_dec_NN(gv);
1015         if (try_downgrade)
1016             gv_try_downgrade(gv);
1017     }
1018 }
1019
1020
1021 void
1022 Perl_op_clear(pTHX_ OP *o)
1023 {
1024
1025     dVAR;
1026
1027     PERL_ARGS_ASSERT_OP_CLEAR;
1028
1029     switch (o->op_type) {
1030     case OP_NULL:       /* Was holding old type, if any. */
1031         /* FALLTHROUGH */
1032     case OP_ENTERTRY:
1033     case OP_ENTEREVAL:  /* Was holding hints. */
1034     case OP_ARGDEFELEM: /* Was holding signature index. */
1035         o->op_targ = 0;
1036         break;
1037     default:
1038         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1039             break;
1040         /* FALLTHROUGH */
1041     case OP_GVSV:
1042     case OP_GV:
1043     case OP_AELEMFAST:
1044 #ifdef USE_ITHREADS
1045             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1046 #else
1047             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1048 #endif
1049         break;
1050     case OP_METHOD_REDIR:
1051     case OP_METHOD_REDIR_SUPER:
1052 #ifdef USE_ITHREADS
1053         if (cMETHOPx(o)->op_rclass_targ) {
1054             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1055             cMETHOPx(o)->op_rclass_targ = 0;
1056         }
1057 #else
1058         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1059         cMETHOPx(o)->op_rclass_sv = NULL;
1060 #endif
1061         /* FALLTHROUGH */
1062     case OP_METHOD_NAMED:
1063     case OP_METHOD_SUPER:
1064         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1065         cMETHOPx(o)->op_u.op_meth_sv = NULL;
1066 #ifdef USE_ITHREADS
1067         if (o->op_targ) {
1068             pad_swipe(o->op_targ, 1);
1069             o->op_targ = 0;
1070         }
1071 #endif
1072         break;
1073     case OP_CONST:
1074     case OP_HINTSEVAL:
1075         SvREFCNT_dec(cSVOPo->op_sv);
1076         cSVOPo->op_sv = NULL;
1077 #ifdef USE_ITHREADS
1078         /** Bug #15654
1079           Even if op_clear does a pad_free for the target of the op,
1080           pad_free doesn't actually remove the sv that exists in the pad;
1081           instead it lives on. This results in that it could be reused as
1082           a target later on when the pad was reallocated.
1083         **/
1084         if(o->op_targ) {
1085           pad_swipe(o->op_targ,1);
1086           o->op_targ = 0;
1087         }
1088 #endif
1089         break;
1090     case OP_DUMP:
1091     case OP_GOTO:
1092     case OP_NEXT:
1093     case OP_LAST:
1094     case OP_REDO:
1095         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1096             break;
1097         /* FALLTHROUGH */
1098     case OP_TRANS:
1099     case OP_TRANSR:
1100         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1101             && (o->op_private & OPpTRANS_USE_SVOP))
1102         {
1103 #ifdef USE_ITHREADS
1104             if (cPADOPo->op_padix > 0) {
1105                 pad_swipe(cPADOPo->op_padix, TRUE);
1106                 cPADOPo->op_padix = 0;
1107             }
1108 #else
1109             SvREFCNT_dec(cSVOPo->op_sv);
1110             cSVOPo->op_sv = NULL;
1111 #endif
1112         }
1113         else {
1114             PerlMemShared_free(cPVOPo->op_pv);
1115             cPVOPo->op_pv = NULL;
1116         }
1117         break;
1118     case OP_SUBST:
1119         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1120         goto clear_pmop;
1121
1122     case OP_SPLIT:
1123         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1124             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1125         {
1126             if (o->op_private & OPpSPLIT_LEX)
1127                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1128             else
1129 #ifdef USE_ITHREADS
1130                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1131 #else
1132                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1133 #endif
1134         }
1135         /* FALLTHROUGH */
1136     case OP_MATCH:
1137     case OP_QR:
1138     clear_pmop:
1139         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1140             op_free(cPMOPo->op_code_list);
1141         cPMOPo->op_code_list = NULL;
1142         forget_pmop(cPMOPo);
1143         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1144         /* we use the same protection as the "SAFE" version of the PM_ macros
1145          * here since sv_clean_all might release some PMOPs
1146          * after PL_regex_padav has been cleared
1147          * and the clearing of PL_regex_padav needs to
1148          * happen before sv_clean_all
1149          */
1150 #ifdef USE_ITHREADS
1151         if(PL_regex_pad) {        /* We could be in destruction */
1152             const IV offset = (cPMOPo)->op_pmoffset;
1153             ReREFCNT_dec(PM_GETRE(cPMOPo));
1154             PL_regex_pad[offset] = &PL_sv_undef;
1155             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1156                            sizeof(offset));
1157         }
1158 #else
1159         ReREFCNT_dec(PM_GETRE(cPMOPo));
1160         PM_SETRE(cPMOPo, NULL);
1161 #endif
1162
1163         break;
1164
1165     case OP_ARGCHECK:
1166         PerlMemShared_free(cUNOP_AUXo->op_aux);
1167         break;
1168
1169     case OP_MULTICONCAT:
1170         {
1171             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1172             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1173              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1174              * utf8 shared strings */
1175             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1176             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1177             if (p1)
1178                 PerlMemShared_free(p1);
1179             if (p2 && p1 != p2)
1180                 PerlMemShared_free(p2);
1181             PerlMemShared_free(aux);
1182         }
1183         break;
1184
1185     case OP_MULTIDEREF:
1186         {
1187             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1188             UV actions = items->uv;
1189             bool last = 0;
1190             bool is_hash = FALSE;
1191
1192             while (!last) {
1193                 switch (actions & MDEREF_ACTION_MASK) {
1194
1195                 case MDEREF_reload:
1196                     actions = (++items)->uv;
1197                     continue;
1198
1199                 case MDEREF_HV_padhv_helem:
1200                     is_hash = TRUE;
1201                     /* FALLTHROUGH */
1202                 case MDEREF_AV_padav_aelem:
1203                     pad_free((++items)->pad_offset);
1204                     goto do_elem;
1205
1206                 case MDEREF_HV_gvhv_helem:
1207                     is_hash = TRUE;
1208                     /* FALLTHROUGH */
1209                 case MDEREF_AV_gvav_aelem:
1210 #ifdef USE_ITHREADS
1211                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1212 #else
1213                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1214 #endif
1215                     goto do_elem;
1216
1217                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1218                     is_hash = TRUE;
1219                     /* FALLTHROUGH */
1220                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1221 #ifdef USE_ITHREADS
1222                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1223 #else
1224                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1225 #endif
1226                     goto do_vivify_rv2xv_elem;
1227
1228                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1229                     is_hash = TRUE;
1230                     /* FALLTHROUGH */
1231                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1232                     pad_free((++items)->pad_offset);
1233                     goto do_vivify_rv2xv_elem;
1234
1235                 case MDEREF_HV_pop_rv2hv_helem:
1236                 case MDEREF_HV_vivify_rv2hv_helem:
1237                     is_hash = TRUE;
1238                     /* FALLTHROUGH */
1239                 do_vivify_rv2xv_elem:
1240                 case MDEREF_AV_pop_rv2av_aelem:
1241                 case MDEREF_AV_vivify_rv2av_aelem:
1242                 do_elem:
1243                     switch (actions & MDEREF_INDEX_MASK) {
1244                     case MDEREF_INDEX_none:
1245                         last = 1;
1246                         break;
1247                     case MDEREF_INDEX_const:
1248                         if (is_hash) {
1249 #ifdef USE_ITHREADS
1250                             /* see RT #15654 */
1251                             pad_swipe((++items)->pad_offset, 1);
1252 #else
1253                             SvREFCNT_dec((++items)->sv);
1254 #endif
1255                         }
1256                         else
1257                             items++;
1258                         break;
1259                     case MDEREF_INDEX_padsv:
1260                         pad_free((++items)->pad_offset);
1261                         break;
1262                     case MDEREF_INDEX_gvsv:
1263 #ifdef USE_ITHREADS
1264                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1265 #else
1266                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1267 #endif
1268                         break;
1269                     }
1270
1271                     if (actions & MDEREF_FLAG_last)
1272                         last = 1;
1273                     is_hash = FALSE;
1274
1275                     break;
1276
1277                 default:
1278                     assert(0);
1279                     last = 1;
1280                     break;
1281
1282                 } /* switch */
1283
1284                 actions >>= MDEREF_SHIFT;
1285             } /* while */
1286
1287             /* start of malloc is at op_aux[-1], where the length is
1288              * stored */
1289             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1290         }
1291         break;
1292     }
1293
1294     if (o->op_targ > 0) {
1295         pad_free(o->op_targ);
1296         o->op_targ = 0;
1297     }
1298 }
1299
1300 STATIC void
1301 S_cop_free(pTHX_ COP* cop)
1302 {
1303     PERL_ARGS_ASSERT_COP_FREE;
1304
1305     CopFILE_free(cop);
1306     if (! specialWARN(cop->cop_warnings))
1307         PerlMemShared_free(cop->cop_warnings);
1308     cophh_free(CopHINTHASH_get(cop));
1309     if (PL_curcop == cop)
1310        PL_curcop = NULL;
1311 }
1312
1313 STATIC void
1314 S_forget_pmop(pTHX_ PMOP *const o)
1315 {
1316     HV * const pmstash = PmopSTASH(o);
1317
1318     PERL_ARGS_ASSERT_FORGET_PMOP;
1319
1320     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1321         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1322         if (mg) {
1323             PMOP **const array = (PMOP**) mg->mg_ptr;
1324             U32 count = mg->mg_len / sizeof(PMOP**);
1325             U32 i = count;
1326
1327             while (i--) {
1328                 if (array[i] == o) {
1329                     /* Found it. Move the entry at the end to overwrite it.  */
1330                     array[i] = array[--count];
1331                     mg->mg_len = count * sizeof(PMOP**);
1332                     /* Could realloc smaller at this point always, but probably
1333                        not worth it. Probably worth free()ing if we're the
1334                        last.  */
1335                     if(!count) {
1336                         Safefree(mg->mg_ptr);
1337                         mg->mg_ptr = NULL;
1338                     }
1339                     break;
1340                 }
1341             }
1342         }
1343     }
1344     if (PL_curpm == o)
1345         PL_curpm = NULL;
1346 }
1347
1348
1349 STATIC void
1350 S_find_and_forget_pmops(pTHX_ OP *o)
1351 {
1352     OP* top_op = o;
1353
1354     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1355
1356     while (1) {
1357         switch (o->op_type) {
1358         case OP_SUBST:
1359         case OP_SPLIT:
1360         case OP_MATCH:
1361         case OP_QR:
1362             forget_pmop((PMOP*)o);
1363         }
1364
1365         if (o->op_flags & OPf_KIDS) {
1366             o = cUNOPo->op_first;
1367             continue;
1368         }
1369
1370         while (1) {
1371             if (o == top_op)
1372                 return; /* at top; no parents/siblings to try */
1373             if (OpHAS_SIBLING(o)) {
1374                 o = o->op_sibparent; /* process next sibling */
1375                 break;
1376             }
1377             o = o->op_sibparent; /*try parent's next sibling */
1378         }
1379     }
1380 }
1381
1382
1383 /*
1384 =for apidoc op_null
1385
1386 Neutralizes an op when it is no longer needed, but is still linked to from
1387 other ops.
1388
1389 =cut
1390 */
1391
1392 void
1393 Perl_op_null(pTHX_ OP *o)
1394 {
1395     dVAR;
1396
1397     PERL_ARGS_ASSERT_OP_NULL;
1398
1399     if (o->op_type == OP_NULL)
1400         return;
1401     op_clear(o);
1402     o->op_targ = o->op_type;
1403     OpTYPE_set(o, OP_NULL);
1404 }
1405
1406 void
1407 Perl_op_refcnt_lock(pTHX)
1408   PERL_TSA_ACQUIRE(PL_op_mutex)
1409 {
1410 #ifdef USE_ITHREADS
1411     dVAR;
1412 #endif
1413     PERL_UNUSED_CONTEXT;
1414     OP_REFCNT_LOCK;
1415 }
1416
1417 void
1418 Perl_op_refcnt_unlock(pTHX)
1419   PERL_TSA_RELEASE(PL_op_mutex)
1420 {
1421 #ifdef USE_ITHREADS
1422     dVAR;
1423 #endif
1424     PERL_UNUSED_CONTEXT;
1425     OP_REFCNT_UNLOCK;
1426 }
1427
1428
1429 /*
1430 =for apidoc op_sibling_splice
1431
1432 A general function for editing the structure of an existing chain of
1433 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1434 you to delete zero or more sequential nodes, replacing them with zero or
1435 more different nodes.  Performs the necessary op_first/op_last
1436 housekeeping on the parent node and op_sibling manipulation on the
1437 children.  The last deleted node will be marked as as the last node by
1438 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1439
1440 Note that op_next is not manipulated, and nodes are not freed; that is the
1441 responsibility of the caller.  It also won't create a new list op for an
1442 empty list etc; use higher-level functions like op_append_elem() for that.
1443
1444 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1445 the splicing doesn't affect the first or last op in the chain.
1446
1447 C<start> is the node preceding the first node to be spliced.  Node(s)
1448 following it will be deleted, and ops will be inserted after it.  If it is
1449 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1450 beginning.
1451
1452 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1453 If -1 or greater than or equal to the number of remaining kids, all
1454 remaining kids are deleted.
1455
1456 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1457 If C<NULL>, no nodes are inserted.
1458
1459 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1460 deleted.
1461
1462 For example:
1463
1464     action                    before      after         returns
1465     ------                    -----       -----         -------
1466
1467                               P           P
1468     splice(P, A, 2, X-Y-Z)    |           |             B-C
1469                               A-B-C-D     A-X-Y-Z-D
1470
1471                               P           P
1472     splice(P, NULL, 1, X-Y)   |           |             A
1473                               A-B-C-D     X-Y-B-C-D
1474
1475                               P           P
1476     splice(P, NULL, 3, NULL)  |           |             A-B-C
1477                               A-B-C-D     D
1478
1479                               P           P
1480     splice(P, B, 0, X-Y)      |           |             NULL
1481                               A-B-C-D     A-B-X-Y-C-D
1482
1483
1484 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1485 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1486
1487 =cut
1488 */
1489
1490 OP *
1491 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1492 {
1493     OP *first;
1494     OP *rest;
1495     OP *last_del = NULL;
1496     OP *last_ins = NULL;
1497
1498     if (start)
1499         first = OpSIBLING(start);
1500     else if (!parent)
1501         goto no_parent;
1502     else
1503         first = cLISTOPx(parent)->op_first;
1504
1505     assert(del_count >= -1);
1506
1507     if (del_count && first) {
1508         last_del = first;
1509         while (--del_count && OpHAS_SIBLING(last_del))
1510             last_del = OpSIBLING(last_del);
1511         rest = OpSIBLING(last_del);
1512         OpLASTSIB_set(last_del, NULL);
1513     }
1514     else
1515         rest = first;
1516
1517     if (insert) {
1518         last_ins = insert;
1519         while (OpHAS_SIBLING(last_ins))
1520             last_ins = OpSIBLING(last_ins);
1521         OpMAYBESIB_set(last_ins, rest, NULL);
1522     }
1523     else
1524         insert = rest;
1525
1526     if (start) {
1527         OpMAYBESIB_set(start, insert, NULL);
1528     }
1529     else {
1530         assert(parent);
1531         cLISTOPx(parent)->op_first = insert;
1532         if (insert)
1533             parent->op_flags |= OPf_KIDS;
1534         else
1535             parent->op_flags &= ~OPf_KIDS;
1536     }
1537
1538     if (!rest) {
1539         /* update op_last etc */
1540         U32 type;
1541         OP *lastop;
1542
1543         if (!parent)
1544             goto no_parent;
1545
1546         /* ought to use OP_CLASS(parent) here, but that can't handle
1547          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1548          * either */
1549         type = parent->op_type;
1550         if (type == OP_CUSTOM) {
1551             dTHX;
1552             type = XopENTRYCUSTOM(parent, xop_class);
1553         }
1554         else {
1555             if (type == OP_NULL)
1556                 type = parent->op_targ;
1557             type = PL_opargs[type] & OA_CLASS_MASK;
1558         }
1559
1560         lastop = last_ins ? last_ins : start ? start : NULL;
1561         if (   type == OA_BINOP
1562             || type == OA_LISTOP
1563             || type == OA_PMOP
1564             || type == OA_LOOP
1565         )
1566             cLISTOPx(parent)->op_last = lastop;
1567
1568         if (lastop)
1569             OpLASTSIB_set(lastop, parent);
1570     }
1571     return last_del ? first : NULL;
1572
1573   no_parent:
1574     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1575 }
1576
1577 /*
1578 =for apidoc op_parent
1579
1580 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1581
1582 =cut
1583 */
1584
1585 OP *
1586 Perl_op_parent(OP *o)
1587 {
1588     PERL_ARGS_ASSERT_OP_PARENT;
1589     while (OpHAS_SIBLING(o))
1590         o = OpSIBLING(o);
1591     return o->op_sibparent;
1592 }
1593
1594 /* replace the sibling following start with a new UNOP, which becomes
1595  * the parent of the original sibling; e.g.
1596  *
1597  *  op_sibling_newUNOP(P, A, unop-args...)
1598  *
1599  *  P              P
1600  *  |      becomes |
1601  *  A-B-C          A-U-C
1602  *                   |
1603  *                   B
1604  *
1605  * where U is the new UNOP.
1606  *
1607  * parent and start args are the same as for op_sibling_splice();
1608  * type and flags args are as newUNOP().
1609  *
1610  * Returns the new UNOP.
1611  */
1612
1613 STATIC OP *
1614 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1615 {
1616     OP *kid, *newop;
1617
1618     kid = op_sibling_splice(parent, start, 1, NULL);
1619     newop = newUNOP(type, flags, kid);
1620     op_sibling_splice(parent, start, 0, newop);
1621     return newop;
1622 }
1623
1624
1625 /* lowest-level newLOGOP-style function - just allocates and populates
1626  * the struct. Higher-level stuff should be done by S_new_logop() /
1627  * newLOGOP(). This function exists mainly to avoid op_first assignment
1628  * being spread throughout this file.
1629  */
1630
1631 LOGOP *
1632 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1633 {
1634     dVAR;
1635     LOGOP *logop;
1636     OP *kid = first;
1637     NewOp(1101, logop, 1, LOGOP);
1638     OpTYPE_set(logop, type);
1639     logop->op_first = first;
1640     logop->op_other = other;
1641     if (first)
1642         logop->op_flags = OPf_KIDS;
1643     while (kid && OpHAS_SIBLING(kid))
1644         kid = OpSIBLING(kid);
1645     if (kid)
1646         OpLASTSIB_set(kid, (OP*)logop);
1647     return logop;
1648 }
1649
1650
1651 /* Contextualizers */
1652
1653 /*
1654 =for apidoc op_contextualize
1655
1656 Applies a syntactic context to an op tree representing an expression.
1657 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1658 or C<G_VOID> to specify the context to apply.  The modified op tree
1659 is returned.
1660
1661 =cut
1662 */
1663
1664 OP *
1665 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1666 {
1667     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1668     switch (context) {
1669         case G_SCALAR: return scalar(o);
1670         case G_ARRAY:  return list(o);
1671         case G_VOID:   return scalarvoid(o);
1672         default:
1673             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1674                        (long) context);
1675     }
1676 }
1677
1678 /*
1679
1680 =for apidoc op_linklist
1681 This function is the implementation of the L</LINKLIST> macro.  It should
1682 not be called directly.
1683
1684 =cut
1685 */
1686
1687
1688 OP *
1689 Perl_op_linklist(pTHX_ OP *o)
1690 {
1691
1692     OP **prevp;
1693     OP *kid;
1694     OP * top_op = o;
1695
1696     PERL_ARGS_ASSERT_OP_LINKLIST;
1697
1698     while (1) {
1699         /* Descend down the tree looking for any unprocessed subtrees to
1700          * do first */
1701         if (!o->op_next) {
1702             if (o->op_flags & OPf_KIDS) {
1703                 o = cUNOPo->op_first;
1704                 continue;
1705             }
1706             o->op_next = o; /* leaf node; link to self initially */
1707         }
1708
1709         /* if we're at the top level, there either weren't any children
1710          * to process, or we've worked our way back to the top. */
1711         if (o == top_op)
1712             return o->op_next;
1713
1714         /* o is now processed. Next, process any sibling subtrees */
1715
1716         if (OpHAS_SIBLING(o)) {
1717             o = OpSIBLING(o);
1718             continue;
1719         }
1720
1721         /* Done all the subtrees at this level. Go back up a level and
1722          * link the parent in with all its (processed) children.
1723          */
1724
1725         o = o->op_sibparent;
1726         assert(!o->op_next);
1727         prevp = &(o->op_next);
1728         kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1729         while (kid) {
1730             *prevp = kid->op_next;
1731             prevp = &(kid->op_next);
1732             kid = OpSIBLING(kid);
1733         }
1734         *prevp = o;
1735     }
1736 }
1737
1738
1739 static OP *
1740 S_scalarkids(pTHX_ OP *o)
1741 {
1742     if (o && o->op_flags & OPf_KIDS) {
1743         OP *kid;
1744         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1745             scalar(kid);
1746     }
1747     return o;
1748 }
1749
1750 STATIC OP *
1751 S_scalarboolean(pTHX_ OP *o)
1752 {
1753     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1754
1755     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1756          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1757         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1758          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1759          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1760         if (ckWARN(WARN_SYNTAX)) {
1761             const line_t oldline = CopLINE(PL_curcop);
1762
1763             if (PL_parser && PL_parser->copline != NOLINE) {
1764                 /* This ensures that warnings are reported at the first line
1765                    of the conditional, not the last.  */
1766                 CopLINE_set(PL_curcop, PL_parser->copline);
1767             }
1768             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1769             CopLINE_set(PL_curcop, oldline);
1770         }
1771     }
1772     return scalar(o);
1773 }
1774
1775 static SV *
1776 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1777 {
1778     assert(o);
1779     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1780            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1781     {
1782         const char funny  = o->op_type == OP_PADAV
1783                          || o->op_type == OP_RV2AV ? '@' : '%';
1784         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1785             GV *gv;
1786             if (cUNOPo->op_first->op_type != OP_GV
1787              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1788                 return NULL;
1789             return varname(gv, funny, 0, NULL, 0, subscript_type);
1790         }
1791         return
1792             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1793     }
1794 }
1795
1796 static SV *
1797 S_op_varname(pTHX_ const OP *o)
1798 {
1799     return S_op_varname_subscript(aTHX_ o, 1);
1800 }
1801
1802 static void
1803 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1804 { /* or not so pretty :-) */
1805     if (o->op_type == OP_CONST) {
1806         *retsv = cSVOPo_sv;
1807         if (SvPOK(*retsv)) {
1808             SV *sv = *retsv;
1809             *retsv = sv_newmortal();
1810             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1811                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1812         }
1813         else if (!SvOK(*retsv))
1814             *retpv = "undef";
1815     }
1816     else *retpv = "...";
1817 }
1818
1819 static void
1820 S_scalar_slice_warning(pTHX_ const OP *o)
1821 {
1822     OP *kid;
1823     const bool h = o->op_type == OP_HSLICE
1824                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1825     const char lbrack =
1826         h ? '{' : '[';
1827     const char rbrack =
1828         h ? '}' : ']';
1829     SV *name;
1830     SV *keysv = NULL; /* just to silence compiler warnings */
1831     const char *key = NULL;
1832
1833     if (!(o->op_private & OPpSLICEWARNING))
1834         return;
1835     if (PL_parser && PL_parser->error_count)
1836         /* This warning can be nonsensical when there is a syntax error. */
1837         return;
1838
1839     kid = cLISTOPo->op_first;
1840     kid = OpSIBLING(kid); /* get past pushmark */
1841     /* weed out false positives: any ops that can return lists */
1842     switch (kid->op_type) {
1843     case OP_BACKTICK:
1844     case OP_GLOB:
1845     case OP_READLINE:
1846     case OP_MATCH:
1847     case OP_RV2AV:
1848     case OP_EACH:
1849     case OP_VALUES:
1850     case OP_KEYS:
1851     case OP_SPLIT:
1852     case OP_LIST:
1853     case OP_SORT:
1854     case OP_REVERSE:
1855     case OP_ENTERSUB:
1856     case OP_CALLER:
1857     case OP_LSTAT:
1858     case OP_STAT:
1859     case OP_READDIR:
1860     case OP_SYSTEM:
1861     case OP_TMS:
1862     case OP_LOCALTIME:
1863     case OP_GMTIME:
1864     case OP_ENTEREVAL:
1865         return;
1866     }
1867
1868     /* Don't warn if we have a nulled list either. */
1869     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1870         return;
1871
1872     assert(OpSIBLING(kid));
1873     name = S_op_varname(aTHX_ OpSIBLING(kid));
1874     if (!name) /* XS module fiddling with the op tree */
1875         return;
1876     S_op_pretty(aTHX_ kid, &keysv, &key);
1877     assert(SvPOK(name));
1878     sv_chop(name,SvPVX(name)+1);
1879     if (key)
1880        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1881         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1882                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1883                    "%c%s%c",
1884                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1885                     lbrack, key, rbrack);
1886     else
1887        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1888         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1889                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1890                     SVf "%c%" SVf "%c",
1891                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1892                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1893 }
1894
1895
1896
1897 /* apply scalar context to the o subtree */
1898
1899 OP *
1900 Perl_scalar(pTHX_ OP *o)
1901 {
1902     OP * top_op = o;
1903
1904     while (1) {
1905         OP *next_kid = NULL; /* what op (if any) to process next */
1906         OP *kid;
1907
1908         /* assumes no premature commitment */
1909         if (!o || (PL_parser && PL_parser->error_count)
1910              || (o->op_flags & OPf_WANT)
1911              || o->op_type == OP_RETURN)
1912         {
1913             goto do_next;
1914         }
1915
1916         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1917
1918         switch (o->op_type) {
1919         case OP_REPEAT:
1920             scalar(cBINOPo->op_first);
1921             /* convert what initially looked like a list repeat into a
1922              * scalar repeat, e.g. $s = (1) x $n
1923              */
1924             if (o->op_private & OPpREPEAT_DOLIST) {
1925                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1926                 assert(kid->op_type == OP_PUSHMARK);
1927                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1928                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1929                     o->op_private &=~ OPpREPEAT_DOLIST;
1930                 }
1931             }
1932             break;
1933
1934         case OP_OR:
1935         case OP_AND:
1936         case OP_COND_EXPR:
1937             /* impose scalar context on everything except the condition */
1938             next_kid = OpSIBLING(cUNOPo->op_first);
1939             break;
1940
1941         default:
1942             if (o->op_flags & OPf_KIDS)
1943                 next_kid = cUNOPo->op_first; /* do all kids */
1944             break;
1945
1946         /* the children of these ops are usually a list of statements,
1947          * except the leaves, whose first child is a corresponding enter
1948          */
1949         case OP_SCOPE:
1950         case OP_LINESEQ:
1951         case OP_LIST:
1952             kid = cLISTOPo->op_first;
1953             goto do_kids;
1954         case OP_LEAVE:
1955         case OP_LEAVETRY:
1956             kid = cLISTOPo->op_first;
1957             scalar(kid);
1958             kid = OpSIBLING(kid);
1959         do_kids:
1960             while (kid) {
1961                 OP *sib = OpSIBLING(kid);
1962                 /* Apply void context to all kids except the last, which
1963                  * is scalar (ignoring a trailing ex-nextstate in determining
1964                  * if it's the last kid). E.g.
1965                  *      $scalar = do { void; void; scalar }
1966                  * Except that 'when's are always scalar, e.g.
1967                  *      $scalar = do { given(..) {
1968                     *                 when (..) { scalar }
1969                     *                 when (..) { scalar }
1970                     *                 ...
1971                     *                }}
1972                     */
1973                 if (!sib
1974                      || (  !OpHAS_SIBLING(sib)
1975                          && sib->op_type == OP_NULL
1976                          && (   sib->op_targ == OP_NEXTSTATE
1977                              || sib->op_targ == OP_DBSTATE  )
1978                         )
1979                 )
1980                 {
1981                     /* tail call optimise calling scalar() on the last kid */
1982                     next_kid = kid;
1983                     goto do_next;
1984                 }
1985                 else if (kid->op_type == OP_LEAVEWHEN)
1986                     scalar(kid);
1987                 else
1988                     scalarvoid(kid);
1989                 kid = sib;
1990             }
1991             NOT_REACHED; /* NOTREACHED */
1992             break;
1993
1994         case OP_SORT:
1995             Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1996             break;
1997
1998         case OP_KVHSLICE:
1999         case OP_KVASLICE:
2000         {
2001             /* Warn about scalar context */
2002             const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
2003             const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
2004             SV *name;
2005             SV *keysv;
2006             const char *key = NULL;
2007
2008             /* This warning can be nonsensical when there is a syntax error. */
2009             if (PL_parser && PL_parser->error_count)
2010                 break;
2011
2012             if (!ckWARN(WARN_SYNTAX)) break;
2013
2014             kid = cLISTOPo->op_first;
2015             kid = OpSIBLING(kid); /* get past pushmark */
2016             assert(OpSIBLING(kid));
2017             name = S_op_varname(aTHX_ OpSIBLING(kid));
2018             if (!name) /* XS module fiddling with the op tree */
2019                 break;
2020             S_op_pretty(aTHX_ kid, &keysv, &key);
2021             assert(SvPOK(name));
2022             sv_chop(name,SvPVX(name)+1);
2023             if (key)
2024       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2025                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2026                            "%%%" SVf "%c%s%c in scalar context better written "
2027                            "as $%" SVf "%c%s%c",
2028                             SVfARG(name), lbrack, key, rbrack, SVfARG(name),
2029                             lbrack, key, rbrack);
2030             else
2031       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
2032                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
2033                            "%%%" SVf "%c%" SVf "%c in scalar context better "
2034                            "written as $%" SVf "%c%" SVf "%c",
2035                             SVfARG(name), lbrack, SVfARG(keysv), rbrack,
2036                             SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2037         }
2038         } /* switch */
2039
2040         /* If next_kid is set, someone in the code above wanted us to process
2041          * that kid and all its remaining siblings.  Otherwise, work our way
2042          * back up the tree */
2043       do_next:
2044         while (!next_kid) {
2045             if (o == top_op)
2046                 return top_op; /* at top; no parents/siblings to try */
2047             if (OpHAS_SIBLING(o))
2048                 next_kid = o->op_sibparent;
2049             else {
2050                 o = o->op_sibparent; /*try parent's next sibling */
2051                 switch (o->op_type) {
2052                 case OP_SCOPE:
2053                 case OP_LINESEQ:
2054                 case OP_LIST:
2055                 case OP_LEAVE:
2056                 case OP_LEAVETRY:
2057                     /* should really restore PL_curcop to its old value, but
2058                      * setting it to PL_compiling is better than do nothing */
2059                     PL_curcop = &PL_compiling;
2060                 }
2061             }
2062         }
2063         o = next_kid;
2064     } /* while */
2065 }
2066
2067
2068 /* apply void context to the optree arg */
2069
2070 OP *
2071 Perl_scalarvoid(pTHX_ OP *arg)
2072 {
2073     dVAR;
2074     OP *kid;
2075     SV* sv;
2076     OP *o = arg;
2077
2078     PERL_ARGS_ASSERT_SCALARVOID;
2079
2080     while (1) {
2081         U8 want;
2082         SV *useless_sv = NULL;
2083         const char* useless = NULL;
2084         OP * next_kid = NULL;
2085
2086         if (o->op_type == OP_NEXTSTATE
2087             || o->op_type == OP_DBSTATE
2088             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2089                                           || o->op_targ == OP_DBSTATE)))
2090             PL_curcop = (COP*)o;                /* for warning below */
2091
2092         /* assumes no premature commitment */
2093         want = o->op_flags & OPf_WANT;
2094         if ((want && want != OPf_WANT_SCALAR)
2095             || (PL_parser && PL_parser->error_count)
2096             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2097         {
2098             goto get_next_op;
2099         }
2100
2101         if ((o->op_private & OPpTARGET_MY)
2102             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2103         {
2104             /* newASSIGNOP has already applied scalar context, which we
2105                leave, as if this op is inside SASSIGN.  */
2106             goto get_next_op;
2107         }
2108
2109         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2110
2111         switch (o->op_type) {
2112         default:
2113             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2114                 break;
2115             /* FALLTHROUGH */
2116         case OP_REPEAT:
2117             if (o->op_flags & OPf_STACKED)
2118                 break;
2119             if (o->op_type == OP_REPEAT)
2120                 scalar(cBINOPo->op_first);
2121             goto func_ops;
2122         case OP_CONCAT:
2123             if ((o->op_flags & OPf_STACKED) &&
2124                     !(o->op_private & OPpCONCAT_NESTED))
2125                 break;
2126             goto func_ops;
2127         case OP_SUBSTR:
2128             if (o->op_private == 4)
2129                 break;
2130             /* FALLTHROUGH */
2131         case OP_WANTARRAY:
2132         case OP_GV:
2133         case OP_SMARTMATCH:
2134         case OP_AV2ARYLEN:
2135         case OP_REF:
2136         case OP_REFGEN:
2137         case OP_SREFGEN:
2138         case OP_DEFINED:
2139         case OP_HEX:
2140         case OP_OCT:
2141         case OP_LENGTH:
2142         case OP_VEC:
2143         case OP_INDEX:
2144         case OP_RINDEX:
2145         case OP_SPRINTF:
2146         case OP_KVASLICE:
2147         case OP_KVHSLICE:
2148         case OP_UNPACK:
2149         case OP_PACK:
2150         case OP_JOIN:
2151         case OP_LSLICE:
2152         case OP_ANONLIST:
2153         case OP_ANONHASH:
2154         case OP_SORT:
2155         case OP_REVERSE:
2156         case OP_RANGE:
2157         case OP_FLIP:
2158         case OP_FLOP:
2159         case OP_CALLER:
2160         case OP_FILENO:
2161         case OP_EOF:
2162         case OP_TELL:
2163         case OP_GETSOCKNAME:
2164         case OP_GETPEERNAME:
2165         case OP_READLINK:
2166         case OP_TELLDIR:
2167         case OP_GETPPID:
2168         case OP_GETPGRP:
2169         case OP_GETPRIORITY:
2170         case OP_TIME:
2171         case OP_TMS:
2172         case OP_LOCALTIME:
2173         case OP_GMTIME:
2174         case OP_GHBYNAME:
2175         case OP_GHBYADDR:
2176         case OP_GHOSTENT:
2177         case OP_GNBYNAME:
2178         case OP_GNBYADDR:
2179         case OP_GNETENT:
2180         case OP_GPBYNAME:
2181         case OP_GPBYNUMBER:
2182         case OP_GPROTOENT:
2183         case OP_GSBYNAME:
2184         case OP_GSBYPORT:
2185         case OP_GSERVENT:
2186         case OP_GPWNAM:
2187         case OP_GPWUID:
2188         case OP_GGRNAM:
2189         case OP_GGRGID:
2190         case OP_GETLOGIN:
2191         case OP_PROTOTYPE:
2192         case OP_RUNCV:
2193         func_ops:
2194             useless = OP_DESC(o);
2195             break;
2196
2197         case OP_GVSV:
2198         case OP_PADSV:
2199         case OP_PADAV:
2200         case OP_PADHV:
2201         case OP_PADANY:
2202         case OP_AELEM:
2203         case OP_AELEMFAST:
2204         case OP_AELEMFAST_LEX:
2205         case OP_ASLICE:
2206         case OP_HELEM:
2207         case OP_HSLICE:
2208             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2209                 /* Otherwise it's "Useless use of grep iterator" */
2210                 useless = OP_DESC(o);
2211             break;
2212
2213         case OP_SPLIT:
2214             if (!(o->op_private & OPpSPLIT_ASSIGN))
2215                 useless = OP_DESC(o);
2216             break;
2217
2218         case OP_NOT:
2219             kid = cUNOPo->op_first;
2220             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2221                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2222                 goto func_ops;
2223             }
2224             useless = "negative pattern binding (!~)";
2225             break;
2226
2227         case OP_SUBST:
2228             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2229                 useless = "non-destructive substitution (s///r)";
2230             break;
2231
2232         case OP_TRANSR:
2233             useless = "non-destructive transliteration (tr///r)";
2234             break;
2235
2236         case OP_RV2GV:
2237         case OP_RV2SV:
2238         case OP_RV2AV:
2239         case OP_RV2HV:
2240             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2241                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2242                 useless = "a variable";
2243             break;
2244
2245         case OP_CONST:
2246             sv = cSVOPo_sv;
2247             if (cSVOPo->op_private & OPpCONST_STRICT)
2248                 no_bareword_allowed(o);
2249             else {
2250                 if (ckWARN(WARN_VOID)) {
2251                     NV nv;
2252                     /* don't warn on optimised away booleans, eg
2253                      * use constant Foo, 5; Foo || print; */
2254                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2255                         useless = NULL;
2256                     /* the constants 0 and 1 are permitted as they are
2257                        conventionally used as dummies in constructs like
2258                        1 while some_condition_with_side_effects;  */
2259                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2260                         useless = NULL;
2261                     else if (SvPOK(sv)) {
2262                         SV * const dsv = newSVpvs("");
2263                         useless_sv
2264                             = Perl_newSVpvf(aTHX_
2265                                             "a constant (%s)",
2266                                             pv_pretty(dsv, SvPVX_const(sv),
2267                                                       SvCUR(sv), 32, NULL, NULL,
2268                                                       PERL_PV_PRETTY_DUMP
2269                                                       | PERL_PV_ESCAPE_NOCLEAR
2270                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2271                         SvREFCNT_dec_NN(dsv);
2272                     }
2273                     else if (SvOK(sv)) {
2274                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2275                     }
2276                     else
2277                         useless = "a constant (undef)";
2278                 }
2279             }
2280             op_null(o);         /* don't execute or even remember it */
2281             break;
2282
2283         case OP_POSTINC:
2284             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2285             break;
2286
2287         case OP_POSTDEC:
2288             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2289             break;
2290
2291         case OP_I_POSTINC:
2292             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2293             break;
2294
2295         case OP_I_POSTDEC:
2296             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2297             break;
2298
2299         case OP_SASSIGN: {
2300             OP *rv2gv;
2301             UNOP *refgen, *rv2cv;
2302             LISTOP *exlist;
2303
2304             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2305                 break;
2306
2307             rv2gv = ((BINOP *)o)->op_last;
2308             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2309                 break;
2310
2311             refgen = (UNOP *)((BINOP *)o)->op_first;
2312
2313             if (!refgen || (refgen->op_type != OP_REFGEN
2314                             && refgen->op_type != OP_SREFGEN))
2315                 break;
2316
2317             exlist = (LISTOP *)refgen->op_first;
2318             if (!exlist || exlist->op_type != OP_NULL
2319                 || exlist->op_targ != OP_LIST)
2320                 break;
2321
2322             if (exlist->op_first->op_type != OP_PUSHMARK
2323                 && exlist->op_first != exlist->op_last)
2324                 break;
2325
2326             rv2cv = (UNOP*)exlist->op_last;
2327
2328             if (rv2cv->op_type != OP_RV2CV)
2329                 break;
2330
2331             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2332             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2333             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2334
2335             o->op_private |= OPpASSIGN_CV_TO_GV;
2336             rv2gv->op_private |= OPpDONT_INIT_GV;
2337             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2338
2339             break;
2340         }
2341
2342         case OP_AASSIGN: {
2343             inplace_aassign(o);
2344             break;
2345         }
2346
2347         case OP_OR:
2348         case OP_AND:
2349             kid = cLOGOPo->op_first;
2350             if (kid->op_type == OP_NOT
2351                 && (kid->op_flags & OPf_KIDS)) {
2352                 if (o->op_type == OP_AND) {
2353                     OpTYPE_set(o, OP_OR);
2354                 } else {
2355                     OpTYPE_set(o, OP_AND);
2356                 }
2357                 op_null(kid);
2358             }
2359             /* FALLTHROUGH */
2360
2361         case OP_DOR:
2362         case OP_COND_EXPR:
2363         case OP_ENTERGIVEN:
2364         case OP_ENTERWHEN:
2365             next_kid = OpSIBLING(cUNOPo->op_first);
2366         break;
2367
2368         case OP_NULL:
2369             if (o->op_flags & OPf_STACKED)
2370                 break;
2371             /* FALLTHROUGH */
2372         case OP_NEXTSTATE:
2373         case OP_DBSTATE:
2374         case OP_ENTERTRY:
2375         case OP_ENTER:
2376             if (!(o->op_flags & OPf_KIDS))
2377                 break;
2378             /* FALLTHROUGH */
2379         case OP_SCOPE:
2380         case OP_LEAVE:
2381         case OP_LEAVETRY:
2382         case OP_LEAVELOOP:
2383         case OP_LINESEQ:
2384         case OP_LEAVEGIVEN:
2385         case OP_LEAVEWHEN:
2386         kids:
2387             next_kid = cLISTOPo->op_first;
2388             break;
2389         case OP_LIST:
2390             /* If the first kid after pushmark is something that the padrange
2391                optimisation would reject, then null the list and the pushmark.
2392             */
2393             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2394                 && (  !(kid = OpSIBLING(kid))
2395                       || (  kid->op_type != OP_PADSV
2396                             && kid->op_type != OP_PADAV
2397                             && kid->op_type != OP_PADHV)
2398                       || kid->op_private & ~OPpLVAL_INTRO
2399                       || !(kid = OpSIBLING(kid))
2400                       || (  kid->op_type != OP_PADSV
2401                             && kid->op_type != OP_PADAV
2402                             && kid->op_type != OP_PADHV)
2403                       || kid->op_private & ~OPpLVAL_INTRO)
2404             ) {
2405                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2406                 op_null(o); /* NULL the list */
2407             }
2408             goto kids;
2409         case OP_ENTEREVAL:
2410             scalarkids(o);
2411             break;
2412         case OP_SCALAR:
2413             scalar(o);
2414             break;
2415         }
2416
2417         if (useless_sv) {
2418             /* mortalise it, in case warnings are fatal.  */
2419             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2420                            "Useless use of %" SVf " in void context",
2421                            SVfARG(sv_2mortal(useless_sv)));
2422         }
2423         else if (useless) {
2424             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2425                            "Useless use of %s in void context",
2426                            useless);
2427         }
2428
2429       get_next_op:
2430         /* if a kid hasn't been nominated to process, continue with the
2431          * next sibling, or if no siblings left, go back to the parent's
2432          * siblings and so on
2433          */
2434         while (!next_kid) {
2435             if (o == arg)
2436                 return arg; /* at top; no parents/siblings to try */
2437             if (OpHAS_SIBLING(o))
2438                 next_kid = o->op_sibparent;
2439             else
2440                 o = o->op_sibparent; /*try parent's next sibling */
2441         }
2442         o = next_kid;
2443     }
2444
2445     return arg;
2446 }
2447
2448
2449 static OP *
2450 S_listkids(pTHX_ OP *o)
2451 {
2452     if (o && o->op_flags & OPf_KIDS) {
2453         OP *kid;
2454         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2455             list(kid);
2456     }
2457     return o;
2458 }
2459
2460
2461 /* apply list context to the o subtree */
2462
2463 OP *
2464 Perl_list(pTHX_ OP *o)
2465 {
2466     OP * top_op = o;
2467
2468     while (1) {
2469         OP *next_kid = NULL; /* what op (if any) to process next */
2470
2471         OP *kid;
2472
2473         /* assumes no premature commitment */
2474         if (!o || (o->op_flags & OPf_WANT)
2475              || (PL_parser && PL_parser->error_count)
2476              || o->op_type == OP_RETURN)
2477         {
2478             goto do_next;
2479         }
2480
2481         if ((o->op_private & OPpTARGET_MY)
2482             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2483         {
2484             goto do_next;                               /* As if inside SASSIGN */
2485         }
2486
2487         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2488
2489         switch (o->op_type) {
2490         case OP_REPEAT:
2491             if (o->op_private & OPpREPEAT_DOLIST
2492              && !(o->op_flags & OPf_STACKED))
2493             {
2494                 list(cBINOPo->op_first);
2495                 kid = cBINOPo->op_last;
2496                 /* optimise away (.....) x 1 */
2497                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2498                  && SvIVX(kSVOP_sv) == 1)
2499                 {
2500                     op_null(o); /* repeat */
2501                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2502                     /* const (rhs): */
2503                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2504                 }
2505             }
2506             break;
2507
2508         case OP_OR:
2509         case OP_AND:
2510         case OP_COND_EXPR:
2511             /* impose list context on everything except the condition */
2512             next_kid = OpSIBLING(cUNOPo->op_first);
2513             break;
2514
2515         default:
2516             if (!(o->op_flags & OPf_KIDS))
2517                 break;
2518             /* possibly flatten 1..10 into a constant array */
2519             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2520                 list(cBINOPo->op_first);
2521                 gen_constant_list(o);
2522                 goto do_next;
2523             }
2524             next_kid = cUNOPo->op_first; /* do all kids */
2525             break;
2526
2527         case OP_LIST:
2528             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2529                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2530                 op_null(o); /* NULL the list */
2531             }
2532             if (o->op_flags & OPf_KIDS)
2533                 next_kid = cUNOPo->op_first; /* do all kids */
2534             break;
2535
2536         /* the children of these ops are usually a list of statements,
2537          * except the leaves, whose first child is a corresponding enter
2538          */
2539         case OP_SCOPE:
2540         case OP_LINESEQ:
2541             kid = cLISTOPo->op_first;
2542             goto do_kids;
2543         case OP_LEAVE:
2544         case OP_LEAVETRY:
2545             kid = cLISTOPo->op_first;
2546             list(kid);
2547             kid = OpSIBLING(kid);
2548         do_kids:
2549             while (kid) {
2550                 OP *sib = OpSIBLING(kid);
2551                 /* Apply void context to all kids except the last, which
2552                  * is list. E.g.
2553                  *      @a = do { void; void; list }
2554                  * Except that 'when's are always list context, e.g.
2555                  *      @a = do { given(..) {
2556                     *                 when (..) { list }
2557                     *                 when (..) { list }
2558                     *                 ...
2559                     *                }}
2560                     */
2561                 if (!sib) {
2562                     /* tail call optimise calling list() on the last kid */
2563                     next_kid = kid;
2564                     goto do_next;
2565                 }
2566                 else if (kid->op_type == OP_LEAVEWHEN)
2567                     list(kid);
2568                 else
2569                     scalarvoid(kid);
2570                 kid = sib;
2571             }
2572             NOT_REACHED; /* NOTREACHED */
2573             break;
2574
2575         }
2576
2577         /* If next_kid is set, someone in the code above wanted us to process
2578          * that kid and all its remaining siblings.  Otherwise, work our way
2579          * back up the tree */
2580       do_next:
2581         while (!next_kid) {
2582             if (o == top_op)
2583                 return top_op; /* at top; no parents/siblings to try */
2584             if (OpHAS_SIBLING(o))
2585                 next_kid = o->op_sibparent;
2586             else {
2587                 o = o->op_sibparent; /*try parent's next sibling */
2588                 switch (o->op_type) {
2589                 case OP_SCOPE:
2590                 case OP_LINESEQ:
2591                 case OP_LIST:
2592                 case OP_LEAVE:
2593                 case OP_LEAVETRY:
2594                     /* should really restore PL_curcop to its old value, but
2595                      * setting it to PL_compiling is better than do nothing */
2596                     PL_curcop = &PL_compiling;
2597                 }
2598             }
2599
2600
2601         }
2602         o = next_kid;
2603     } /* while */
2604 }
2605
2606
2607 static OP *
2608 S_scalarseq(pTHX_ OP *o)
2609 {
2610     if (o) {
2611         const OPCODE type = o->op_type;
2612
2613         if (type == OP_LINESEQ || type == OP_SCOPE ||
2614             type == OP_LEAVE || type == OP_LEAVETRY)
2615         {
2616             OP *kid, *sib;
2617             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2618                 if ((sib = OpSIBLING(kid))
2619                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2620                     || (  sib->op_targ != OP_NEXTSTATE
2621                        && sib->op_targ != OP_DBSTATE  )))
2622                 {
2623                     scalarvoid(kid);
2624                 }
2625             }
2626             PL_curcop = &PL_compiling;
2627         }
2628         o->op_flags &= ~OPf_PARENS;
2629         if (PL_hints & HINT_BLOCK_SCOPE)
2630             o->op_flags |= OPf_PARENS;
2631     }
2632     else
2633         o = newOP(OP_STUB, 0);
2634     return o;
2635 }
2636
2637 STATIC OP *
2638 S_modkids(pTHX_ OP *o, I32 type)
2639 {
2640     if (o && o->op_flags & OPf_KIDS) {
2641         OP *kid;
2642         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2643             op_lvalue(kid, type);
2644     }
2645     return o;
2646 }
2647
2648
2649 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2650  * const fields. Also, convert CONST keys to HEK-in-SVs.
2651  * rop    is the op that retrieves the hash;
2652  * key_op is the first key
2653  * real   if false, only check (and possibly croak); don't update op
2654  */
2655
2656 STATIC void
2657 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2658 {
2659     PADNAME *lexname;
2660     GV **fields;
2661     bool check_fields;
2662
2663     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2664     if (rop) {
2665         if (rop->op_first->op_type == OP_PADSV)
2666             /* @$hash{qw(keys here)} */
2667             rop = (UNOP*)rop->op_first;
2668         else {
2669             /* @{$hash}{qw(keys here)} */
2670             if (rop->op_first->op_type == OP_SCOPE
2671                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2672                 {
2673                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2674                 }
2675             else
2676                 rop = NULL;
2677         }
2678     }
2679
2680     lexname = NULL; /* just to silence compiler warnings */
2681     fields  = NULL; /* just to silence compiler warnings */
2682
2683     check_fields =
2684             rop
2685          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2686              SvPAD_TYPED(lexname))
2687          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2688          && isGV(*fields) && GvHV(*fields);
2689
2690     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2691         SV **svp, *sv;
2692         if (key_op->op_type != OP_CONST)
2693             continue;
2694         svp = cSVOPx_svp(key_op);
2695
2696         /* make sure it's not a bareword under strict subs */
2697         if (key_op->op_private & OPpCONST_BARE &&
2698             key_op->op_private & OPpCONST_STRICT)
2699         {
2700             no_bareword_allowed((OP*)key_op);
2701         }
2702
2703         /* Make the CONST have a shared SV */
2704         if (   !SvIsCOW_shared_hash(sv = *svp)
2705             && SvTYPE(sv) < SVt_PVMG
2706             && SvOK(sv)
2707             && !SvROK(sv)
2708             && real)
2709         {
2710             SSize_t keylen;
2711             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2712             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2713             SvREFCNT_dec_NN(sv);
2714             *svp = nsv;
2715         }
2716
2717         if (   check_fields
2718             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2719         {
2720             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2721                         "in variable %" PNf " of type %" HEKf,
2722                         SVfARG(*svp), PNfARG(lexname),
2723                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2724         }
2725     }
2726 }
2727
2728 /* info returned by S_sprintf_is_multiconcatable() */
2729
2730 struct sprintf_ismc_info {
2731     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2732     char  *start;     /* start of raw format string */
2733     char  *end;       /* bytes after end of raw format string */
2734     STRLEN total_len; /* total length (in bytes) of format string, not
2735                          including '%s' and  half of '%%' */
2736     STRLEN variant;   /* number of bytes by which total_len_p would grow
2737                          if upgraded to utf8 */
2738     bool   utf8;      /* whether the format is utf8 */
2739 };
2740
2741
2742 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2743  * i.e. its format argument is a const string with only '%s' and '%%'
2744  * formats, and the number of args is known, e.g.
2745  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2746  * but not
2747  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2748  *
2749  * If successful, the sprintf_ismc_info struct pointed to by info will be
2750  * populated.
2751  */
2752
2753 STATIC bool
2754 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2755 {
2756     OP    *pm, *constop, *kid;
2757     SV    *sv;
2758     char  *s, *e, *p;
2759     SSize_t nargs, nformats;
2760     STRLEN cur, total_len, variant;
2761     bool   utf8;
2762
2763     /* if sprintf's behaviour changes, die here so that someone
2764      * can decide whether to enhance this function or skip optimising
2765      * under those new circumstances */
2766     assert(!(o->op_flags & OPf_STACKED));
2767     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2768     assert(!(o->op_private & ~OPpARG4_MASK));
2769
2770     pm = cUNOPo->op_first;
2771     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2772         return FALSE;
2773     constop = OpSIBLING(pm);
2774     if (!constop || constop->op_type != OP_CONST)
2775         return FALSE;
2776     sv = cSVOPx_sv(constop);
2777     if (SvMAGICAL(sv) || !SvPOK(sv))
2778         return FALSE;
2779
2780     s = SvPV(sv, cur);
2781     e = s + cur;
2782
2783     /* Scan format for %% and %s and work out how many %s there are.
2784      * Abandon if other format types are found.
2785      */
2786
2787     nformats  = 0;
2788     total_len = 0;
2789     variant   = 0;
2790
2791     for (p = s; p < e; p++) {
2792         if (*p != '%') {
2793             total_len++;
2794             if (!UTF8_IS_INVARIANT(*p))
2795                 variant++;
2796             continue;
2797         }
2798         p++;
2799         if (p >= e)
2800             return FALSE; /* lone % at end gives "Invalid conversion" */
2801         if (*p == '%')
2802             total_len++;
2803         else if (*p == 's')
2804             nformats++;
2805         else
2806             return FALSE;
2807     }
2808
2809     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2810         return FALSE;
2811
2812     utf8 = cBOOL(SvUTF8(sv));
2813     if (utf8)
2814         variant = 0;
2815
2816     /* scan args; they must all be in scalar cxt */
2817
2818     nargs = 0;
2819     kid = OpSIBLING(constop);
2820
2821     while (kid) {
2822         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2823             return FALSE;
2824         nargs++;
2825         kid = OpSIBLING(kid);
2826     }
2827
2828     if (nargs != nformats)
2829         return FALSE; /* e.g. sprintf("%s%s", $a); */
2830
2831
2832     info->nargs      = nargs;
2833     info->start      = s;
2834     info->end        = e;
2835     info->total_len  = total_len;
2836     info->variant    = variant;
2837     info->utf8       = utf8;
2838
2839     return TRUE;
2840 }
2841
2842
2843
2844 /* S_maybe_multiconcat():
2845  *
2846  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2847  * convert it (and its children) into an OP_MULTICONCAT. See the code
2848  * comments just before pp_multiconcat() for the full details of what
2849  * OP_MULTICONCAT supports.
2850  *
2851  * Basically we're looking for an optree with a chain of OP_CONCATS down
2852  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2853  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2854  *
2855  *      $x = "$a$b-$c"
2856  *
2857  *  looks like
2858  *
2859  *      SASSIGN
2860  *         |
2861  *      STRINGIFY   -- PADSV[$x]
2862  *         |
2863  *         |
2864  *      ex-PUSHMARK -- CONCAT/S
2865  *                        |
2866  *                     CONCAT/S  -- PADSV[$d]
2867  *                        |
2868  *                     CONCAT    -- CONST["-"]
2869  *                        |
2870  *                     PADSV[$a] -- PADSV[$b]
2871  *
2872  * Note that at this stage the OP_SASSIGN may have already been optimised
2873  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2874  */
2875
2876 STATIC void
2877 S_maybe_multiconcat(pTHX_ OP *o)
2878 {
2879     dVAR;
2880     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2881     OP *topop;       /* the top-most op in the concat tree (often equals o,
2882                         unless there are assign/stringify ops above it */
2883     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2884     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2885     OP *targetop;    /* the op corresponding to target=... or target.=... */
2886     OP *stringop;    /* the OP_STRINGIFY op, if any */
2887     OP *nextop;      /* used for recreating the op_next chain without consts */
2888     OP *kid;         /* general-purpose op pointer */
2889     UNOP_AUX_item *aux;
2890     UNOP_AUX_item *lenp;
2891     char *const_str, *p;
2892     struct sprintf_ismc_info sprintf_info;
2893
2894                      /* store info about each arg in args[];
2895                       * toparg is the highest used slot; argp is a general
2896                       * pointer to args[] slots */
2897     struct {
2898         void *p;      /* initially points to const sv (or null for op);
2899                          later, set to SvPV(constsv), with ... */
2900         STRLEN len;   /* ... len set to SvPV(..., len) */
2901     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2902
2903     SSize_t nargs  = 0;
2904     SSize_t nconst = 0;
2905     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2906     STRLEN variant;
2907     bool utf8 = FALSE;
2908     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2909                                  the last-processed arg will the LHS of one,
2910                                  as args are processed in reverse order */
2911     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2912     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2913     U8 flags          = 0;   /* what will become the op_flags and ... */
2914     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2915     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2916     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2917     bool prev_was_const = FALSE; /* previous arg was a const */
2918
2919     /* -----------------------------------------------------------------
2920      * Phase 1:
2921      *
2922      * Examine the optree non-destructively to determine whether it's
2923      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2924      * information about the optree in args[].
2925      */
2926
2927     argp     = args;
2928     targmyop = NULL;
2929     targetop = NULL;
2930     stringop = NULL;
2931     topop    = o;
2932     parentop = o;
2933
2934     assert(   o->op_type == OP_SASSIGN
2935            || o->op_type == OP_CONCAT
2936            || o->op_type == OP_SPRINTF
2937            || o->op_type == OP_STRINGIFY);
2938
2939     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2940
2941     /* first see if, at the top of the tree, there is an assign,
2942      * append and/or stringify */
2943
2944     if (topop->op_type == OP_SASSIGN) {
2945         /* expr = ..... */
2946         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2947             return;
2948         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2949             return;
2950         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2951
2952         parentop = topop;
2953         topop = cBINOPo->op_first;
2954         targetop = OpSIBLING(topop);
2955         if (!targetop) /* probably some sort of syntax error */
2956             return;
2957
2958         /* don't optimise away assign in 'local $foo = ....' */
2959         if (   (targetop->op_private & OPpLVAL_INTRO)
2960             /* these are the common ops which do 'local', but
2961              * not all */
2962             && (   targetop->op_type == OP_GVSV
2963                 || targetop->op_type == OP_RV2SV
2964                 || targetop->op_type == OP_AELEM
2965                 || targetop->op_type == OP_HELEM
2966                 )
2967         )
2968             return;
2969     }
2970     else if (   topop->op_type == OP_CONCAT
2971              && (topop->op_flags & OPf_STACKED)
2972              && (!(topop->op_private & OPpCONCAT_NESTED))
2973             )
2974     {
2975         /* expr .= ..... */
2976
2977         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2978          * decide what to do about it */
2979         assert(!(o->op_private & OPpTARGET_MY));
2980
2981         /* barf on unknown flags */
2982         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2983         private_flags |= OPpMULTICONCAT_APPEND;
2984         targetop = cBINOPo->op_first;
2985         parentop = topop;
2986         topop    = OpSIBLING(targetop);
2987
2988         /* $x .= <FOO> gets optimised to rcatline instead */
2989         if (topop->op_type == OP_READLINE)
2990             return;
2991     }
2992
2993     if (targetop) {
2994         /* Can targetop (the LHS) if it's a padsv, be be optimised
2995          * away and use OPpTARGET_MY instead?
2996          */
2997         if (    (targetop->op_type == OP_PADSV)
2998             && !(targetop->op_private & OPpDEREF)
2999             && !(targetop->op_private & OPpPAD_STATE)
3000                /* we don't support 'my $x .= ...' */
3001             && (   o->op_type == OP_SASSIGN
3002                 || !(targetop->op_private & OPpLVAL_INTRO))
3003         )
3004             is_targable = TRUE;
3005     }
3006
3007     if (topop->op_type == OP_STRINGIFY) {
3008         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
3009             return;
3010         stringop = topop;
3011
3012         /* barf on unknown flags */
3013         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
3014
3015         if ((topop->op_private & OPpTARGET_MY)) {
3016             if (o->op_type == OP_SASSIGN)
3017                 return; /* can't have two assigns */
3018             targmyop = topop;
3019         }
3020
3021         private_flags |= OPpMULTICONCAT_STRINGIFY;
3022         parentop = topop;
3023         topop = cBINOPx(topop)->op_first;
3024         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
3025         topop = OpSIBLING(topop);
3026     }
3027
3028     if (topop->op_type == OP_SPRINTF) {
3029         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
3030             return;
3031         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
3032             nargs     = sprintf_info.nargs;
3033             total_len = sprintf_info.total_len;
3034             variant   = sprintf_info.variant;
3035             utf8      = sprintf_info.utf8;
3036             is_sprintf = TRUE;
3037             private_flags |= OPpMULTICONCAT_FAKE;
3038             toparg = argp;
3039             /* we have an sprintf op rather than a concat optree.
3040              * Skip most of the code below which is associated with
3041              * processing that optree. We also skip phase 2, determining
3042              * whether its cost effective to optimise, since for sprintf,
3043              * multiconcat is *always* faster */
3044             goto create_aux;
3045         }
3046         /* note that even if the sprintf itself isn't multiconcatable,
3047          * the expression as a whole may be, e.g. in
3048          *    $x .= sprintf("%d",...)
3049          * the sprintf op will be left as-is, but the concat/S op may
3050          * be upgraded to multiconcat
3051          */
3052     }
3053     else if (topop->op_type == OP_CONCAT) {
3054         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3055             return;
3056
3057         if ((topop->op_private & OPpTARGET_MY)) {
3058             if (o->op_type == OP_SASSIGN || targmyop)
3059                 return; /* can't have two assigns */
3060             targmyop = topop;
3061         }
3062     }
3063
3064     /* Is it safe to convert a sassign/stringify/concat op into
3065      * a multiconcat? */
3066     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
3067     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
3068     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3069     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
3070     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
3071                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
3072     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
3073                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
3074
3075     /* Now scan the down the tree looking for a series of
3076      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3077      * stacked). For example this tree:
3078      *
3079      *     |
3080      *   CONCAT/STACKED
3081      *     |
3082      *   CONCAT/STACKED -- EXPR5
3083      *     |
3084      *   CONCAT/STACKED -- EXPR4
3085      *     |
3086      *   CONCAT -- EXPR3
3087      *     |
3088      *   EXPR1  -- EXPR2
3089      *
3090      * corresponds to an expression like
3091      *
3092      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3093      *
3094      * Record info about each EXPR in args[]: in particular, whether it is
3095      * a stringifiable OP_CONST and if so what the const sv is.
3096      *
3097      * The reason why the last concat can't be STACKED is the difference
3098      * between
3099      *
3100      *    ((($a .= $a) .= $a) .= $a) .= $a
3101      *
3102      * and
3103      *    $a . $a . $a . $a . $a
3104      *
3105      * The main difference between the optrees for those two constructs
3106      * is the presence of the last STACKED. As well as modifying $a,
3107      * the former sees the changed $a between each concat, so if $s is
3108      * initially 'a', the first returns 'a' x 16, while the latter returns
3109      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3110      */
3111
3112     kid = topop;
3113
3114     for (;;) {
3115         OP *argop;
3116         SV *sv;
3117         bool last = FALSE;
3118
3119         if (    kid->op_type == OP_CONCAT
3120             && !kid_is_last
3121         ) {
3122             OP *k1, *k2;
3123             k1 = cUNOPx(kid)->op_first;
3124             k2 = OpSIBLING(k1);
3125             /* shouldn't happen except maybe after compile err? */
3126             if (!k2)
3127                 return;
3128
3129             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
3130             if (kid->op_private & OPpTARGET_MY)
3131                 kid_is_last = TRUE;
3132
3133             stacked_last = (kid->op_flags & OPf_STACKED);
3134             if (!stacked_last)
3135                 kid_is_last = TRUE;
3136
3137             kid   = k1;
3138             argop = k2;
3139         }
3140         else {
3141             argop = kid;
3142             last = TRUE;
3143         }
3144
3145         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
3146             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3147         {
3148             /* At least two spare slots are needed to decompose both
3149              * concat args. If there are no slots left, continue to
3150              * examine the rest of the optree, but don't push new values
3151              * on args[]. If the optree as a whole is legal for conversion
3152              * (in particular that the last concat isn't STACKED), then
3153              * the first PERL_MULTICONCAT_MAXARG elements of the optree
3154              * can be converted into an OP_MULTICONCAT now, with the first
3155              * child of that op being the remainder of the optree -
3156              * which may itself later be converted to a multiconcat op
3157              * too.
3158              */
3159             if (last) {
3160                 /* the last arg is the rest of the optree */
3161                 argp++->p = NULL;
3162                 nargs++;
3163             }
3164         }
3165         else if (   argop->op_type == OP_CONST
3166             && ((sv = cSVOPx_sv(argop)))
3167             /* defer stringification until runtime of 'constant'
3168              * things that might stringify variantly, e.g. the radix
3169              * point of NVs, or overloaded RVs */
3170             && (SvPOK(sv) || SvIOK(sv))
3171             && (!SvGMAGICAL(sv))
3172         ) {
3173             if (argop->op_private & OPpCONST_STRICT)
3174                 no_bareword_allowed(argop);
3175             argp++->p = sv;
3176             utf8   |= cBOOL(SvUTF8(sv));
3177             nconst++;
3178             if (prev_was_const)
3179                 /* this const may be demoted back to a plain arg later;
3180                  * make sure we have enough arg slots left */
3181                 nadjconst++;
3182             prev_was_const = !prev_was_const;
3183         }
3184         else {
3185             argp++->p = NULL;
3186             nargs++;
3187             prev_was_const = FALSE;
3188         }
3189
3190         if (last)
3191             break;
3192     }
3193
3194     toparg = argp - 1;
3195
3196     if (stacked_last)
3197         return; /* we don't support ((A.=B).=C)...) */
3198
3199     /* look for two adjacent consts and don't fold them together:
3200      *     $o . "a" . "b"
3201      * should do
3202      *     $o->concat("a")->concat("b")
3203      * rather than
3204      *     $o->concat("ab")
3205      * (but $o .=  "a" . "b" should still fold)
3206      */
3207     {
3208         bool seen_nonconst = FALSE;
3209         for (argp = toparg; argp >= args; argp--) {
3210             if (argp->p == NULL) {
3211                 seen_nonconst = TRUE;
3212                 continue;
3213             }
3214             if (!seen_nonconst)
3215                 continue;
3216             if (argp[1].p) {
3217                 /* both previous and current arg were constants;
3218                  * leave the current OP_CONST as-is */
3219                 argp->p = NULL;
3220                 nconst--;
3221                 nargs++;
3222             }
3223         }
3224     }
3225
3226     /* -----------------------------------------------------------------
3227      * Phase 2:
3228      *
3229      * At this point we have determined that the optree *can* be converted
3230      * into a multiconcat. Having gathered all the evidence, we now decide
3231      * whether it *should*.
3232      */
3233
3234
3235     /* we need at least one concat action, e.g.:
3236      *
3237      *  Y . Z
3238      *  X = Y . Z
3239      *  X .= Y
3240      *
3241      * otherwise we could be doing something like $x = "foo", which
3242      * if treated as as a concat, would fail to COW.
3243      */
3244     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3245         return;
3246
3247     /* Benchmarking seems to indicate that we gain if:
3248      * * we optimise at least two actions into a single multiconcat
3249      *    (e.g concat+concat, sassign+concat);
3250      * * or if we can eliminate at least 1 OP_CONST;
3251      * * or if we can eliminate a padsv via OPpTARGET_MY
3252      */
3253
3254     if (
3255            /* eliminated at least one OP_CONST */
3256            nconst >= 1
3257            /* eliminated an OP_SASSIGN */
3258         || o->op_type == OP_SASSIGN
3259            /* eliminated an OP_PADSV */
3260         || (!targmyop && is_targable)
3261     )
3262         /* definitely a net gain to optimise */
3263         goto optimise;
3264
3265     /* ... if not, what else? */
3266
3267     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3268      * multiconcat is faster (due to not creating a temporary copy of
3269      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3270      * faster.
3271      */
3272     if (   nconst == 0
3273          && nargs == 2
3274          && targmyop
3275          && topop->op_type == OP_CONCAT
3276     ) {
3277         PADOFFSET t = targmyop->op_targ;
3278         OP *k1 = cBINOPx(topop)->op_first;
3279         OP *k2 = cBINOPx(topop)->op_last;
3280         if (   k2->op_type == OP_PADSV
3281             && k2->op_targ == t
3282             && (   k1->op_type != OP_PADSV
3283                 || k1->op_targ != t)
3284         )
3285             goto optimise;
3286     }
3287
3288     /* need at least two concats */
3289     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3290         return;
3291
3292
3293
3294     /* -----------------------------------------------------------------
3295      * Phase 3:
3296      *
3297      * At this point the optree has been verified as ok to be optimised
3298      * into an OP_MULTICONCAT. Now start changing things.
3299      */
3300
3301    optimise:
3302
3303     /* stringify all const args and determine utf8ness */
3304
3305     variant = 0;
3306     for (argp = args; argp <= toparg; argp++) {
3307         SV *sv = (SV*)argp->p;
3308         if (!sv)
3309             continue; /* not a const op */
3310         if (utf8 && !SvUTF8(sv))
3311             sv_utf8_upgrade_nomg(sv);
3312         argp->p = SvPV_nomg(sv, argp->len);
3313         total_len += argp->len;
3314
3315         /* see if any strings would grow if converted to utf8 */
3316         if (!utf8) {
3317             variant += variant_under_utf8_count((U8 *) argp->p,
3318                                                 (U8 *) argp->p + argp->len);
3319         }
3320     }
3321
3322     /* create and populate aux struct */
3323
3324   create_aux:
3325
3326     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3327                     sizeof(UNOP_AUX_item)
3328                     *  (
3329                            PERL_MULTICONCAT_HEADER_SIZE
3330                          + ((nargs + 1) * (variant ? 2 : 1))
3331                         )
3332                     );
3333     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3334
3335     /* Extract all the non-const expressions from the concat tree then
3336      * dispose of the old tree, e.g. convert the tree from this:
3337      *
3338      *  o => SASSIGN
3339      *         |
3340      *       STRINGIFY   -- TARGET
3341      *         |
3342      *       ex-PUSHMARK -- CONCAT
3343      *                        |
3344      *                      CONCAT -- EXPR5
3345      *                        |
3346      *                      CONCAT -- EXPR4
3347      *                        |
3348      *                      CONCAT -- EXPR3
3349      *                        |
3350      *                      EXPR1  -- EXPR2
3351      *
3352      *
3353      * to:
3354      *
3355      *  o => MULTICONCAT
3356      *         |
3357      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3358      *
3359      * except that if EXPRi is an OP_CONST, it's discarded.
3360      *
3361      * During the conversion process, EXPR ops are stripped from the tree
3362      * and unshifted onto o. Finally, any of o's remaining original
3363      * childen are discarded and o is converted into an OP_MULTICONCAT.
3364      *
3365      * In this middle of this, o may contain both: unshifted args on the
3366      * left, and some remaining original args on the right. lastkidop
3367      * is set to point to the right-most unshifted arg to delineate
3368      * between the two sets.
3369      */
3370
3371
3372     if (is_sprintf) {
3373         /* create a copy of the format with the %'s removed, and record
3374          * the sizes of the const string segments in the aux struct */
3375         char *q, *oldq;
3376         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3377
3378         p    = sprintf_info.start;
3379         q    = const_str;
3380         oldq = q;
3381         for (; p < sprintf_info.end; p++) {
3382             if (*p == '%') {
3383                 p++;
3384                 if (*p != '%') {
3385                     (lenp++)->ssize = q - oldq;
3386                     oldq = q;
3387                     continue;
3388                 }
3389             }
3390             *q++ = *p;
3391         }
3392         lenp->ssize = q - oldq;
3393         assert((STRLEN)(q - const_str) == total_len);
3394
3395         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3396          * may or may not be topop) The pushmark and const ops need to be
3397          * kept in case they're an op_next entry point.
3398          */
3399         lastkidop = cLISTOPx(topop)->op_last;
3400         kid = cUNOPx(topop)->op_first; /* pushmark */
3401         op_null(kid);
3402         op_null(OpSIBLING(kid));       /* const */
3403         if (o != topop) {
3404             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3405             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3406             lastkidop->op_next = o;
3407         }
3408     }
3409     else {
3410         p = const_str;
3411         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3412
3413         lenp->ssize = -1;
3414
3415         /* Concatenate all const strings into const_str.
3416          * Note that args[] contains the RHS args in reverse order, so
3417          * we scan args[] from top to bottom to get constant strings
3418          * in L-R order
3419          */
3420         for (argp = toparg; argp >= args; argp--) {
3421             if (!argp->p)
3422                 /* not a const op */
3423                 (++lenp)->ssize = -1;
3424             else {
3425                 STRLEN l = argp->len;
3426                 Copy(argp->p, p, l, char);
3427                 p += l;
3428                 if (lenp->ssize == -1)
3429                     lenp->ssize = l;
3430                 else
3431                     lenp->ssize += l;
3432             }
3433         }
3434
3435         kid = topop;
3436         nextop = o;
3437         lastkidop = NULL;
3438
3439         for (argp = args; argp <= toparg; argp++) {
3440             /* only keep non-const args, except keep the first-in-next-chain
3441              * arg no matter what it is (but nulled if OP_CONST), because it
3442              * may be the entry point to this subtree from the previous
3443              * op_next.
3444              */
3445             bool last = (argp == toparg);
3446             OP *prev;
3447
3448             /* set prev to the sibling *before* the arg to be cut out,
3449              * e.g. when cutting EXPR:
3450              *
3451              *         |
3452              * kid=  CONCAT
3453              *         |
3454              * prev= CONCAT -- EXPR
3455              *         |
3456              */
3457             if (argp == args && kid->op_type != OP_CONCAT) {
3458                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3459                  * so the expression to be cut isn't kid->op_last but
3460                  * kid itself */
3461                 OP *o1, *o2;
3462                 /* find the op before kid */
3463                 o1 = NULL;
3464                 o2 = cUNOPx(parentop)->op_first;
3465                 while (o2 && o2 != kid) {
3466                     o1 = o2;
3467                     o2 = OpSIBLING(o2);
3468                 }
3469                 assert(o2 == kid);
3470                 prev = o1;
3471                 kid  = parentop;
3472             }
3473             else if (kid == o && lastkidop)
3474                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3475             else
3476                 prev = last ? NULL : cUNOPx(kid)->op_first;
3477
3478             if (!argp->p || last) {
3479                 /* cut RH op */
3480                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3481                 /* and unshift to front of o */
3482                 op_sibling_splice(o, NULL, 0, aop);
3483                 /* record the right-most op added to o: later we will
3484                  * free anything to the right of it */
3485                 if (!lastkidop)
3486                     lastkidop = aop;
3487                 aop->op_next = nextop;
3488                 if (last) {
3489                     if (argp->p)
3490                         /* null the const at start of op_next chain */
3491                         op_null(aop);
3492                 }
3493                 else if (prev)
3494                     nextop = prev->op_next;
3495             }
3496
3497             /* the last two arguments are both attached to the same concat op */
3498             if (argp < toparg - 1)
3499                 kid = prev;
3500         }
3501     }
3502
3503     /* Populate the aux struct */
3504
3505     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3506     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3507     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3508     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3509     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3510
3511     /* if variant > 0, calculate a variant const string and lengths where
3512      * the utf8 version of the string will take 'variant' more bytes than
3513      * the plain one. */
3514
3515     if (variant) {
3516         char              *p = const_str;
3517         STRLEN          ulen = total_len + variant;
3518         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3519         UNOP_AUX_item *ulens = lens + (nargs + 1);
3520         char             *up = (char*)PerlMemShared_malloc(ulen);
3521         SSize_t            n;
3522
3523         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3524         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3525
3526         for (n = 0; n < (nargs + 1); n++) {
3527             SSize_t i;
3528             char * orig_up = up;
3529             for (i = (lens++)->ssize; i > 0; i--) {
3530                 U8 c = *p++;
3531                 append_utf8_from_native_byte(c, (U8**)&up);
3532             }
3533             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3534         }
3535     }
3536
3537     if (stringop) {
3538         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3539          * that op's first child - an ex-PUSHMARK - because the op_next of
3540          * the previous op may point to it (i.e. it's the entry point for
3541          * the o optree)
3542          */
3543         OP *pmop =
3544             (stringop == o)
3545                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3546                 : op_sibling_splice(stringop, NULL, 1, NULL);
3547         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3548         op_sibling_splice(o, NULL, 0, pmop);
3549         if (!lastkidop)
3550             lastkidop = pmop;
3551     }
3552
3553     /* Optimise
3554      *    target  = A.B.C...
3555      *    target .= A.B.C...
3556      */
3557
3558     if (targetop) {
3559         assert(!targmyop);
3560
3561         if (o->op_type == OP_SASSIGN) {
3562             /* Move the target subtree from being the last of o's children
3563              * to being the last of o's preserved children.
3564              * Note the difference between 'target = ...' and 'target .= ...':
3565              * for the former, target is executed last; for the latter,
3566              * first.
3567              */
3568             kid = OpSIBLING(lastkidop);
3569             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3570             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3571             lastkidop->op_next = kid->op_next;
3572             lastkidop = targetop;
3573         }
3574         else {
3575             /* Move the target subtree from being the first of o's
3576              * original children to being the first of *all* o's children.
3577              */
3578             if (lastkidop) {
3579                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3580                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3581             }
3582             else {
3583                 /* if the RHS of .= doesn't contain a concat (e.g.
3584                  * $x .= "foo"), it gets missed by the "strip ops from the
3585                  * tree and add to o" loop earlier */
3586                 assert(topop->op_type != OP_CONCAT);
3587                 if (stringop) {
3588                     /* in e.g. $x .= "$y", move the $y expression
3589                      * from being a child of OP_STRINGIFY to being the
3590                      * second child of the OP_CONCAT
3591                      */
3592                     assert(cUNOPx(stringop)->op_first == topop);
3593                     op_sibling_splice(stringop, NULL, 1, NULL);
3594                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3595                 }
3596                 assert(topop == OpSIBLING(cBINOPo->op_first));
3597                 if (toparg->p)
3598                     op_null(topop);
3599                 lastkidop = topop;
3600             }
3601         }
3602
3603         if (is_targable) {
3604             /* optimise
3605              *  my $lex  = A.B.C...
3606              *     $lex  = A.B.C...
3607              *     $lex .= A.B.C...
3608              * The original padsv op is kept but nulled in case it's the
3609              * entry point for the optree (which it will be for
3610              * '$lex .=  ... '
3611              */
3612             private_flags |= OPpTARGET_MY;
3613             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3614             o->op_targ = targetop->op_targ;
3615             targetop->op_targ = 0;
3616             op_null(targetop);
3617         }
3618         else
3619             flags |= OPf_STACKED;
3620     }
3621     else if (targmyop) {
3622         private_flags |= OPpTARGET_MY;
3623         if (o != targmyop) {
3624             o->op_targ = targmyop->op_targ;
3625             targmyop->op_targ = 0;
3626         }
3627     }
3628
3629     /* detach the emaciated husk of the sprintf/concat optree and free it */
3630     for (;;) {
3631         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3632         if (!kid)
3633             break;
3634         op_free(kid);
3635     }
3636
3637     /* and convert o into a multiconcat */
3638
3639     o->op_flags        = (flags|OPf_KIDS|stacked_last
3640                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3641     o->op_private      = private_flags;
3642     o->op_type         = OP_MULTICONCAT;
3643     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3644     cUNOP_AUXo->op_aux = aux;
3645 }
3646
3647
3648 /* do all the final processing on an optree (e.g. running the peephole
3649  * optimiser on it), then attach it to cv (if cv is non-null)
3650  */
3651
3652 static void
3653 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3654 {
3655     OP **startp;
3656
3657     /* XXX for some reason, evals, require and main optrees are
3658      * never attached to their CV; instead they just hang off
3659      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3660      * and get manually freed when appropriate */
3661     if (cv)
3662         startp = &CvSTART(cv);
3663     else
3664         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3665
3666     *startp = start;
3667     optree->op_private |= OPpREFCOUNTED;
3668     OpREFCNT_set(optree, 1);
3669     optimize_optree(optree);
3670     CALL_PEEP(*startp);
3671     finalize_optree(optree);
3672     S_prune_chain_head(startp);
3673
3674     if (cv) {
3675         /* now that optimizer has done its work, adjust pad values */
3676         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3677                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3678     }
3679 }
3680
3681
3682 /*
3683 =for apidoc optimize_optree
3684
3685 This function applies some optimisations to the optree in top-down order.
3686 It is called before the peephole optimizer, which processes ops in
3687 execution order. Note that finalize_optree() also does a top-down scan,
3688 but is called *after* the peephole optimizer.
3689
3690 =cut
3691 */
3692
3693 void
3694 Perl_optimize_optree(pTHX_ OP* o)
3695 {
3696     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3697
3698     ENTER;
3699     SAVEVPTR(PL_curcop);
3700
3701     optimize_op(o);
3702
3703     LEAVE;
3704 }
3705
3706
3707 /* helper for optimize_optree() which optimises one op then recurses
3708  * to optimise any children.
3709  */
3710
3711 STATIC void
3712 S_optimize_op(pTHX_ OP* o)
3713 {
3714     OP *top_op = o;
3715
3716     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3717
3718     while (1) {
3719         OP * next_kid = NULL;
3720
3721         assert(o->op_type != OP_FREED);
3722
3723         switch (o->op_type) {
3724         case OP_NEXTSTATE:
3725         case OP_DBSTATE:
3726             PL_curcop = ((COP*)o);              /* for warnings */
3727             break;
3728
3729
3730         case OP_CONCAT:
3731         case OP_SASSIGN:
3732         case OP_STRINGIFY:
3733         case OP_SPRINTF:
3734             S_maybe_multiconcat(aTHX_ o);
3735             break;
3736
3737         case OP_SUBST:
3738             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3739                 /* we can't assume that op_pmreplroot->op_sibparent == o
3740                  * and that it is thus possible to walk back up the tree
3741                  * past op_pmreplroot. So, although we try to avoid
3742                  * recursing through op trees, do it here. After all,
3743                  * there are unlikely to be many nested s///e's within
3744                  * the replacement part of a s///e.
3745                  */
3746                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3747             }
3748             break;
3749
3750         default:
3751             break;
3752         }
3753
3754         if (o->op_flags & OPf_KIDS)
3755             next_kid = cUNOPo->op_first;
3756
3757         /* if a kid hasn't been nominated to process, continue with the
3758          * next sibling, or if no siblings left, go back to the parent's
3759          * siblings and so on
3760          */
3761         while (!next_kid) {
3762             if (o == top_op)
3763                 return; /* at top; no parents/siblings to try */
3764             if (OpHAS_SIBLING(o))
3765                 next_kid = o->op_sibparent;
3766             else
3767                 o = o->op_sibparent; /*try parent's next sibling */
3768         }
3769
3770       /* this label not yet used. Goto here if any code above sets
3771        * next-kid
3772        get_next_op:
3773        */
3774         o = next_kid;
3775     }
3776 }
3777
3778
3779 /*
3780 =for apidoc finalize_optree
3781
3782 This function finalizes the optree.  Should be called directly after
3783 the complete optree is built.  It does some additional
3784 checking which can't be done in the normal C<ck_>xxx functions and makes
3785 the tree thread-safe.
3786
3787 =cut
3788 */
3789 void
3790 Perl_finalize_optree(pTHX_ OP* o)
3791 {
3792     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3793
3794     ENTER;
3795     SAVEVPTR(PL_curcop);
3796
3797     finalize_op(o);
3798
3799     LEAVE;
3800 }
3801
3802 #ifdef USE_ITHREADS
3803 /* Relocate sv to the pad for thread safety.
3804  * Despite being a "constant", the SV is written to,
3805  * for reference counts, sv_upgrade() etc. */
3806 PERL_STATIC_INLINE void
3807 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3808 {
3809     PADOFFSET ix;
3810     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3811     if (!*svp) return;
3812     ix = pad_alloc(OP_CONST, SVf_READONLY);
3813     SvREFCNT_dec(PAD_SVl(ix));
3814     PAD_SETSV(ix, *svp);
3815     /* XXX I don't know how this isn't readonly already. */
3816     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3817     *svp = NULL;
3818     *targp = ix;
3819 }
3820 #endif
3821
3822 /*
3823 =for apidoc traverse_op_tree
3824
3825 Return the next op in a depth-first traversal of the op tree,
3826 returning NULL when the traversal is complete.
3827
3828 The initial call must supply the root of the tree as both top and o.
3829
3830 For now it's static, but it may be exposed to the API in the future.
3831
3832 =cut
3833 */
3834
3835 STATIC OP*
3836 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3837     OP *sib;
3838
3839     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3840
3841     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3842         return cUNOPo->op_first;
3843     }
3844     else if ((sib = OpSIBLING(o))) {
3845         return sib;
3846     }
3847     else {
3848         OP *parent = o->op_sibparent;
3849         assert(!(o->op_moresib));
3850         while (parent && parent != top) {
3851             OP *sib = OpSIBLING(parent);
3852             if (sib)
3853                 return sib;
3854             parent = parent->op_sibparent;
3855         }
3856
3857         return NULL;
3858     }
3859 }
3860
3861 STATIC void
3862 S_finalize_op(pTHX_ OP* o)
3863 {
3864     OP * const top = o;
3865     PERL_ARGS_ASSERT_FINALIZE_OP;
3866
3867     do {
3868         assert(o->op_type != OP_FREED);
3869
3870         switch (o->op_type) {
3871         case OP_NEXTSTATE:
3872         case OP_DBSTATE:
3873             PL_curcop = ((COP*)o);              /* for warnings */
3874             break;
3875         case OP_EXEC:
3876             if (OpHAS_SIBLING(o)) {
3877                 OP *sib = OpSIBLING(o);
3878                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3879                     && ckWARN(WARN_EXEC)
3880                     && OpHAS_SIBLING(sib))
3881                 {
3882                     const OPCODE type = OpSIBLING(sib)->op_type;
3883                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3884                         const line_t oldline = CopLINE(PL_curcop);
3885                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3886                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3887                             "Statement unlikely to be reached");
3888                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3889                             "\t(Maybe you meant system() when you said exec()?)\n");
3890                         CopLINE_set(PL_curcop, oldline);
3891                     }
3892                 }
3893             }
3894             break;
3895
3896         case OP_GV:
3897             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3898                 GV * const gv = cGVOPo_gv;
3899                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3900                     /* XXX could check prototype here instead of just carping */
3901                     SV * const sv = sv_newmortal();
3902                     gv_efullname3(sv, gv, NULL);
3903                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3904                                 "%" SVf "() called too early to check prototype",
3905                                 SVfARG(sv));
3906                 }
3907             }
3908             break;
3909
3910         case OP_CONST:
3911             if (cSVOPo->op_private & OPpCONST_STRICT)
3912                 no_bareword_allowed(o);
3913 #ifdef USE_ITHREADS
3914             /* FALLTHROUGH */
3915         case OP_HINTSEVAL:
3916             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3917 #endif
3918             break;
3919
3920 #ifdef USE_ITHREADS
3921             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3922         case OP_METHOD_NAMED:
3923         case OP_METHOD_SUPER:
3924         case OP_METHOD_REDIR:
3925         case OP_METHOD_REDIR_SUPER:
3926             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3927             break;
3928 #endif
3929
3930         case OP_HELEM: {
3931             UNOP *rop;
3932             SVOP *key_op;
3933             OP *kid;
3934
3935             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3936                 break;
3937
3938             rop = (UNOP*)((BINOP*)o)->op_first;
3939
3940             goto check_keys;
3941
3942             case OP_HSLICE:
3943                 S_scalar_slice_warning(aTHX_ o);
3944                 /* FALLTHROUGH */
3945
3946             case OP_KVHSLICE:
3947                 kid = OpSIBLING(cLISTOPo->op_first);
3948             if (/* I bet there's always a pushmark... */
3949                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3950                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3951             {
3952                 break;
3953             }
3954
3955             key_op = (SVOP*)(kid->op_type == OP_CONST
3956                              ? kid
3957                              : OpSIBLING(kLISTOP->op_first));
3958
3959             rop = (UNOP*)((LISTOP*)o)->op_last;
3960
3961         check_keys:
3962             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3963                 rop = NULL;
3964             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3965             break;
3966         }
3967         case OP_NULL:
3968             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3969                 break;
3970             /* FALLTHROUGH */
3971         case OP_ASLICE:
3972             S_scalar_slice_warning(aTHX_ o);
3973             break;
3974
3975         case OP_SUBST: {
3976             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3977                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3978             break;
3979         }
3980         default:
3981             break;
3982         }
3983
3984 #ifdef DEBUGGING
3985         if (o->op_flags & OPf_KIDS) {
3986             OP *kid;
3987
3988             /* check that op_last points to the last sibling, and that
3989              * the last op_sibling/op_sibparent field points back to the
3990              * parent, and that the only ops with KIDS are those which are
3991              * entitled to them */
3992             U32 type = o->op_type;
3993             U32 family;
3994             bool has_last;
3995
3996             if (type == OP_NULL) {
3997                 type = o->op_targ;
3998                 /* ck_glob creates a null UNOP with ex-type GLOB
3999                  * (which is a list op. So pretend it wasn't a listop */
4000                 if (type == OP_GLOB)
4001                     type = OP_NULL;
4002             }
4003             family = PL_opargs[type] & OA_CLASS_MASK;
4004
4005             has_last = (   family == OA_BINOP
4006                         || family == OA_LISTOP
4007                         || family == OA_PMOP
4008                         || family == OA_LOOP
4009                        );
4010             assert(  has_last /* has op_first and op_last, or ...
4011                   ... has (or may have) op_first: */
4012                   || family == OA_UNOP
4013                   || family == OA_UNOP_AUX
4014                   || family == OA_LOGOP
4015                   || family == OA_BASEOP_OR_UNOP
4016                   || family == OA_FILESTATOP
4017                   || family == OA_LOOPEXOP
4018                   || family == OA_METHOP
4019                   || type == OP_CUSTOM
4020                   || type == OP_NULL /* new_logop does this */
4021                   );
4022
4023             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
4024                 if (!OpHAS_SIBLING(kid)) {
4025                     if (has_last)
4026                         assert(kid == cLISTOPo->op_last);
4027                     assert(kid->op_sibparent == o);
4028                 }
4029             }
4030         }
4031 #endif
4032     } while (( o = traverse_op_tree(top, o)) != NULL);
4033 }
4034
4035 static void
4036 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4037 {
4038     CV *cv = PL_compcv;
4039     PadnameLVALUE_on(pn);
4040     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4041         cv = CvOUTSIDE(cv);
4042         /* RT #127786: cv can be NULL due to an eval within the DB package
4043          * called from an anon sub - anon subs don't have CvOUTSIDE() set
4044          * unless they contain an eval, but calling eval within DB
4045          * pretends the eval was done in the caller's scope.
4046          */
4047         if (!cv)
4048             break;
4049         assert(CvPADLIST(cv));
4050         pn =
4051            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4052         assert(PadnameLEN(pn));
4053         PadnameLVALUE_on(pn);
4054     }
4055 }
4056
4057 static bool
4058 S_vivifies(const OPCODE type)
4059 {
4060     switch(type) {
4061     case OP_RV2AV:     case   OP_ASLICE:
4062     case OP_RV2HV:     case OP_KVASLICE:
4063     case OP_RV2SV:     case   OP_HSLICE:
4064     case OP_AELEMFAST: case OP_KVHSLICE:
4065     case OP_HELEM:
4066     case OP_AELEM:
4067         return 1;
4068     }
4069     return 0;
4070 }
4071
4072
4073 /* apply lvalue reference (aliasing) context to the optree o.
4074  * E.g. in
4075  *     \($x,$y) = (...)
4076  * o would be the list ($x,$y) and type would be OP_AASSIGN.
4077  * It may descend and apply this to children too, for example in
4078  * \( $cond ? $x, $y) = (...)
4079  */
4080
4081 static void
4082 S_lvref(pTHX_ OP *o, I32 type)
4083 {
4084     dVAR;
4085     OP *kid;
4086     OP * top_op = o;
4087
4088     while (1) {
4089         switch (o->op_type) {
4090         case OP_COND_EXPR:
4091             o = OpSIBLING(cUNOPo->op_first);
4092             continue;
4093
4094         case OP_PUSHMARK:
4095             goto do_next;
4096
4097         case OP_RV2AV:
4098             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4099             o->op_flags |= OPf_STACKED;
4100             if (o->op_flags & OPf_PARENS) {
4101                 if (o->op_private & OPpLVAL_INTRO) {
4102                      yyerror(Perl_form(aTHX_ "Can't modify reference to "
4103                           "localized parenthesized array in list assignment"));
4104                     goto do_next;
4105                 }
4106               slurpy:
4107                 OpTYPE_set(o, OP_LVAVREF);
4108                 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4109                 o->op_flags |= OPf_MOD|OPf_REF;
4110                 goto do_next;
4111             }
4112             o->op_private |= OPpLVREF_AV;
4113             goto checkgv;
4114
4115         case OP_RV2CV:
4116             kid = cUNOPo->op_first;
4117             if (kid->op_type == OP_NULL)
4118                 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4119                     ->op_first;
4120             o->op_private = OPpLVREF_CV;
4121             if (kid->op_type == OP_GV)
4122                 o->op_flags |= OPf_STACKED;
4123             else if (kid->op_type == OP_PADCV) {
4124                 o->op_targ = kid->op_targ;
4125                 kid->op_targ = 0;
4126                 op_free(cUNOPo->op_first);
4127                 cUNOPo->op_first = NULL;
4128                 o->op_flags &=~ OPf_KIDS;
4129             }
4130             else goto badref;
4131             break;
4132
4133         case OP_RV2HV:
4134             if (o->op_flags & OPf_PARENS) {
4135               parenhash:
4136                 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4137                                      "parenthesized hash in list assignment"));
4138                     goto do_next;
4139             }
4140             o->op_private |= OPpLVREF_HV;
4141             /* FALLTHROUGH */
4142         case OP_RV2SV:
4143           checkgv:
4144             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4145             o->op_flags |= OPf_STACKED;
4146             break;
4147
4148         case OP_PADHV:
4149             if (o->op_flags & OPf_PARENS) goto parenhash;
4150             o->op_private |= OPpLVREF_HV;
4151             /* FALLTHROUGH */
4152         case OP_PADSV:
4153             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4154             break;
4155
4156         case OP_PADAV:
4157             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4158             if (o->op_flags & OPf_PARENS) goto slurpy;
4159             o->op_private |= OPpLVREF_AV;
4160             break;
4161
4162         case OP_AELEM:
4163         case OP_HELEM:
4164             o->op_private |= OPpLVREF_ELEM;
4165             o->op_flags   |= OPf_STACKED;
4166             break;
4167
4168         case OP_ASLICE:
4169         case OP_HSLICE:
4170             OpTYPE_set(o, OP_LVREFSLICE);
4171             o->op_private &= OPpLVAL_INTRO;
4172             goto do_next;
4173
4174         case OP_NULL:
4175             if (o->op_flags & OPf_SPECIAL)              /* do BLOCK */
4176                 goto badref;
4177             else if (!(o->op_flags & OPf_KIDS))
4178                 goto do_next;
4179
4180             /* the code formerly only recursed into the first child of
4181              * a non ex-list OP_NULL. if we ever encounter such a null op with
4182              * more than one child, need to decide whether its ok to process
4183              * *all* its kids or not */
4184             assert(o->op_targ == OP_LIST
4185                     || !(OpHAS_SIBLING(cBINOPo->op_first)));
4186             /* FALLTHROUGH */
4187         case OP_LIST:
4188             o = cLISTOPo->op_first;
4189             continue;
4190
4191         case OP_STUB:
4192             if (o->op_flags & OPf_PARENS)
4193                 goto do_next;
4194             /* FALLTHROUGH */
4195         default:
4196           badref:
4197             /* diag_listed_as: Can't modify reference to %s in %s assignment */
4198             yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4199                          o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4200                           ? "do block"
4201                           : OP_DESC(o),
4202                          PL_op_desc[type]));
4203             goto do_next;
4204         }
4205
4206         OpTYPE_set(o, OP_LVREF);
4207         o->op_private &=
4208             OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4209         if (type == OP_ENTERLOOP)
4210             o->op_private |= OPpLVREF_ITER;
4211
4212       do_next:
4213         while (1) {
4214             if (o == top_op)
4215                 return; /* at top; no parents/siblings to try */
4216             if (OpHAS_SIBLING(o)) {
4217                 o = o->op_sibparent;
4218                 break;
4219             }
4220             o = o->op_sibparent; /*try parent's next sibling */
4221         }
4222     } /* while */
4223 }
4224
4225
4226 PERL_STATIC_INLINE bool
4227 S_potential_mod_type(I32 type)
4228 {
4229     /* Types that only potentially result in modification.  */
4230     return type == OP_GREPSTART || type == OP_ENTERSUB
4231         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
4232 }
4233
4234
4235 /*
4236 =for apidoc op_lvalue
4237
4238 Propagate lvalue ("modifiable") context to an op and its children.
4239 C<type> represents the context type, roughly based on the type of op that
4240 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4241 because it has no op type of its own (it is signalled by a flag on
4242 the lvalue op).
4243
4244 This function detects things that can't be modified, such as C<$x+1>, and
4245 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
4246 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4247
4248 It also flags things that need to behave specially in an lvalue context,
4249 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4250
4251 =cut
4252
4253 Perl_op_lvalue_flags() is a non-API lower-level interface to
4254 op_lvalue().  The flags param has these bits:
4255     OP_LVALUE_NO_CROAK:  return rather than croaking on error
4256
4257 */
4258
4259 OP *
4260 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4261 {
4262     dVAR;
4263     OP *top_op = o;
4264
4265     if (!o || (PL_parser && PL_parser->error_count))
4266         return o;
4267
4268     while (1) {
4269     OP *kid;
4270     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4271     int localize = -1;
4272     OP *next_kid = NULL;
4273
4274     if ((o->op_private & OPpTARGET_MY)
4275         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4276     {
4277         goto do_next;
4278     }
4279
4280     /* elements of a list might be in void context because the list is
4281        in scalar context or because they are attribute sub calls */
4282     if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4283         goto do_next;
4284
4285     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4286
4287     switch (o->op_type) {
4288     case OP_UNDEF:
4289         PL_modcount++;
4290         goto do_next;
4291
4292     case OP_STUB:
4293         if ((o->op_flags & OPf_PARENS))
4294             break;
4295         goto nomod;
4296
4297     case OP_ENTERSUB:
4298         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4299             !(o->op_flags & OPf_STACKED)) {
4300             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4301             assert(cUNOPo->op_first->op_type == OP_NULL);
4302             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4303             break;
4304         }
4305         else {                          /* lvalue subroutine call */
4306             o->op_private |= OPpLVAL_INTRO;
4307             PL_modcount = RETURN_UNLIMITED_NUMBER;
4308             if (S_potential_mod_type(type)) {
4309                 o->op_private |= OPpENTERSUB_INARGS;
4310                 break;
4311             }
4312             else {                      /* Compile-time error message: */
4313                 OP *kid = cUNOPo->op_first;
4314                 CV *cv;
4315                 GV *gv;
4316                 SV *namesv;
4317
4318                 if (kid->op_type != OP_PUSHMARK) {
4319                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4320                         Perl_croak(aTHX_
4321                                 "panic: unexpected lvalue entersub "
4322                                 "args: type/targ %ld:%" UVuf,
4323                                 (long)kid->op_type, (UV)kid->op_targ);
4324                     kid = kLISTOP->op_first;
4325                 }
4326                 while (OpHAS_SIBLING(kid))
4327                     kid = OpSIBLING(kid);
4328                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4329                     break;      /* Postpone until runtime */
4330                 }
4331
4332                 kid = kUNOP->op_first;
4333                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4334                     kid = kUNOP->op_first;
4335                 if (kid->op_type == OP_NULL)
4336                     Perl_croak(aTHX_
4337                                "Unexpected constant lvalue entersub "
4338                                "entry via type/targ %ld:%" UVuf,
4339                                (long)kid->op_type, (UV)kid->op_targ);
4340                 if (kid->op_type != OP_GV) {
4341                     break;
4342                 }
4343
4344                 gv = kGVOP_gv;
4345                 cv = isGV(gv)
4346                     ? GvCV(gv)
4347                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4348                         ? MUTABLE_CV(SvRV(gv))
4349                         : NULL;
4350                 if (!cv)
4351                     break;
4352                 if (CvLVALUE(cv))
4353                     break;
4354                 if (flags & OP_LVALUE_NO_CROAK)
4355                     return NULL;
4356
4357                 namesv = cv_name(cv, NULL, 0);
4358                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4359                                      "subroutine call of &%" SVf " in %s",
4360                                      SVfARG(namesv), PL_op_desc[type]),
4361                            SvUTF8(namesv));
4362                 goto do_next;
4363             }
4364         }
4365         /* FALLTHROUGH */
4366     default:
4367       nomod:
4368         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4369         /* grep, foreach, subcalls, refgen */
4370         if (S_potential_mod_type(type))
4371             break;
4372         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4373                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4374                       ? "do block"
4375                       : OP_DESC(o)),
4376                      type ? PL_op_desc[type] : "local"));
4377         goto do_next;
4378
4379     case OP_PREINC:
4380     case OP_PREDEC:
4381     case OP_POW:
4382     case OP_MULTIPLY:
4383     case OP_DIVIDE:
4384     case OP_MODULO:
4385     case OP_ADD:
4386     case OP_SUBTRACT:
4387     case OP_CONCAT:
4388     case OP_LEFT_SHIFT:
4389     case OP_RIGHT_SHIFT:
4390     case OP_BIT_AND:
4391     case OP_BIT_XOR:
4392     case OP_BIT_OR:
4393     case OP_I_MULTIPLY:
4394     case OP_I_DIVIDE:
4395     case OP_I_MODULO:
4396     case OP_I_ADD:
4397     case OP_I_SUBTRACT:
4398         if (!(o->op_flags & OPf_STACKED))
4399             goto nomod;
4400         PL_modcount++;
4401         break;
4402
4403     case OP_REPEAT:
4404         if (o->op_flags & OPf_STACKED) {
4405             PL_modcount++;
4406             break;
4407         }
4408         if (!(o->op_private & OPpREPEAT_DOLIST))
4409             goto nomod;
4410         else {
4411             const I32 mods = PL_modcount;
4412             /* we recurse rather than iterate here because we need to
4413              * calculate and use the delta applied to PL_modcount by the
4414              * first child. So in something like
4415              *     ($x, ($y) x 3) = split;
4416              * split knows that 4 elements are wanted
4417              */
4418             modkids(cBINOPo->op_first, type);
4419             if (type != OP_AASSIGN)
4420                 goto nomod;
4421             kid = cBINOPo->op_last;
4422             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4423                 const IV iv = SvIV(kSVOP_sv);
4424                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4425                     PL_modcount =
4426                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4427             }
4428             else
4429                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4430         }
4431         break;
4432
4433     case OP_COND_EXPR:
4434         localize = 1;
4435         next_kid = OpSIBLING(cUNOPo->op_first);
4436         break;
4437
4438     case OP_RV2AV:
4439     case OP_RV2HV:
4440         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4441            PL_modcount = RETURN_UNLIMITED_NUMBER;
4442            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4443               fiable since some contexts need to know.  */
4444            o->op_flags |= OPf_MOD;
4445            goto do_next;
4446         }
4447         /* FALLTHROUGH */
4448     case OP_RV2GV:
4449         if (scalar_mod_type(o, type))
4450             goto nomod;
4451         ref(cUNOPo->op_first, o->op_type);
4452         /* FALLTHROUGH */
4453     case OP_ASLICE:
4454     case OP_HSLICE:
4455         localize = 1;
4456         /* FALLTHROUGH */
4457     case OP_AASSIGN:
4458         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4459         if (type == OP_LEAVESUBLV && (
4460                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4461              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4462            ))
4463             o->op_private |= OPpMAYBE_LVSUB;
4464         /* FALLTHROUGH */
4465     case OP_NEXTSTATE:
4466     case OP_DBSTATE:
4467        PL_modcount = RETURN_UNLIMITED_NUMBER;
4468         break;
4469
4470     case OP_KVHSLICE:
4471     case OP_KVASLICE:
4472     case OP_AKEYS:
4473         if (type == OP_LEAVESUBLV)
4474             o->op_private |= OPpMAYBE_LVSUB;
4475         goto nomod;
4476
4477     case OP_AVHVSWITCH:
4478         if (type == OP_LEAVESUBLV
4479          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4480             o->op_private |= OPpMAYBE_LVSUB;
4481         goto nomod;
4482
4483     case OP_AV2ARYLEN:
4484         PL_hints |= HINT_BLOCK_SCOPE;
4485         if (type == OP_LEAVESUBLV)
4486             o->op_private |= OPpMAYBE_LVSUB;
4487         PL_modcount++;
4488         break;
4489
4490     case OP_RV2SV:
4491         ref(cUNOPo->op_first, o->op_type);
4492         localize = 1;
4493         /* FALLTHROUGH */
4494     case OP_GV:
4495         PL_hints |= HINT_BLOCK_SCOPE;
4496         /* FALLTHROUGH */
4497     case OP_SASSIGN:
4498     case OP_ANDASSIGN:
4499     case OP_ORASSIGN:
4500     case OP_DORASSIGN:
4501         PL_modcount++;
4502         break;
4503
4504     case OP_AELEMFAST:
4505     case OP_AELEMFAST_LEX:
4506         localize = -1;
4507         PL_modcount++;
4508         break;
4509
4510     case OP_PADAV:
4511     case OP_PADHV:
4512        PL_modcount = RETURN_UNLIMITED_NUMBER;
4513         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4514         {
4515            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4516               fiable since some contexts need to know.  */
4517             o->op_flags |= OPf_MOD;
4518             goto do_next;
4519         }
4520         if (scalar_mod_type(o, type))
4521             goto nomod;
4522         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4523           && type == OP_LEAVESUBLV)
4524             o->op_private |= OPpMAYBE_LVSUB;
4525         /* FALLTHROUGH */
4526     case OP_PADSV:
4527         PL_modcount++;
4528         if (!type) /* local() */
4529             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4530                               PNfARG(PAD_COMPNAME(o->op_targ)));
4531         if (!(o->op_private & OPpLVAL_INTRO)
4532          || (  type != OP_SASSIGN && type != OP_AASSIGN
4533             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4534             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4535         break;
4536
4537     case OP_PUSHMARK:
4538         localize = 0;
4539         break;
4540
4541     case OP_KEYS:
4542         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4543             goto nomod;
4544         goto lvalue_func;
4545     case OP_SUBSTR:
4546         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4547             goto nomod;
4548         /* FALLTHROUGH */
4549     case OP_POS:
4550     case OP_VEC:
4551       lvalue_func:
4552         if (type == OP_LEAVESUBLV)
4553             o->op_private |= OPpMAYBE_LVSUB;
4554         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4555             /* we recurse rather than iterate here because the child
4556              * needs to be processed with a different 'type' parameter */
4557
4558             /* substr and vec */
4559             /* If this op is in merely potential (non-fatal) modifiable
4560                context, then apply OP_ENTERSUB context to
4561                the kid op (to avoid croaking).  Other-
4562                wise pass this op’s own type so the correct op is mentioned
4563                in error messages.  */
4564             op_lvalue(OpSIBLING(cBINOPo->op_first),
4565                       S_potential_mod_type(type)
4566                         ? (I32)OP_ENTERSUB
4567                         : o->op_type);
4568         }
4569         break;
4570
4571     case OP_AELEM:
4572     case OP_HELEM:
4573         ref(cBINOPo->op_first, o->op_type);
4574         if (type == OP_ENTERSUB &&
4575              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4576             o->op_private |= OPpLVAL_DEFER;
4577         if (type == OP_LEAVESUBLV)
4578             o->op_private |= OPpMAYBE_LVSUB;
4579         localize = 1;
4580         PL_modcount++;
4581         break;
4582
4583     case OP_LEAVE:
4584     case OP_LEAVELOOP:
4585         o->op_private |= OPpLVALUE;
4586         /* FALLTHROUGH */
4587     case OP_SCOPE:
4588     case OP_ENTER:
4589     case OP_LINESEQ:
4590         localize = 0;
4591         if (o->op_flags & OPf_KIDS)
4592             next_kid = cLISTOPo->op_last;
4593         break;
4594
4595     case OP_NULL:
4596         localize = 0;
4597         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4598             goto nomod;
4599         else if (!(o->op_flags & OPf_KIDS))
4600             break;
4601
4602         if (o->op_targ != OP_LIST) {
4603             OP *sib = OpSIBLING(cLISTOPo->op_first);
4604             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4605              * that looks like
4606              *
4607              *   null
4608              *      arg
4609              *      trans
4610              *
4611              * compared with things like OP_MATCH which have the argument
4612              * as a child:
4613              *
4614              *   match
4615              *      arg
4616              *
4617              * so handle specially to correctly get "Can't modify" croaks etc
4618              */
4619
4620             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4621             {
4622                 /* this should trigger a "Can't modify transliteration" err */
4623                 op_lvalue(sib, type);
4624             }
4625             next_kid = cBINOPo->op_first;
4626             /* we assume OP_NULLs which aren't ex-list have no more than 2
4627              * children. If this assumption is wrong, increase the scan
4628              * limit below */
4629             assert(   !OpHAS_SIBLING(next_kid)
4630                    || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4631             break;
4632         }
4633         /* FALLTHROUGH */
4634     case OP_LIST:
4635         localize = 0;
4636         next_kid = cLISTOPo->op_first;
4637         break;
4638
4639     case OP_COREARGS:
4640         goto do_next;
4641
4642     case OP_AND:
4643     case OP_OR:
4644         if (type == OP_LEAVESUBLV
4645          || !S_vivifies(cLOGOPo->op_first->op_type))
4646             next_kid = cLOGOPo->op_first;
4647         else if (type == OP_LEAVESUBLV
4648          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4649             next_kid = OpSIBLING(cLOGOPo->op_first);
4650         goto nomod;
4651
4652     case OP_SREFGEN:
4653         if (type == OP_NULL) { /* local */
4654           local_refgen:
4655             if (!FEATURE_MYREF_IS_ENABLED)
4656                 Perl_croak(aTHX_ "The experimental declared_refs "
4657                                  "feature is not enabled");
4658             Perl_ck_warner_d(aTHX_
4659                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4660                     "Declaring references is experimental");
4661             next_kid = cUNOPo->op_first;
4662             goto do_next;
4663         }
4664         if (type != OP_AASSIGN && type != OP_SASSIGN
4665          && type != OP_ENTERLOOP)
4666             goto nomod;
4667         /* Don’t bother applying lvalue context to the ex-list.  */
4668         kid = cUNOPx(cUNOPo->op_first)->op_first;
4669         assert (!OpHAS_SIBLING(kid));
4670         goto kid_2lvref;
4671     case OP_REFGEN:
4672         if (type == OP_NULL) /* local */
4673             goto local_refgen;
4674         if (type != OP_AASSIGN) goto nomod;
4675         kid = cUNOPo->op_first;
4676       kid_2lvref:
4677         {
4678             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4679             S_lvref(aTHX_ kid, type);
4680             if (!PL_parser || PL_parser->error_count == ec) {
4681                 if (!FEATURE_REFALIASING_IS_ENABLED)
4682                     Perl_croak(aTHX_
4683                        "Experimental aliasing via reference not enabled");
4684                 Perl_ck_warner_d(aTHX_
4685                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4686                                 "Aliasing via reference is experimental");
4687             }
4688         }
4689         if (o->op_type == OP_REFGEN)
4690             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4691         op_null(o);
4692         goto do_next;
4693
4694     case OP_SPLIT:
4695         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4696             /* This is actually @array = split.  */
4697             PL_modcount = RETURN_UNLIMITED_NUMBER;
4698             break;
4699         }
4700         goto nomod;
4701
4702     case OP_SCALAR:
4703         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4704         goto nomod;
4705     }
4706
4707     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4708        their argument is a filehandle; thus \stat(".") should not set
4709        it. AMS 20011102 */
4710     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4711         goto do_next;
4712
4713     if (type != OP_LEAVESUBLV)
4714         o->op_flags |= OPf_MOD;
4715
4716     if (type == OP_AASSIGN || type == OP_SASSIGN)
4717         o->op_flags |= OPf_SPECIAL
4718                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4719     else if (!type) { /* local() */
4720         switch (localize) {
4721         case 1:
4722             o->op_private |= OPpLVAL_INTRO;
4723             o->op_flags &= ~OPf_SPECIAL;
4724             PL_hints |= HINT_BLOCK_SCOPE;
4725             break;
4726         case 0:
4727             break;
4728         case -1:
4729             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4730                            "Useless localization of %s", OP_DESC(o));
4731         }
4732     }
4733     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4734              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4735         o->op_flags |= OPf_REF;
4736
4737   do_next:
4738     while (!next_kid) {
4739         if (o == top_op)
4740             return top_op; /* at top; no parents/siblings to try */
4741         if (OpHAS_SIBLING(o)) {
4742             next_kid = o->op_sibparent;
4743             if (!OpHAS_SIBLING(next_kid)) {
4744                 /* a few node types don't recurse into their second child */
4745                 OP *parent = next_kid->op_sibparent;
4746                 I32 ptype  = parent->op_type;
4747                 if (   (ptype == OP_NULL && parent->op_targ != OP_LIST)
4748                     || (   (ptype == OP_AND || ptype == OP_OR)
4749                         && (type != OP_LEAVESUBLV
4750                             && S_vivifies(next_kid->op_type))
4751                        )
4752                 )  {
4753                     /*try parent's next sibling */
4754                     o = parent;
4755                     next_kid =  NULL;
4756                 }
4757             }
4758         }
4759         else
4760             o = o->op_sibparent; /*try parent's next sibling */
4761
4762     }
4763     o = next_kid;
4764
4765     } /* while */
4766
4767 }
4768
4769
4770 STATIC bool
4771 S_scalar_mod_type(const OP *o, I32 type)
4772 {
4773     switch (type) {
4774     case OP_POS:
4775     case OP_SASSIGN:
4776         if (o && o->op_type == OP_RV2GV)
4777             return FALSE;
4778         /* FALLTHROUGH */
4779     case OP_PREINC:
4780     case OP_PREDEC:
4781     case OP_POSTINC:
4782     case OP_POSTDEC:
4783     case OP_I_PREINC:
4784     case OP_I_PREDEC:
4785     case OP_I_POSTINC:
4786     case OP_I_POSTDEC:
4787     case OP_POW:
4788     case OP_MULTIPLY:
4789     case OP_DIVIDE:
4790     case OP_MODULO:
4791     case OP_REPEAT:
4792     case OP_ADD:
4793     case OP_SUBTRACT:
4794     case OP_I_MULTIPLY:
4795     case OP_I_DIVIDE:
4796     case OP_I_MODULO:
4797     case OP_I_ADD:
4798     case OP_I_SUBTRACT:
4799     case OP_LEFT_SHIFT:
4800     case OP_RIGHT_SHIFT:
4801     case OP_BIT_AND:
4802     case OP_BIT_XOR:
4803     case OP_BIT_OR:
4804     case OP_NBIT_AND:
4805     case OP_NBIT_XOR:
4806     case OP_NBIT_OR:
4807     case OP_SBIT_AND:
4808     case OP_SBIT_XOR:
4809     case OP_SBIT_OR:
4810     case OP_CONCAT:
4811     case OP_SUBST:
4812     case OP_TRANS:
4813     case OP_TRANSR:
4814     case OP_READ:
4815     case OP_SYSREAD:
4816     case OP_RECV:
4817     case OP_ANDASSIGN:
4818     case OP_ORASSIGN:
4819     case OP_DORASSIGN:
4820     case OP_VEC:
4821     case OP_SUBSTR:
4822         return TRUE;
4823     default:
4824         return FALSE;
4825     }
4826 }
4827
4828 STATIC bool
4829 S_is_handle_constructor(const OP *o, I32 numargs)
4830 {
4831     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4832
4833     switch (o->op_type) {
4834     case OP_PIPE_OP:
4835     case OP_SOCKPAIR:
4836         if (numargs == 2)
4837             return TRUE;
4838         /* FALLTHROUGH */
4839     case OP_SYSOPEN:
4840     case OP_OPEN:
4841     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4842     case OP_SOCKET:
4843     case OP_OPEN_DIR:
4844     case OP_ACCEPT:
4845         if (numargs == 1)
4846             return TRUE;
4847         /* FALLTHROUGH */
4848     default:
4849         return FALSE;
4850     }
4851 }
4852
4853 static OP *
4854 S_refkids(pTHX_ OP *o, I32 type)
4855 {
4856     if (o && o->op_flags & OPf_KIDS) {
4857         OP *kid;
4858         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4859             ref(kid, type);
4860     }
4861     return o;
4862 }
4863
4864
4865 /* Apply reference (autovivification) context to the subtree at o.
4866  * For example in
4867  *     push @{expression}, ....;
4868  * o will be the head of 'expression' and type will be OP_RV2AV.
4869  * It marks the op o (or a suitable child) as autovivifying, e.g. by
4870  * setting  OPf_MOD.
4871  * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4872  * set_op_ref is true.
4873  *
4874  * Also calls scalar(o).
4875  */
4876
4877 OP *
4878 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4879 {
4880     dVAR;
4881     OP * top_op = o;
4882
4883     PERL_ARGS_ASSERT_DOREF;
4884
4885     if (PL_parser && PL_parser->error_count)
4886         return o;
4887
4888     while (1) {
4889         switch (o->op_type) {
4890         case OP_ENTERSUB:
4891             if ((type == OP_EXISTS || type == OP_DEFINED) &&
4892                 !(o->op_flags & OPf_STACKED)) {
4893                 OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4894                 assert(cUNOPo->op_first->op_type == OP_NULL);
4895                 /* disable pushmark */
4896                 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4897                 o->op_flags |= OPf_SPECIAL;
4898             }
4899             else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4900                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4901                                   : type == OP_RV2HV ? OPpDEREF_HV
4902                                   : OPpDEREF_SV);
4903                 o->op_flags |= OPf_MOD;
4904             }
4905
4906             break;
4907
4908         case OP_COND_EXPR:
4909             o = OpSIBLING(cUNOPo->op_first);
4910             continue;
4911
4912         case OP_RV2SV:
4913             if (type == OP_DEFINED)
4914                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
4915             /* FALLTHROUGH */
4916         case OP_PADSV:
4917             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4918                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4919                                   : type == OP_RV2HV ? OPpDEREF_HV
4920                                   : OPpDEREF_SV);
4921                 o->op_flags |= OPf_MOD;
4922             }
4923             if (o->op_flags & OPf_KIDS) {
4924                 type = o->op_type;
4925                 o = cUNOPo->op_first;
4926                 continue;
4927             }
4928             break;
4929
4930         case OP_RV2AV:
4931         case OP_RV2HV:
4932             if (set_op_ref)
4933                 o->op_flags |= OPf_REF;
4934             /* FALLTHROUGH */
4935         case OP_RV2GV:
4936             if (type == OP_DEFINED)
4937                 o->op_flags |= OPf_SPECIAL;             /* don't create GV */
4938             type = o->op_type;
4939             o = cUNOPo->op_first;
4940             continue;
4941
4942         case OP_PADAV:
4943         case OP_PADHV:
4944             if (set_op_ref)
4945                 o->op_flags |= OPf_REF;
4946             break;
4947
4948         case OP_SCALAR:
4949         case OP_NULL:
4950             if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4951                 break;
4952              o = cBINOPo->op_first;
4953             continue;
4954
4955         case OP_AELEM:
4956         case OP_HELEM:
4957             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4958                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4959                                   : type == OP_RV2HV ? OPpDEREF_HV
4960                                   : OPpDEREF_SV);
4961                 o->op_flags |= OPf_MOD;
4962             }
4963             type = o->op_type;
4964             o = cBINOPo->op_first;
4965             continue;;
4966
4967         case OP_SCOPE:
4968         case OP_LEAVE:
4969             set_op_ref = FALSE;
4970             /* FALLTHROUGH */
4971         case OP_ENTER:
4972         case OP_LIST:
4973             if (!(o->op_flags & OPf_KIDS))
4974                 break;
4975             o = cLISTOPo->op_last;
4976             continue;
4977
4978         default:
4979             break;
4980         } /* switch */
4981
4982         while (1) {
4983             if (o == top_op)
4984                 return scalar(top_op); /* at top; no parents/siblings to try */
4985             if (OpHAS_SIBLING(o)) {
4986                 o = o->op_sibparent;
4987                 /* Normally skip all siblings and go straight to the parent;
4988                  * the only op that requires two children to be processed
4989                  * is OP_COND_EXPR */
4990                 if (!OpHAS_SIBLING(o)
4991                         && o->op_sibparent->op_type == OP_COND_EXPR)
4992                     break;
4993                 continue;
4994             }
4995             o = o->op_sibparent; /*try parent's next sibling */
4996         }
4997     } /* while */
4998 }
4999
5000
5001 STATIC OP *
5002 S_dup_attrlist(pTHX_ OP *o)
5003 {
5004     OP *rop;
5005
5006     PERL_ARGS_ASSERT_DUP_ATTRLIST;
5007
5008     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
5009      * where the first kid is OP_PUSHMARK and the remaining ones
5010      * are OP_CONST.  We need to push the OP_CONST values.
5011      */
5012     if (o->op_type == OP_CONST)
5013         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
5014     else {
5015         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5016         rop = NULL;
5017         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
5018             if (o->op_type == OP_CONST)
5019                 rop = op_append_elem(OP_LIST, rop,
5020                                   newSVOP(OP_CONST, o->op_flags,
5021                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
5022         }
5023     }
5024     return rop;
5025 }
5026
5027 STATIC void
5028 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
5029 {
5030     PERL_ARGS_ASSERT_APPLY_ATTRS;
5031     {
5032         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
5033
5034         /* fake up C<use attributes $pkg,$rv,@attrs> */
5035
5036 #define ATTRSMODULE "attributes"
5037 #define ATTRSMODULE_PM "attributes.pm"
5038
5039         Perl_load_module(
5040           aTHX_ PERL_LOADMOD_IMPORT_OPS,
5041           newSVpvs(ATTRSMODULE),
5042           NULL,
5043           op_prepend_elem(OP_LIST,
5044                           newSVOP(OP_CONST, 0, stashsv),
5045                           op_prepend_elem(OP_LIST,
5046                                           newSVOP(OP_CONST, 0,
5047                                                   newRV(target)),
5048                                           dup_attrlist(attrs))));
5049     }
5050 }
5051
5052 STATIC void
5053 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5054 {
5055     OP *pack, *imop, *arg;
5056     SV *meth, *stashsv, **svp;
5057
5058     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5059
5060     if (!attrs)
5061         return;
5062
5063     assert(target->op_type == OP_PADSV ||
5064            target->op_type == OP_PADHV ||
5065            target->op_type == OP_PADAV);
5066
5067     /* Ensure that attributes.pm is loaded. */
5068     /* Don't force the C<use> if we don't need it. */
5069     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5070     if (svp && *svp != &PL_sv_undef)
5071         NOOP;   /* already in %INC */
5072     else
5073         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5074                                newSVpvs(ATTRSMODULE), NULL);
5075
5076     /* Need package name for method call. */
5077     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5078
5079     /* Build up the real arg-list. */
5080     stashsv = newSVhek(HvNAME_HEK(stash));
5081
5082     arg = newOP(OP_PADSV, 0);
5083     arg->op_targ = target->op_targ;
5084     arg = op_prepend_elem(OP_LIST,
5085                        newSVOP(OP_CONST, 0, stashsv),
5086                        op_prepend_elem(OP_LIST,
5087                                     newUNOP(OP_REFGEN, 0,
5088                                             arg),
5089                                     dup_attrlist(attrs)));
5090
5091     /* Fake up a method call to import */
5092     meth = newSVpvs_share("import");
5093     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5094                    op_append_elem(OP_LIST,
5095                                op_prepend_elem(OP_LIST, pack, arg),
5096                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5097
5098     /* Combine the ops. */
5099     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5100 }
5101
5102 /*
5103 =notfor apidoc apply_attrs_string
5104
5105 Attempts to apply a list of attributes specified by the C<attrstr> and
5106 C<len> arguments to the subroutine identified by the C<cv> argument which
5107 is expected to be associated with the package identified by the C<stashpv>
5108 argument (see L<attributes>).  It gets this wrong, though, in that it
5109 does not correctly identify the boundaries of the individual attribute
5110 specifications within C<attrstr>.  This is not really intended for the
5111 public API, but has to be listed here for systems such as AIX which
5112 need an explicit export list for symbols.  (It's called from XS code
5113 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
5114 to respect attribute syntax properly would be welcome.
5115
5116 =cut
5117 */
5118
5119 void
5120 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5121                         const char *attrstr, STRLEN len)
5122 {
5123     OP *attrs = NULL;
5124
5125     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5126
5127     if (!len) {
5128         len = strlen(attrstr);
5129     }
5130
5131     while (len) {
5132         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5133         if (len) {
5134             const char * const sstr = attrstr;
5135             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5136             attrs = op_append_elem(OP_LIST, attrs,
5137                                 newSVOP(OP_CONST, 0,
5138                                         newSVpvn(sstr, attrstr-sstr)));
5139         }
5140     }
5141
5142     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5143                      newSVpvs(ATTRSMODULE),
5144                      NULL, op_prepend_elem(OP_LIST,
5145                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5146                                   op_prepend_elem(OP_LIST,
5147                                                newSVOP(OP_CONST, 0,
5148                                                        newRV(MUTABLE_SV(cv))),
5149                                                attrs)));
5150 }
5151
5152 STATIC void
5153 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5154                         bool curstash)
5155 {
5156     OP *new_proto = NULL;
5157     STRLEN pvlen;
5158     char *pv;
5159     OP *o;
5160
5161     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5162
5163     if (!*attrs)
5164         return;
5165
5166     o = *attrs;
5167     if (o->op_type == OP_CONST) {
5168         pv = SvPV(cSVOPo_sv, pvlen);
5169         if (memBEGINs(pv, pvlen, "prototype(")) {
5170             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5171             SV ** const tmpo = cSVOPx_svp(o);
5172             SvREFCNT_dec(cSVOPo_sv);
5173             *tmpo = tmpsv;
5174             new_proto = o;
5175             *attrs = NULL;
5176         }
5177     } else if (o->op_type == OP_LIST) {
5178         OP * lasto;
5179         assert(o->op_flags & OPf_KIDS);
5180         lasto = cLISTOPo->op_first;
5181         assert(lasto->op_type == OP_PUSHMARK);
5182         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5183             if (o->op_type == OP_CONST) {
5184                 pv = SvPV(cSVOPo_sv, pvlen);
5185                 if (memBEGINs(pv, pvlen, "prototype(")) {
5186                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5187                     SV ** const tmpo = cSVOPx_svp(o);
5188                     SvREFCNT_dec(cSVOPo_sv);
5189                     *tmpo = tmpsv;
5190                     if (new_proto && ckWARN(WARN_MISC)) {
5191                         STRLEN new_len;
5192                         const char * newp = SvPV(cSVOPo_sv, new_len);
5193                         Perl_warner(aTHX_ packWARN(WARN_MISC),
5194                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5195                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5196                         op_free(new_proto);
5197                     }
5198                     else if (new_proto)
5199                         op_free(new_proto);
5200                     new_proto = o;
5201                     /* excise new_proto from the list */
5202                     op_sibling_splice(*attrs, lasto, 1, NULL);
5203                     o = lasto;
5204                     continue;
5205                 }
5206             }
5207             lasto = o;
5208         }
5209         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5210            would get pulled in with no real need */
5211         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5212             op_free(*attrs);
5213             *attrs = NULL;
5214         }
5215     }
5216
5217     if (new_proto) {
5218         SV *svname;
5219         if (isGV(name)) {
5220             svname = sv_newmortal();
5221             gv_efullname3(svname, name, NULL);
5222         }
5223         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5224             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5225         else
5226             svname = (SV *)name;
5227         if (ckWARN(WARN_ILLEGALPROTO))
5228             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5229                                  curstash);
5230         if (*proto && ckWARN(WARN_PROTOTYPE)) {
5231             STRLEN old_len, new_len;
5232             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5233             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5234
5235             if (curstash && svname == (SV *)name
5236              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5237                 svname = sv_2mortal(newSVsv(PL_curstname));
5238                 sv_catpvs(svname, "::");
5239                 sv_catsv(svname, (SV *)name);
5240             }
5241
5242             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5243                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5244                 " in %" SVf,
5245                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5246                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5247                 SVfARG(svname));
5248         }
5249         if (*proto)
5250             op_free(*proto);
5251         *proto = new_proto;
5252     }
5253 }
5254
5255 static void
5256 S_cant_declare(pTHX_ OP *o)
5257 {
5258     if (o->op_type == OP_NULL
5259      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5260         o = cUNOPo->op_first;
5261     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5262                              o->op_type == OP_NULL
5263                                && o->op_flags & OPf_SPECIAL
5264                                  ? "do block"
5265                                  : OP_DESC(o),
5266                              PL_parser->in_my == KEY_our   ? "our"   :
5267                              PL_parser->in_my == KEY_state ? "state" :
5268                                                              "my"));
5269 }
5270
5271 STATIC OP *
5272 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5273 {
5274     I32 type;
5275     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5276
5277     PERL_ARGS_ASSERT_MY_KID;
5278
5279     if (!o || (PL_parser && PL_parser->error_count))
5280         return o;
5281
5282     type = o->op_type;
5283
5284     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5285         OP *kid;
5286         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5287             my_kid(kid, attrs, imopsp);
5288         return o;
5289     } else if (type == OP_UNDEF || type == OP_STUB) {
5290         return o;
5291     } else if (type == OP_RV2SV ||      /* "our" declaration */
5292                type == OP_RV2AV ||
5293                type == OP_RV2HV) {
5294         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5295             S_cant_declare(aTHX_ o);
5296         } else if (attrs) {
5297             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5298             assert(PL_parser);
5299             PL_parser->in_my = FALSE;
5300             PL_parser->in_my_stash = NULL;
5301             apply_attrs(GvSTASH(gv),
5302                         (type == OP_RV2SV ? GvSVn(gv) :
5303                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5304                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5305                         attrs);
5306         }
5307         o->op_private |= OPpOUR_INTRO;
5308         return o;
5309     }
5310     else if (type == OP_REFGEN || type == OP_SREFGEN) {
5311         if (!FEATURE_MYREF_IS_ENABLED)
5312             Perl_croak(aTHX_ "The experimental declared_refs "
5313                              "feature is not enabled");
5314         Perl_ck_warner_d(aTHX_
5315              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5316             "Declaring references is experimental");
5317         /* Kid is a nulled OP_LIST, handled above.  */
5318         my_kid(cUNOPo->op_first, attrs, imopsp);
5319         return o;
5320     }
5321     else if (type != OP_PADSV &&
5322              type != OP_PADAV &&
5323              type != OP_PADHV &&
5324              type != OP_PUSHMARK)
5325     {
5326         S_cant_declare(aTHX_ o);
5327         return o;
5328     }
5329     else if (attrs && type != OP_PUSHMARK) {
5330         HV *stash;
5331
5332         assert(PL_parser);
5333         PL_parser->in_my = FALSE;
5334         PL_parser->in_my_stash = NULL;
5335
5336         /* check for C<my Dog $spot> when deciding package */
5337         stash = PAD_COMPNAME_TYPE(o->op_targ);
5338         if (!stash)
5339             stash = PL_curstash;
5340         apply_attrs_my(stash, o, attrs, imopsp);
5341     }
5342     o->op_flags |= OPf_MOD;
5343     o->op_private |= OPpLVAL_INTRO;
5344     if (stately)
5345         o->op_private |= OPpPAD_STATE;
5346     return o;
5347 }
5348
5349 OP *
5350 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5351 {
5352     OP *rops;
5353     int maybe_scalar = 0;
5354
5355     PERL_ARGS_ASSERT_MY_ATTRS;
5356
5357 /* [perl #17376]: this appears to be premature, and results in code such as
5358    C< our(%x); > executing in list mode rather than void mode */
5359 #if 0
5360     if (o->op_flags & OPf_PARENS)
5361         list(o);
5362     else
5363         maybe_scalar = 1;
5364 #else
5365     maybe_scalar = 1;
5366 #endif
5367     if (attrs)
5368         SAVEFREEOP(attrs);
5369     rops = NULL;
5370     o = my_kid(o, attrs, &rops);
5371     if (rops) {
5372         if (maybe_scalar && o->op_type == OP_PADSV) {
5373             o = scalar(op_append_list(OP_LIST, rops, o));
5374             o->op_private |= OPpLVAL_INTRO;
5375         }
5376         else {
5377             /* The listop in rops might have a pushmark at the beginning,
5378                which will mess up list assignment. */
5379             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5380             if (rops->op_type == OP_LIST &&
5381                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5382             {
5383                 OP * const pushmark = lrops->op_first;
5384                 /* excise pushmark */
5385                 op_sibling_splice(rops, NULL, 1, NULL);
5386                 op_free(pushmark);
5387             }
5388             o = op_append_list(OP_LIST, o, rops);
5389         }
5390     }
5391     PL_parser->in_my = FALSE;
5392     PL_parser->in_my_stash = NULL;
5393     return o;
5394 }
5395
5396 OP *
5397 Perl_sawparens(pTHX_ OP *o)
5398 {
5399     PERL_UNUSED_CONTEXT;
5400     if (o)
5401         o->op_flags |= OPf_PARENS;
5402     return o;
5403 }
5404
5405 OP *
5406 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5407 {
5408     OP *o;
5409     bool ismatchop = 0;
5410     const OPCODE ltype = left->op_type;
5411     const OPCODE rtype = right->op_type;
5412
5413     PERL_ARGS_ASSERT_BIND_MATCH;
5414
5415     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5416           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5417     {
5418       const char * const desc
5419           = PL_op_desc[(
5420                           rtype == OP_SUBST || rtype == OP_TRANS
5421                        || rtype == OP_TRANSR
5422                        )
5423                        ? (int)rtype : OP_MATCH];
5424       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5425       SV * const name =
5426         S_op_varname(aTHX_ left);
5427       if (name)
5428         Perl_warner(aTHX_ packWARN(WARN_MISC),
5429              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5430              desc, SVfARG(name), SVfARG(name));
5431       else {
5432         const char * const sample = (isary
5433              ? "@array" : "%hash");
5434         Perl_warner(aTHX_ packWARN(WARN_MISC),
5435              "Applying %s to %s will act on scalar(%s)",
5436              desc, sample, sample);
5437       }
5438     }
5439
5440     if (rtype == OP_CONST &&
5441         cSVOPx(right)->op_private & OPpCONST_BARE &&
5442         cSVOPx(right)->op_private & OPpCONST_STRICT)
5443     {
5444         no_bareword_allowed(right);
5445     }
5446
5447     /* !~ doesn't make sense with /r, so error on it for now */
5448     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5449         type == OP_NOT)
5450         /* diag_listed_as: Using !~ with %s doesn't make sense */
5451         yyerror("Using !~ with s///r doesn't make sense");
5452     if (rtype == OP_TRANSR && type == OP_NOT)
5453         /* diag_listed_as: Using !~ with %s doesn't make sense */
5454         yyerror("Using !~ with tr///r doesn't make sense");
5455
5456     ismatchop = (rtype == OP_MATCH ||
5457                  rtype == OP_SUBST ||
5458                  rtype == OP_TRANS || rtype == OP_TRANSR)
5459              && !(right->op_flags & OPf_SPECIAL);
5460     if (ismatchop && right->op_private & OPpTARGET_MY) {
5461         right->op_targ = 0;
5462         right->op_private &= ~OPpTARGET_MY;
5463     }
5464     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5465         if (left->op_type == OP_PADSV
5466          && !(left->op_private & OPpLVAL_INTRO))
5467         {
5468             right->op_targ = left->op_targ;
5469             op_free(left);
5470             o = right;
5471         }
5472         else {
5473             right->op_flags |= OPf_STACKED;
5474             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5475             ! (rtype == OP_TRANS &&
5476                right->op_private & OPpTRANS_IDENTICAL) &&
5477             ! (rtype == OP_SUBST &&
5478                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5479                 left = op_lvalue(left, rtype);
5480             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5481                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5482             else
5483                 o = op_prepend_elem(rtype, scalar(left), right);
5484         }
5485         if (type == OP_NOT)
5486             return newUNOP(OP_NOT, 0, scalar(o));
5487         return o;
5488     }
5489     else
5490         return bind_match(type, left,
5491                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5492 }
5493
5494 OP *
5495 Perl_invert(pTHX_ OP *o)
5496 {
5497     if (!o)
5498         return NULL;
5499     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5500 }
5501
5502 OP *
5503 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
5504 {
5505     BINOP *bop;
5506     OP *op;
5507
5508     if (!left)
5509         left = newOP(OP_NULL, 0);
5510     if (!right)
5511         right = newOP(OP_NULL, 0);
5512     scalar(left);
5513     scalar(right);
5514     NewOp(0, bop, 1, BINOP);
5515     op = (OP*)bop;
5516     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5517     OpTYPE_set(op, type);
5518     cBINOPx(op)->op_flags = OPf_KIDS;
5519     cBINOPx(op)->op_private = 2;
5520     cBINOPx(op)->op_first = left;
5521     cBINOPx(op)->op_last = right;
5522     OpMORESIB_set(left, right);
5523     OpLASTSIB_set(right, op);
5524     return op;
5525 }
5526
5527 OP *
5528 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5529 {
5530     BINOP *bop;
5531     OP *op;
5532
5533     PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5534     if (!right)
5535         right = newOP(OP_NULL, 0);
5536     scalar(right);
5537     NewOp(0, bop, 1, BINOP);
5538     op = (OP*)bop;
5539     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5540     OpTYPE_set(op, type);
5541     if (ch->op_type != OP_NULL) {
5542         UNOP *lch;
5543         OP *nch, *cleft, *cright;
5544         NewOp(0, lch, 1, UNOP);
5545         nch = (OP*)lch;
5546         OpTYPE_set(nch, OP_NULL);
5547         nch->op_flags = OPf_KIDS;
5548         cleft = cBINOPx(ch)->op_first;
5549         cright = cBINOPx(ch)->op_last;
5550         cBINOPx(ch)->op_first = NULL;
5551         cBINOPx(ch)->op_last = NULL;
5552         cBINOPx(ch)->op_private = 0;
5553         cBINOPx(ch)->op_flags = 0;
5554         cUNOPx(nch)->op_first = cright;
5555         OpMORESIB_set(cright, ch);
5556         OpMORESIB_set(ch, cleft);
5557         OpLASTSIB_set(cleft, nch);
5558         ch = nch;
5559     }
5560     OpMORESIB_set(right, op);
5561     OpMORESIB_set(op, cUNOPx(ch)->op_first);
5562     cUNOPx(ch)->op_first = right;
5563     return ch;
5564 }
5565
5566 OP *
5567 Perl_cmpchain_finish(pTHX_ OP *ch)
5568 {
5569     PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5570     if (ch->op_type != OP_NULL) {
5571         OPCODE cmpoptype = ch->op_type;
5572         ch = CHECKOP(cmpoptype, ch);
5573         if(!ch->op_next && ch->op_type == cmpoptype)
5574             ch = fold_constants(op_integerize(op_std_init(ch)));
5575         return ch;
5576     } else {
5577         OP *condop = NULL;
5578         OP *rightarg = cUNOPx(ch)->op_first;
5579         cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5580         OpLASTSIB_set(rightarg, NULL);
5581         while (1) {
5582             OP *cmpop = cUNOPx(ch)->op_first;
5583             OP *leftarg = OpSIBLING(cmpop);
5584             OPCODE cmpoptype = cmpop->op_type;
5585             OP *nextrightarg;
5586             bool is_last;
5587             is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5588             OpLASTSIB_set(cmpop, NULL);
5589             OpLASTSIB_set(leftarg, NULL);
5590             if (is_last) {
5591                 ch->op_flags = 0;
5592                 op_free(ch);
5593                 nextrightarg = NULL;
5594             } else {
5595                 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5596                 leftarg = newOP(OP_NULL, 0);
5597             }
5598             cBINOPx(cmpop)->op_first = leftarg;
5599             cBINOPx(cmpop)->op_last = rightarg;
5600             OpMORESIB_set(leftarg, rightarg);
5601             OpLASTSIB_set(rightarg, cmpop);
5602             cmpop->op_flags = OPf_KIDS;
5603             cmpop->op_private = 2;
5604             cmpop = CHECKOP(cmpoptype, cmpop);
5605             if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5606                 cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
5607             condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5608                         cmpop;
5609             if (!nextrightarg)
5610                 return condop;
5611             rightarg = nextrightarg;
5612         }
5613     }
5614 }
5615
5616 /*
5617 =for apidoc op_scope
5618
5619 Wraps up an op tree with some additional ops so that at runtime a dynamic
5620 scope will be created.  The original ops run in the new dynamic scope,
5621 and then, provided that they exit normally, the scope will be unwound.
5622 The additional ops used to create and unwind the dynamic scope will
5623 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5624 instead if the ops are simple enough to not need the full dynamic scope
5625 structure.
5626
5627 =cut
5628 */
5629
5630 OP *
5631 Perl_op_scope(pTHX_ OP *o)
5632 {
5633     dVAR;
5634     if (o) {
5635         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5636             o = op_prepend_elem(OP_LINESEQ,
5637                     newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5638             OpTYPE_set(o, OP_LEAVE);
5639         }
5640         else if (o->op_type == OP_LINESEQ) {
5641             OP *kid;
5642             OpTYPE_set(o, OP_SCOPE);
5643             kid = ((LISTOP*)o)->op_first;
5644             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5645                 op_null(kid);
5646
5647                 /* The following deals with things like 'do {1 for 1}' */
5648                 kid = OpSIBLING(kid);
5649                 if (kid &&
5650                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5651                     op_null(kid);
5652             }
5653         }
5654         else
5655             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5656     }
5657     return o;
5658 }
5659
5660 OP *
5661 Perl_op_unscope(pTHX_ OP *o)
5662 {
5663     if (o && o->op_type == OP_LINESEQ) {
5664         OP *kid = cLISTOPo->op_first;
5665         for(; kid; kid = OpSIBLING(kid))
5666             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5667                 op_null(kid);
5668     }
5669     return o;
5670 }
5671
5672 /*
5673 =for apidoc block_start
5674
5675 Handles compile-time scope entry.
5676 Arranges for hints to be restored on block
5677 exit and also handles pad sequence numbers to make lexical variables scope
5678 right.  Returns a savestack index for use with C<block_end>.
5679
5680 =cut
5681 */
5682
5683 int
5684 Perl_block_start(pTHX_ int full)
5685 {
5686     const int retval = PL_savestack_ix;
5687
5688     PL_compiling.cop_seq = PL_cop_seqmax;
5689     COP_SEQMAX_INC;
5690     pad_block_start(full);
5691     SAVEHINTS();
5692     PL_hints &= ~HINT_BLOCK_SCOPE;
5693     SAVECOMPILEWARNINGS();
5694     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5695     SAVEI32(PL_compiling.cop_seq);
5696     PL_compiling.cop_seq = 0;
5697
5698     CALL_BLOCK_HOOKS(bhk_start, full);
5699
5700     return retval;
5701 }
5702
5703 /*
5704 =for apidoc block_end
5705
5706 Handles compile-time scope exit.  C<floor>
5707 is the savestack index returned by
5708 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5709 possibly modified.
5710
5711 =cut
5712 */
5713
5714 OP*
5715 Perl_block_end(pTHX_ I32 floor, OP *seq)
5716 {
5717     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5718     OP* retval = scalarseq(seq);
5719     OP *o;
5720
5721     /* XXX Is the null PL_parser check necessary here? */
5722     assert(PL_parser); /* Let’s find out under debugging builds.  */
5723     if (PL_parser && PL_parser->parsed_sub) {
5724         o = newSTATEOP(0, NULL, NULL);
5725         op_null(o);
5726         retval = op_append_elem(OP_LINESEQ, retval, o);
5727     }
5728
5729     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5730
5731     LEAVE_SCOPE(floor);
5732     if (needblockscope)
5733         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5734     o = pad_leavemy();
5735
5736     if (o) {
5737         /* pad_leavemy has created a sequence of introcv ops for all my
5738            subs declared in the block.  We have to replicate that list with
5739            clonecv ops, to deal with this situation:
5740
5741                sub {
5742                    my sub s1;
5743                    my sub s2;
5744                    sub s1 { state sub foo { \&s2 } }
5745                }->()
5746
5747            Originally, I was going to have introcv clone the CV and turn
5748            off the stale flag.  Since &s1 is declared before &s2, the
5749            introcv op for &s1 is executed (on sub entry) before the one for
5750            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5751            cloned, since it is a state sub) closes over &s2 and expects
5752            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5753            then &s2 is still marked stale.  Since &s1 is not active, and
5754            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5755            ble will not stay shared’ warning.  Because it is the same stub
5756            that will be used when the introcv op for &s2 is executed, clos-
5757            ing over it is safe.  Hence, we have to turn off the stale flag
5758            on all lexical subs in the block before we clone any of them.
5759            Hence, having introcv clone the sub cannot work.  So we create a
5760            list of ops like this:
5761
5762                lineseq
5763                   |
5764                   +-- introcv
5765                   |
5766                   +-- introcv
5767                   |
5768                   +-- introcv
5769                   |
5770                   .
5771                   .
5772                   .
5773                   |
5774                   +-- clonecv
5775                   |
5776                   +-- clonecv
5777                   |
5778                   +-- clonecv
5779                   |
5780                   .
5781                   .
5782                   .
5783          */
5784         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5785         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5786         for (;; kid = OpSIBLING(kid)) {
5787             OP *newkid = newOP(OP_CLONECV, 0);
5788             newkid->op_targ = kid->op_targ;
5789             o = op_append_elem(OP_LINESEQ, o, newkid);
5790             if (kid == last) break;
5791         }
5792         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5793     }
5794
5795     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5796
5797     return retval;
5798 }
5799
5800 /*
5801 =head1 Compile-time scope hooks
5802
5803 =for apidoc blockhook_register
5804
5805 Register a set of hooks to be called when the Perl lexical scope changes
5806 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5807
5808 =cut
5809 */
5810
5811 void
5812 Perl_blockhook_register(pTHX_ BHK *hk)
5813 {
5814     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5815
5816     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5817 }
5818
5819 void
5820 Perl_newPROG(pTHX_ OP *o)
5821 {
5822     OP *start;
5823
5824     PERL_ARGS_ASSERT_NEWPROG;
5825
5826     if (PL_in_eval) {
5827         PERL_CONTEXT *cx;
5828         I32 i;
5829         if (PL_eval_root)
5830                 return;
5831         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5832                                ((PL_in_eval & EVAL_KEEPERR)
5833                                 ? OPf_SPECIAL : 0), o);
5834
5835         cx = CX_CUR();
5836         assert(CxTYPE(cx) == CXt_EVAL);
5837
5838         if ((cx->blk_gimme & G_WANT) == G_VOID)
5839             scalarvoid(PL_eval_root);
5840         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5841             list(PL_eval_root);
5842         else
5843             scalar(PL_eval_root);
5844
5845         start = op_linklist(PL_eval_root);
5846         PL_eval_root->op_next = 0;
5847         i = PL_savestack_ix;
5848         SAVEFREEOP(o);
5849         ENTER;
5850         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5851         LEAVE;
5852         PL_savestack_ix = i;
5853     }
5854     else {
5855         if (o->op_type == OP_STUB) {
5856             /* This block is entered if nothing is compiled for the main
5857                program. This will be the case for an genuinely empty main
5858                program, or one which only has BEGIN blocks etc, so already
5859                run and freed.
5860
5861                Historically (5.000) the guard above was !o. However, commit
5862                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5863                c71fccf11fde0068, changed perly.y so that newPROG() is now
5864                called with the output of block_end(), which returns a new
5865                OP_STUB for the case of an empty optree. ByteLoader (and
5866                maybe other things) also take this path, because they set up
5867                PL_main_start and PL_main_root directly, without generating an
5868                optree.
5869
5870                If the parsing the main program aborts (due to parse errors,
5871                or due to BEGIN or similar calling exit), then newPROG()
5872                isn't even called, and hence this code path and its cleanups
5873                are skipped. This shouldn't make a make a difference:
5874                * a non-zero return from perl_parse is a failure, and
5875                  perl_destruct() should be called immediately.
5876                * however, if exit(0) is called during the parse, then
5877                  perl_parse() returns 0, and perl_run() is called. As
5878                  PL_main_start will be NULL, perl_run() will return
5879                  promptly, and the exit code will remain 0.
5880             */
5881
5882             PL_comppad_name = 0;
5883             PL_compcv = 0;
5884             S_op_destroy(aTHX_ o);
5885             return;
5886         }
5887         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5888         PL_curcop = &PL_compiling;
5889         start = LINKLIST(PL_main_root);
5890         PL_main_root->op_next = 0;
5891         S_process_optree(aTHX_ NULL, PL_main_root, start);
5892         if (!PL_parser->error_count)
5893             /* on error, leave CV slabbed so that ops left lying around
5894              * will eb cleaned up. Else unslab */
5895             cv_forget_slab(PL_compcv);
5896         PL_compcv = 0;
5897
5898         /* Register with debugger */
5899         if (PERLDB_INTER) {
5900             CV * const cv = get_cvs("DB::postponed", 0);
5901             if (cv) {
5902                 dSP;
5903                 PUSHMARK(SP);
5904                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5905                 PUTBACK;
5906                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5907             }
5908         }
5909     }
5910 }
5911
5912 OP *
5913 Perl_localize(pTHX_ OP *o, I32 lex)
5914 {
5915     PERL_ARGS_ASSERT_LOCALIZE;
5916
5917     if (o->op_flags & OPf_PARENS)
5918 /* [perl #17376]: this appears to be premature, and results in code such as
5919    C< our(%x); > executing in list mode rather than void mode */
5920 #if 0
5921         list(o);
5922 #else
5923         NOOP;
5924 #endif
5925     else {
5926         if ( PL_parser->bufptr > PL_parser->oldbufptr
5927             && PL_parser->bufptr[-1] == ','
5928             && ckWARN(WARN_PARENTHESIS))
5929         {
5930             char *s = PL_parser->bufptr;
5931             bool sigil = FALSE;
5932
5933             /* some heuristics to detect a potential error */
5934             while (*s && (memCHRs(", \t\n", *s)))
5935                 s++;
5936
5937             while (1) {
5938                 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5939                        && *++s
5940                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5941                     s++;
5942                     sigil = TRUE;
5943                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5944                         s++;
5945                     while (*s && (memCHRs(", \t\n", *s)))
5946                         s++;
5947                 }
5948                 else
5949                     break;
5950             }
5951             if (sigil && (*s == ';' || *s == '=')) {
5952                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5953                                 "Parentheses missing around \"%s\" list",
5954                                 lex
5955                                     ? (PL_parser->in_my == KEY_our
5956                                         ? "our"
5957                                         : PL_parser->in_my == KEY_state
5958                                             ? "state"
5959                                             : "my")
5960                                     : "local");
5961             }
5962         }
5963     }
5964     if (lex)
5965         o = my(o);
5966     else
5967         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5968     PL_parser->in_my = FALSE;
5969     PL_parser->in_my_stash = NULL;
5970     return o;
5971 }
5972
5973 OP *
5974 Perl_jmaybe(pTHX_ OP *o)
5975 {
5976     PERL_ARGS_ASSERT_JMAYBE;
5977
5978     if (o->op_type == OP_LIST) {
5979         OP * const o2
5980             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5981         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5982     }
5983     return o;
5984 }
5985
5986 PERL_STATIC_INLINE OP *
5987 S_op_std_init(pTHX_ OP *o)
5988 {
5989     I32 type = o->op_type;
5990
5991     PERL_ARGS_ASSERT_OP_STD_INIT;
5992
5993     if (PL_opargs[type] & OA_RETSCALAR)
5994         scalar(o);
5995     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5996         o->op_targ = pad_alloc(type, SVs_PADTMP);
5997
5998     return o;
5999 }
6000
6001 PERL_STATIC_INLINE OP *
6002 S_op_integerize(pTHX_ OP *o)
6003 {
6004     I32 type = o->op_type;
6005
6006     PERL_ARGS_ASSERT_OP_INTEGERIZE;
6007
6008     /* integerize op. */
6009     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6010     {
6011         dVAR;
6012         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6013     }
6014
6015     if (type == OP_NEGATE)
6016         /* XXX might want a ck_negate() for this */
6017         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6018
6019     return o;
6020 }
6021
6022 /* This function exists solely to provide a scope to limit
6023    setjmp/longjmp() messing with auto variables.  It cannot be inlined because
6024    it uses setjmp
6025  */
6026 STATIC int
6027 S_fold_constants_eval(pTHX) {
6028     int ret = 0;
6029     dJMPENV;
6030
6031     JMPENV_PUSH(ret);
6032
6033     if (ret == 0) {
6034         CALLRUNOPS(aTHX);
6035     }
6036
6037     JMPENV_POP;
6038
6039     return ret;
6040 }
6041
6042 static OP *
6043 S_fold_constants(pTHX_ OP *const o)
6044 {
6045     dVAR;
6046     OP *curop;
6047     OP *newop;
6048     I32 type = o->op_type;
6049     bool is_stringify;
6050     SV *sv = NULL;
6051     int ret = 0;
6052     OP *old_next;
6053     SV * const oldwarnhook = PL_warnhook;
6054     SV * const olddiehook  = PL_diehook;
6055     COP not_compiling;
6056     U8 oldwarn = PL_dowarn;
6057     I32 old_cxix;
6058
6059     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6060
6061     if (!(PL_opargs[type] & OA_FOLDCONST))
6062         goto nope;
6063
6064     switch (type) {
6065     case OP_UCFIRST:
6066     case OP_LCFIRST:
6067     case OP_UC:
6068     case OP_LC:
6069     case OP_FC:
6070 #ifdef USE_LOCALE_CTYPE
6071         if (IN_LC_COMPILETIME(LC_CTYPE))
6072             goto nope;
6073 #endif
6074         break;
6075     case OP_SLT:
6076     case OP_SGT:
6077     case OP_SLE:
6078     case OP_SGE:
6079     case OP_SCMP:
6080 #ifdef USE_LOCALE_COLLATE
6081         if (IN_LC_COMPILETIME(LC_COLLATE))
6082             goto nope;
6083 #endif
6084         break;
6085     case OP_SPRINTF:
6086         /* XXX what about the numeric ops? */
6087 #ifdef USE_LOCALE_NUMERIC
6088         if (IN_LC_COMPILETIME(LC_NUMERIC))
6089             goto nope;
6090 #endif
6091         break;
6092     case OP_PACK:
6093         if (!OpHAS_SIBLING(cLISTOPo->op_first)
6094           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6095             goto nope;
6096         {
6097             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6098             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6099             {
6100                 const char *s = SvPVX_const(sv);
6101                 while (s < SvEND(sv)) {
6102                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6103                     s++;
6104                 }
6105             }
6106         }
6107         break;
6108     case OP_REPEAT:
6109         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6110         break;
6111     case OP_SREFGEN:
6112         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6113          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6114             goto nope;
6115     }
6116
6117     if (PL_parser && PL_parser->error_count)
6118         goto nope;              /* Don't try to run w/ errors */
6119
6120     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6121         switch (curop->op_type) {
6122         case OP_CONST:
6123             if (   (curop->op_private & OPpCONST_BARE)
6124                 && (curop->op_private & OPpCONST_STRICT)) {
6125                 no_bareword_allowed(curop);
6126                 goto nope;
6127             }
6128             /* FALLTHROUGH */
6129         case OP_LIST:
6130         case OP_SCALAR:
6131         case OP_NULL:
6132         case OP_PUSHMARK:
6133             /* Foldable; move to next op in list */
6134             break;
6135
6136         default:
6137             /* No other op types are considered foldable */
6138             goto nope;
6139         }
6140     }
6141
6142     curop = LINKLIST(o);
6143     old_next = o->op_next;
6144     o->op_next = 0;
6145     PL_op = curop;
6146
6147     old_cxix = cxstack_ix;
6148     create_eval_scope(NULL, G_FAKINGEVAL);
6149
6150     /* Verify that we don't need to save it:  */
6151     assert(PL_curcop == &PL_compiling);
6152     StructCopy(&PL_compiling, &not_compiling, COP);
6153     PL_curcop = &not_compiling;
6154     /* The above ensures that we run with all the correct hints of the
6155        currently compiling COP, but that IN_PERL_RUNTIME is true. */
6156     assert(IN_PERL_RUNTIME);
6157     PL_warnhook = PERL_WARNHOOK_FATAL;
6158     PL_diehook  = NULL;
6159
6160     /* Effective $^W=1.  */
6161     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6162         PL_dowarn |= G_WARN_ON;
6163
6164     ret = S_fold_constants_eval(aTHX);
6165
6166     switch (ret) {
6167     case 0:
6168         sv = *(PL_stack_sp--);
6169         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
6170             pad_swipe(o->op_targ,  FALSE);
6171         }
6172         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
6173             SvREFCNT_inc_simple_void(sv);
6174             SvTEMP_off(sv);
6175         }
6176         else { assert(SvIMMORTAL(sv)); }
6177         break;
6178     case 3:
6179         /* Something tried to die.  Abandon constant folding.  */
6180         /* Pretend the error never happened.  */
6181         CLEAR_ERRSV();
6182         o->op_next = old_next;
6183         break;
6184     default:
6185         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
6186         PL_warnhook = oldwarnhook;
6187         PL_diehook  = olddiehook;
6188         /* XXX note that this croak may fail as we've already blown away
6189          * the stack - eg any nested evals */
6190         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6191     }
6192     PL_dowarn   = oldwarn;
6193     PL_warnhook = oldwarnhook;
6194     PL_diehook  = olddiehook;
6195     PL_curcop = &PL_compiling;
6196
6197     /* if we croaked, depending on how we croaked the eval scope
6198      * may or may not have already been popped */
6199     if (cxstack_ix > old_cxix) {
6200         assert(cxstack_ix == old_cxix + 1);
6201         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6202         delete_eval_scope();
6203     }
6204     if (ret)
6205         goto nope;
6206
6207     /* OP_STRINGIFY and constant folding are used to implement qq.
6208        Here the constant folding is an implementation detail that we
6209        want to hide.  If the stringify op is itself already marked
6210        folded, however, then it is actually a folded join.  */
6211     is_stringify = type == OP_STRINGIFY && !o->op_folded;
6212     op_free(o);
6213     assert(sv);
6214     if (is_stringify)
6215         SvPADTMP_off(sv);
6216     else if (!SvIMMORTAL(sv)) {
6217         SvPADTMP_on(sv);
6218         SvREADONLY_on(sv);
6219     }
6220     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6221     if (!is_stringify) newop->op_folded = 1;
6222     return newop;
6223
6224  nope:
6225     return o;
6226 }
6227
6228 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6229  * the constant value being an AV holding the flattened range.
6230  */
6231
6232 static void
6233 S_gen_constant_list(pTHX_ OP *o)
6234 {
6235     dVAR;
6236     OP *curop, *old_next;
6237     SV * const oldwarnhook = PL_warnhook;
6238     SV * const olddiehook  = PL_diehook;
6239     COP *old_curcop;
6240     U8 oldwarn = PL_dowarn;
6241     SV **svp;
6242     AV *av;
6243     I32 old_cxix;
6244     COP not_compiling;
6245     int ret = 0;
6246     dJMPENV;
6247     bool op_was_null;
6248
6249     list(o);
6250     if (PL_parser && PL_parser->error_count)
6251         return;         /* Don't attempt to run with errors */
6252
6253     curop = LINKLIST(o);
6254     old_next = o->op_next;
6255     o->op_next = 0;
6256     op_was_null = o->op_type == OP_NULL;
6257     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6258         o->op_type = OP_CUSTOM;
6259     CALL_PEEP(curop);
6260     if (op_was_null)
6261         o->op_type = OP_NULL;
6262     S_prune_chain_head(&curop);
6263     PL_op = curop;
6264
6265     old_cxix = cxstack_ix;
6266     create_eval_scope(NULL, G_FAKINGEVAL);
6267
6268     old_curcop = PL_curcop;
6269     StructCopy(old_curcop, &not_compiling, COP);
6270     PL_curcop = &not_compiling;
6271     /* The above ensures that we run with all the correct hints of the
6272        current COP, but that IN_PERL_RUNTIME is true. */
6273     assert(IN_PERL_RUNTIME);
6274     PL_warnhook = PERL_WARNHOOK_FATAL;
6275     PL_diehook  = NULL;
6276     JMPENV_PUSH(ret);
6277
6278     /* Effective $^W=1.  */
6279     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6280         PL_dowarn |= G_WARN_ON;
6281
6282     switch (ret) {
6283     case 0:
6284 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6285         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6286 #endif
6287         Perl_pp_pushmark(aTHX);
6288         CALLRUNOPS(aTHX);
6289         PL_op = curop;
6290         assert (!(curop->op_flags & OPf_SPECIAL));
6291         assert(curop->op_type == OP_RANGE);
6292         Perl_pp_anonlist(aTHX);
6293         break;
6294     case 3:
6295         CLEAR_ERRSV();
6296         o->op_next = old_next;
6297         break;
6298     default:
6299         JMPENV_POP;
6300         PL_warnhook = oldwarnhook;
6301         PL_diehook = olddiehook;
6302         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6303             ret);
6304     }
6305
6306     JMPENV_POP;
6307     PL_dowarn = oldwarn;
6308     PL_warnhook = oldwarnhook;
6309     PL_diehook = olddiehook;
6310     PL_curcop = old_curcop;
6311
6312     if (cxstack_ix > old_cxix) {
6313         assert(cxstack_ix == old_cxix + 1);
6314         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6315         delete_eval_scope();
6316     }
6317     if (ret)
6318         return;
6319
6320     OpTYPE_set(o, OP_RV2AV);
6321     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
6322     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
6323     o->op_opt = 0;              /* needs to be revisited in rpeep() */
6324     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6325
6326     /* replace subtree with an OP_CONST */
6327     curop = ((UNOP*)o)->op_first;
6328     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6329     op_free(curop);
6330
6331     if (AvFILLp(av) != -1)
6332         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6333         {
6334             SvPADTMP_on(*svp);
6335             SvREADONLY_on(*svp);
6336         }
6337     LINKLIST(o);
6338     list(o);
6339     return;
6340 }
6341
6342 /*
6343 =head1 Optree Manipulation Functions
6344 */
6345
6346 /* List constructors */
6347
6348 /*
6349 =for apidoc op_append_elem
6350
6351 Append an item to the list of ops contained directly within a list-type
6352 op, returning the lengthened list.  C<first> is the list-type op,
6353 and C<last> is the op to append to the list.  C<optype> specifies the
6354 intended opcode for the list.  If C<first> is not already a list of the
6355 right type, it will be upgraded into one.  If either C<first> or C<last>
6356 is null, the other is returned unchanged.
6357
6358 =cut
6359 */
6360
6361 OP *
6362 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6363 {
6364     if (!first)
6365         return last;
6366
6367     if (!last)
6368         return first;
6369
6370     if (first->op_type != (unsigned)type
6371         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6372     {
6373         return newLISTOP(type, 0, first, last);
6374     }
6375
6376     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6377     first->op_flags |= OPf_KIDS;
6378     return first;
6379 }
6380
6381 /*
6382 =for apidoc op_append_list
6383
6384 Concatenate the lists of ops contained directly within two list-type ops,
6385 returning the combined list.  C<first> and C<last> are the list-type ops
6386 to concatenate.  C<optype> specifies the intended opcode for the list.
6387 If either C<first> or C<last> is not already a list of the right type,
6388 it will be upgraded into one.  If either C<first> or C<last> is null,
6389 the other is returned unchanged.
6390
6391 =cut
6392 */
6393
6394 OP *
6395 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6396 {
6397     if (!first)
6398         return last;
6399
6400     if (!last)
6401         return first;
6402
6403     if (first->op_type != (unsigned)type)
6404         return op_prepend_elem(type, first, last);
6405
6406     if (last->op_type != (unsigned)type)
6407         return op_append_elem(type, first, last);
6408
6409     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6410     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6411     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6412     first->op_flags |= (last->op_flags & OPf_KIDS);
6413
6414     S_op_destroy(aTHX_ last);
6415
6416     return first;
6417 }
6418
6419 /*
6420 =for apidoc op_prepend_elem
6421
6422 Prepend an item to the list of ops contained directly within a list-type
6423 op, returning the lengthened list.  C<first> is the op to prepend to the
6424 list, and C<last> is the list-type op.  C<optype> specifies the intended
6425 opcode for the list.  If C<last> is not already a list of the right type,
6426 it will be upgraded into one.  If either C<first> or C<last> is null,
6427 the other is returned unchanged.
6428
6429 =cut
6430 */
6431
6432 OP *
6433 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6434 {
6435     if (!first)
6436         return last;
6437
6438     if (!last)
6439         return first;
6440
6441     if (last->op_type == (unsigned)type) {
6442         if (type == OP_LIST) {  /* already a PUSHMARK there */
6443             /* insert 'first' after pushmark */
6444             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6445             if (!(first->op_flags & OPf_PARENS))
6446                 last->op_flags &= ~OPf_PARENS;
6447         }
6448         else
6449             op_sibling_splice(last, NULL, 0, first);
6450         last->op_flags |= OPf_KIDS;
6451         return last;
6452     }
6453
6454     return newLISTOP(type, 0, first, last);
6455 }
6456
6457 /*
6458 =for apidoc op_convert_list
6459
6460 Converts C<o> into a list op if it is not one already, and then converts it
6461 into the specified C<type>, calling its check function, allocating a target if
6462 it needs one, and folding constants.
6463
6464 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6465 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
6466 C<op_convert_list> to make it the right type.
6467
6468 =cut
6469 */
6470
6471 OP *
6472 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6473 {
6474     dVAR;
6475     if (type < 0) type = -type, flags |= OPf_SPECIAL;
6476     if (!o || o->op_type != OP_LIST)
6477         o = force_list(o, 0);
6478     else
6479     {
6480         o->op_flags &= ~OPf_WANT;
6481         o->op_private &= ~OPpLVAL_INTRO;
6482     }
6483
6484     if (!(PL_opargs[type] & OA_MARK))
6485         op_null(cLISTOPo->op_first);
6486     else {
6487         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6488         if (kid2 && kid2->op_type == OP_COREARGS) {
6489             op_null(cLISTOPo->op_first);
6490             kid2->op_private |= OPpCOREARGS_PUSHMARK;
6491         }
6492     }
6493
6494     if (type != OP_SPLIT)
6495         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6496          * ck_split() create a real PMOP and leave the op's type as listop
6497          * for now. Otherwise op_free() etc will crash.
6498          */
6499         OpTYPE_set(o, type);
6500
6501     o->op_flags |= flags;
6502     if (flags & OPf_FOLDED)
6503         o->op_folded = 1;
6504
6505     o = CHECKOP(type, o);
6506     if (o->op_type != (unsigned)type)
6507         return o;
6508
6509     return fold_constants(op_integerize(op_std_init(o)));
6510 }
6511
6512 /* Constructors */
6513
6514
6515 /*
6516 =head1 Optree construction
6517
6518 =for apidoc newNULLLIST
6519
6520 Constructs, checks, and returns a new C<stub> op, which represents an
6521 empty list expression.
6522
6523 =cut
6524 */
6525
6526 OP *
6527 Perl_newNULLLIST(pTHX)
6528 {
6529     return newOP(OP_STUB, 0);
6530 }
6531
6532 /* promote o and any siblings to be a list if its not already; i.e.
6533  *
6534  *  o - A - B
6535  *
6536  * becomes
6537  *
6538  *  list
6539  *    |
6540  *  pushmark - o - A - B
6541  *
6542  * If nullit it true, the list op is nulled.
6543  */
6544
6545 static OP *
6546 S_force_list(pTHX_ OP *o, bool nullit)
6547 {
6548     if (!o || o->op_type != OP_LIST) {
6549         OP *rest = NULL;
6550         if (o) {
6551             /* manually detach any siblings then add them back later */
6552             rest = OpSIBLING(o);
6553             OpLASTSIB_set(o, NULL);
6554         }
6555         o = newLISTOP(OP_LIST, 0, o, NULL);
6556         if (rest)
6557             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6558     }
6559     if (nullit)
6560         op_null(o);
6561     return o;
6562 }
6563
6564 /*
6565 =for apidoc newLISTOP
6566
6567 Constructs, checks, and returns an op of any list type.  C<type> is
6568 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6569 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6570 supply up to two ops to be direct children of the list op; they are
6571 consumed by this function and become part of the constructed op tree.
6572
6573 For most list operators, the check function expects all the kid ops to be
6574 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6575 appropriate.  What you want to do in that case is create an op of type
6576 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6577 See L</op_convert_list> for more information.
6578
6579
6580 =cut
6581 */
6582
6583 OP *
6584 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6585 {
6586     dVAR;
6587     LISTOP *listop;
6588     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6589      * pushmark is banned. So do it now while existing ops are in a
6590      * consistent state, in case they suddenly get freed */
6591     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6592
6593     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6594         || type == OP_CUSTOM);
6595
6596     NewOp(1101, listop, 1, LISTOP);
6597     OpTYPE_set(listop, type);
6598     if (first || last)
6599         flags |= OPf_KIDS;
6600     listop->op_flags = (U8)flags;
6601
6602     if (!last && first)
6603         last = first;
6604     else if (!first && last)
6605         first = last;
6606     else if (first)
6607         OpMORESIB_set(first, last);
6608     listop->op_first = first;
6609     listop->op_last = last;
6610
6611     if (pushop) {
6612         OpMORESIB_set(pushop, first);
6613         listop->op_first = pushop;
6614         listop->op_flags |= OPf_KIDS;
6615         if (!last)
6616             listop->op_last = pushop;
6617     }
6618     if (listop->op_last)
6619         OpLASTSIB_set(listop->op_last, (OP*)listop);
6620
6621     return CHECKOP(type, listop);
6622 }
6623
6624 /*
6625 =for apidoc newOP
6626
6627 Constructs, checks, and returns an op of any base type (any type that
6628 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6629 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6630 of C<op_private>.
6631
6632 =cut
6633 */
6634
6635 OP *
6636 Perl_newOP(pTHX_ I32 type, I32 flags)
6637 {
6638     dVAR;
6639     OP *o;
6640
6641     if (type == -OP_ENTEREVAL) {
6642         type = OP_ENTEREVAL;
6643         flags |= OPpEVAL_BYTES<<8;
6644     }
6645
6646     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6647         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6648         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6649         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6650
6651     NewOp(1101, o, 1, OP);
6652     OpTYPE_set(o, type);
6653     o->op_flags = (U8)flags;
6654
6655     o->op_next = o;
6656     o->op_private = (U8)(0 | (flags >> 8));
6657     if (PL_opargs[type] & OA_RETSCALAR)
6658         scalar(o);
6659     if (PL_opargs[type] & OA_TARGET)
6660         o->op_targ = pad_alloc(type, SVs_PADTMP);
6661     return CHECKOP(type, o);
6662 }
6663
6664 /*
6665 =for apidoc newUNOP
6666
6667 Constructs, checks, and returns an op of any unary type.  C<type> is
6668 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6669 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6670 bits, the eight bits of C<op_private>, except that the bit with value 1
6671 is automatically set.  C<first> supplies an optional op to be the direct
6672 child of the unary op; it is consumed by this function and become part
6673 of the constructed op tree.
6674
6675 =for apidoc Amnh||OPf_KIDS
6676
6677 =cut
6678 */
6679
6680 OP *
6681 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6682 {
6683     dVAR;
6684     UNOP *unop;
6685
6686     if (type == -OP_ENTEREVAL) {
6687         type = OP_ENTEREVAL;
6688         flags |= OPpEVAL_BYTES<<8;
6689     }
6690
6691     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6692         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6693         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6694         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6695         || type == OP_SASSIGN
6696         || type == OP_ENTERTRY
6697         || type == OP_CUSTOM
6698         || type == OP_NULL );
6699
6700     if (!first)
6701         first = newOP(OP_STUB, 0);
6702     if (PL_opargs[type] & OA_MARK)
6703         first = force_list(first, 1);
6704
6705     NewOp(1101, unop, 1, UNOP);
6706     OpTYPE_set(unop, type);
6707     unop->op_first = first;
6708     unop->op_flags = (U8)(flags | OPf_KIDS);
6709     unop->op_private = (U8)(1 | (flags >> 8));
6710
6711     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6712         OpLASTSIB_set(first, (OP*)unop);
6713
6714     unop = (UNOP*) CHECKOP(type, unop);
6715     if (unop->op_next)
6716         return (OP*)unop;
6717
6718     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6719 }
6720
6721 /*
6722 =for apidoc newUNOP_AUX
6723
6724 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6725 initialised to C<aux>
6726
6727 =cut
6728 */
6729
6730 OP *
6731 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6732 {
6733     dVAR;
6734     UNOP_AUX *unop;
6735
6736     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6737         || type == OP_CUSTOM);
6738
6739     NewOp(1101, unop, 1, UNOP_AUX);
6740     unop->op_type = (OPCODE)type;
6741     unop->op_ppaddr = PL_ppaddr[type];
6742     unop->op_first = first;
6743     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6744     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6745     unop->op_aux = aux;
6746
6747     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6748         OpLASTSIB_set(first, (OP*)unop);
6749
6750     unop = (UNOP_AUX*) CHECKOP(type, unop);
6751
6752     return op_std_init((OP *) unop);
6753 }
6754
6755 /*
6756 =for apidoc newMETHOP
6757
6758 Constructs, checks, and returns an op of method type with a method name
6759 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6760 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6761 and, shifted up eight bits, the eight bits of C<op_private>, except that
6762 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6763 op which evaluates method name; it is consumed by this function and
6764 become part of the constructed op tree.
6765 Supported optypes: C<OP_METHOD>.
6766
6767 =cut
6768 */
6769
6770 static OP*
6771 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6772     dVAR;
6773     METHOP *methop;
6774
6775     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6776         || type == OP_CUSTOM);
6777
6778     NewOp(1101, methop, 1, METHOP);
6779     if (dynamic_meth) {
6780         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6781         methop->op_flags = (U8)(flags | OPf_KIDS);
6782         methop->op_u.op_first = dynamic_meth;
6783         methop->op_private = (U8)(1 | (flags >> 8));
6784
6785         if (!OpHAS_SIBLING(dynamic_meth))
6786             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6787     }
6788     else {
6789         assert(const_meth);
6790         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6791         methop->op_u.op_meth_sv = const_meth;
6792         methop->op_private = (U8)(0 | (flags >> 8));
6793         methop->op_next = (OP*)methop;
6794     }
6795
6796 #ifdef USE_ITHREADS
6797     methop->op_rclass_targ = 0;
6798 #else
6799     methop->op_rclass_sv = NULL;
6800 #endif
6801
6802     OpTYPE_set(methop, type);
6803     return CHECKOP(type, methop);
6804 }
6805
6806 OP *
6807 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6808     PERL_ARGS_ASSERT_NEWMETHOP;
6809     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6810 }
6811
6812 /*
6813 =for apidoc newMETHOP_named
6814
6815 Constructs, checks, and returns an op of method type with a constant
6816 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6817 C<op_flags>, and, shifted up eight bits, the eight bits of
6818 C<op_private>.  C<const_meth> supplies a constant method name;
6819 it must be a shared COW string.
6820 Supported optypes: C<OP_METHOD_NAMED>.
6821
6822 =cut
6823 */
6824
6825 OP *
6826 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6827     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6828     return newMETHOP_internal(type, flags, NULL, const_meth);
6829 }
6830
6831 /*
6832 =for apidoc newBINOP
6833
6834 Constructs, checks, and returns an op of any binary type.  C<type>
6835 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6836 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6837 the eight bits of C<op_private>, except that the bit with value 1 or
6838 2 is automatically set as required.  C<first> and C<last> supply up to
6839 two ops to be the direct children of the binary op; they are consumed
6840 by this function and become part of the constructed op tree.
6841
6842 =cut
6843 */
6844
6845 OP *
6846 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6847 {
6848     dVAR;
6849     BINOP *binop;
6850
6851     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6852         || type == OP_NULL || type == OP_CUSTOM);
6853
6854     NewOp(1101, binop, 1, BINOP);
6855
6856     if (!first)
6857         first = newOP(OP_NULL, 0);
6858
6859     OpTYPE_set(binop, type);
6860     binop->op_first = first;
6861     binop->op_flags = (U8)(flags | OPf_KIDS);
6862     if (!last) {
6863         last = first;
6864         binop->op_private = (U8)(1 | (flags >> 8));
6865     }
6866     else {
6867         binop->op_private = (U8)(2 | (flags >> 8));
6868         OpMORESIB_set(first, last);
6869     }
6870
6871     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6872         OpLASTSIB_set(last, (OP*)binop);
6873
6874     binop->op_last = OpSIBLING(binop->op_first);
6875     if (binop->op_last)
6876         OpLASTSIB_set(binop->op_last, (OP*)binop);
6877
6878     binop = (BINOP*)CHECKOP(type, binop);
6879     if (binop->op_next || binop->op_type != (OPCODE)type)
6880         return (OP*)binop;
6881
6882     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6883 }
6884
6885 void
6886 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6887 {
6888     const char indent[] = "    ";
6889
6890     UV len = _invlist_len(invlist);
6891     UV * array = invlist_array(invlist);
6892     UV i;
6893
6894     PERL_ARGS_ASSERT_INVMAP_DUMP;
6895
6896     for (i = 0; i < len; i++) {
6897         UV start = array[i];
6898         UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6899
6900         PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6901         if (end == IV_MAX) {
6902             PerlIO_printf(Perl_debug_log, " .. INFTY");
6903         }
6904         else if (end != start) {
6905             PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6906         }
6907         else {
6908             PerlIO_printf(Perl_debug_log, "            ");
6909         }
6910
6911         PerlIO_printf(Perl_debug_log, "\t");
6912
6913         if (map[i] == TR_UNLISTED) {
6914             PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6915         }
6916         else if (map[i] == TR_SPECIAL_HANDLING) {
6917             PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6918         }
6919         else {
6920             PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6921         }
6922     }
6923 }
6924
6925 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6926  * containing the search and replacement strings, assemble into
6927  * a translation table attached as o->op_pv.
6928  * Free expr and repl.
6929  * It expects the toker to have already set the
6930  *   OPpTRANS_COMPLEMENT
6931  *   OPpTRANS_SQUASH
6932  *   OPpTRANS_DELETE
6933  * flags as appropriate; this function may add
6934  *   OPpTRANS_USE_SVOP
6935  *   OPpTRANS_CAN_FORCE_UTF8
6936  *   OPpTRANS_IDENTICAL
6937  *   OPpTRANS_GROWS
6938  * flags
6939  */
6940
6941 static OP *
6942 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6943 {
6944     /* This function compiles a tr///, from data gathered from toke.c, into a
6945      * form suitable for use by do_trans() in doop.c at runtime.
6946      *
6947      * It first normalizes the data, while discarding extraneous inputs; then
6948      * writes out the compiled data.  The normalization allows for complete
6949      * analysis, and avoids some false negatives and positives earlier versions
6950      * of this code had.
6951      *
6952      * The normalization form is an inversion map (described below in detail).
6953      * This is essentially the compiled form for tr///'s that require UTF-8,
6954      * and its easy to use it to write the 257-byte table for tr///'s that
6955      * don't need UTF-8.  That table is identical to what's been in use for
6956      * many perl versions, except that it doesn't handle some edge cases that
6957      * it used to, involving code points above 255.  The UTF-8 form now handles
6958      * these.  (This could be changed with extra coding should it shown to be
6959      * desirable.)
6960      *
6961      * If the complement (/c) option is specified, the lhs string (tstr) is
6962      * parsed into an inversion list.  Complementing these is trivial.  Then a
6963      * complemented tstr is built from that, and used thenceforth.  This hides
6964      * the fact that it was complemented from almost all successive code.
6965      *
6966      * One of the important characteristics to know about the input is whether
6967      * the transliteration may be done in place, or does a temporary need to be
6968      * allocated, then copied.  If the replacement for every character in every
6969      * possible string takes up no more bytes than the the character it
6970      * replaces, then it can be edited in place.  Otherwise the replacement
6971      * could "grow", depending on the strings being processed.  Some inputs
6972      * won't grow, and might even shrink under /d, but some inputs could grow,
6973      * so we have to assume any given one might grow.  On very long inputs, the
6974      * temporary could eat up a lot of memory, so we want to avoid it if
6975      * possible.  For non-UTF-8 inputs, everything is single-byte, so can be
6976      * edited in place, unless there is something in the pattern that could
6977      * force it into UTF-8.  The inversion map makes it feasible to determine
6978      * this.  Previous versions of this code pretty much punted on determining
6979      * if UTF-8 could be edited in place.  Now, this code is rigorous in making
6980      * that determination.
6981      *
6982      * Another characteristic we need to know is whether the lhs and rhs are
6983      * identical.  If so, and no other flags are present, the only effect of
6984      * the tr/// is to count the characters present in the input that are
6985      * mentioned in the lhs string.  The implementation of that is easier and
6986      * runs faster than the more general case.  Normalizing here allows for
6987      * accurate determination of this.  Previously there were false negatives
6988      * possible.
6989      *
6990      * Instead of 'transliterated', the comments here use 'unmapped' for the
6991      * characters that are left unchanged by the operation; otherwise they are
6992      * 'mapped'
6993      *
6994      * The lhs of the tr/// is here referred to as the t side.
6995      * The rhs of the tr/// is here referred to as the r side.
6996      */
6997
6998     SV * const tstr = ((SVOP*)expr)->op_sv;
6999     SV * const rstr = ((SVOP*)repl)->op_sv;
7000     STRLEN tlen;
7001     STRLEN rlen;
7002     const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7003     const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7004     const U8 * t = t0;
7005     const U8 * r = r0;
7006     UV t_count = 0, r_count = 0;  /* Number of characters in search and
7007                                          replacement lists */
7008
7009     /* khw thinks some of the private flags for this op are quaintly named.
7010      * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7011      * character when represented in UTF-8 is longer than the original
7012      * character's UTF-8 representation */
7013     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7014     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
7015     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
7016
7017     /* Set to true if there is some character < 256 in the lhs that maps to >
7018      * 255.  If so, a non-UTF-8 match string can be forced into requiring to be
7019      * in UTF-8 by a tr/// operation. */
7020     bool can_force_utf8 = FALSE;
7021
7022     /* What is the maximum expansion factor in UTF-8 transliterations.  If a
7023      * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7024      * expansion factor is 1.5.  This number is used at runtime to calculate
7025      * how much space to allocate for non-inplace transliterations.  Without
7026      * this number, the worst case is 14, which is extremely unlikely to happen
7027      * in real life, and would require significant memory overhead. */
7028     NV max_expansion = 1.;
7029
7030     UV t_range_count, r_range_count, min_range_count;
7031     UV* t_array;
7032     SV* t_invlist;
7033     UV* r_map;
7034     UV r_cp, t_cp;
7035     UV t_cp_end = (UV) -1;
7036     UV r_cp_end;
7037     Size_t len;
7038     AV* invmap;
7039     UV final_map = TR_UNLISTED;    /* The final character in the replacement
7040                                       list, updated as we go along.  Initialize
7041                                       to something illegal */
7042
7043     bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7044     bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7045
7046     const U8* tend = t + tlen;
7047     const U8* rend = r + rlen;
7048
7049     SV * inverted_tstr = NULL;
7050
7051     Size_t i;
7052     unsigned int pass2;
7053
7054     /* This routine implements detection of a transliteration having a longer
7055      * UTF-8 representation than its source, by partitioning all the possible
7056      * code points of the platform into equivalence classes of the same UTF-8
7057      * byte length in the first pass.  As it constructs the mappings, it carves
7058      * these up into smaller chunks, but doesn't merge any together.  This
7059      * makes it easy to find the instances it's looking for.  A second pass is
7060      * done after this has been determined which merges things together to
7061      * shrink the table for runtime.  For ASCII platforms, the table is
7062      * trivial, given below, and uses the fundamental characteristics of UTF-8
7063      * to construct the values.  For EBCDIC, it isn't so, and we rely on a
7064      * table constructed by the perl script that generates these kinds of
7065      * things */
7066 #ifndef EBCDIC
7067     UV PL_partition_by_byte_length[] = {
7068         0,
7069         0x80,
7070         (32 * (1UL << (    UTF_ACCUMULATION_SHIFT))),
7071         (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),
7072         ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),
7073         ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),
7074         ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))
7075
7076 #  ifdef UV_IS_QUAD
7077                                                     ,
7078         ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))
7079 #  endif
7080
7081     };
7082
7083 #endif
7084
7085     PERL_ARGS_ASSERT_PMTRANS;
7086
7087     PL_hints |= HINT_BLOCK_SCOPE;
7088
7089     /* If /c, the search list is sorted and complemented.  This is now done by
7090      * creating an inversion list from it, and then trivially inverting that.
7091      * The previous implementation used qsort, but creating the list
7092      * automatically keeps it sorted as we go along */
7093     if (complement) {
7094         UV start, end;
7095         SV * inverted_tlist = _new_invlist(tlen);
7096         Size_t temp_len;
7097
7098         DEBUG_y(PerlIO_printf(Perl_debug_log,
7099                     "%s: %d: tstr before inversion=\n%s\n",
7100                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7101
7102         while (t < tend) {
7103
7104             /* Non-utf8 strings don't have ranges, so each character is listed
7105              * out */
7106             if (! tstr_utf8) {
7107                 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7108                 t++;
7109             }
7110             else {  /* But UTF-8 strings have been parsed in toke.c to have
7111                  * ranges if appropriate. */
7112                 UV t_cp;
7113                 Size_t t_char_len;
7114
7115                 /* Get the first character */
7116                 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7117                 t += t_char_len;
7118
7119                 /* If the next byte indicates that this wasn't the first
7120                  * element of a range, the range is just this one */
7121                 if (t >= tend || *t != RANGE_INDICATOR) {
7122                     inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7123                 }
7124                 else { /* Otherwise, ignore the indicator byte, and get the
7125                           final element, and add the whole range */
7126                     t++;
7127                     t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7128                     t += t_char_len;
7129
7130                     inverted_tlist = _add_range_to_invlist(inverted_tlist,
7131                                                       t_cp, t_cp_end);
7132                 }
7133             }
7134         } /* End of parse through tstr */
7135
7136         /* The inversion list is done; now invert it */
7137         _invlist_invert(inverted_tlist);
7138
7139         /* Now go through the inverted list and create a new tstr for the rest
7140          * of the routine to use.  Since the UTF-8 version can have ranges, and
7141          * can be much more compact than the non-UTF-8 version, we create the
7142          * string in UTF-8 even if not necessary.  (This is just an intermediate
7143          * value that gets thrown away anyway.) */
7144         invlist_iterinit(inverted_tlist);
7145         inverted_tstr = newSVpvs("");
7146         while (invlist_iternext(inverted_tlist, &start, &end)) {
7147             U8 temp[UTF8_MAXBYTES];
7148             U8 * temp_end_pos;
7149
7150             /* IV_MAX keeps things from going out of bounds */
7151             start = MIN(IV_MAX, start);
7152             end   = MIN(IV_MAX, end);
7153
7154             temp_end_pos = uvchr_to_utf8(temp, start);
7155             sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7156
7157             if (start != end) {
7158                 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7159                 temp_end_pos = uvchr_to_utf8(temp, end);
7160                 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7161             }
7162         }
7163
7164         /* Set up so the remainder of the routine uses this complement, instead
7165          * of the actual input */
7166         t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7167         tend = t0 + temp_len;
7168         tstr_utf8 = TRUE;
7169
7170         SvREFCNT_dec_NN(inverted_tlist);
7171     }
7172
7173     /* For non-/d, an empty rhs means to use the lhs */
7174     if (rlen == 0 && ! del) {
7175         r0 = t0;
7176         rend = tend;
7177         rstr_utf8  = tstr_utf8;
7178     }
7179
7180     t_invlist = _new_invlist(1);
7181
7182     /* Initialize to a single range */
7183     t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7184
7185     /* For the first pass, the lhs is partitioned such that the
7186      * number of UTF-8 bytes required to represent a code point in each
7187      * partition is the same as the number for any other code point in
7188      * that partion.  We copy the pre-compiled partion. */
7189     len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7190     invlist_extend(t_invlist, len);
7191     t_array = invlist_array(t_invlist);
7192     Copy(PL_partition_by_byte_length, t_array, len, UV);
7193     invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7194     Newx(r_map, len + 1, UV);
7195
7196     /* Parse the (potentially adjusted) input, creating the inversion map.
7197      * This is done in two passes.  The first pass is to determine if the
7198      * transliteration can be done in place.  The inversion map it creates
7199      * could be used, but generally would be larger and slower to run than the
7200      * output of the second pass, which starts with a more compact table and
7201      * allows more ranges to be merged */
7202     for (pass2 = 0; pass2 < 2; pass2++) {
7203         if (pass2) {
7204             /* Initialize to a single range */
7205             t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7206
7207             /* In the second pass, we just have the single range */
7208             len = 1;
7209             t_array = invlist_array(t_invlist);
7210         }
7211
7212         /* And the mapping of each of the ranges is initialized.  Initially,
7213          * everything is TR_UNLISTED. */
7214         for (i = 0; i < len; i++) {
7215             r_map[i] = TR_UNLISTED;
7216         }
7217
7218         t = t0;
7219         t_count = 0;
7220         r = r0;
7221         r_count = 0;
7222         t_range_count = r_range_count = 0;
7223
7224         DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7225                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7226         DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7227                                         _byte_dump_string(r, rend - r, 0)));
7228         DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7229                                                   complement, squash, del));
7230         DEBUG_y(invmap_dump(t_invlist, r_map));
7231
7232         /* Now go through the search list constructing an inversion map.  The
7233          * input is not necessarily in any particular order.  Making it an
7234          * inversion map orders it, potentially simplifying, and makes it easy
7235          * to deal with at run time.  This is the only place in core that
7236          * generates an inversion map; if others were introduced, it might be
7237          * better to create general purpose routines to handle them.
7238          * (Inversion maps are created in perl in other places.)
7239          *
7240          * An inversion map consists of two parallel arrays.  One is
7241          * essentially an inversion list: an ordered list of code points such
7242          * that each element gives the first code point of a range of
7243          * consecutive code points that map to the element in the other array
7244          * that has the same index as this one (in other words, the
7245          * corresponding element).  Thus the range extends up to (but not
7246          * including) the code point given by the next higher element.  In a
7247          * true inversion map, the corresponding element in the other array
7248          * gives the mapping of the first code point in the range, with the
7249          * understanding that the next higher code point in the inversion
7250          * list's range will map to the next higher code point in the map.
7251          *
7252          * So if at element [i], let's say we have:
7253          *
7254          *     t_invlist  r_map
7255          * [i]    A         a
7256          *
7257          * This means that A => a, B => b, C => c....  Let's say that the
7258          * situation is such that:
7259          *
7260          * [i+1]  L        -1
7261          *
7262          * This means the sequence that started at [i] stops at K => k.  This
7263          * illustrates that you need to look at the next element to find where
7264          * a sequence stops.  Except, the highest element in the inversion list
7265          * begins a range that is understood to extend to the platform's
7266          * infinity.
7267          *
7268          * This routine modifies traditional inversion maps to reserve two
7269          * mappings:
7270          *
7271          *  TR_UNLISTED (or -1) indicates that no code point in the range
7272          *      is listed in the tr/// searchlist.  At runtime, these are
7273          *      always passed through unchanged.  In the inversion map, all
7274          *      points in the range are mapped to -1, instead of increasing,
7275          *      like the 'L' in the example above.
7276          *
7277          *      We start the parse with every code point mapped to this, and as
7278          *      we parse and find ones that are listed in the search list, we
7279          *      carve out ranges as we go along that override that.
7280          *
7281          *  TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7282          *      range needs special handling.  Again, all code points in the
7283          *      range are mapped to -2, instead of increasing.
7284          *
7285          *      Under /d this value means the code point should be deleted from
7286          *      the transliteration when encountered.
7287          *
7288          *      Otherwise, it marks that every code point in the range is to
7289          *      map to the final character in the replacement list.  This
7290          *      happens only when the replacement list is shorter than the
7291          *      search one, so there are things in the search list that have no
7292          *      correspondence in the replacement list.  For example, in
7293          *      tr/a-z/A/, 'A' is the final value, and the inversion map
7294          *      generated for this would be like this:
7295          *          \0  =>  -1
7296          *          a   =>   A
7297          *          b-z =>  -2
7298          *          z+1 =>  -1
7299          *      'A' appears once, then the remainder of the range maps to -2.
7300          *      The use of -2 isn't strictly necessary, as an inversion map is
7301          *      capable of representing this situation, but not nearly so
7302          *      compactly, and this is actually quite commonly encountered.
7303          *      Indeed, the original design of this code used a full inversion
7304          *      map for this.  But things like
7305          *          tr/\0-\x{FFFF}/A/
7306          *      generated huge data structures, slowly, and the execution was
7307          *      also slow.  So the current scheme was implemented.
7308          *
7309          *  So, if the next element in our example is:
7310          *
7311          * [i+2]  Q        q
7312          *
7313          * Then all of L, M, N, O, and P map to TR_UNLISTED.  If the next
7314          * elements are
7315          *
7316          * [i+3]  R        z
7317          * [i+4]  S       TR_UNLISTED
7318          *
7319          * Then Q => q; R => z; and S => TR_UNLISTED.  If [i+4] (the 'S') is
7320          * the final element in the arrays, every code point from S to infinity
7321          * maps to TR_UNLISTED.
7322          *
7323          */
7324                            /* Finish up range started in what otherwise would
7325                             * have been the final iteration */
7326         while (t < tend || t_range_count > 0) {
7327             bool adjacent_to_range_above = FALSE;
7328             bool adjacent_to_range_below = FALSE;
7329
7330             bool merge_with_range_above = FALSE;
7331             bool merge_with_range_below = FALSE;
7332
7333             UV span, invmap_range_length_remaining;
7334             SSize_t j;
7335             Size_t i;
7336
7337             /* If we are in the middle of processing a range in the 'target'
7338              * side, the previous iteration has set us up.  Otherwise, look at
7339              * the next character in the search list */
7340             if (t_range_count <= 0) {
7341                 if (! tstr_utf8) {
7342
7343                     /* Here, not in the middle of a range, and not UTF-8.  The
7344                      * next code point is the single byte where we're at */
7345                     t_cp = *t;
7346                     t_range_count = 1;
7347                     t++;
7348                 }
7349                 else {
7350                     Size_t t_char_len;
7351
7352                     /* Here, not in the middle of a range, and is UTF-8.  The
7353                      * next code point is the next UTF-8 char in the input.  We
7354                      * know the input is valid, because the toker constructed
7355                      * it */
7356                     t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7357                     t += t_char_len;
7358
7359                     /* UTF-8 strings (only) have been parsed in toke.c to have
7360                      * ranges.  See if the next byte indicates that this was
7361                      * the first element of a range.  If so, get the final
7362                      * element and calculate the range size.  If not, the range
7363                      * size is 1 */
7364                     if (t < tend && *t == RANGE_INDICATOR) {
7365                         t++;
7366                         t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7367                                       - t_cp + 1;
7368                         t += t_char_len;
7369                     }
7370                     else {
7371                         t_range_count = 1;
7372                     }
7373                 }
7374
7375                 /* Count the total number of listed code points * */
7376                 t_count += t_range_count;
7377             }
7378
7379             /* Similarly, get the next character in the replacement list */
7380             if (r_range_count <= 0) {
7381                 if (r >= rend) {
7382
7383                     /* But if we've exhausted the rhs, there is nothing to map
7384                      * to, except the special handling one, and we make the
7385                      * range the same size as the lhs one. */
7386                     r_cp = TR_SPECIAL_HANDLING;
7387                     r_range_count = t_range_count;
7388
7389                     if (! del) {
7390                         DEBUG_yv(PerlIO_printf(Perl_debug_log,
7391                                         "final_map =%" UVXf "\n", final_map));
7392                     }
7393                 }
7394                 else {
7395                     if (! rstr_utf8) {
7396                         r_cp = *r;
7397                         r_range_count = 1;
7398                         r++;
7399                     }
7400                     else {
7401                         Size_t r_char_len;
7402
7403                         r_cp = valid_utf8_to_uvchr(r, &r_char_len);
7404                         r += r_char_len;
7405                         if (r < rend && *r == RANGE_INDICATOR) {
7406                             r++;
7407                             r_range_count = valid_utf8_to_uvchr(r,
7408                                                     &r_char_len) - r_cp + 1;
7409                             r += r_char_len;
7410                         }
7411                         else {
7412                             r_range_count = 1;
7413                         }
7414                     }
7415
7416                     if (r_cp == TR_SPECIAL_HANDLING) {
7417                         r_range_count = t_range_count;
7418                     }
7419
7420                     /* This is the final character so far */
7421                     final_map = r_cp + r_range_count - 1;
7422
7423                     r_count += r_range_count;
7424                 }
7425             }
7426
7427             /* Here, we have the next things ready in both sides.  They are
7428              * potentially ranges.  We try to process as big a chunk as
7429              * possible at once, but the lhs and rhs must be synchronized, so
7430              * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7431              * */
7432             min_range_count = MIN(t_range_count, r_range_count);
7433
7434             /* Search the inversion list for the entry that contains the input
7435              * code point <cp>.  The inversion map was initialized to cover the
7436              * entire range of possible inputs, so this should not fail.  So
7437              * the return value is the index into the list's array of the range
7438              * that contains <cp>, that is, 'i' such that array[i] <= cp <
7439              * array[i+1] */
7440             j = _invlist_search(t_invlist, t_cp);
7441             assert(j >= 0);
7442             i = j;
7443
7444             /* Here, the data structure might look like:
7445              *
7446              * index    t   r     Meaning
7447              * [i-1]    J   j   # J-L => j-l
7448              * [i]      M  -1   # M => default; as do N, O, P, Q
7449              * [i+1]    R   x   # R => x, S => x+1, T => x+2
7450              * [i+2]    U   y   # U => y, V => y+1, ...
7451              * ...
7452              * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7453              *
7454              * where 'x' and 'y' above are not to be taken literally.
7455              *
7456              * The maximum chunk we can handle in this loop iteration, is the
7457              * smallest of the three components: the lhs 't_', the rhs 'r_',
7458              * and the remainder of the range in element [i].  (In pass 1, that
7459              * range will have everything in it be of the same class; we can't
7460              * cross into another class.)  'min_range_count' already contains
7461              * the smallest of the first two values.  The final one is
7462              * irrelevant if the map is to the special indicator */
7463
7464             invmap_range_length_remaining = (i + 1 < len)
7465                                             ? t_array[i+1] - t_cp
7466                                             : IV_MAX - t_cp;
7467             span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7468
7469             /* The end point of this chunk is where we are, plus the span, but
7470              * never larger than the platform's infinity */
7471             t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7472
7473             if (r_cp == TR_SPECIAL_HANDLING) {
7474                 r_cp_end = TR_SPECIAL_HANDLING;
7475             }
7476             else {
7477                 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7478
7479                 /* If something on the lhs is below 256, and something on the
7480                  * rhs is above, there is a potential mapping here across that
7481                  * boundary.  Indeed the only way there isn't is if both sides
7482                  * start at the same point.  That means they both cross at the
7483                  * same time.  But otherwise one crosses before the other */
7484                 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7485                     can_force_utf8 = TRUE;
7486                 }
7487             }
7488
7489             /* If a character appears in the search list more than once, the
7490              * 2nd and succeeding occurrences are ignored, so only do this
7491              * range if haven't already processed this character.  (The range
7492              * has been set up so that all members in it will be of the same
7493              * ilk) */
7494             if (r_map[i] == TR_UNLISTED) {
7495                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7496                     "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7497                     t_cp, t_cp_end, r_cp, r_cp_end));
7498
7499                 /* This is the first definition for this chunk, hence is valid
7500                  * and needs to be processed.  Here and in the comments below,
7501                  * we use the above sample data.  The t_cp chunk must be any
7502                  * contiguous subset of M, N, O, P, and/or Q.
7503                  *
7504                  * In the first pass, the t_invlist has been partitioned so
7505                  * that all elements in any single range have the same number
7506                  * of bytes in their UTF-8 representations.  And the r space is
7507                  * either a single byte, or a range of strictly monotonically
7508                  * increasing code points.  So the final element in the range
7509                  * will be represented by no fewer bytes than the initial one.
7510                  * That means that if the final code point in the t range has
7511                  * at least as many bytes as the final code point in the r,
7512                  * then all code points in the t range have at least as many
7513                  * bytes as their corresponding r range element.  But if that's
7514                  * not true, the transliteration of at least the final code
7515                  * point grows in length.  As an example, suppose we had
7516                  *      tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7517                  * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7518                  * platforms.  We have deliberately set up the data structure
7519                  * so that any range in the lhs gets split into chunks for
7520                  * processing, such that every code point in a chunk has the
7521                  * same number of UTF-8 bytes.  We only have to check the final
7522                  * code point in the rhs against any code point in the lhs. */
7523                 if ( ! pass2
7524                     && r_cp_end != TR_SPECIAL_HANDLING
7525                     && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end))
7526                 {
7527                     /* Consider tr/\xCB/\X{E000}/.  The maximum expansion
7528                      * factor is 1 byte going to 3 if the lhs is not UTF-8, but
7529                      * 2 bytes going to 3 if it is in UTF-8.  We could pass two
7530                      * different values so doop could choose based on the
7531                      * UTF-8ness of the target.  But khw thinks (perhaps
7532                      * wrongly) that is overkill.  It is used only to make sure
7533                      * we malloc enough space.  If no target string can force
7534                      * the result to be UTF-8, then we don't have to worry
7535                      * about this */
7536                     NV t_size = (can_force_utf8 && t_cp < 256)
7537                                 ? 1
7538                                 : UVCHR_SKIP(t_cp_end);
7539                     NV ratio = UVCHR_SKIP(r_cp_end) / t_size;
7540
7541                     o->op_private |= OPpTRANS_GROWS;
7542
7543                     /* Now that we know it grows, we can keep track of the
7544                      * largest ratio */
7545                     if (ratio > max_expansion) {
7546                         max_expansion = ratio;
7547                         DEBUG_y(PerlIO_printf(Perl_debug_log,
7548                                         "New expansion factor: %" NVgf "\n",
7549                                         max_expansion));
7550                     }
7551                 }
7552
7553                 /* The very first range is marked as adjacent to the
7554                  * non-existent range below it, as it causes things to "just
7555                  * work" (TradeMark)
7556                  *
7557                  * If the lowest code point in this chunk is M, it adjoins the
7558                  * J-L range */
7559                 if (t_cp == t_array[i]) {
7560                     adjacent_to_range_below = TRUE;
7561
7562                     /* And if the map has the same offset from the beginning of
7563                      * the range as does this new code point (or both are for
7564                      * TR_SPECIAL_HANDLING), this chunk can be completely
7565                      * merged with the range below.  EXCEPT, in the first pass,
7566                      * we don't merge ranges whose UTF-8 byte representations
7567                      * have different lengths, so that we can more easily
7568                      * detect if a replacement is longer than the source, that
7569                      * is if it 'grows'.  But in the 2nd pass, there's no
7570                      * reason to not merge */
7571                     if (   (i > 0 && (   pass2
7572                                       || UVCHR_SKIP(t_array[i-1])
7573                                                         == UVCHR_SKIP(t_cp)))
7574                         && (   (   r_cp == TR_SPECIAL_HANDLING
7575                                 && r_map[i-1] == TR_SPECIAL_HANDLING)
7576                             || (   r_cp != TR_SPECIAL_HANDLING
7577                                 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7578                     {
7579                         merge_with_range_below = TRUE;
7580                     }
7581                 }
7582
7583                 /* Similarly, if the highest code point in this chunk is 'Q',
7584                  * it adjoins the range above, and if the map is suitable, can
7585                  * be merged with it */
7586                 if (    t_cp_end >= IV_MAX - 1
7587                     || (   i + 1 < len
7588                         && t_cp_end + 1 == t_array[i+1]))
7589                 {
7590                     adjacent_to_range_above = TRUE;
7591                     if (i + 1 < len)
7592                     if (    (   pass2
7593                              || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1]))
7594                         && (   (   r_cp == TR_SPECIAL_HANDLING
7595                                 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7596                             || (   r_cp != TR_SPECIAL_HANDLING
7597                                 && r_cp_end == r_map[i+1] - 1)))
7598                     {
7599                         merge_with_range_above = TRUE;
7600                     }
7601                 }
7602
7603                 if (merge_with_range_below && merge_with_range_above) {
7604
7605                     /* Here the new chunk looks like M => m, ... Q => q; and
7606                      * the range above is like R => r, ....  Thus, the [i-1]
7607                      * and [i+1] ranges should be seamlessly melded so the
7608                      * result looks like
7609                      *
7610                      * [i-1]    J   j   # J-T => j-t
7611                      * [i]      U   y   # U => y, V => y+1, ...
7612                      * ...
7613                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7614                      */
7615                     Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7616                     Move(r_map   + i + 2, r_map   + i, len - i - 2, UV);
7617                     len -= 2;
7618                     invlist_set_len(t_invlist,
7619                                     len,
7620                                     *(get_invlist_offset_addr(t_invlist)));
7621                 }
7622                 else if (merge_with_range_below) {
7623
7624                     /* Here the new chunk looks like M => m, .... But either
7625                      * (or both) it doesn't extend all the way up through Q; or
7626                      * the range above doesn't start with R => r. */
7627                     if (! adjacent_to_range_above) {
7628
7629                         /* In the first case, let's say the new chunk extends
7630                          * through O.  We then want:
7631                          *
7632                          * [i-1]    J   j   # J-O => j-o
7633                          * [i]      P  -1   # P => -1, Q => -1
7634                          * [i+1]    R   x   # R => x, S => x+1, T => x+2
7635                          * [i+2]    U   y   # U => y, V => y+1, ...
7636                          * ...
7637                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7638                          *                                            infinity
7639                          */
7640                         t_array[i] = t_cp_end + 1;
7641                         r_map[i] = TR_UNLISTED;
7642                     }
7643                     else { /* Adjoins the range above, but can't merge with it
7644                               (because 'x' is not the next map after q) */
7645                         /*
7646                          * [i-1]    J   j   # J-Q => j-q
7647                          * [i]      R   x   # R => x, S => x+1, T => x+2
7648                          * [i+1]    U   y   # U => y, V => y+1, ...
7649                          * ...
7650                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7651                          *                                          infinity
7652                          */
7653
7654                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7655                         Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7656                         len--;
7657                         invlist_set_len(t_invlist, len,
7658                                         *(get_invlist_offset_addr(t_invlist)));
7659                     }
7660                 }
7661                 else if (merge_with_range_above) {
7662
7663                     /* Here the new chunk ends with Q => q, and the range above
7664                      * must start with R => r, so the two can be merged. But
7665                      * either (or both) the new chunk doesn't extend all the
7666                      * way down to M; or the mapping of the final code point
7667                      * range below isn't m */
7668                     if (! adjacent_to_range_below) {
7669
7670                         /* In the first case, let's assume the new chunk starts
7671                          * with P => p.  Then, because it's merge-able with the
7672                          * range above, that range must be R => r.  We want:
7673                          *
7674                          * [i-1]    J   j   # J-L => j-l
7675                          * [i]      M  -1   # M => -1, N => -1
7676                          * [i+1]    P   p   # P-T => p-t
7677                          * [i+2]    U   y   # U => y, V => y+1, ...
7678                          * ...
7679                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7680                          *                                          infinity
7681                          */
7682                         t_array[i+1] = t_cp;
7683                         r_map[i+1] = r_cp;
7684                     }
7685                     else { /* Adjoins the range below, but can't merge with it
7686                             */
7687                         /*
7688                          * [i-1]    J   j   # J-L => j-l
7689                          * [i]      M   x   # M-T => x-5 .. x+2
7690                          * [i+1]    U   y   # U => y, V => y+1, ...
7691                          * ...
7692                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7693                          *                                          infinity
7694                          */
7695                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7696                         Move(r_map   + i + 1, r_map   + i, len - i - 1, UV);
7697                         len--;
7698                         t_array[i] = t_cp;
7699                         r_map[i] = r_cp;
7700                         invlist_set_len(t_invlist, len,
7701                                         *(get_invlist_offset_addr(t_invlist)));
7702                     }
7703                 }
7704                 else if (adjacent_to_range_below && adjacent_to_range_above) {
7705                     /* The new chunk completely fills the gap between the
7706                      * ranges on either side, but can't merge with either of
7707                      * them.
7708                      *
7709                      * [i-1]    J   j   # J-L => j-l
7710                      * [i]      M   z   # M => z, N => z+1 ... Q => z+4
7711                      * [i+1]    R   x   # R => x, S => x+1, T => x+2
7712                      * [i+2]    U   y   # U => y, V => y+1, ...
7713                      * ...
7714                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7715                      */
7716                     r_map[i] = r_cp;
7717                 }
7718                 else if (adjacent_to_range_below) {
7719                     /* The new chunk adjoins the range below, but not the range
7720                      * above, and can't merge.  Let's assume the chunk ends at
7721                      * O.
7722                      *
7723                      * [i-1]    J   j   # J-L => j-l
7724                      * [i]      M   z   # M => z, N => z+1, O => z+2
7725                      * [i+1]    P   -1  # P => -1, Q => -1
7726                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
7727                      * [i+3]    U   y   # U => y, V => y+1, ...
7728                      * ...
7729                      * [-w]     Z  -1   # Z => default; as do Z+1, ... infinity
7730                      */
7731                     invlist_extend(t_invlist, len + 1);
7732                     t_array = invlist_array(t_invlist);
7733                     Renew(r_map, len + 1, UV);
7734
7735                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7736                     Move(r_map + i + 1,   r_map   + i + 2, len - i - 1, UV);
7737                     r_map[i] = r_cp;
7738                     t_array[i+1] = t_cp_end + 1;
7739                     r_map[i+1] = TR_UNLISTED;
7740                     len++;
7741                     invlist_set_len(t_invlist, len,
7742                                     *(get_invlist_offset_addr(t_invlist)));
7743                 }
7744                 else if (adjacent_to_range_above) {
7745                     /* The new chunk adjoins the range above, but not the range
7746                      * below, and can't merge.  Let's assume the new chunk
7747                      * starts at O
7748                      *
7749                      * [i-1]    J   j   # J-L => j-l
7750                      * [i]      M  -1   # M => default, N => default
7751                      * [i+1]    O   z   # O => z, P => z+1, Q => z+2
7752                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
7753                      * [i+3]    U   y   # U => y, V => y+1, ...
7754                      * ...
7755                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7756                      */
7757                     invlist_extend(t_invlist, len + 1);
7758                     t_array = invlist_array(t_invlist);
7759                     Renew(r_map, len + 1, UV);
7760
7761                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7762                     Move(r_map   + i + 1, r_map   + i + 2, len - i - 1, UV);
7763                     t_array[i+1] = t_cp;
7764                     r_map[i+1] = r_cp;
7765                     len++;
7766                     invlist_set_len(t_invlist, len,
7767                                     *(get_invlist_offset_addr(t_invlist)));
7768                 }
7769                 else {
7770                     /* The new chunk adjoins neither the range above, nor the
7771                      * range below.  Lets assume it is N..P => n..p
7772                      *
7773                      * [i-1]    J   j   # J-L => j-l
7774                      * [i]      M  -1   # M => default
7775                      * [i+1]    N   n   # N..P => n..p
7776                      * [i+2]    Q  -1   # Q => default
7777                      * [i+3]    R   x   # R => x, S => x+1, T => x+2
7778                      * [i+4]    U   y   # U => y, V => y+1, ...
7779                      * ...
7780                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7781                      */
7782
7783                     DEBUG_yv(PerlIO_printf(Perl_debug_log,
7784                                         "Before fixing up: len=%d, i=%d\n",
7785                                         (int) len, (int) i));
7786                     DEBUG_yv(invmap_dump(t_invlist, r_map));
7787
7788                     invlist_extend(t_invlist, len + 2);
7789                     t_array = invlist_array(t_invlist);
7790                     Renew(r_map, len + 2, UV);
7791
7792                     Move(t_array + i + 1,
7793                          t_array + i + 2 + 1, len - i - (2 - 1), UV);
7794                     Move(r_map   + i + 1,
7795                          r_map   + i + 2 + 1, len - i - (2 - 1), UV);
7796
7797                     len += 2;
7798                     invlist_set_len(t_invlist, len,
7799                                     *(get_invlist_offset_addr(t_invlist)));
7800
7801                     t_array[i+1] = t_cp;
7802                     r_map[i+1] = r_cp;
7803
7804                     t_array[i+2] = t_cp_end + 1;
7805                     r_map[i+2] = TR_UNLISTED;
7806                 }
7807                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7808                           "After iteration: span=%" UVuf ", t_range_count=%"
7809                           UVuf " r_range_count=%" UVuf "\n",
7810                           span, t_range_count, r_range_count));
7811                 DEBUG_yv(invmap_dump(t_invlist, r_map));
7812             } /* End of this chunk needs to be processed */
7813
7814             /* Done with this chunk. */
7815             t_cp += span;
7816             if (t_cp >= IV_MAX) {
7817                 break;
7818             }
7819             t_range_count -= span;
7820             if (r_cp != TR_SPECIAL_HANDLING) {
7821                 r_cp += span;
7822                 r_range_count -= span;
7823             }
7824             else {
7825                 r_range_count = 0;
7826             }
7827
7828         } /* End of loop through the search list */
7829
7830         /* We don't need an exact count, but we do need to know if there is
7831          * anything left over in the replacement list.  So, just assume it's
7832          * one byte per character */
7833         if (rend > r) {
7834             r_count++;
7835         }
7836     } /* End of passes */
7837
7838     SvREFCNT_dec(inverted_tstr);
7839
7840     DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7841     DEBUG_y(invmap_dump(t_invlist, r_map));
7842
7843     /* We now have normalized the input into an inversion map.
7844      *
7845      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
7846      * except for the count, and streamlined runtime code can be used */
7847     if (!del && !squash) {
7848
7849         /* They are identical if they point to same address, or if everything
7850          * maps to UNLISTED or to itself.  This catches things that not looking
7851          * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7852          * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104}  */
7853         if (r0 != t0) {
7854             for (i = 0; i < len; i++) {
7855                 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7856                     goto done_identical_check;
7857                 }
7858             }
7859         }
7860
7861         /* Here have gone through entire list, and didn't find any
7862          * non-identical mappings */
7863         o->op_private |= OPpTRANS_IDENTICAL;
7864
7865       done_identical_check: ;
7866     }
7867
7868     t_array = invlist_array(t_invlist);
7869
7870     /* If has components above 255, we generally need to use the inversion map
7871      * implementation */
7872     if (   can_force_utf8
7873         || (   len > 0
7874             && t_array[len-1] > 255
7875                  /* If the final range is 0x100-INFINITY and is a special
7876                   * mapping, the table implementation can handle it */
7877             && ! (   t_array[len-1] == 256
7878                   && (   r_map[len-1] == TR_UNLISTED
7879                       || r_map[len-1] == TR_SPECIAL_HANDLING))))
7880     {
7881         SV* r_map_sv;
7882
7883         /* A UTF-8 op is generated, indicated by this flag.  This op is an
7884          * sv_op */
7885         o->op_private |= OPpTRANS_USE_SVOP;
7886
7887         if (can_force_utf8) {
7888             o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7889         }
7890
7891         /* The inversion map is pushed; first the list. */
7892         invmap = MUTABLE_AV(newAV());
7893         av_push(invmap, t_invlist);
7894
7895         /* 2nd is the mapping */
7896         r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7897         av_push(invmap, r_map_sv);
7898
7899         /* 3rd is the max possible expansion factor */
7900         av_push(invmap, newSVnv(max_expansion));
7901
7902         /* Characters that are in the search list, but not in the replacement
7903          * list are mapped to the final character in the replacement list */
7904         if (! del && r_count < t_count) {
7905             av_push(invmap, newSVuv(final_map));
7906         }
7907
7908 #ifdef USE_ITHREADS
7909         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7910         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7911         PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7912         SvPADTMP_on(invmap);
7913         SvREADONLY_on(invmap);
7914 #else
7915         cSVOPo->op_sv = (SV *) invmap;
7916 #endif
7917
7918     }
7919     else {
7920         OPtrans_map *tbl;
7921         unsigned short i;
7922
7923         /* The OPtrans_map struct already contains one slot; hence the -1. */
7924         SSize_t struct_size = sizeof(OPtrans_map)
7925                             + (256 - 1 + 1)*sizeof(short);
7926
7927         /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7928         * table. Entries with the value TR_UNMAPPED indicate chars not to be
7929         * translated, while TR_DELETE indicates a search char without a
7930         * corresponding replacement char under /d.
7931         *
7932         * In addition, an extra slot at the end is used to store the final
7933         * repeating char, or TR_R_EMPTY under an empty replacement list, or
7934         * TR_DELETE under /d; which makes the runtime code easier.
7935         */
7936
7937         /* Indicate this is an op_pv */
7938         o->op_private &= ~OPpTRANS_USE_SVOP;
7939
7940         tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7941         tbl->size = 256;
7942         cPVOPo->op_pv = (char*)tbl;
7943
7944         for (i = 0; i < len; i++) {
7945             STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7946             short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7947             short to = (short) r_map[i];
7948             short j;
7949             bool do_increment = TRUE;
7950
7951             /* Any code points above our limit should be irrelevant */
7952             if (t_array[i] >= tbl->size) break;
7953
7954             /* Set up the map */
7955             if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7956                 to = (short) final_map;
7957                 do_increment = FALSE;
7958             }
7959             else if (to < 0) {
7960                 do_increment = FALSE;
7961             }
7962
7963             /* Create a map for everything in this range.  The value increases
7964              * except for the special cases */
7965             for (j = (short) t_array[i]; j < upper; j++) {
7966                 tbl->map[j] = to;
7967                 if (do_increment) to++;
7968             }
7969         }
7970
7971         tbl->map[tbl->size] = del
7972                               ? (short) TR_DELETE
7973                               : (short) rlen
7974                                 ? (short) final_map
7975                                 : (short) TR_R_EMPTY;
7976         DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7977         for (i = 0; i < tbl->size; i++) {
7978             if (tbl->map[i] < 0) {
7979                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7980                                                 (unsigned) i, tbl->map[i]));
7981             }
7982             else {
7983                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7984                                                 (unsigned) i, tbl->map[i]));
7985             }
7986             if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7987                 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7988             }
7989         }
7990         DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7991                                 (unsigned) tbl->size, tbl->map[tbl->size]));
7992
7993         SvREFCNT_dec(t_invlist);
7994
7995 #if 0   /* code that added excess above-255 chars at the end of the table, in
7996            case we ever want to not use the inversion map implementation for
7997            this */
7998
7999         ASSUME(j <= rlen);
8000         excess = rlen - j;
8001
8002         if (excess) {
8003             /* More replacement chars than search chars:
8004              * store excess replacement chars at end of main table.
8005              */
8006
8007             struct_size += excess;
8008             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8009                         struct_size + excess * sizeof(short));
8010             tbl->size += excess;
8011             cPVOPo->op_pv = (char*)tbl;
8012
8013             for (i = 0; i < excess; i++)
8014                 tbl->map[i + 256] = r[j+i];
8015         }
8016         else {
8017             /* no more replacement chars than search chars */
8018         }
8019 #endif
8020
8021     }
8022
8023     DEBUG_y(PerlIO_printf(Perl_debug_log,
8024             "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8025             " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8026             del, squash, complement,
8027             cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8028             cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8029             cBOOL(o->op_private & OPpTRANS_GROWS),
8030             cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8031             max_expansion));
8032
8033     Safefree(r_map);
8034
8035     if(del && rlen != 0 && r_count == t_count) {
8036         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8037     } else if(r_count > t_count) {
8038         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8039     }
8040
8041     op_free(expr);
8042     op_free(repl);
8043
8044     return o;
8045 }
8046
8047
8048 /*
8049 =for apidoc newPMOP
8050
8051 Constructs, checks, and returns an op of any pattern matching type.
8052 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
8053 and, shifted up eight bits, the eight bits of C<op_private>.
8054
8055 =cut
8056 */
8057
8058 OP *
8059 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8060 {
8061     dVAR;
8062     PMOP *pmop;
8063
8064     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8065         || type == OP_CUSTOM);
8066
8067     NewOp(1101, pmop, 1, PMOP);
8068     OpTYPE_set(pmop, type);
8069     pmop->op_flags = (U8)flags;
8070     pmop->op_private = (U8)(0 | (flags >> 8));
8071     if (PL_opargs[type] & OA_RETSCALAR)
8072         scalar((OP *)pmop);
8073
8074     if (PL_hints & HINT_RE_TAINT)
8075         pmop->op_pmflags |= PMf_RETAINT;
8076 #ifdef USE_LOCALE_CTYPE
8077     if (IN_LC_COMPILETIME(LC_CTYPE)) {
8078         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8079     }
8080     else
8081 #endif
8082          if (IN_UNI_8_BIT) {
8083         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8084     }
8085     if (PL_hints & HINT_RE_FLAGS) {
8086         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8087          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8088         );
8089         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8090         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8091          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8092         );
8093         if (reflags && SvOK(reflags)) {
8094             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8095         }
8096     }
8097
8098
8099 #ifdef USE_ITHREADS
8100     assert(SvPOK(PL_regex_pad[0]));
8101     if (SvCUR(PL_regex_pad[0])) {
8102         /* Pop off the "packed" IV from the end.  */
8103         SV *const repointer_list = PL_regex_pad[0];
8104         const char *p = SvEND(repointer_list) - sizeof(IV);
8105         const IV offset = *((IV*)p);
8106
8107         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8108
8109         SvEND_set(repointer_list, p);
8110
8111         pmop->op_pmoffset = offset;
8112         /* This slot should be free, so assert this:  */
8113         assert(PL_regex_pad[offset] == &PL_sv_undef);
8114     } else {
8115         SV * const repointer = &PL_sv_undef;
8116         av_push(PL_regex_padav, repointer);
8117         pmop->op_pmoffset = av_tindex(PL_regex_padav);
8118         PL_regex_pad = AvARRAY(PL_regex_padav);
8119     }
8120 #endif
8121
8122     return CHECKOP(type, pmop);
8123 }
8124
8125 static void
8126 S_set_haseval(pTHX)
8127 {
8128     PADOFFSET i = 1;
8129     PL_cv_has_eval = 1;
8130     /* Any pad names in scope are potentially lvalues.  */
8131     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8132         PADNAME *pn = PAD_COMPNAME_SV(i);
8133         if (!pn || !PadnameLEN(pn))
8134             continue;
8135         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8136             S_mark_padname_lvalue(aTHX_ pn);
8137     }
8138 }
8139
8140 /* Given some sort of match op o, and an expression expr containing a
8141  * pattern, either compile expr into a regex and attach it to o (if it's
8142  * constant), or convert expr into a runtime regcomp op sequence (if it's
8143  * not)
8144  *
8145  * Flags currently has 2 bits of meaning:
8146  * 1: isreg indicates that the pattern is part of a regex construct, eg
8147  *      $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8148  *      split "pattern", which aren't. In the former case, expr will be a list
8149  *      if the pattern contains more than one term (eg /a$b/).
8150  * 2: The pattern is for a split.
8151  *
8152  * When the pattern has been compiled within a new anon CV (for
8153  * qr/(?{...})/ ), then floor indicates the savestack level just before
8154  * the new sub was created
8155  *
8156  * tr/// is also handled.
8157  */
8158
8159 OP *
8160 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8161 {
8162     PMOP *pm;
8163     LOGOP *rcop;
8164     I32 repl_has_vars = 0;
8165     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8166     bool is_compiletime;
8167     bool has_code;
8168     bool isreg    = cBOOL(flags & 1);
8169     bool is_split = cBOOL(flags & 2);
8170
8171     PERL_ARGS_ASSERT_PMRUNTIME;
8172
8173     if (is_trans) {
8174         return pmtrans(o, expr, repl);
8175     }
8176
8177     /* find whether we have any runtime or code elements;
8178      * at the same time, temporarily set the op_next of each DO block;
8179      * then when we LINKLIST, this will cause the DO blocks to be excluded
8180      * from the op_next chain (and from having LINKLIST recursively
8181      * applied to them). We fix up the DOs specially later */
8182
8183     is_compiletime = 1;
8184     has_code = 0;
8185     if (expr->op_type == OP_LIST) {
8186         OP *child;
8187         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8188             if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8189                 has_code = 1;
8190                 assert(!child->op_next);
8191                 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8192                     assert(PL_parser && PL_parser->error_count);
8193                     /* This can happen with qr/ (?{(^{})/.  Just fake up
8194                        the op we were expecting to see, to avoid crashing
8195                        elsewhere.  */
8196                     op_sibling_splice(expr, child, 0,
8197                               newSVOP(OP_CONST, 0, &PL_sv_no));
8198                 }
8199                 child->op_next = OpSIBLING(child);
8200             }
8201             else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8202             is_compiletime = 0;
8203         }
8204     }
8205     else if (expr->op_type != OP_CONST)
8206         is_compiletime = 0;
8207
8208     LINKLIST(expr);
8209
8210     /* fix up DO blocks; treat each one as a separate little sub;
8211      * also, mark any arrays as LIST/REF */
8212
8213     if (expr->op_type == OP_LIST) {
8214         OP *child;
8215         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8216
8217             if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8218                 assert( !(child->op_flags  & OPf_WANT));
8219                 /* push the array rather than its contents. The regex
8220                  * engine will retrieve and join the elements later */
8221                 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8222                 continue;
8223             }
8224
8225             if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8226                 continue;
8227             child->op_next = NULL; /* undo temporary hack from above */
8228             scalar(child);
8229             LINKLIST(child);
8230             if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8231                 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8232                 /* skip ENTER */
8233                 assert(leaveop->op_first->op_type == OP_ENTER);
8234                 assert(OpHAS_SIBLING(leaveop->op_first));
8235                 child->op_next = OpSIBLING(leaveop->op_first);
8236                 /* skip leave */
8237                 assert(leaveop->op_flags & OPf_KIDS);
8238                 assert(leaveop->op_last->op_next == (OP*)leaveop);
8239                 leaveop->op_next = NULL; /* stop on last op */
8240                 op_null((OP*)leaveop);
8241             }
8242             else {
8243                 /* skip SCOPE */
8244                 OP *scope = cLISTOPx(child)->op_first;
8245                 assert(scope->op_type == OP_SCOPE);
8246                 assert(scope->op_flags & OPf_KIDS);
8247                 scope->op_next = NULL; /* stop on last op */
8248                 op_null(scope);
8249             }
8250
8251             /* XXX optimize_optree() must be called on o before
8252              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8253              * currently cope with a peephole-optimised optree.
8254              * Calling optimize_optree() here ensures that condition
8255              * is met, but may mean optimize_optree() is applied
8256              * to the same optree later (where hopefully it won't do any
8257              * harm as it can't convert an op to multiconcat if it's
8258              * already been converted */
8259             optimize_optree(child);
8260
8261             /* have to peep the DOs individually as we've removed it from
8262              * the op_next chain */
8263             CALL_PEEP(child);
8264             S_prune_chain_head(&(child->op_next));
8265             if (is_compiletime)
8266                 /* runtime finalizes as part of finalizing whole tree */
8267                 finalize_optree(child);
8268         }
8269     }
8270     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8271         assert( !(expr->op_flags  & OPf_WANT));
8272         /* push the array rather than its contents. The regex
8273          * engine will retrieve and join the elements later */
8274         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8275     }
8276
8277     PL_hints |= HINT_BLOCK_SCOPE;
8278     pm = (PMOP*)o;
8279     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8280
8281     if (is_compiletime) {
8282         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8283         regexp_engine const *eng = current_re_engine();
8284
8285         if (is_split) {
8286             /* make engine handle split ' ' specially */
8287             pm->op_pmflags |= PMf_SPLIT;
8288             rx_flags |= RXf_SPLIT;
8289         }
8290
8291         if (!has_code || !eng->op_comp) {
8292             /* compile-time simple constant pattern */
8293
8294             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8295                 /* whoops! we guessed that a qr// had a code block, but we
8296                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8297                  * that isn't required now. Note that we have to be pretty
8298                  * confident that nothing used that CV's pad while the
8299                  * regex was parsed, except maybe op targets for \Q etc.
8300                  * If there were any op targets, though, they should have
8301                  * been stolen by constant folding.
8302                  */
8303 #ifdef DEBUGGING
8304                 SSize_t i = 0;
8305                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8306                 while (++i <= AvFILLp(PL_comppad)) {
8307 #  ifdef USE_PAD_RESET
8308                     /* under USE_PAD_RESET, pad swipe replaces a swiped
8309                      * folded constant with a fresh padtmp */
8310                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8311 #  else
8312                     assert(!PL_curpad[i]);
8313 #  endif
8314                 }
8315 #endif
8316                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8317                  * outer CV (the one whose slab holds the pm op). The
8318                  * inner CV (which holds expr) will be freed later, once
8319                  * all the entries on the parse stack have been popped on
8320                  * return from this function. Which is why its safe to
8321                  * call op_free(expr) below.
8322                  */
8323                 LEAVE_SCOPE(floor);
8324                 pm->op_pmflags &= ~PMf_HAS_CV;
8325             }
8326
8327             /* Skip compiling if parser found an error for this pattern */
8328             if (pm->op_pmflags & PMf_HAS_ERROR) {
8329                 return o;
8330             }
8331
8332             PM_SETRE(pm,
8333                 eng->op_comp
8334                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8335                                         rx_flags, pm->op_pmflags)
8336                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8337                                         rx_flags, pm->op_pmflags)
8338             );
8339             op_free(expr);
8340         }
8341         else {
8342             /* compile-time pattern that includes literal code blocks */
8343
8344             REGEXP* re;
8345
8346             /* Skip compiling if parser found an error for this pattern */
8347             if (pm->op_pmflags & PMf_HAS_ERROR) {
8348                 return o;
8349             }
8350
8351             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8352                         rx_flags,
8353                         (pm->op_pmflags |
8354                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8355                     );
8356             PM_SETRE(pm, re);
8357             if (pm->op_pmflags & PMf_HAS_CV) {
8358                 CV *cv;
8359                 /* this QR op (and the anon sub we embed it in) is never
8360                  * actually executed. It's just a placeholder where we can
8361                  * squirrel away expr in op_code_list without the peephole
8362                  * optimiser etc processing it for a second time */
8363                 OP *qr = newPMOP(OP_QR, 0);
8364                 ((PMOP*)qr)->op_code_list = expr;
8365
8366                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8367                 SvREFCNT_inc_simple_void(PL_compcv);
8368                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8369                 ReANY(re)->qr_anoncv = cv;
8370
8371                 /* attach the anon CV to the pad so that
8372                  * pad_fixup_inner_anons() can find it */
8373                 (void)pad_add_anon(cv, o->op_type);
8374                 SvREFCNT_inc_simple_void(cv);
8375             }
8376             else {
8377                 pm->op_code_list = expr;
8378             }
8379         }
8380     }
8381     else {
8382         /* runtime pattern: build chain of regcomp etc ops */
8383         bool reglist;
8384         PADOFFSET cv_targ = 0;
8385
8386         reglist = isreg && expr->op_type == OP_LIST;
8387         if (reglist)
8388             op_null(expr);
8389
8390         if (has_code) {
8391             pm->op_code_list = expr;
8392             /* don't free op_code_list; its ops are embedded elsewhere too */
8393             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8394         }
8395
8396         if (is_split)
8397             /* make engine handle split ' ' specially */
8398             pm->op_pmflags |= PMf_SPLIT;
8399
8400         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8401          * to allow its op_next to be pointed past the regcomp and
8402          * preceding stacking ops;
8403          * OP_REGCRESET is there to reset taint before executing the
8404          * stacking ops */
8405         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8406             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8407
8408         if (pm->op_pmflags & PMf_HAS_CV) {
8409             /* we have a runtime qr with literal code. This means
8410              * that the qr// has been wrapped in a new CV, which
8411              * means that runtime consts, vars etc will have been compiled
8412              * against a new pad. So... we need to execute those ops
8413              * within the environment of the new CV. So wrap them in a call
8414              * to a new anon sub. i.e. for
8415              *
8416              *     qr/a$b(?{...})/,
8417              *
8418              * we build an anon sub that looks like
8419              *
8420              *     sub { "a", $b, '(?{...})' }
8421              *
8422              * and call it, passing the returned list to regcomp.
8423              * Or to put it another way, the list of ops that get executed
8424              * are:
8425              *
8426              *     normal              PMf_HAS_CV
8427              *     ------              -------------------
8428              *                         pushmark (for regcomp)
8429              *                         pushmark (for entersub)
8430              *                         anoncode
8431              *                         srefgen
8432              *                         entersub
8433              *     regcreset                  regcreset
8434              *     pushmark                   pushmark
8435              *     const("a")                 const("a")
8436              *     gvsv(b)                    gvsv(b)
8437              *     const("(?{...})")          const("(?{...})")
8438              *                                leavesub
8439              *     regcomp             regcomp
8440              */
8441
8442             SvREFCNT_inc_simple_void(PL_compcv);
8443             CvLVALUE_on(PL_compcv);
8444             /* these lines are just an unrolled newANONATTRSUB */
8445             expr = newSVOP(OP_ANONCODE, 0,
8446                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8447             cv_targ = expr->op_targ;
8448             expr = newUNOP(OP_REFGEN, 0, expr);
8449
8450             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8451         }
8452
8453         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8454         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8455                            | (reglist ? OPf_STACKED : 0);
8456         rcop->op_targ = cv_targ;
8457
8458         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
8459         if (PL_hints & HINT_RE_EVAL)
8460             S_set_haseval(aTHX);
8461
8462         /* establish postfix order */
8463         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8464             LINKLIST(expr);
8465             rcop->op_next = expr;
8466             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8467         }
8468         else {
8469             rcop->op_next = LINKLIST(expr);
8470             expr->op_next = (OP*)rcop;
8471         }
8472
8473         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8474     }
8475
8476     if (repl) {
8477         OP *curop = repl;
8478         bool konst;
8479         /* If we are looking at s//.../e with a single statement, get past
8480            the implicit do{}. */
8481         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8482              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8483              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8484          {
8485             OP *sib;
8486             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8487             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8488              && !OpHAS_SIBLING(sib))
8489                 curop = sib;
8490         }
8491         if (curop->op_type == OP_CONST)
8492             konst = TRUE;
8493         else if (( (curop->op_type == OP_RV2SV ||
8494                     curop->op_type == OP_RV2AV ||
8495                     curop->op_type == OP_RV2HV ||
8496                     curop->op_type == OP_RV2GV)
8497                    && cUNOPx(curop)->op_first
8498                    && cUNOPx(curop)->op_first->op_type == OP_GV )
8499                 || curop->op_type == OP_PADSV
8500                 || curop->op_type == OP_PADAV
8501                 || curop->op_type == OP_PADHV
8502                 || curop->op_type == OP_PADANY) {
8503             repl_has_vars = 1;
8504             konst = TRUE;
8505         }
8506         else konst = FALSE;
8507         if (konst
8508             && !(repl_has_vars
8509                  && (!PM_GETRE(pm)
8510                      || !RX_PRELEN(PM_GETRE(pm))
8511                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8512         {
8513             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
8514             op_prepend_elem(o->op_type, scalar(repl), o);
8515         }
8516         else {
8517             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8518             rcop->op_private = 1;
8519
8520             /* establish postfix order */
8521             rcop->op_next = LINKLIST(repl);
8522             repl->op_next = (OP*)rcop;
8523
8524             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8525             assert(!(pm->op_pmflags & PMf_ONCE));
8526             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8527             rcop->op_next = 0;
8528         }
8529     }
8530
8531     return (OP*)pm;
8532 }
8533
8534 /*
8535 =for apidoc newSVOP
8536
8537 Constructs, checks, and returns an op of any type that involves an
8538 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
8539 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
8540 takes ownership of one reference to it.
8541
8542 =cut
8543 */
8544
8545 OP *
8546 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8547 {
8548     dVAR;
8549     SVOP *svop;
8550
8551     PERL_ARGS_ASSERT_NEWSVOP;
8552
8553     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8554         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8555         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8556         || type == OP_CUSTOM);
8557
8558     NewOp(1101, svop, 1, SVOP);
8559     OpTYPE_set(svop, type);
8560     svop->op_sv = sv;
8561     svop->op_next = (OP*)svop;
8562     svop->op_flags = (U8)flags;
8563     svop->op_private = (U8)(0 | (flags >> 8));
8564     if (PL_opargs[type] & OA_RETSCALAR)
8565         scalar((OP*)svop);
8566     if (PL_opargs[type] & OA_TARGET)
8567         svop->op_targ = pad_alloc(type, SVs_PADTMP);
8568     return CHECKOP(type, svop);
8569 }
8570
8571 /*
8572 =for apidoc newDEFSVOP
8573
8574 Constructs and returns an op to access C<$_>.
8575
8576 =cut
8577 */
8578
8579 OP *
8580 Perl_newDEFSVOP(pTHX)
8581 {
8582         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8583 }
8584
8585 #ifdef USE_ITHREADS
8586
8587 /*
8588 =for apidoc newPADOP
8589
8590 Constructs, checks, and returns an op of any type that involves a
8591 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
8592 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
8593 is populated with C<sv>; this function takes ownership of one reference
8594 to it.
8595
8596 This function only exists if Perl has been compiled to use ithreads.
8597
8598 =cut
8599 */
8600
8601 OP *
8602 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8603 {
8604     dVAR;
8605     PADOP *padop;
8606
8607     PERL_ARGS_ASSERT_NEWPADOP;
8608
8609     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8610         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8611         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8612         || type == OP_CUSTOM);
8613
8614     NewOp(1101, padop, 1, PADOP);
8615     OpTYPE_set(padop, type);
8616     padop->op_padix =
8617         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8618     SvREFCNT_dec(PAD_SVl(padop->op_padix));
8619     PAD_SETSV(padop->op_padix, sv);
8620     assert(sv);
8621     padop->op_next = (OP*)padop;
8622     padop->op_flags = (U8)flags;
8623     if (PL_opargs[type] & OA_RETSCALAR)
8624         scalar((OP*)padop);
8625     if (PL_opargs[type] & OA_TARGET)
8626         padop->op_targ = pad_alloc(type, SVs_PADTMP);
8627     return CHECKOP(type, padop);
8628 }
8629
8630 #endif /* USE_ITHREADS */
8631
8632 /*
8633 =for apidoc newGVOP
8634
8635 Constructs, checks, and returns an op of any type that involves an
8636 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
8637 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
8638 reference; calling this function does not transfer ownership of any
8639 reference to it.
8640
8641 =cut
8642 */
8643
8644 OP *
8645 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8646 {
8647     PERL_ARGS_ASSERT_NEWGVOP;
8648
8649 #ifdef USE_ITHREADS
8650     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8651 #else
8652     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8653 #endif
8654 }
8655
8656 /*
8657 =for apidoc newPVOP
8658
8659 Constructs, checks, and returns an op of any type that involves an
8660 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
8661 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
8662 Depending on the op type, the memory referenced by C<pv> may be freed
8663 when the op is destroyed.  If the op is of a freeing type, C<pv> must
8664 have been allocated using C<PerlMemShared_malloc>.
8665
8666 =cut
8667 */
8668
8669 OP *
8670 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8671 {
8672     dVAR;
8673     const bool utf8 = cBOOL(flags & SVf_UTF8);
8674     PVOP *pvop;
8675
8676     flags &= ~SVf_UTF8;
8677
8678     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8679         || type == OP_RUNCV || type == OP_CUSTOM
8680         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8681
8682     NewOp(1101, pvop, 1, PVOP);
8683     OpTYPE_set(pvop, type);
8684     pvop->op_pv = pv;
8685     pvop->op_next = (OP*)pvop;
8686     pvop->op_flags = (U8)flags;
8687     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8688     if (PL_opargs[type] & OA_RETSCALAR)
8689         scalar((OP*)pvop);
8690     if (PL_opargs[type] & OA_TARGET)
8691         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8692     return CHECKOP(type, pvop);
8693 }
8694
8695 void
8696 Perl_package(pTHX_ OP *o)
8697 {
8698     SV *const sv = cSVOPo->op_sv;
8699
8700     PERL_ARGS_ASSERT_PACKAGE;
8701
8702     SAVEGENERICSV(PL_curstash);
8703     save_item(PL_curstname);
8704
8705     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8706
8707     sv_setsv(PL_curstname, sv);
8708
8709     PL_hints |= HINT_BLOCK_SCOPE;
8710     PL_parser->copline = NOLINE;
8711
8712     op_free(o);
8713 }
8714
8715 void
8716 Perl_package_version( pTHX_ OP *v )
8717 {
8718     U32 savehints = PL_hints;
8719     PERL_ARGS_ASSERT_PACKAGE_VERSION;
8720     PL_hints &= ~HINT_STRICT_VARS;
8721     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8722     PL_hints = savehints;
8723     op_free(v);
8724 }
8725
8726 void
8727 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8728 {
8729     OP *pack;
8730     OP *imop;
8731     OP *veop;
8732     SV *use_version = NULL;
8733
8734     PERL_ARGS_ASSERT_UTILIZE;
8735
8736     if (idop->op_type != OP_CONST)
8737         Perl_croak(aTHX_ "Module name must be constant");
8738
8739     veop = NULL;
8740
8741     if (version) {
8742         SV * const vesv = ((SVOP*)version)->op_sv;
8743
8744         if (!arg && !SvNIOKp(vesv)) {
8745             arg = version;
8746         }
8747         else {
8748             OP *pack;
8749             SV *meth;
8750
8751             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8752                 Perl_croak(aTHX_ "Version number must be a constant number");
8753
8754             /* Make copy of idop so we don't free it twice */
8755             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8756
8757             /* Fake up a method call to VERSION */
8758             meth = newSVpvs_share("VERSION");
8759             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8760                             op_append_elem(OP_LIST,
8761                                         op_prepend_elem(OP_LIST, pack, version),
8762                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8763         }
8764     }
8765
8766     /* Fake up an import/unimport */
8767     if (arg && arg->op_type == OP_STUB) {
8768         imop = arg;             /* no import on explicit () */
8769     }
8770     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8771         imop = NULL;            /* use 5.0; */
8772         if (aver)
8773             use_version = ((SVOP*)idop)->op_sv;
8774         else
8775             idop->op_private |= OPpCONST_NOVER;
8776     }
8777     else {
8778         SV *meth;
8779
8780         /* Make copy of idop so we don't free it twice */
8781         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8782
8783         /* Fake up a method call to import/unimport */
8784         meth = aver
8785             ? newSVpvs_share("import") : newSVpvs_share("unimport");
8786         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8787                        op_append_elem(OP_LIST,
8788                                    op_prepend_elem(OP_LIST, pack, arg),
8789                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8790                        ));
8791     }
8792
8793     /* Fake up the BEGIN {}, which does its thing immediately. */
8794     newATTRSUB(floor,
8795         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8796         NULL,
8797         NULL,
8798         op_append_elem(OP_LINESEQ,
8799             op_append_elem(OP_LINESEQ,
8800                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8801                 newSTATEOP(0, NULL, veop)),
8802             newSTATEOP(0, NULL, imop) ));
8803
8804     if (use_version) {
8805         /* Enable the
8806          * feature bundle that corresponds to the required version. */
8807         use_version = sv_2mortal(new_version(use_version));
8808         S_enable_feature_bundle(aTHX_ use_version);
8809
8810         /* If a version >= 5.11.0 is requested, strictures are on by default! */
8811         if (vcmp(use_version,
8812                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8813             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8814                 PL_hints |= HINT_STRICT_REFS;
8815             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8816                 PL_hints |= HINT_STRICT_SUBS;
8817             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8818                 PL_hints |= HINT_STRICT_VARS;
8819         }
8820         /* otherwise they are off */
8821         else {
8822             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8823                 PL_hints &= ~HINT_STRICT_REFS;
8824             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8825                 PL_hints &= ~HINT_STRICT_SUBS;
8826             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8827                 PL_hints &= ~HINT_STRICT_VARS;
8828         }
8829     }
8830
8831     /* The "did you use incorrect case?" warning used to be here.
8832      * The problem is that on case-insensitive filesystems one
8833      * might get false positives for "use" (and "require"):
8834      * "use Strict" or "require CARP" will work.  This causes
8835      * portability problems for the script: in case-strict
8836      * filesystems the script will stop working.
8837      *
8838      * The "incorrect case" warning checked whether "use Foo"
8839      * imported "Foo" to your namespace, but that is wrong, too:
8840      * there is no requirement nor promise in the language that
8841      * a Foo.pm should or would contain anything in package "Foo".
8842      *
8843      * There is very little Configure-wise that can be done, either:
8844      * the case-sensitivity of the build filesystem of Perl does not
8845      * help in guessing the case-sensitivity of the runtime environment.
8846      */
8847
8848     PL_hints |= HINT_BLOCK_SCOPE;
8849     PL_parser->copline = NOLINE;
8850     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8851 }
8852
8853 /*
8854 =head1 Embedding Functions
8855
8856 =for apidoc load_module
8857
8858 Loads the module whose name is pointed to by the string part of C<name>.
8859 Note that the actual module name, not its filename, should be given.
8860 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8861 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8862 trailing arguments can be used to specify arguments to the module's C<import()>
8863 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8864 on the flags. The flags argument is a bitwise-ORed collection of any of
8865 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8866 (or 0 for no flags).
8867
8868 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8869 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8870 the trailing optional arguments may be omitted entirely. Otherwise, if
8871 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8872 exactly one C<OP*>, containing the op tree that produces the relevant import
8873 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8874 will be used as import arguments; and the list must be terminated with C<(SV*)
8875 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8876 set, the trailing C<NULL> pointer is needed even if no import arguments are
8877 desired. The reference count for each specified C<SV*> argument is
8878 decremented. In addition, the C<name> argument is modified.
8879
8880 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8881 than C<use>.
8882
8883 =for apidoc Amnh||PERL_LOADMOD_DENY
8884 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8885 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8886
8887 =cut */
8888
8889 void
8890 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8891 {
8892     va_list args;
8893
8894     PERL_ARGS_ASSERT_LOAD_MODULE;
8895
8896     va_start(args, ver);
8897     vload_module(flags, name, ver, &args);
8898     va_end(args);
8899 }
8900
8901 #ifdef PERL_IMPLICIT_CONTEXT
8902 void
8903 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8904 {
8905     dTHX;
8906     va_list args;
8907     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8908     va_start(args, ver);
8909     vload_module(flags, name, ver, &args);
8910     va_end(args);
8911 }
8912 #endif
8913
8914 void
8915 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8916 {
8917     OP *veop, *imop;
8918     OP * modname;
8919     I32 floor;
8920
8921     PERL_ARGS_ASSERT_VLOAD_MODULE;
8922
8923     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8924      * that it has a PL_parser to play with while doing that, and also
8925      * that it doesn't mess with any existing parser, by creating a tmp
8926      * new parser with lex_start(). This won't actually be used for much,
8927      * since pp_require() will create another parser for the real work.
8928      * The ENTER/LEAVE pair protect callers from any side effects of use.
8929      *
8930      * start_subparse() creates a new PL_compcv. This means that any ops
8931      * allocated below will be allocated from that CV's op slab, and so
8932      * will be automatically freed if the utilise() fails
8933      */
8934
8935     ENTER;
8936     SAVEVPTR(PL_curcop);
8937     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8938     floor = start_subparse(FALSE, 0);
8939
8940     modname = newSVOP(OP_CONST, 0, name);
8941     modname->op_private |= OPpCONST_BARE;
8942     if (ver) {
8943         veop = newSVOP(OP_CONST, 0, ver);
8944     }
8945     else
8946         veop = NULL;
8947     if (flags & PERL_LOADMOD_NOIMPORT) {
8948         imop = sawparens(newNULLLIST());
8949     }
8950     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8951         imop = va_arg(*args, OP*);
8952     }
8953     else {
8954         SV *sv;
8955         imop = NULL;
8956         sv = va_arg(*args, SV*);
8957         while (sv) {
8958             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8959             sv = va_arg(*args, SV*);
8960         }
8961     }
8962
8963     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8964     LEAVE;
8965 }
8966
8967 PERL_STATIC_INLINE OP *
8968 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8969 {
8970     return newUNOP(OP_ENTERSUB, OPf_STACKED,
8971                    newLISTOP(OP_LIST, 0, arg,
8972                              newUNOP(OP_RV2CV, 0,
8973                                      newGVOP(OP_GV, 0, gv))));
8974 }
8975
8976 OP *
8977 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8978 {
8979     OP *doop;
8980     GV *gv;
8981
8982     PERL_ARGS_ASSERT_DOFILE;
8983
8984     if (!force_builtin && (gv = gv_override("do", 2))) {
8985         doop = S_new_entersubop(aTHX_ gv, term);
8986     }
8987     else {
8988         doop = newUNOP(OP_DOFILE, 0, scalar(term));
8989     }
8990     return doop;
8991 }
8992
8993 /*
8994 =head1 Optree construction
8995
8996 =for apidoc newSLICEOP
8997
8998 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
8999 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9000 be set automatically, and, shifted up eight bits, the eight bits of
9001 C<op_private>, except that the bit with value 1 or 2 is automatically
9002 set as required.  C<listval> and C<subscript> supply the parameters of
9003 the slice; they are consumed by this function and become part of the
9004 constructed op tree.
9005
9006 =cut
9007 */
9008
9009 OP *
9010 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9011 {
9012     return newBINOP(OP_LSLICE, flags,
9013             list(force_list(subscript, 1)),
9014             list(force_list(listval,   1)) );
9015 }
9016
9017 #define ASSIGN_SCALAR 0
9018 #define ASSIGN_LIST   1
9019 #define ASSIGN_REF    2
9020
9021 /* given the optree o on the LHS of an assignment, determine whether its:
9022  *  ASSIGN_SCALAR   $x  = ...
9023  *  ASSIGN_LIST    ($x) = ...
9024  *  ASSIGN_REF     \$x  = ...
9025  */
9026
9027 STATIC I32
9028 S_assignment_type(pTHX_ const OP *o)
9029 {
9030     unsigned type;
9031     U8 flags;
9032     U8 ret;
9033
9034     if (!o)
9035         return ASSIGN_LIST;
9036
9037     if (o->op_type == OP_SREFGEN)
9038     {
9039         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9040         type = kid->op_type;
9041         flags = o->op_flags | kid->op_flags;
9042         if (!(flags & OPf_PARENS)
9043           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9044               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9045             return ASSIGN_REF;
9046         ret = ASSIGN_REF;
9047     } else {
9048         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9049             o = cUNOPo->op_first;
9050         flags = o->op_flags;
9051         type = o->op_type;
9052         ret = ASSIGN_SCALAR;
9053     }
9054
9055     if (type == OP_COND_EXPR) {
9056         OP * const sib = OpSIBLING(cLOGOPo->op_first);
9057         const I32 t = assignment_type(sib);
9058         const I32 f = assignment_type(OpSIBLING(sib));
9059
9060         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9061             return ASSIGN_LIST;
9062         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9063             yyerror("Assignment to both a list and a scalar");
9064         return ASSIGN_SCALAR;
9065     }
9066
9067     if (type == OP_LIST &&
9068         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9069         o->op_private & OPpLVAL_INTRO)
9070         return ret;
9071
9072     if (type == OP_LIST || flags & OPf_PARENS ||
9073         type == OP_RV2AV || type == OP_RV2HV ||
9074         type == OP_ASLICE || type == OP_HSLICE ||
9075         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9076         return ASSIGN_LIST;
9077
9078     if (type == OP_PADAV || type == OP_PADHV)
9079         return ASSIGN_LIST;
9080
9081     if (type == OP_RV2SV)
9082         return ret;
9083
9084     return ret;
9085 }
9086
9087 static OP *
9088 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9089 {
9090     dVAR;
9091     const PADOFFSET target = padop->op_targ;
9092     OP *const other = newOP(OP_PADSV,
9093                             padop->op_flags
9094                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9095     OP *const first = newOP(OP_NULL, 0);
9096     OP *const nullop = newCONDOP(0, first, initop, other);
9097     /* XXX targlex disabled for now; see ticket #124160
9098         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9099      */
9100     OP *const condop = first->op_next;
9101
9102     OpTYPE_set(condop, OP_ONCE);
9103     other->op_targ = target;
9104     nullop->op_flags |= OPf_WANT_SCALAR;
9105
9106     /* Store the initializedness of state vars in a separate
9107        pad entry.  */
9108     condop->op_targ =
9109       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9110     /* hijacking PADSTALE for uninitialized state variables */
9111     SvPADSTALE_on(PAD_SVl(condop->op_targ));
9112
9113     return nullop;
9114 }
9115
9116 /*
9117 =for apidoc newASSIGNOP
9118
9119 Constructs, checks, and returns an assignment op.  C<left> and C<right>
9120 supply the parameters of the assignment; they are consumed by this
9121 function and become part of the constructed op tree.
9122
9123 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9124 a suitable conditional optree is constructed.  If C<optype> is the opcode
9125 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9126 performs the binary operation and assigns the result to the left argument.
9127 Either way, if C<optype> is non-zero then C<flags> has no effect.
9128
9129 If C<optype> is zero, then a plain scalar or list assignment is
9130 constructed.  Which type of assignment it is is automatically determined.
9131 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9132 will be set automatically, and, shifted up eight bits, the eight bits
9133 of C<op_private>, except that the bit with value 1 or 2 is automatically
9134 set as required.
9135
9136 =cut
9137 */
9138
9139 OP *
9140 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9141 {
9142     OP *o;
9143     I32 assign_type;
9144
9145     if (optype) {
9146         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9147             right = scalar(right);
9148             return newLOGOP(optype, 0,
9149                 op_lvalue(scalar(left), optype),
9150                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9151         }
9152         else {
9153             return newBINOP(optype, OPf_STACKED,
9154                 op_lvalue(scalar(left), optype), scalar(right));
9155         }
9156     }
9157
9158     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9159         OP *state_var_op = NULL;
9160         static const char no_list_state[] = "Initialization of state variables"
9161             " in list currently forbidden";
9162         OP *curop;
9163
9164         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9165             left->op_private &= ~ OPpSLICEWARNING;
9166
9167         PL_modcount = 0;
9168         left = op_lvalue(left, OP_AASSIGN);
9169         curop = list(force_list(left, 1));
9170         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9171         o->op_private = (U8)(0 | (flags >> 8));
9172
9173         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9174         {
9175             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9176             if (!(left->op_flags & OPf_PARENS) &&
9177                     lop->op_type == OP_PUSHMARK &&
9178                     (vop = OpSIBLING(lop)) &&
9179                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9180                     !(vop->op_flags & OPf_PARENS) &&
9181                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9182                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
9183                     (eop = OpSIBLING(vop)) &&
9184                     eop->op_type == OP_ENTERSUB &&
9185                     !OpHAS_SIBLING(eop)) {
9186                 state_var_op = vop;
9187             } else {
9188                 while (lop) {
9189                     if ((lop->op_type == OP_PADSV ||
9190                          lop->op_type == OP_PADAV ||
9191                          lop->op_type == OP_PADHV ||
9192                          lop->op_type == OP_PADANY)
9193                       && (lop->op_private & OPpPAD_STATE)
9194                     )
9195                         yyerror(no_list_state);
9196                     lop = OpSIBLING(lop);
9197                 }
9198             }
9199         }
9200         else if (  (left->op_private & OPpLVAL_INTRO)
9201                 && (left->op_private & OPpPAD_STATE)
9202                 && (   left->op_type == OP_PADSV
9203                     || left->op_type == OP_PADAV
9204                     || left->op_type == OP_PADHV
9205                     || left->op_type == OP_PADANY)
9206         ) {
9207                 /* All single variable list context state assignments, hence
9208                    state ($a) = ...
9209                    (state $a) = ...
9210                    state @a = ...
9211                    state (@a) = ...
9212                    (state @a) = ...
9213                    state %a = ...
9214                    state (%a) = ...
9215                    (state %a) = ...
9216                 */
9217                 if (left->op_flags & OPf_PARENS)
9218                     yyerror(no_list_state);
9219                 else
9220                     state_var_op = left;
9221         }
9222
9223         /* optimise @a = split(...) into:
9224         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
9225         * @a, my @a, local @a:  split(...)          (where @a is attached to
9226         *                                            the split op itself)
9227         */
9228
9229         if (   right
9230             && right->op_type == OP_SPLIT
9231             /* don't do twice, e.g. @b = (@a = split) */
9232             && !(right->op_private & OPpSPLIT_ASSIGN))
9233         {
9234             OP *gvop = NULL;
9235
9236             if (   (  left->op_type == OP_RV2AV
9237                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9238                 || left->op_type == OP_PADAV)
9239             {
9240                 /* @pkg or @lex or local @pkg' or 'my @lex' */
9241                 OP *tmpop;
9242                 if (gvop) {
9243 #ifdef USE_ITHREADS
9244                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9245                         = cPADOPx(gvop)->op_padix;
9246                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
9247 #else
9248                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9249                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9250                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
9251 #endif
9252                     right->op_private |=
9253                         left->op_private & OPpOUR_INTRO;
9254                 }
9255                 else {
9256                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9257                     left->op_targ = 0;  /* steal it */
9258                     right->op_private |= OPpSPLIT_LEX;
9259                 }
9260                 right->op_private |= left->op_private & OPpLVAL_INTRO;
9261
9262               detach_split:
9263                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
9264                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9265                 assert(OpSIBLING(tmpop) == right);
9266                 assert(!OpHAS_SIBLING(right));
9267                 /* detach the split subtreee from the o tree,
9268                  * then free the residual o tree */
9269                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9270                 op_free(o);                     /* blow off assign */
9271                 right->op_private |= OPpSPLIT_ASSIGN;
9272                 right->op_flags &= ~OPf_WANT;
9273                         /* "I don't know and I don't care." */
9274                 return right;
9275             }
9276             else if (left->op_type == OP_RV2AV) {
9277                 /* @{expr} */
9278
9279                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9280                 assert(OpSIBLING(pushop) == left);
9281                 /* Detach the array ...  */
9282                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9283                 /* ... and attach it to the split.  */
9284                 op_sibling_splice(right, cLISTOPx(right)->op_last,
9285                                   0, left);
9286                 right->op_flags |= OPf_STACKED;
9287                 /* Detach split and expunge aassign as above.  */
9288                 goto detach_split;
9289             }
9290             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9291                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
9292             {
9293                 /* convert split(...,0) to split(..., PL_modcount+1) */
9294                 SV ** const svp =
9295                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9296                 SV * const sv = *svp;
9297                 if (SvIOK(sv) && SvIVX(sv) == 0)
9298                 {
9299                   if (right->op_private & OPpSPLIT_IMPLIM) {
9300                     /* our own SV, created in ck_split */
9301                     SvREADONLY_off(sv);
9302                     sv_setiv(sv, PL_modcount+1);
9303                   }
9304                   else {
9305                     /* SV may belong to someone else */
9306                     SvREFCNT_dec(sv);
9307                     *svp = newSViv(PL_modcount+1);
9308                   }
9309                 }
9310             }
9311         }
9312
9313         if (state_var_op)
9314             o = S_newONCEOP(aTHX_ o, state_var_op);
9315         return o;
9316     }
9317     if (assign_type == ASSIGN_REF)
9318         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9319     if (!right)
9320         right = newOP(OP_UNDEF, 0);
9321     if (right->op_type == OP_READLINE) {
9322         right->op_flags |= OPf_STACKED;
9323         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9324                 scalar(right));
9325     }
9326     else {
9327         o = newBINOP(OP_SASSIGN, flags,
9328             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9329     }
9330     return o;
9331 }
9332
9333 /*
9334 =for apidoc newSTATEOP
9335
9336 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
9337 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9338 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9339 If C<label> is non-null, it supplies the name of a label to attach to
9340 the state op; this function takes ownership of the memory pointed at by
9341 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
9342 for the state op.
9343
9344 If C<o> is null, the state op is returned.  Otherwise the state op is
9345 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
9346 is consumed by this function and becomes part of the returned op tree.
9347
9348 =cut
9349 */
9350
9351 OP *
9352 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9353 {
9354     dVAR;
9355     const U32 seq = intro_my();
9356     const U32 utf8 = flags & SVf_UTF8;
9357     COP *cop;
9358
9359     PL_parser->parsed_sub = 0;
9360
9361     flags &= ~SVf_UTF8;
9362
9363     NewOp(1101, cop, 1, COP);
9364     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9365         OpTYPE_set(cop, OP_DBSTATE);
9366     }
9367     else {
9368         OpTYPE_set(cop, OP_NEXTSTATE);
9369     }
9370     cop->op_flags = (U8)flags;
9371     CopHINTS_set(cop, PL_hints);
9372 #ifdef VMS
9373     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9374 #endif
9375     cop->op_next = (OP*)cop;
9376
9377     cop->cop_seq = seq;
9378     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9379     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9380     if (label) {
9381         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9382
9383         PL_hints |= HINT_BLOCK_SCOPE;
9384         /* It seems that we need to defer freeing this pointer, as other parts
9385            of the grammar end up wanting to copy it after this op has been
9386            created. */
9387         SAVEFREEPV(label);
9388     }
9389
9390     if (PL_parser->preambling != NOLINE) {
9391         CopLINE_set(cop, PL_parser->preambling);
9392         PL_parser->copline = NOLINE;
9393     }
9394     else if (PL_parser->copline == NOLINE)
9395         CopLINE_set(cop, CopLINE(PL_curcop));
9396     else {
9397         CopLINE_set(cop, PL_parser->copline);
9398         PL_parser->copline = NOLINE;
9399     }
9400 #ifdef USE_ITHREADS
9401     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
9402 #else
9403     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9404 #endif
9405     CopSTASH_set(cop, PL_curstash);
9406
9407     if (cop->op_type == OP_DBSTATE) {
9408         /* this line can have a breakpoint - store the cop in IV */
9409         AV *av = CopFILEAVx(PL_curcop);
9410         if (av) {
9411             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9412             if (svp && *svp != &PL_sv_undef ) {
9413                 (void)SvIOK_on(*svp);
9414                 SvIV_set(*svp, PTR2IV(cop));
9415             }
9416         }
9417     }
9418
9419     if (flags & OPf_SPECIAL)
9420         op_null((OP*)cop);
9421     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9422 }
9423
9424 /*
9425 =for apidoc newLOGOP
9426
9427 Constructs, checks, and returns a logical (flow control) op.  C<type>
9428 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
9429 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9430 the eight bits of C<op_private>, except that the bit with value 1 is
9431 automatically set.  C<first> supplies the expression controlling the
9432 flow, and C<other> supplies the side (alternate) chain of ops; they are
9433 consumed by this function and become part of the constructed op tree.
9434
9435 =cut
9436 */
9437
9438 OP *
9439 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9440 {
9441     PERL_ARGS_ASSERT_NEWLOGOP;
9442
9443     return new_logop(type, flags, &first, &other);
9444 }
9445
9446
9447 /* See if the optree o contains a single OP_CONST (plus possibly
9448  * surrounding enter/nextstate/null etc). If so, return it, else return
9449  * NULL.
9450  */
9451
9452 STATIC OP *
9453 S_search_const(pTHX_ OP *o)
9454 {
9455     PERL_ARGS_ASSERT_SEARCH_CONST;
9456
9457   redo:
9458     switch (o->op_type) {
9459         case OP_CONST:
9460             return o;
9461         case OP_NULL:
9462             if (o->op_flags & OPf_KIDS) {
9463                 o = cUNOPo->op_first;
9464                 goto redo;
9465             }
9466             break;
9467         case OP_LEAVE:
9468         case OP_SCOPE:
9469         case OP_LINESEQ:
9470         {
9471             OP *kid;
9472             if (!(o->op_flags & OPf_KIDS))
9473                 return NULL;
9474             kid = cLISTOPo->op_first;
9475
9476             do {
9477                 switch (kid->op_type) {
9478                     case OP_ENTER:
9479                     case OP_NULL:
9480                     case OP_NEXTSTATE:
9481                         kid = OpSIBLING(kid);
9482                         break;
9483                     default:
9484                         if (kid != cLISTOPo->op_last)
9485                             return NULL;
9486                         goto last;
9487                 }
9488             } while (kid);
9489
9490             if (!kid)
9491                 kid = cLISTOPo->op_last;
9492           last:
9493              o = kid;
9494              goto redo;
9495         }
9496     }
9497
9498     return NULL;
9499 }
9500
9501
9502 STATIC OP *
9503 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9504 {
9505     dVAR;
9506     LOGOP *logop;
9507     OP *o;
9508     OP *first;
9509     OP *other;
9510     OP *cstop = NULL;
9511     int prepend_not = 0;
9512
9513     PERL_ARGS_ASSERT_NEW_LOGOP;
9514
9515     first = *firstp;
9516     other = *otherp;
9517
9518     /* [perl #59802]: Warn about things like "return $a or $b", which
9519        is parsed as "(return $a) or $b" rather than "return ($a or
9520        $b)".  NB: This also applies to xor, which is why we do it
9521        here.
9522      */
9523     switch (first->op_type) {
9524     case OP_NEXT:
9525     case OP_LAST:
9526     case OP_REDO:
9527         /* XXX: Perhaps we should emit a stronger warning for these.
9528            Even with the high-precedence operator they don't seem to do
9529            anything sensible.
9530
9531            But until we do, fall through here.
9532          */
9533     case OP_RETURN:
9534     case OP_EXIT:
9535     case OP_DIE:
9536     case OP_GOTO:
9537         /* XXX: Currently we allow people to "shoot themselves in the
9538            foot" by explicitly writing "(return $a) or $b".
9539
9540            Warn unless we are looking at the result from folding or if
9541            the programmer explicitly grouped the operators like this.
9542            The former can occur with e.g.
9543
9544                 use constant FEATURE => ( $] >= ... );
9545                 sub { not FEATURE and return or do_stuff(); }
9546          */
9547         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9548             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9549                            "Possible precedence issue with control flow operator");
9550         /* XXX: Should we optimze this to "return $a;" (i.e. remove
9551            the "or $b" part)?
9552         */
9553         break;
9554     }
9555
9556     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
9557         return newBINOP(type, flags, scalar(first), scalar(other));
9558
9559     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9560         || type == OP_CUSTOM);
9561
9562     scalarboolean(first);
9563
9564     /* search for a constant op that could let us fold the test */
9565     if ((cstop = search_const(first))) {
9566         if (cstop->op_private & OPpCONST_STRICT)
9567             no_bareword_allowed(cstop);
9568         else if ((cstop->op_private & OPpCONST_BARE))
9569                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9570         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
9571             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9572             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9573             /* Elide the (constant) lhs, since it can't affect the outcome */
9574             *firstp = NULL;
9575             if (other->op_type == OP_CONST)
9576                 other->op_private |= OPpCONST_SHORTCIRCUIT;
9577             op_free(first);
9578             if (other->op_type == OP_LEAVE)
9579                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9580             else if (other->op_type == OP_MATCH
9581                   || other->op_type == OP_SUBST
9582                   || other->op_type == OP_TRANSR
9583                   || other->op_type == OP_TRANS)
9584                 /* Mark the op as being unbindable with =~ */
9585                 other->op_flags |= OPf_SPECIAL;
9586
9587             other->op_folded = 1;
9588             return other;
9589         }
9590         else {
9591             /* Elide the rhs, since the outcome is entirely determined by
9592              * the (constant) lhs */
9593
9594             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9595             const OP *o2 = other;
9596             if ( ! (o2->op_type == OP_LIST
9597                     && (( o2 = cUNOPx(o2)->op_first))
9598                     && o2->op_type == OP_PUSHMARK
9599                     && (( o2 = OpSIBLING(o2))) )
9600             )
9601                 o2 = other;
9602             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9603                         || o2->op_type == OP_PADHV)
9604                 && o2->op_private & OPpLVAL_INTRO
9605                 && !(o2->op_private & OPpPAD_STATE))
9606             {
9607         Perl_croak(aTHX_ "This use of my() in false conditional is "
9608                           "no longer allowed");
9609             }
9610
9611             *otherp = NULL;
9612             if (cstop->op_type == OP_CONST)
9613                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9614             op_free(other);
9615             return first;
9616         }
9617     }
9618     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9619         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9620     {
9621         const OP * const k1 = ((UNOP*)first)->op_first;
9622         const OP * const k2 = OpSIBLING(k1);
9623         OPCODE warnop = 0;
9624         switch (first->op_type)
9625         {
9626         case OP_NULL:
9627             if (k2 && k2->op_type == OP_READLINE
9628                   && (k2->op_flags & OPf_STACKED)
9629                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9630             {
9631                 warnop = k2->op_type;
9632             }
9633             break;
9634
9635         case OP_SASSIGN:
9636             if (k1->op_type == OP_READDIR
9637                   || k1->op_type == OP_GLOB
9638                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9639                  || k1->op_type == OP_EACH
9640                  || k1->op_type == OP_AEACH)
9641             {
9642                 warnop = ((k1->op_type == OP_NULL)
9643                           ? (OPCODE)k1->op_targ : k1->op_type);
9644             }
9645             break;
9646         }
9647         if (warnop) {
9648             const line_t oldline = CopLINE(PL_curcop);
9649             /* This ensures that warnings are reported at the first line
9650                of the construction, not the last.  */
9651             CopLINE_set(PL_curcop, PL_parser->copline);
9652             Perl_warner(aTHX_ packWARN(WARN_MISC),
9653                  "Value of %s%s can be \"0\"; test with defined()",
9654                  PL_op_desc[warnop],
9655                  ((warnop == OP_READLINE || warnop == OP_GLOB)
9656                   ? " construct" : "() operator"));
9657             CopLINE_set(PL_curcop, oldline);
9658         }
9659     }
9660
9661     /* optimize AND and OR ops that have NOTs as children */
9662     if (first->op_type == OP_NOT
9663         && (first->op_flags & OPf_KIDS)
9664         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9665             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
9666         ) {
9667         if (type == OP_AND || type == OP_OR) {
9668             if (type == OP_AND)
9669                 type = OP_OR;
9670             else
9671                 type = OP_AND;
9672             op_null(first);
9673             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9674                 op_null(other);
9675                 prepend_not = 1; /* prepend a NOT op later */
9676             }
9677         }
9678     }
9679
9680     logop = alloc_LOGOP(type, first, LINKLIST(other));
9681     logop->op_flags |= (U8)flags;
9682     logop->op_private = (U8)(1 | (flags >> 8));
9683
9684     /* establish postfix order */
9685     logop->op_next = LINKLIST(first);
9686     first->op_next = (OP*)logop;
9687     assert(!OpHAS_SIBLING(first));
9688     op_sibling_splice((OP*)logop, first, 0, other);
9689
9690     CHECKOP(type,logop);
9691
9692     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9693                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9694                 (OP*)logop);
9695     other->op_next = o;
9696
9697     return o;
9698 }
9699
9700 /*
9701 =for apidoc newCONDOP
9702
9703 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9704 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9705 will be set automatically, and, shifted up eight bits, the eight bits of
9706 C<op_private>, except that the bit with value 1 is automatically set.
9707 C<first> supplies the expression selecting between the two branches,
9708 and C<trueop> and C<falseop> supply the branches; they are consumed by
9709 this function and become part of the constructed op tree.
9710
9711 =cut
9712 */
9713
9714 OP *
9715 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9716 {
9717     dVAR;
9718     LOGOP *logop;
9719     OP *start;
9720     OP *o;
9721     OP *cstop;
9722
9723     PERL_ARGS_ASSERT_NEWCONDOP;
9724
9725     if (!falseop)
9726         return newLOGOP(OP_AND, 0, first, trueop);
9727     if (!trueop)
9728         return newLOGOP(OP_OR, 0, first, falseop);
9729
9730     scalarboolean(first);
9731     if ((cstop = search_const(first))) {
9732         /* Left or right arm of the conditional?  */
9733         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9734         OP *live = left ? trueop : falseop;
9735         OP *const dead = left ? falseop : trueop;
9736         if (cstop->op_private & OPpCONST_BARE &&
9737             cstop->op_private & OPpCONST_STRICT) {
9738             no_bareword_allowed(cstop);
9739         }
9740         op_free(first);
9741         op_free(dead);
9742         if (live->op_type == OP_LEAVE)
9743             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9744         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9745               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9746             /* Mark the op as being unbindable with =~ */
9747             live->op_flags |= OPf_SPECIAL;
9748         live->op_folded = 1;
9749         return live;
9750     }
9751     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9752     logop->op_flags |= (U8)flags;
9753     logop->op_private = (U8)(1 | (flags >> 8));
9754     logop->op_next = LINKLIST(falseop);
9755
9756     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9757             logop);
9758
9759     /* establish postfix order */
9760     start = LINKLIST(first);
9761     first->op_next = (OP*)logop;
9762
9763     /* make first, trueop, falseop siblings */
9764     op_sibling_splice((OP*)logop, first,  0, trueop);
9765     op_sibling_splice((OP*)logop, trueop, 0, falseop);
9766
9767     o = newUNOP(OP_NULL, 0, (OP*)logop);
9768
9769     trueop->op_next = falseop->op_next = o;
9770
9771     o->op_next = start;
9772     return o;
9773 }
9774
9775 /*
9776 =for apidoc newRANGE
9777
9778 Constructs and returns a C<range> op, with subordinate C<flip> and
9779 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
9780 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9781 for both the C<flip> and C<range> ops, except that the bit with value
9782 1 is automatically set.  C<left> and C<right> supply the expressions
9783 controlling the endpoints of the range; they are consumed by this function
9784 and become part of the constructed op tree.
9785
9786 =cut
9787 */
9788
9789 OP *
9790 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9791 {
9792     LOGOP *range;
9793     OP *flip;
9794     OP *flop;
9795     OP *leftstart;
9796     OP *o;
9797
9798     PERL_ARGS_ASSERT_NEWRANGE;
9799
9800     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9801     range->op_flags = OPf_KIDS;
9802     leftstart = LINKLIST(left);
9803     range->op_private = (U8)(1 | (flags >> 8));
9804
9805     /* make left and right siblings */
9806     op_sibling_splice((OP*)range, left, 0, right);
9807
9808     range->op_next = (OP*)range;
9809     flip = newUNOP(OP_FLIP, flags, (OP*)range);
9810     flop = newUNOP(OP_FLOP, 0, flip);
9811     o = newUNOP(OP_NULL, 0, flop);
9812     LINKLIST(flop);
9813     range->op_next = leftstart;
9814
9815     left->op_next = flip;
9816     right->op_next = flop;
9817
9818     range->op_targ =
9819         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9820     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9821     flip->op_targ =
9822         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9823     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9824     SvPADTMP_on(PAD_SV(flip->op_targ));
9825
9826     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9827     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9828
9829     /* check barewords before they might be optimized aways */
9830     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9831         no_bareword_allowed(left);
9832     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9833         no_bareword_allowed(right);
9834
9835     flip->op_next = o;
9836     if (!flip->op_private || !flop->op_private)
9837         LINKLIST(o);            /* blow off optimizer unless constant */
9838
9839     return o;
9840 }
9841
9842 /*
9843 =for apidoc newLOOPOP
9844
9845 Constructs, checks, and returns an op tree expressing a loop.  This is
9846 only a loop in the control flow through the op tree; it does not have
9847 the heavyweight loop structure that allows exiting the loop by C<last>
9848 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
9849 top-level op, except that some bits will be set automatically as required.
9850 C<expr> supplies the expression controlling loop iteration, and C<block>
9851 supplies the body of the loop; they are consumed by this function and
9852 become part of the constructed op tree.  C<debuggable> is currently
9853 unused and should always be 1.
9854
9855 =cut
9856 */
9857
9858 OP *
9859 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9860 {
9861     OP* listop;
9862     OP* o;
9863     const bool once = block && block->op_flags & OPf_SPECIAL &&
9864                       block->op_type == OP_NULL;
9865
9866     PERL_UNUSED_ARG(debuggable);
9867
9868     if (expr) {
9869         if (once && (
9870               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9871            || (  expr->op_type == OP_NOT
9872               && cUNOPx(expr)->op_first->op_type == OP_CONST
9873               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9874               )
9875            ))
9876             /* Return the block now, so that S_new_logop does not try to
9877                fold it away. */
9878         {
9879             op_free(expr);
9880             return block;       /* do {} while 0 does once */
9881         }
9882
9883         if (expr->op_type == OP_READLINE
9884             || expr->op_type == OP_READDIR
9885             || expr->op_type == OP_GLOB
9886             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9887             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9888             expr = newUNOP(OP_DEFINED, 0,
9889                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9890         } else if (expr->op_flags & OPf_KIDS) {
9891             const OP * const k1 = ((UNOP*)expr)->op_first;
9892             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9893             switch (expr->op_type) {
9894               case OP_NULL:
9895                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9896                       && (k2->op_flags & OPf_STACKED)
9897                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9898                     expr = newUNOP(OP_DEFINED, 0, expr);
9899                 break;
9900
9901               case OP_SASSIGN:
9902                 if (k1 && (k1->op_type == OP_READDIR
9903                       || k1->op_type == OP_GLOB
9904                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9905                      || k1->op_type == OP_EACH
9906                      || k1->op_type == OP_AEACH))
9907                     expr = newUNOP(OP_DEFINED, 0, expr);
9908                 break;
9909             }
9910         }
9911     }
9912
9913     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9914      * op, in listop. This is wrong. [perl #27024] */
9915     if (!block)
9916         block = newOP(OP_NULL, 0);
9917     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9918     o = new_logop(OP_AND, 0, &expr, &listop);
9919
9920     if (once) {
9921         ASSUME(listop);
9922     }
9923
9924     if (listop)
9925         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9926
9927     if (once && o != listop)
9928     {
9929         assert(cUNOPo->op_first->op_type == OP_AND
9930             || cUNOPo->op_first->op_type == OP_OR);
9931         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9932     }
9933
9934     if (o == listop)
9935         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
9936
9937     o->op_flags |= flags;
9938     o = op_scope(o);
9939     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9940     return o;
9941 }
9942
9943 /*
9944 =for apidoc newWHILEOP
9945
9946 Constructs, checks, and returns an op tree expressing a C<while> loop.
9947 This is a heavyweight loop, with structure that allows exiting the loop
9948 by C<last> and suchlike.
9949
9950 C<loop> is an optional preconstructed C<enterloop> op to use in the
9951 loop; if it is null then a suitable op will be constructed automatically.
9952 C<expr> supplies the loop's controlling expression.  C<block> supplies the
9953 main body of the loop, and C<cont> optionally supplies a C<continue> block
9954 that operates as a second half of the body.  All of these optree inputs
9955 are consumed by this function and become part of the constructed op tree.
9956
9957 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9958 op and, shifted up eight bits, the eight bits of C<op_private> for
9959 the C<leaveloop> op, except that (in both cases) some bits will be set
9960 automatically.  C<debuggable> is currently unused and should always be 1.
9961 C<has_my> can be supplied as true to force the
9962 loop body to be enclosed in its own scope.
9963
9964 =cut
9965 */
9966
9967 OP *
9968 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9969         OP *expr, OP *block, OP *cont, I32 has_my)
9970 {
9971     dVAR;
9972     OP *redo;
9973     OP *next = NULL;
9974     OP *listop;
9975     OP *o;
9976     U8 loopflags = 0;
9977
9978     PERL_UNUSED_ARG(debuggable);
9979
9980     if (expr) {
9981         if (expr->op_type == OP_READLINE
9982          || expr->op_type == OP_READDIR
9983          || expr->op_type == OP_GLOB
9984          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9985                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9986             expr = newUNOP(OP_DEFINED, 0,
9987                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9988         } else if (expr->op_flags & OPf_KIDS) {
9989             const OP * const k1 = ((UNOP*)expr)->op_first;
9990             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9991             switch (expr->op_type) {
9992               case OP_NULL:
9993                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9994                       && (k2->op_flags & OPf_STACKED)
9995                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9996                     expr = newUNOP(OP_DEFINED, 0, expr);
9997                 break;
9998
9999               case OP_SASSIGN:
10000                 if (k1 && (k1->op_type == OP_READDIR
10001                       || k1->op_type == OP_GLOB
10002                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10003                      || k1->op_type == OP_EACH
10004                      || k1->op_type == OP_AEACH))
10005                     expr = newUNOP(OP_DEFINED, 0, expr);
10006                 break;
10007             }
10008         }
10009     }
10010
10011     if (!block)
10012         block = newOP(OP_NULL, 0);
10013     else if (cont || has_my) {
10014         block = op_scope(block);
10015     }
10016
10017     if (cont) {
10018         next = LINKLIST(cont);
10019     }
10020     if (expr) {
10021         OP * const unstack = newOP(OP_UNSTACK, 0);
10022         if (!next)
10023             next = unstack;
10024         cont = op_append_elem(OP_LINESEQ, cont, unstack);
10025     }
10026
10027     assert(block);
10028     listop = op_append_list(OP_LINESEQ, block, cont);
10029     assert(listop);
10030     redo = LINKLIST(listop);
10031
10032     if (expr) {
10033         scalar(listop);
10034         o = new_logop(OP_AND, 0, &expr, &listop);
10035         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10036             op_free((OP*)loop);
10037             return expr;                /* listop already freed by new_logop */
10038         }
10039         if (listop)
10040             ((LISTOP*)listop)->op_last->op_next =
10041                 (o == listop ? redo : LINKLIST(o));
10042     }
10043     else
10044         o = listop;
10045
10046     if (!loop) {
10047         NewOp(1101,loop,1,LOOP);
10048         OpTYPE_set(loop, OP_ENTERLOOP);
10049         loop->op_private = 0;
10050         loop->op_next = (OP*)loop;
10051     }
10052
10053     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10054
10055     loop->op_redoop = redo;
10056     loop->op_lastop = o;
10057     o->op_private |= loopflags;
10058
10059     if (next)
10060         loop->op_nextop = next;
10061     else
10062         loop->op_nextop = o;
10063
10064     o->op_flags |= flags;
10065     o->op_private |= (flags >> 8);
10066     return o;
10067 }
10068
10069 /*
10070 =for apidoc newFOROP
10071
10072 Constructs, checks, and returns an op tree expressing a C<foreach>
10073 loop (iteration through a list of values).  This is a heavyweight loop,
10074 with structure that allows exiting the loop by C<last> and suchlike.
10075
10076 C<sv> optionally supplies the variable that will be aliased to each
10077 item in turn; if null, it defaults to C<$_>.
10078 C<expr> supplies the list of values to iterate over.  C<block> supplies
10079 the main body of the loop, and C<cont> optionally supplies a C<continue>
10080 block that operates as a second half of the body.  All of these optree
10081 inputs are consumed by this function and become part of the constructed
10082 op tree.
10083
10084 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10085 op and, shifted up eight bits, the eight bits of C<op_private> for
10086 the C<leaveloop> op, except that (in both cases) some bits will be set
10087 automatically.
10088
10089 =cut
10090 */
10091
10092 OP *
10093 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10094 {
10095     dVAR;
10096     LOOP *loop;
10097     OP *wop;
10098     PADOFFSET padoff = 0;
10099     I32 iterflags = 0;
10100     I32 iterpflags = 0;
10101
10102     PERL_ARGS_ASSERT_NEWFOROP;
10103
10104     if (sv) {
10105         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
10106             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10107             OpTYPE_set(sv, OP_RV2GV);
10108
10109             /* The op_type check is needed to prevent a possible segfault
10110              * if the loop variable is undeclared and 'strict vars' is in
10111              * effect. This is illegal but is nonetheless parsed, so we
10112              * may reach this point with an OP_CONST where we're expecting
10113              * an OP_GV.
10114              */
10115             if (cUNOPx(sv)->op_first->op_type == OP_GV
10116              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10117                 iterpflags |= OPpITER_DEF;
10118         }
10119         else if (sv->op_type == OP_PADSV) { /* private variable */
10120             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10121             padoff = sv->op_targ;
10122             sv->op_targ = 0;
10123             op_free(sv);
10124             sv = NULL;
10125             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10126         }
10127         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10128             NOOP;
10129         else
10130             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10131         if (padoff) {
10132             PADNAME * const pn = PAD_COMPNAME(padoff);
10133             const char * const name = PadnamePV(pn);
10134
10135             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10136                 iterpflags |= OPpITER_DEF;
10137         }
10138     }
10139     else {
10140         sv = newGVOP(OP_GV, 0, PL_defgv);
10141         iterpflags |= OPpITER_DEF;
10142     }
10143
10144     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10145         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10146         iterflags |= OPf_STACKED;
10147     }
10148     else if (expr->op_type == OP_NULL &&
10149              (expr->op_flags & OPf_KIDS) &&
10150              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10151     {
10152         /* Basically turn for($x..$y) into the same as for($x,$y), but we
10153          * set the STACKED flag to indicate that these values are to be
10154          * treated as min/max values by 'pp_enteriter'.
10155          */
10156         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10157         LOGOP* const range = (LOGOP*) flip->op_first;
10158         OP* const left  = range->op_first;
10159         OP* const right = OpSIBLING(left);
10160         LISTOP* listop;
10161
10162         range->op_flags &= ~OPf_KIDS;
10163         /* detach range's children */
10164         op_sibling_splice((OP*)range, NULL, -1, NULL);
10165
10166         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10167         listop->op_first->op_next = range->op_next;
10168         left->op_next = range->op_other;
10169         right->op_next = (OP*)listop;
10170         listop->op_next = listop->op_first;
10171
10172         op_free(expr);
10173         expr = (OP*)(listop);
10174         op_null(expr);
10175         iterflags |= OPf_STACKED;
10176     }
10177     else {
10178         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10179     }
10180
10181     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10182                                   op_append_elem(OP_LIST, list(expr),
10183                                                  scalar(sv)));
10184     assert(!loop->op_next);
10185     /* for my  $x () sets OPpLVAL_INTRO;
10186      * for our $x () sets OPpOUR_INTRO */
10187     loop->op_private = (U8)iterpflags;
10188
10189     /* upgrade loop from a LISTOP to a LOOPOP;
10190      * keep it in-place if there's space */
10191     if (loop->op_slabbed
10192         &&    OpSLOT(loop)->opslot_size
10193             < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10194     {
10195         /* no space; allocate new op */
10196         LOOP *tmp;
10197         NewOp(1234,tmp,1,LOOP);
10198         Copy(loop,tmp,1,LISTOP);
10199         assert(loop->op_last->op_sibparent == (OP*)loop);
10200         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10201         S_op_destroy(aTHX_ (OP*)loop);
10202         loop = tmp;
10203     }
10204     else if (!loop->op_slabbed)
10205     {
10206         /* loop was malloc()ed */
10207         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10208         OpLASTSIB_set(loop->op_last, (OP*)loop);
10209     }
10210     loop->op_targ = padoff;
10211     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10212     return wop;
10213 }
10214
10215 /*
10216 =for apidoc newLOOPEX
10217
10218 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10219 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
10220 determining the target of the op; it is consumed by this function and
10221 becomes part of the constructed op tree.
10222
10223 =cut
10224 */
10225
10226 OP*
10227 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10228 {
10229     OP *o = NULL;
10230
10231     PERL_ARGS_ASSERT_NEWLOOPEX;
10232
10233     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10234         || type == OP_CUSTOM);
10235
10236     if (type != OP_GOTO) {
10237         /* "last()" means "last" */
10238         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10239             o = newOP(type, OPf_SPECIAL);
10240         }
10241     }
10242     else {
10243         /* Check whether it's going to be a goto &function */
10244         if (label->op_type == OP_ENTERSUB
10245                 && !(label->op_flags & OPf_STACKED))
10246             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10247     }
10248
10249     /* Check for a constant argument */
10250     if (label->op_type == OP_CONST) {
10251             SV * const sv = ((SVOP *)label)->op_sv;
10252             STRLEN l;
10253             const char *s = SvPV_const(sv,l);
10254             if (l == strlen(s)) {
10255                 o = newPVOP(type,
10256                             SvUTF8(((SVOP*)label)->op_sv),
10257                             savesharedpv(
10258                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10259             }
10260     }
10261
10262     /* If we have already created an op, we do not need the label. */
10263     if (o)
10264                 op_free(label);
10265     else o = newUNOP(type, OPf_STACKED, label);
10266
10267     PL_hints |= HINT_BLOCK_SCOPE;
10268     return o;
10269 }
10270
10271 /* if the condition is a literal array or hash
10272    (or @{ ... } etc), make a reference to it.
10273  */
10274 STATIC OP *
10275 S_ref_array_or_hash(pTHX_ OP *cond)
10276 {
10277     if (cond
10278     && (cond->op_type == OP_RV2AV
10279     ||  cond->op_type == OP_PADAV
10280     ||  cond->op_type == OP_RV2HV
10281     ||  cond->op_type == OP_PADHV))
10282
10283         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10284
10285     else if(cond
10286     && (cond->op_type == OP_ASLICE
10287     ||  cond->op_type == OP_KVASLICE
10288     ||  cond->op_type == OP_HSLICE
10289     ||  cond->op_type == OP_KVHSLICE)) {
10290
10291         /* anonlist now needs a list from this op, was previously used in
10292          * scalar context */
10293         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10294         cond->op_flags |= OPf_WANT_LIST;
10295
10296         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10297     }
10298
10299     else
10300         return cond;
10301 }
10302
10303 /* These construct the optree fragments representing given()
10304    and when() blocks.
10305
10306    entergiven and enterwhen are LOGOPs; the op_other pointer
10307    points up to the associated leave op. We need this so we
10308    can put it in the context and make break/continue work.
10309    (Also, of course, pp_enterwhen will jump straight to
10310    op_other if the match fails.)
10311  */
10312
10313 STATIC OP *
10314 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10315                    I32 enter_opcode, I32 leave_opcode,
10316                    PADOFFSET entertarg)
10317 {
10318     dVAR;
10319     LOGOP *enterop;
10320     OP *o;
10321
10322     PERL_ARGS_ASSERT_NEWGIVWHENOP;
10323     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10324
10325     enterop = alloc_LOGOP(enter_opcode, block, NULL);
10326     enterop->op_targ = 0;
10327     enterop->op_private = 0;
10328
10329     o = newUNOP(leave_opcode, 0, (OP *) enterop);
10330
10331     if (cond) {
10332         /* prepend cond if we have one */
10333         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10334
10335         o->op_next = LINKLIST(cond);
10336         cond->op_next = (OP *) enterop;
10337     }
10338     else {
10339         /* This is a default {} block */
10340         enterop->op_flags |= OPf_SPECIAL;
10341         o      ->op_flags |= OPf_SPECIAL;
10342
10343         o->op_next = (OP *) enterop;
10344     }
10345
10346     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10347                                        entergiven and enterwhen both
10348                                        use ck_null() */
10349
10350     enterop->op_next = LINKLIST(block);
10351     block->op_next = enterop->op_other = o;
10352
10353     return o;
10354 }
10355
10356
10357 /* For the purposes of 'when(implied_smartmatch)'
10358  *              versus 'when(boolean_expression)',
10359  * does this look like a boolean operation? For these purposes
10360    a boolean operation is:
10361      - a subroutine call [*]
10362      - a logical connective
10363      - a comparison operator
10364      - a filetest operator, with the exception of -s -M -A -C
10365      - defined(), exists() or eof()
10366      - /$re/ or $foo =~ /$re/
10367
10368    [*] possibly surprising
10369  */
10370 STATIC bool
10371 S_looks_like_bool(pTHX_ const OP *o)
10372 {
10373     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10374
10375     switch(o->op_type) {
10376         case OP_OR:
10377         case OP_DOR:
10378             return looks_like_bool(cLOGOPo->op_first);
10379
10380         case OP_AND:
10381         {
10382             OP* sibl = OpSIBLING(cLOGOPo->op_first);
10383             ASSUME(sibl);
10384             return (
10385                 looks_like_bool(cLOGOPo->op_first)
10386              && looks_like_bool(sibl));
10387         }
10388
10389         case OP_NULL:
10390         case OP_SCALAR:
10391             return (
10392                 o->op_flags & OPf_KIDS
10393             && looks_like_bool(cUNOPo->op_first));
10394
10395         case OP_ENTERSUB:
10396
10397         case OP_NOT:    case OP_XOR:
10398
10399         case OP_EQ:     case OP_NE:     case OP_LT:
10400         case OP_GT:     case OP_LE:     case OP_GE:
10401
10402         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
10403         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
10404
10405         case OP_SEQ:    case OP_SNE:    case OP_SLT:
10406         case OP_SGT:    case OP_SLE:    case OP_SGE:
10407
10408         case OP_SMARTMATCH:
10409
10410         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
10411         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
10412         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
10413         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
10414         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
10415         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
10416         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
10417         case OP_FTTEXT:   case OP_FTBINARY:
10418
10419         case OP_DEFINED: case OP_EXISTS:
10420         case OP_MATCH:   case OP_EOF:
10421
10422         case OP_FLOP:
10423
10424             return TRUE;
10425
10426         case OP_INDEX:
10427         case OP_RINDEX:
10428             /* optimised-away (index() != -1) or similar comparison */
10429             if (o->op_private & OPpTRUEBOOL)
10430                 return TRUE;
10431             return FALSE;
10432
10433         case OP_CONST:
10434             /* Detect comparisons that have been optimized away */
10435             if (cSVOPo->op_sv == &PL_sv_yes
10436             ||  cSVOPo->op_sv == &PL_sv_no)
10437
10438                 return TRUE;
10439             else
10440                 return FALSE;
10441         /* FALLTHROUGH */
10442         default:
10443             return FALSE;
10444     }
10445 }
10446
10447
10448 /*
10449 =for apidoc newGIVENOP
10450
10451 Constructs, checks, and returns an op tree expressing a C<given> block.
10452 C<cond> supplies the expression to whose value C<$_> will be locally
10453 aliased, and C<block> supplies the body of the C<given> construct; they
10454 are consumed by this function and become part of the constructed op tree.
10455 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10456
10457 =cut
10458 */
10459
10460 OP *
10461 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10462 {
10463     PERL_ARGS_ASSERT_NEWGIVENOP;
10464     PERL_UNUSED_ARG(defsv_off);
10465
10466     assert(!defsv_off);
10467     return newGIVWHENOP(
10468         ref_array_or_hash(cond),
10469         block,
10470         OP_ENTERGIVEN, OP_LEAVEGIVEN,
10471         0);
10472 }
10473
10474 /*
10475 =for apidoc newWHENOP
10476
10477 Constructs, checks, and returns an op tree expressing a C<when> block.
10478 C<cond> supplies the test expression, and C<block> supplies the block
10479 that will be executed if the test evaluates to true; they are consumed
10480 by this function and become part of the constructed op tree.  C<cond>
10481 will be interpreted DWIMically, often as a comparison against C<$_>,
10482 and may be null to generate a C<default> block.
10483
10484 =cut
10485 */
10486
10487 OP *
10488 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10489 {
10490     const bool cond_llb = (!cond || looks_like_bool(cond));
10491     OP *cond_op;
10492
10493     PERL_ARGS_ASSERT_NEWWHENOP;
10494
10495     if (cond_llb)
10496         cond_op = cond;
10497     else {
10498         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10499                 newDEFSVOP(),
10500                 scalar(ref_array_or_hash(cond)));
10501     }
10502
10503     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10504 }
10505
10506 /* must not conflict with SVf_UTF8 */
10507 #define CV_CKPROTO_CURSTASH     0x1
10508
10509 void
10510 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10511                     const STRLEN len, const U32 flags)
10512 {
10513     SV *name = NULL, *msg;
10514     const char * cvp = SvROK(cv)
10515                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10516                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10517                            : ""
10518                         : CvPROTO(cv);
10519     STRLEN clen = CvPROTOLEN(cv), plen = len;
10520
10521     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10522
10523     if (p == NULL && cvp == NULL)
10524         return;
10525
10526     if (!ckWARN_d(WARN_PROTOTYPE))
10527         return;
10528
10529     if (p && cvp) {
10530         p = S_strip_spaces(aTHX_ p, &plen);
10531         cvp = S_strip_spaces(aTHX_ cvp, &clen);
10532         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10533             if (plen == clen && memEQ(cvp, p, plen))
10534                 return;
10535         } else {
10536             if (flags & SVf_UTF8) {
10537                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10538                     return;
10539             }
10540             else {
10541                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10542                     return;
10543             }
10544         }
10545     }
10546
10547     msg = sv_newmortal();
10548
10549     if (gv)
10550     {
10551         if (isGV(gv))
10552             gv_efullname3(name = sv_newmortal(), gv, NULL);
10553         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10554             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10555         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10556             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10557             sv_catpvs(name, "::");
10558             if (SvROK(gv)) {
10559                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10560                 assert (CvNAMED(SvRV_const(gv)));
10561                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10562             }
10563             else sv_catsv(name, (SV *)gv);
10564         }
10565         else name = (SV *)gv;
10566     }
10567     sv_setpvs(msg, "Prototype mismatch:");
10568     if (name)
10569         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10570     if (cvp)
10571         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10572             UTF8fARG(SvUTF8(cv),clen,cvp)
10573         );
10574     else
10575         sv_catpvs(msg, ": none");
10576     sv_catpvs(msg, " vs ");
10577     if (p)
10578         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10579     else
10580         sv_catpvs(msg, "none");
10581     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10582 }
10583
10584 static void const_sv_xsub(pTHX_ CV* cv);
10585 static void const_av_xsub(pTHX_ CV* cv);
10586
10587 /*
10588
10589 =head1 Optree Manipulation Functions
10590
10591 =for apidoc cv_const_sv
10592
10593 If C<cv> is a constant sub eligible for inlining, returns the constant
10594 value returned by the sub.  Otherwise, returns C<NULL>.
10595
10596 Constant subs can be created with C<newCONSTSUB> or as described in
10597 L<perlsub/"Constant Functions">.
10598
10599 =cut
10600 */
10601 SV *
10602 Perl_cv_const_sv(const CV *const cv)
10603 {
10604     SV *sv;
10605     if (!cv)
10606         return NULL;
10607     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10608         return NULL;
10609     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10610     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10611     return sv;
10612 }
10613
10614 SV *
10615 Perl_cv_const_sv_or_av(const CV * const cv)
10616 {
10617     if (!cv)
10618         return NULL;
10619     if (SvROK(cv)) return SvRV((SV *)cv);
10620     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10621     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10622 }
10623
10624 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
10625  * Can be called in 2 ways:
10626  *
10627  * !allow_lex
10628  *      look for a single OP_CONST with attached value: return the value
10629  *
10630  * allow_lex && !CvCONST(cv);
10631  *
10632  *      examine the clone prototype, and if contains only a single
10633  *      OP_CONST, return the value; or if it contains a single PADSV ref-
10634  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
10635  *      a candidate for "constizing" at clone time, and return NULL.
10636  */
10637
10638 static SV *
10639 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10640 {
10641     SV *sv = NULL;
10642     bool padsv = FALSE;
10643
10644     assert(o);
10645     assert(cv);
10646
10647     for (; o; o = o->op_next) {
10648         const OPCODE type = o->op_type;
10649
10650         if (type == OP_NEXTSTATE || type == OP_LINESEQ
10651              || type == OP_NULL
10652              || type == OP_PUSHMARK)
10653                 continue;
10654         if (type == OP_DBSTATE)
10655                 continue;
10656         if (type == OP_LEAVESUB)
10657             break;
10658         if (sv)
10659             return NULL;
10660         if (type == OP_CONST && cSVOPo->op_sv)
10661             sv = cSVOPo->op_sv;
10662         else if (type == OP_UNDEF && !o->op_private) {
10663             sv = newSV(0);
10664             SAVEFREESV(sv);
10665         }
10666         else if (allow_lex && type == OP_PADSV) {
10667                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10668                 {
10669                     sv = &PL_sv_undef; /* an arbitrary non-null value */
10670                     padsv = TRUE;
10671                 }
10672                 else
10673                     return NULL;
10674         }
10675         else {
10676             return NULL;
10677         }
10678     }
10679     if (padsv) {
10680         CvCONST_on(cv);
10681         return NULL;
10682     }
10683     return sv;
10684 }
10685
10686 static void
10687 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10688                         PADNAME * const name, SV ** const const_svp)
10689 {
10690     assert (cv);
10691     assert (o || name);
10692     assert (const_svp);
10693     if (!block) {
10694         if (CvFLAGS(PL_compcv)) {
10695             /* might have had built-in attrs applied */
10696             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10697             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10698              && ckWARN(WARN_MISC))
10699             {
10700                 /* protect against fatal warnings leaking compcv */
10701                 SAVEFREESV(PL_compcv);
10702                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10703                 SvREFCNT_inc_simple_void_NN(PL_compcv);
10704             }
10705             CvFLAGS(cv) |=
10706                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10707                   & ~(CVf_LVALUE * pureperl));
10708         }
10709         return;
10710     }
10711
10712     /* redundant check for speed: */
10713     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10714         const line_t oldline = CopLINE(PL_curcop);
10715         SV *namesv = o
10716             ? cSVOPo->op_sv
10717             : sv_2mortal(newSVpvn_utf8(
10718                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10719               ));
10720         if (PL_parser && PL_parser->copline != NOLINE)
10721             /* This ensures that warnings are reported at the first
10722                line of a redefinition, not the last.  */
10723             CopLINE_set(PL_curcop, PL_parser->copline);
10724         /* protect against fatal warnings leaking compcv */
10725         SAVEFREESV(PL_compcv);
10726         report_redefined_cv(namesv, cv, const_svp);
10727         SvREFCNT_inc_simple_void_NN(PL_compcv);
10728         CopLINE_set(PL_curcop, oldline);
10729     }
10730     SAVEFREESV(cv);
10731     return;
10732 }
10733
10734 CV *
10735 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10736 {
10737     CV **spot;
10738     SV **svspot;
10739     const char *ps;
10740     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10741     U32 ps_utf8 = 0;
10742     CV *cv = NULL;
10743     CV *compcv = PL_compcv;
10744     SV *const_sv;
10745     PADNAME *name;
10746     PADOFFSET pax = o->op_targ;
10747     CV *outcv = CvOUTSIDE(PL_compcv);
10748     CV *clonee = NULL;
10749     HEK *hek = NULL;
10750     bool reusable = FALSE;
10751     OP *start = NULL;
10752 #ifdef PERL_DEBUG_READONLY_OPS
10753     OPSLAB *slab = NULL;
10754 #endif
10755
10756     PERL_ARGS_ASSERT_NEWMYSUB;
10757
10758     PL_hints |= HINT_BLOCK_SCOPE;
10759
10760     /* Find the pad slot for storing the new sub.
10761        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
10762        need to look in CvOUTSIDE and find the pad belonging to the enclos-
10763        ing sub.  And then we need to dig deeper if this is a lexical from
10764        outside, as in:
10765            my sub foo; sub { sub foo { } }
10766      */
10767   redo:
10768     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10769     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10770         pax = PARENT_PAD_INDEX(name);
10771         outcv = CvOUTSIDE(outcv);
10772         assert(outcv);
10773         goto redo;
10774     }
10775     svspot =
10776         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10777                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10778     spot = (CV **)svspot;
10779
10780     if (!(PL_parser && PL_parser->error_count))
10781         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10782
10783     if (proto) {
10784         assert(proto->op_type == OP_CONST);
10785         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10786         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10787     }
10788     else
10789         ps = NULL;
10790
10791     if (proto)
10792         SAVEFREEOP(proto);
10793     if (attrs)
10794         SAVEFREEOP(attrs);
10795
10796     if (PL_parser && PL_parser->error_count) {
10797         op_free(block);
10798         SvREFCNT_dec(PL_compcv);
10799         PL_compcv = 0;
10800         goto done;
10801     }
10802
10803     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10804         cv = *spot;
10805         svspot = (SV **)(spot = &clonee);
10806     }
10807     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10808         cv = *spot;
10809     else {
10810         assert (SvTYPE(*spot) == SVt_PVCV);
10811         if (CvNAMED(*spot))
10812             hek = CvNAME_HEK(*spot);
10813         else {
10814             dVAR;
10815             U32 hash;
10816             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10817             CvNAME_HEK_set(*spot, hek =
10818                 share_hek(
10819                     PadnamePV(name)+1,
10820                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10821                     hash
10822                 )
10823             );
10824             CvLEXICAL_on(*spot);
10825         }
10826         cv = PadnamePROTOCV(name);
10827         svspot = (SV **)(spot = &PadnamePROTOCV(name));
10828     }
10829
10830     if (block) {
10831         /* This makes sub {}; work as expected.  */
10832         if (block->op_type == OP_STUB) {
10833             const line_t l = PL_parser->copline;
10834             op_free(block);
10835             block = newSTATEOP(0, NULL, 0);
10836             PL_parser->copline = l;
10837         }
10838         block = CvLVALUE(compcv)
10839              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10840                    ? newUNOP(OP_LEAVESUBLV, 0,
10841                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10842                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10843         start = LINKLIST(block);
10844         block->op_next = 0;
10845         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10846             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10847         else
10848             const_sv = NULL;
10849     }
10850     else
10851         const_sv = NULL;
10852
10853     if (cv) {
10854         const bool exists = CvROOT(cv) || CvXSUB(cv);
10855
10856         /* if the subroutine doesn't exist and wasn't pre-declared
10857          * with a prototype, assume it will be AUTOLOADed,
10858          * skipping the prototype check
10859          */
10860         if (exists || SvPOK(cv))
10861             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10862                                  ps_utf8);
10863         /* already defined? */
10864         if (exists) {
10865             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10866             if (block)
10867                 cv = NULL;
10868             else {
10869                 if (attrs)
10870                     goto attrs;
10871                 /* just a "sub foo;" when &foo is already defined */
10872                 SAVEFREESV(compcv);
10873                 goto done;
10874             }
10875         }
10876         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10877             cv = NULL;
10878             reusable = TRUE;
10879         }
10880     }
10881
10882     if (const_sv) {
10883         SvREFCNT_inc_simple_void_NN(const_sv);
10884         SvFLAGS(const_sv) |= SVs_PADTMP;
10885         if (cv) {
10886             assert(!CvROOT(cv) && !CvCONST(cv));
10887             cv_forget_slab(cv);
10888         }
10889         else {
10890             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10891             CvFILE_set_from_cop(cv, PL_curcop);
10892             CvSTASH_set(cv, PL_curstash);
10893             *spot = cv;
10894         }
10895         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10896         CvXSUBANY(cv).any_ptr = const_sv;
10897         CvXSUB(cv) = const_sv_xsub;
10898         CvCONST_on(cv);
10899         CvISXSUB_on(cv);
10900         PoisonPADLIST(cv);
10901         CvFLAGS(cv) |= CvMETHOD(compcv);
10902         op_free(block);
10903         SvREFCNT_dec(compcv);
10904         PL_compcv = NULL;
10905         goto setname;
10906     }
10907
10908     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10909        determine whether this sub definition is in the same scope as its
10910        declaration.  If this sub definition is inside an inner named pack-
10911        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10912        the package sub.  So check PadnameOUTER(name) too.
10913      */
10914     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10915         assert(!CvWEAKOUTSIDE(compcv));
10916         SvREFCNT_dec(CvOUTSIDE(compcv));
10917         CvWEAKOUTSIDE_on(compcv);
10918     }
10919     /* XXX else do we have a circular reference? */
10920
10921     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
10922         /* transfer PL_compcv to cv */
10923         if (block) {
10924             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10925             cv_flags_t preserved_flags =
10926                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10927             PADLIST *const temp_padl = CvPADLIST(cv);
10928             CV *const temp_cv = CvOUTSIDE(cv);
10929             const cv_flags_t other_flags =
10930                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10931             OP * const cvstart = CvSTART(cv);
10932
10933             SvPOK_off(cv);
10934             CvFLAGS(cv) =
10935                 CvFLAGS(compcv) | preserved_flags;
10936             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10937             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10938             CvPADLIST_set(cv, CvPADLIST(compcv));
10939             CvOUTSIDE(compcv) = temp_cv;
10940             CvPADLIST_set(compcv, temp_padl);
10941             CvSTART(cv) = CvSTART(compcv);
10942             CvSTART(compcv) = cvstart;
10943             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10944             CvFLAGS(compcv) |= other_flags;
10945
10946             if (free_file) {
10947                 Safefree(CvFILE(cv));
10948                 CvFILE(cv) = NULL;
10949             }
10950
10951             /* inner references to compcv must be fixed up ... */
10952             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10953             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10954                 ++PL_sub_generation;
10955         }
10956         else {
10957             /* Might have had built-in attributes applied -- propagate them. */
10958             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10959         }
10960         /* ... before we throw it away */
10961         SvREFCNT_dec(compcv);
10962         PL_compcv = compcv = cv;
10963     }
10964     else {
10965         cv = compcv;
10966         *spot = cv;
10967     }
10968
10969   setname:
10970     CvLEXICAL_on(cv);
10971     if (!CvNAME_HEK(cv)) {
10972         if (hek) (void)share_hek_hek(hek);
10973         else {
10974             dVAR;
10975             U32 hash;
10976             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10977             hek = share_hek(PadnamePV(name)+1,
10978                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10979                       hash);
10980         }
10981         CvNAME_HEK_set(cv, hek);
10982     }
10983
10984     if (const_sv)
10985         goto clone;
10986
10987     if (CvFILE(cv) && CvDYNFILE(cv))
10988         Safefree(CvFILE(cv));
10989     CvFILE_set_from_cop(cv, PL_curcop);
10990     CvSTASH_set(cv, PL_curstash);
10991
10992     if (ps) {
10993         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10994         if (ps_utf8)
10995             SvUTF8_on(MUTABLE_SV(cv));
10996     }
10997
10998     if (block) {
10999         /* If we assign an optree to a PVCV, then we've defined a
11000          * subroutine that the debugger could be able to set a breakpoint
11001          * in, so signal to pp_entereval that it should not throw away any
11002          * saved lines at scope exit.  */
11003
11004         PL_breakable_sub_gen++;
11005         CvROOT(cv) = block;
11006         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11007            itself has a refcount. */
11008         CvSLABBED_off(cv);
11009         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11010 #ifdef PERL_DEBUG_READONLY_OPS
11011         slab = (OPSLAB *)CvSTART(cv);
11012 #endif
11013         S_process_optree(aTHX_ cv, block, start);
11014     }
11015
11016   attrs:
11017     if (attrs) {
11018         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11019         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11020     }
11021
11022     if (block) {
11023         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11024             SV * const tmpstr = sv_newmortal();
11025             GV * const db_postponed = gv_fetchpvs("DB::postponed",
11026                                                   GV_ADDMULTI, SVt_PVHV);
11027             HV *hv;
11028             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11029                                           CopFILE(PL_curcop),
11030                                           (long)PL_subline,
11031                                           (long)CopLINE(PL_curcop));
11032             if (HvNAME_HEK(PL_curstash)) {
11033                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11034                 sv_catpvs(tmpstr, "::");
11035             }
11036             else
11037                 sv_setpvs(tmpstr, "__ANON__::");
11038
11039             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11040                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11041             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11042                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11043             hv = GvHVn(db_postponed);
11044             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11045                 CV * const pcv = GvCV(db_postponed);
11046                 if (pcv) {
11047                     dSP;
11048                     PUSHMARK(SP);
11049                     XPUSHs(tmpstr);
11050                     PUTBACK;
11051                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
11052                 }
11053             }
11054         }
11055     }
11056
11057   clone:
11058     if (clonee) {
11059         assert(CvDEPTH(outcv));
11060         spot = (CV **)
11061             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11062         if (reusable)
11063             cv_clone_into(clonee, *spot);
11064         else *spot = cv_clone(clonee);
11065         SvREFCNT_dec_NN(clonee);
11066         cv = *spot;
11067     }
11068
11069     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11070         PADOFFSET depth = CvDEPTH(outcv);
11071         while (--depth) {
11072             SV *oldcv;
11073             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11074             oldcv = *svspot;
11075             *svspot = SvREFCNT_inc_simple_NN(cv);
11076             SvREFCNT_dec(oldcv);
11077         }
11078     }
11079
11080   done:
11081     if (PL_parser)
11082         PL_parser->copline = NOLINE;
11083     LEAVE_SCOPE(floor);
11084 #ifdef PERL_DEBUG_READONLY_OPS
11085     if (slab)
11086         Slab_to_ro(slab);
11087 #endif
11088     op_free(o);
11089     return cv;
11090 }
11091
11092 /*
11093 =for apidoc newATTRSUB_x
11094
11095 Construct a Perl subroutine, also performing some surrounding jobs.
11096
11097 This function is expected to be called in a Perl compilation context,
11098 and some aspects of the subroutine are taken from global variables
11099 associated with compilation.  In particular, C<PL_compcv> represents
11100 the subroutine that is currently being compiled.  It must be non-null
11101 when this function is called, and some aspects of the subroutine being
11102 constructed are taken from it.  The constructed subroutine may actually
11103 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11104
11105 If C<block> is null then the subroutine will have no body, and for the
11106 time being it will be an error to call it.  This represents a forward
11107 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
11108 non-null then it provides the Perl code of the subroutine body, which
11109 will be executed when the subroutine is called.  This body includes
11110 any argument unwrapping code resulting from a subroutine signature or
11111 similar.  The pad use of the code must correspond to the pad attached
11112 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
11113 C<leavesublv> op; this function will add such an op.  C<block> is consumed
11114 by this function and will become part of the constructed subroutine.
11115
11116 C<proto> specifies the subroutine's prototype, unless one is supplied
11117 as an attribute (see below).  If C<proto> is null, then the subroutine
11118 will not have a prototype.  If C<proto> is non-null, it must point to a
11119 C<const> op whose value is a string, and the subroutine will have that
11120 string as its prototype.  If a prototype is supplied as an attribute, the
11121 attribute takes precedence over C<proto>, but in that case C<proto> should
11122 preferably be null.  In any case, C<proto> is consumed by this function.
11123
11124 C<attrs> supplies attributes to be applied the subroutine.  A handful of
11125 attributes take effect by built-in means, being applied to C<PL_compcv>
11126 immediately when seen.  Other attributes are collected up and attached
11127 to the subroutine by this route.  C<attrs> may be null to supply no
11128 attributes, or point to a C<const> op for a single attribute, or point
11129 to a C<list> op whose children apart from the C<pushmark> are C<const>
11130 ops for one or more attributes.  Each C<const> op must be a string,
11131 giving the attribute name optionally followed by parenthesised arguments,
11132 in the manner in which attributes appear in Perl source.  The attributes
11133 will be applied to the sub by this function.  C<attrs> is consumed by
11134 this function.
11135
11136 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11137 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
11138 must point to a C<const> op, which will be consumed by this function,
11139 and its string value supplies a name for the subroutine.  The name may
11140 be qualified or unqualified, and if it is unqualified then a default
11141 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
11142 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11143 by which the subroutine will be named.
11144
11145 If there is already a subroutine of the specified name, then the new
11146 sub will either replace the existing one in the glob or be merged with
11147 the existing one.  A warning may be generated about redefinition.
11148
11149 If the subroutine has one of a few special names, such as C<BEGIN> or
11150 C<END>, then it will be claimed by the appropriate queue for automatic
11151 running of phase-related subroutines.  In this case the relevant glob will
11152 be left not containing any subroutine, even if it did contain one before.
11153 In the case of C<BEGIN>, the subroutine will be executed and the reference
11154 to it disposed of before this function returns.
11155
11156 The function returns a pointer to the constructed subroutine.  If the sub
11157 is anonymous then ownership of one counted reference to the subroutine
11158 is transferred to the caller.  If the sub is named then the caller does
11159 not get ownership of a reference.  In most such cases, where the sub
11160 has a non-phase name, the sub will be alive at the point it is returned
11161 by virtue of being contained in the glob that names it.  A phase-named
11162 subroutine will usually be alive by virtue of the reference owned by the
11163 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
11164 been executed, will quite likely have been destroyed already by the
11165 time this function returns, making it erroneous for the caller to make
11166 any use of the returned pointer.  It is the caller's responsibility to
11167 ensure that it knows which of these situations applies.
11168
11169 =cut
11170 */
11171
11172 /* _x = extended */
11173 CV *
11174 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11175                             OP *block, bool o_is_gv)
11176 {
11177     GV *gv;
11178     const char *ps;
11179     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11180     U32 ps_utf8 = 0;
11181     CV *cv = NULL;     /* the previous CV with this name, if any */
11182     SV *const_sv;
11183     const bool ec = PL_parser && PL_parser->error_count;
11184     /* If the subroutine has no body, no attributes, and no builtin attributes
11185        then it's just a sub declaration, and we may be able to get away with
11186        storing with a placeholder scalar in the symbol table, rather than a
11187        full CV.  If anything is present then it will take a full CV to
11188        store it.  */
11189     const I32 gv_fetch_flags
11190         = ec ? GV_NOADD_NOINIT :
11191         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11192         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11193     STRLEN namlen = 0;
11194     const char * const name =
11195          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11196     bool has_name;
11197     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11198     bool evanescent = FALSE;
11199     OP *start = NULL;
11200 #ifdef PERL_DEBUG_READONLY_OPS
11201     OPSLAB *slab = NULL;
11202 #endif
11203
11204     if (o_is_gv) {
11205         gv = (GV*)o;
11206         o = NULL;
11207         has_name = TRUE;
11208     } else if (name) {
11209         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
11210            hek and CvSTASH pointer together can imply the GV.  If the name
11211            contains a package name, then GvSTASH(CvGV(cv)) may differ from
11212            CvSTASH, so forego the optimisation if we find any.
11213            Also, we may be called from load_module at run time, so
11214            PL_curstash (which sets CvSTASH) may not point to the stash the
11215            sub is stored in.  */
11216         /* XXX This optimization is currently disabled for packages other
11217                than main, since there was too much CPAN breakage.  */
11218         const I32 flags =
11219            ec ? GV_NOADD_NOINIT
11220               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11221                || PL_curstash != PL_defstash
11222                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11223                     ? gv_fetch_flags
11224                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11225         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11226         has_name = TRUE;
11227     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11228         SV * const sv = sv_newmortal();
11229         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11230                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11231                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11232         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11233         has_name = TRUE;
11234     } else if (PL_curstash) {
11235         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11236         has_name = FALSE;
11237     } else {
11238         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11239         has_name = FALSE;
11240     }
11241
11242     if (!ec) {
11243         if (isGV(gv)) {
11244             move_proto_attr(&proto, &attrs, gv, 0);
11245         } else {
11246             assert(cSVOPo);
11247             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11248         }
11249     }
11250
11251     if (proto) {
11252         assert(proto->op_type == OP_CONST);
11253         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11254         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11255     }
11256     else
11257         ps = NULL;
11258
11259     if (o)
11260         SAVEFREEOP(o);
11261     if (proto)
11262         SAVEFREEOP(proto);
11263     if (attrs)
11264         SAVEFREEOP(attrs);
11265
11266     if (ec) {
11267         op_free(block);
11268
11269         if (name)
11270             SvREFCNT_dec(PL_compcv);
11271         else
11272             cv = PL_compcv;
11273
11274         PL_compcv = 0;
11275         if (name && block) {
11276             const char *s = (char *) my_memrchr(name, ':', namlen);
11277             s = s ? s+1 : name;
11278             if (strEQ(s, "BEGIN")) {
11279                 if (PL_in_eval & EVAL_KEEPERR)
11280                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11281                 else {
11282                     SV * const errsv = ERRSV;
11283                     /* force display of errors found but not reported */
11284                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11285                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11286                 }
11287             }
11288         }
11289         goto done;
11290     }
11291
11292     if (!block && SvTYPE(gv) != SVt_PVGV) {
11293         /* If we are not defining a new sub and the existing one is not a
11294            full GV + CV... */
11295         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11296             /* We are applying attributes to an existing sub, so we need it
11297                upgraded if it is a constant.  */
11298             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11299                 gv_init_pvn(gv, PL_curstash, name, namlen,
11300                             SVf_UTF8 * name_is_utf8);
11301         }
11302         else {                  /* Maybe prototype now, and had at maximum
11303                                    a prototype or const/sub ref before.  */
11304             if (SvTYPE(gv) > SVt_NULL) {
11305                 cv_ckproto_len_flags((const CV *)gv,
11306                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11307                                     ps_len, ps_utf8);
11308             }
11309
11310             if (!SvROK(gv)) {
11311                 if (ps) {
11312                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11313                     if (ps_utf8)
11314                         SvUTF8_on(MUTABLE_SV(gv));
11315                 }
11316                 else
11317                     sv_setiv(MUTABLE_SV(gv), -1);
11318             }
11319
11320             SvREFCNT_dec(PL_compcv);
11321             cv = PL_compcv = NULL;
11322             goto done;
11323         }
11324     }
11325
11326     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11327         ? NULL
11328         : isGV(gv)
11329             ? GvCV(gv)
11330             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11331                 ? (CV *)SvRV(gv)
11332                 : NULL;
11333
11334     if (block) {
11335         assert(PL_parser);
11336         /* This makes sub {}; work as expected.  */
11337         if (block->op_type == OP_STUB) {
11338             const line_t l = PL_parser->copline;
11339             op_free(block);
11340             block = newSTATEOP(0, NULL, 0);
11341             PL_parser->copline = l;
11342         }
11343         block = CvLVALUE(PL_compcv)
11344              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11345                     && (!isGV(gv) || !GvASSUMECV(gv)))
11346                    ? newUNOP(OP_LEAVESUBLV, 0,
11347                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11348                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11349         start = LINKLIST(block);
11350         block->op_next = 0;
11351         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11352             const_sv =
11353                 S_op_const_sv(aTHX_ start, PL_compcv,
11354                                         cBOOL(CvCLONE(PL_compcv)));
11355         else
11356             const_sv = NULL;
11357     }
11358     else
11359         const_sv = NULL;
11360
11361     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11362         cv_ckproto_len_flags((const CV *)gv,
11363                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11364                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11365         if (SvROK(gv)) {
11366             /* All the other code for sub redefinition warnings expects the
11367                clobbered sub to be a CV.  Instead of making all those code
11368                paths more complex, just inline the RV version here.  */
11369             const line_t oldline = CopLINE(PL_curcop);
11370             assert(IN_PERL_COMPILETIME);
11371             if (PL_parser && PL_parser->copline != NOLINE)
11372                 /* This ensures that warnings are reported at the first
11373                    line of a redefinition, not the last.  */
11374                 CopLINE_set(PL_curcop, PL_parser->copline);
11375             /* protect against fatal warnings leaking compcv */
11376             SAVEFREESV(PL_compcv);
11377
11378             if (ckWARN(WARN_REDEFINE)
11379              || (  ckWARN_d(WARN_REDEFINE)
11380                 && (  !const_sv || SvRV(gv) == const_sv
11381                    || sv_cmp(SvRV(gv), const_sv)  ))) {
11382                 assert(cSVOPo);
11383                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11384                           "Constant subroutine %" SVf " redefined",
11385                           SVfARG(cSVOPo->op_sv));
11386             }
11387
11388             SvREFCNT_inc_simple_void_NN(PL_compcv);
11389             CopLINE_set(PL_curcop, oldline);
11390             SvREFCNT_dec(SvRV(gv));
11391         }
11392     }
11393
11394     if (cv) {
11395         const bool exists = CvROOT(cv) || CvXSUB(cv);
11396
11397         /* if the subroutine doesn't exist and wasn't pre-declared
11398          * with a prototype, assume it will be AUTOLOADed,
11399          * skipping the prototype check
11400          */
11401         if (exists || SvPOK(cv))
11402             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11403         /* already defined (or promised)? */
11404         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11405             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11406             if (block)
11407                 cv = NULL;
11408             else {
11409                 if (attrs)
11410                     goto attrs;
11411                 /* just a "sub foo;" when &foo is already defined */
11412                 SAVEFREESV(PL_compcv);
11413                 goto done;
11414             }
11415         }
11416     }
11417
11418     if (const_sv) {
11419         SvREFCNT_inc_simple_void_NN(const_sv);
11420         SvFLAGS(const_sv) |= SVs_PADTMP;
11421         if (cv) {
11422             assert(!CvROOT(cv) && !CvCONST(cv));
11423             cv_forget_slab(cv);
11424             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
11425             CvXSUBANY(cv).any_ptr = const_sv;
11426             CvXSUB(cv) = const_sv_xsub;
11427             CvCONST_on(cv);
11428             CvISXSUB_on(cv);
11429             PoisonPADLIST(cv);
11430             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11431         }
11432         else {
11433             if (isGV(gv) || CvMETHOD(PL_compcv)) {
11434                 if (name && isGV(gv))
11435                     GvCV_set(gv, NULL);
11436                 cv = newCONSTSUB_flags(
11437                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11438                     const_sv
11439                 );
11440                 assert(cv);
11441                 assert(SvREFCNT((SV*)cv) != 0);
11442                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11443             }
11444             else {
11445                 if (!SvROK(gv)) {
11446                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11447                     prepare_SV_for_RV((SV *)gv);
11448                     SvOK_off((SV *)gv);
11449                     SvROK_on(gv);
11450                 }
11451                 SvRV_set(gv, const_sv);
11452             }
11453         }
11454         op_free(block);
11455         SvREFCNT_dec(PL_compcv);
11456         PL_compcv = NULL;
11457         goto done;
11458     }
11459
11460     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11461     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11462         cv = NULL;
11463
11464     if (cv) {                           /* must reuse cv if autoloaded */
11465         /* transfer PL_compcv to cv */
11466         if (block) {
11467             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11468             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11469             PADLIST *const temp_av = CvPADLIST(cv);
11470             CV *const temp_cv = CvOUTSIDE(cv);
11471             const cv_flags_t other_flags =
11472                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11473             OP * const cvstart = CvSTART(cv);
11474
11475             if (isGV(gv)) {
11476                 CvGV_set(cv,gv);
11477                 assert(!CvCVGV_RC(cv));
11478                 assert(CvGV(cv) == gv);
11479             }
11480             else {
11481                 dVAR;
11482                 U32 hash;
11483                 PERL_HASH(hash, name, namlen);
11484                 CvNAME_HEK_set(cv,
11485                                share_hek(name,
11486                                          name_is_utf8
11487                                             ? -(SSize_t)namlen
11488                                             :  (SSize_t)namlen,
11489                                          hash));
11490             }
11491
11492             SvPOK_off(cv);
11493             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11494                                              | CvNAMED(cv);
11495             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11496             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11497             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11498             CvOUTSIDE(PL_compcv) = temp_cv;
11499             CvPADLIST_set(PL_compcv, temp_av);
11500             CvSTART(cv) = CvSTART(PL_compcv);
11501             CvSTART(PL_compcv) = cvstart;
11502             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11503             CvFLAGS(PL_compcv) |= other_flags;
11504
11505             if (free_file) {
11506                 Safefree(CvFILE(cv));
11507             }
11508             CvFILE_set_from_cop(cv, PL_curcop);
11509             CvSTASH_set(cv, PL_curstash);
11510
11511             /* inner references to PL_compcv must be fixed up ... */
11512             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11513             if (PERLDB_INTER)/* Advice debugger on the new sub. */
11514                 ++PL_sub_generation;
11515         }
11516         else {
11517             /* Might have had built-in attributes applied -- propagate them. */
11518             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11519         }
11520         /* ... before we throw it away */
11521         SvREFCNT_dec(PL_compcv);
11522         PL_compcv = cv;
11523     }
11524     else {
11525         cv = PL_compcv;
11526         if (name && isGV(gv)) {
11527             GvCV_set(gv, cv);
11528             GvCVGEN(gv) = 0;
11529             if (HvENAME_HEK(GvSTASH(gv)))
11530                 /* sub Foo::bar { (shift)+1 } */
11531                 gv_method_changed(gv);
11532         }
11533         else if (name) {
11534             if (!SvROK(gv)) {
11535                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11536                 prepare_SV_for_RV((SV *)gv);
11537                 SvOK_off((SV *)gv);
11538                 SvROK_on(gv);
11539             }
11540             SvRV_set(gv, (SV *)cv);
11541             if (HvENAME_HEK(PL_curstash))
11542                 mro_method_changed_in(PL_curstash);
11543         }
11544     }
11545     assert(cv);
11546     assert(SvREFCNT((SV*)cv) != 0);
11547
11548     if (!CvHASGV(cv)) {
11549         if (isGV(gv))
11550             CvGV_set(cv, gv);
11551         else {
11552             dVAR;
11553             U32 hash;
11554             PERL_HASH(hash, name, namlen);
11555             CvNAME_HEK_set(cv, share_hek(name,
11556                                          name_is_utf8
11557                                             ? -(SSize_t)namlen
11558                                             :  (SSize_t)namlen,
11559                                          hash));
11560         }
11561         CvFILE_set_from_cop(cv, PL_curcop);
11562         CvSTASH_set(cv, PL_curstash);
11563     }
11564
11565     if (ps) {
11566         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11567         if ( ps_utf8 )
11568             SvUTF8_on(MUTABLE_SV(cv));
11569     }
11570
11571     if (block) {
11572         /* If we assign an optree to a PVCV, then we've defined a
11573          * subroutine that the debugger could be able to set a breakpoint
11574          * in, so signal to pp_entereval that it should not throw away any
11575          * saved lines at scope exit.  */
11576
11577         PL_breakable_sub_gen++;
11578         CvROOT(cv) = block;
11579         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11580            itself has a refcount. */
11581         CvSLABBED_off(cv);
11582         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11583 #ifdef PERL_DEBUG_READONLY_OPS
11584         slab = (OPSLAB *)CvSTART(cv);
11585 #endif
11586         S_process_optree(aTHX_ cv, block, start);
11587     }
11588
11589   attrs:
11590     if (attrs) {
11591         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11592         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11593                         ? GvSTASH(CvGV(cv))
11594                         : PL_curstash;
11595         if (!name)
11596             SAVEFREESV(cv);
11597         apply_attrs(stash, MUTABLE_SV(cv), attrs);
11598         if (!name)
11599             SvREFCNT_inc_simple_void_NN(cv);
11600     }
11601
11602     if (block && has_name) {
11603         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11604             SV * const tmpstr = cv_name(cv,NULL,0);
11605             GV * const db_postponed = gv_fetchpvs("DB::postponed",
11606                                                   GV_ADDMULTI, SVt_PVHV);
11607             HV *hv;
11608             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11609                                           CopFILE(PL_curcop),
11610                                           (long)PL_subline,
11611                                           (long)CopLINE(PL_curcop));
11612             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11613                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11614             hv = GvHVn(db_postponed);
11615             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11616                 CV * const pcv = GvCV(db_postponed);
11617                 if (pcv) {
11618                     dSP;
11619                     PUSHMARK(SP);
11620                     XPUSHs(tmpstr);
11621                     PUTBACK;
11622                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
11623                 }
11624             }
11625         }
11626
11627         if (name) {
11628             if (PL_parser && PL_parser->error_count)
11629                 clear_special_blocks(name, gv, cv);
11630             else
11631                 evanescent =
11632                     process_special_blocks(floor, name, gv, cv);
11633         }
11634     }
11635     assert(cv);
11636
11637   done:
11638     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11639     if (PL_parser)
11640         PL_parser->copline = NOLINE;
11641     LEAVE_SCOPE(floor);
11642
11643     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11644     if (!evanescent) {
11645 #ifdef PERL_DEBUG_READONLY_OPS
11646     if (slab)
11647         Slab_to_ro(slab);
11648 #endif
11649     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11650         pad_add_weakref(cv);
11651     }
11652     return cv;
11653 }
11654
11655 STATIC void
11656 S_clear_special_blocks(pTHX_ const char *const fullname,
11657                        GV *const gv, CV *const cv) {
11658     const char *colon;
11659     const char *name;
11660
11661     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11662
11663     colon = strrchr(fullname,':');
11664     name = colon ? colon + 1 : fullname;
11665
11666     if ((*name == 'B' && strEQ(name, "BEGIN"))
11667         || (*name == 'E' && strEQ(name, "END"))
11668         || (*name == 'U' && strEQ(name, "UNITCHECK"))
11669         || (*name == 'C' && strEQ(name, "CHECK"))
11670         || (*name == 'I' && strEQ(name, "INIT"))) {
11671         if (!isGV(gv)) {
11672             (void)CvGV(cv);
11673             assert(isGV(gv));
11674         }
11675         GvCV_set(gv, NULL);
11676         SvREFCNT_dec_NN(MUTABLE_SV(cv));
11677     }
11678 }
11679
11680 /* Returns true if the sub has been freed.  */
11681 STATIC bool
11682 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11683                          GV *const gv,
11684                          CV *const cv)
11685 {
11686     const char *const colon = strrchr(fullname,':');
11687     const char *const name = colon ? colon + 1 : fullname;
11688
11689     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11690
11691     if (*name == 'B') {
11692         if (strEQ(name, "BEGIN")) {
11693             const I32 oldscope = PL_scopestack_ix;
11694             dSP;
11695             (void)CvGV(cv);
11696             if (floor) LEAVE_SCOPE(floor);
11697             ENTER;
11698
11699             SAVEVPTR(PL_curcop);
11700             if (PL_curcop == &PL_compiling) {
11701                 /* Avoid pushing the "global" &PL_compiling onto the
11702                  * context stack. For example, a stack trace inside
11703                  * nested use's would show all calls coming from whoever
11704                  * most recently updated PL_compiling.cop_file and
11705                  * cop_line.  So instead, temporarily set PL_curcop to a
11706                  * private copy of &PL_compiling. PL_curcop will soon be
11707                  * set to point back to &PL_compiling anyway but only
11708                  * after the temp value has been pushed onto the context
11709                  * stack as blk_oldcop.
11710                  * This is slightly hacky, but necessary. Note also
11711                  * that in the brief window before PL_curcop is set back
11712                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11713                  * will give the wrong answer.
11714                  */
11715                 Newx(PL_curcop, 1, COP);
11716                 StructCopy(&PL_compiling, PL_curcop, COP);
11717                 PL_curcop->op_slabbed = 0;
11718                 SAVEFREEPV(PL_curcop);
11719             }
11720
11721             PUSHSTACKi(PERLSI_REQUIRE);
11722             SAVECOPFILE(&PL_compiling);
11723             SAVECOPLINE(&PL_compiling);
11724
11725             DEBUG_x( dump_sub(gv) );
11726             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11727             GvCV_set(gv,0);             /* cv has been hijacked */
11728             call_list(oldscope, PL_beginav);
11729
11730             POPSTACK;
11731             LEAVE;
11732             return !PL_savebegin;
11733         }
11734         else
11735             return FALSE;
11736     } else {
11737         if (*name == 'E') {
11738             if (strEQ(name, "END")) {
11739                 DEBUG_x( dump_sub(gv) );
11740                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11741             } else
11742                 return FALSE;
11743         } else if (*name == 'U') {
11744             if (strEQ(name, "UNITCHECK")) {
11745                 /* It's never too late to run a unitcheck block */
11746                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11747             }
11748             else
11749                 return FALSE;
11750         } else if (*name == 'C') {
11751             if (strEQ(name, "CHECK")) {
11752                 if (PL_main_start)
11753                     /* diag_listed_as: Too late to run %s block */
11754                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11755                                    "Too late to run CHECK block");
11756                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11757             }
11758             else
11759                 return FALSE;
11760         } else if (*name == 'I') {
11761             if (strEQ(name, "INIT")) {
11762                 if (PL_main_start)
11763                     /* diag_listed_as: Too late to run %s block */
11764                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11765                                    "Too late to run INIT block");
11766                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11767             }
11768             else
11769                 return FALSE;
11770         } else
11771             return FALSE;
11772         DEBUG_x( dump_sub(gv) );
11773         (void)CvGV(cv);
11774         GvCV_set(gv,0);         /* cv has been hijacked */
11775         return FALSE;
11776     }
11777 }
11778
11779 /*
11780 =for apidoc newCONSTSUB
11781
11782 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11783 rather than of counted length, and no flags are set.  (This means that
11784 C<name> is always interpreted as Latin-1.)
11785
11786 =cut
11787 */
11788
11789 CV *
11790 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11791 {
11792     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11793 }
11794
11795 /*
11796 =for apidoc newCONSTSUB_flags
11797
11798 Construct a constant subroutine, also performing some surrounding
11799 jobs.  A scalar constant-valued subroutine is eligible for inlining
11800 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11801 123 }>>.  Other kinds of constant subroutine have other treatment.
11802
11803 The subroutine will have an empty prototype and will ignore any arguments
11804 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
11805 is null, the subroutine will yield an empty list.  If C<sv> points to a
11806 scalar, the subroutine will always yield that scalar.  If C<sv> points
11807 to an array, the subroutine will always yield a list of the elements of
11808 that array in list context, or the number of elements in the array in
11809 scalar context.  This function takes ownership of one counted reference
11810 to the scalar or array, and will arrange for the object to live as long
11811 as the subroutine does.  If C<sv> points to a scalar then the inlining
11812 assumes that the value of the scalar will never change, so the caller
11813 must ensure that the scalar is not subsequently written to.  If C<sv>
11814 points to an array then no such assumption is made, so it is ostensibly
11815 safe to mutate the array or its elements, but whether this is really
11816 supported has not been determined.
11817
11818 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11819 Other aspects of the subroutine will be left in their default state.
11820 The caller is free to mutate the subroutine beyond its initial state
11821 after this function has returned.
11822
11823 If C<name> is null then the subroutine will be anonymous, with its
11824 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11825 subroutine will be named accordingly, referenced by the appropriate glob.
11826 C<name> is a string of length C<len> bytes giving a sigilless symbol
11827 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11828 otherwise.  The name may be either qualified or unqualified.  If the
11829 name is unqualified then it defaults to being in the stash specified by
11830 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11831 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11832 semantics.
11833
11834 C<flags> should not have bits set other than C<SVf_UTF8>.
11835
11836 If there is already a subroutine of the specified name, then the new sub
11837 will replace the existing one in the glob.  A warning may be generated
11838 about the redefinition.
11839
11840 If the subroutine has one of a few special names, such as C<BEGIN> or
11841 C<END>, then it will be claimed by the appropriate queue for automatic
11842 running of phase-related subroutines.  In this case the relevant glob will
11843 be left not containing any subroutine, even if it did contain one before.
11844 Execution of the subroutine will likely be a no-op, unless C<sv> was
11845 a tied array or the caller modified the subroutine in some interesting
11846 way before it was executed.  In the case of C<BEGIN>, the treatment is
11847 buggy: the sub will be executed when only half built, and may be deleted
11848 prematurely, possibly causing a crash.
11849
11850 The function returns a pointer to the constructed subroutine.  If the sub
11851 is anonymous then ownership of one counted reference to the subroutine
11852 is transferred to the caller.  If the sub is named then the caller does
11853 not get ownership of a reference.  In most such cases, where the sub
11854 has a non-phase name, the sub will be alive at the point it is returned
11855 by virtue of being contained in the glob that names it.  A phase-named
11856 subroutine will usually be alive by virtue of the reference owned by
11857 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
11858 destroyed already by the time this function returns, but currently bugs
11859 occur in that case before the caller gets control.  It is the caller's
11860 responsibility to ensure that it knows which of these situations applies.
11861
11862 =cut
11863 */
11864
11865 CV *
11866 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11867                              U32 flags, SV *sv)
11868 {
11869     CV* cv;
11870     const char *const file = CopFILE(PL_curcop);
11871
11872     ENTER;
11873
11874     if (IN_PERL_RUNTIME) {
11875         /* at runtime, it's not safe to manipulate PL_curcop: it may be
11876          * an op shared between threads. Use a non-shared COP for our
11877          * dirty work */
11878          SAVEVPTR(PL_curcop);
11879          SAVECOMPILEWARNINGS();
11880          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11881          PL_curcop = &PL_compiling;
11882     }
11883     SAVECOPLINE(PL_curcop);
11884     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11885
11886     SAVEHINTS();
11887     PL_hints &= ~HINT_BLOCK_SCOPE;
11888
11889     if (stash) {
11890         SAVEGENERICSV(PL_curstash);
11891         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11892     }
11893
11894     /* Protect sv against leakage caused by fatal warnings. */
11895     if (sv) SAVEFREESV(sv);
11896
11897     /* file becomes the CvFILE. For an XS, it's usually static storage,
11898        and so doesn't get free()d.  (It's expected to be from the C pre-
11899        processor __FILE__ directive). But we need a dynamically allocated one,
11900        and we need it to get freed.  */
11901     cv = newXS_len_flags(name, len,
11902                          sv && SvTYPE(sv) == SVt_PVAV
11903                              ? const_av_xsub
11904                              : const_sv_xsub,
11905                          file ? file : "", "",
11906                          &sv, XS_DYNAMIC_FILENAME | flags);
11907     assert(cv);
11908     assert(SvREFCNT((SV*)cv) != 0);
11909     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11910     CvCONST_on(cv);
11911
11912     LEAVE;
11913
11914     return cv;
11915 }
11916
11917 /*
11918 =for apidoc newXS
11919
11920 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
11921 static storage, as it is used directly as CvFILE(), without a copy being made.
11922
11923 =cut
11924 */
11925
11926 CV *
11927 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11928 {
11929     PERL_ARGS_ASSERT_NEWXS;
11930     return newXS_len_flags(
11931         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11932     );
11933 }
11934
11935 CV *
11936 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11937                  const char *const filename, const char *const proto,
11938                  U32 flags)
11939 {
11940     PERL_ARGS_ASSERT_NEWXS_FLAGS;
11941     return newXS_len_flags(
11942        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11943     );
11944 }
11945
11946 CV *
11947 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11948 {
11949     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11950     return newXS_len_flags(
11951         name, strlen(name), subaddr, NULL, NULL, NULL, 0
11952     );
11953 }
11954
11955 /*
11956 =for apidoc newXS_len_flags
11957
11958 Construct an XS subroutine, also performing some surrounding jobs.
11959
11960 The subroutine will have the entry point C<subaddr>.  It will have
11961 the prototype specified by the nul-terminated string C<proto>, or
11962 no prototype if C<proto> is null.  The prototype string is copied;
11963 the caller can mutate the supplied string afterwards.  If C<filename>
11964 is non-null, it must be a nul-terminated filename, and the subroutine
11965 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
11966 point directly to the supplied string, which must be static.  If C<flags>
11967 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11968 be taken instead.
11969
11970 Other aspects of the subroutine will be left in their default state.
11971 If anything else needs to be done to the subroutine for it to function
11972 correctly, it is the caller's responsibility to do that after this
11973 function has constructed it.  However, beware of the subroutine
11974 potentially being destroyed before this function returns, as described
11975 below.
11976
11977 If C<name> is null then the subroutine will be anonymous, with its
11978 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11979 subroutine will be named accordingly, referenced by the appropriate glob.
11980 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11981 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11982 The name may be either qualified or unqualified, with the stash defaulting
11983 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
11984 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11985 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
11986 the stash if necessary, with C<GV_ADDMULTI> semantics.
11987
11988 If there is already a subroutine of the specified name, then the new sub
11989 will replace the existing one in the glob.  A warning may be generated
11990 about the redefinition.  If the old subroutine was C<CvCONST> then the
11991 decision about whether to warn is influenced by an expectation about
11992 whether the new subroutine will become a constant of similar value.
11993 That expectation is determined by C<const_svp>.  (Note that the call to
11994 this function doesn't make the new subroutine C<CvCONST> in any case;
11995 that is left to the caller.)  If C<const_svp> is null then it indicates
11996 that the new subroutine will not become a constant.  If C<const_svp>
11997 is non-null then it indicates that the new subroutine will become a
11998 constant, and it points to an C<SV*> that provides the constant value
11999 that the subroutine will have.
12000
12001 If the subroutine has one of a few special names, such as C<BEGIN> or
12002 C<END>, then it will be claimed by the appropriate queue for automatic
12003 running of phase-related subroutines.  In this case the relevant glob will
12004 be left not containing any subroutine, even if it did contain one before.
12005 In the case of C<BEGIN>, the subroutine will be executed and the reference
12006 to it disposed of before this function returns, and also before its
12007 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
12008 constructed by this function to be ready for execution then the caller
12009 must prevent this happening by giving the subroutine a different name.
12010
12011 The function returns a pointer to the constructed subroutine.  If the sub
12012 is anonymous then ownership of one counted reference to the subroutine
12013 is transferred to the caller.  If the sub is named then the caller does
12014 not get ownership of a reference.  In most such cases, where the sub
12015 has a non-phase name, the sub will be alive at the point it is returned
12016 by virtue of being contained in the glob that names it.  A phase-named
12017 subroutine will usually be alive by virtue of the reference owned by the
12018 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
12019 been executed, will quite likely have been destroyed already by the
12020 time this function returns, making it erroneous for the caller to make
12021 any use of the returned pointer.  It is the caller's responsibility to
12022 ensure that it knows which of these situations applies.
12023
12024 =cut
12025 */
12026
12027 CV *
12028 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12029                            XSUBADDR_t subaddr, const char *const filename,
12030                            const char *const proto, SV **const_svp,
12031                            U32 flags)
12032 {
12033     CV *cv;
12034     bool interleave = FALSE;
12035     bool evanescent = FALSE;
12036
12037     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12038
12039     {
12040         GV * const gv = gv_fetchpvn(
12041                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12042                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12043                                 sizeof("__ANON__::__ANON__") - 1,
12044                             GV_ADDMULTI | flags, SVt_PVCV);
12045
12046         if ((cv = (name ? GvCV(gv) : NULL))) {
12047             if (GvCVGEN(gv)) {
12048                 /* just a cached method */
12049                 SvREFCNT_dec(cv);
12050                 cv = NULL;
12051             }
12052             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12053                 /* already defined (or promised) */
12054                 /* Redundant check that allows us to avoid creating an SV
12055                    most of the time: */
12056                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12057                     report_redefined_cv(newSVpvn_flags(
12058                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
12059                                         ),
12060                                         cv, const_svp);
12061                 }
12062                 interleave = TRUE;
12063                 ENTER;
12064                 SAVEFREESV(cv);
12065                 cv = NULL;
12066             }
12067         }
12068
12069         if (cv)                         /* must reuse cv if autoloaded */
12070             cv_undef(cv);
12071         else {
12072             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12073             if (name) {
12074                 GvCV_set(gv,cv);
12075                 GvCVGEN(gv) = 0;
12076                 if (HvENAME_HEK(GvSTASH(gv)))
12077                     gv_method_changed(gv); /* newXS */
12078             }
12079         }
12080         assert(cv);
12081         assert(SvREFCNT((SV*)cv) != 0);
12082
12083         CvGV_set(cv, gv);
12084         if(filename) {
12085             /* XSUBs can't be perl lang/perl5db.pl debugged
12086             if (PERLDB_LINE_OR_SAVESRC)
12087                 (void)gv_fetchfile(filename); */
12088             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12089             if (flags & XS_DYNAMIC_FILENAME) {
12090                 CvDYNFILE_on(cv);
12091                 CvFILE(cv) = savepv(filename);
12092             } else {
12093             /* NOTE: not copied, as it is expected to be an external constant string */
12094                 CvFILE(cv) = (char *)filename;
12095             }
12096         } else {
12097             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12098             CvFILE(cv) = (char*)PL_xsubfilename;
12099         }
12100         CvISXSUB_on(cv);
12101         CvXSUB(cv) = subaddr;
12102 #ifndef PERL_IMPLICIT_CONTEXT
12103         CvHSCXT(cv) = &PL_stack_sp;
12104 #else
12105         PoisonPADLIST(cv);
12106 #endif
12107
12108         if (name)
12109             evanescent = process_special_blocks(0, name, gv, cv);
12110         else
12111             CvANON_on(cv);
12112     } /* <- not a conditional branch */
12113
12114     assert(cv);
12115     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12116
12117     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12118     if (interleave) LEAVE;
12119     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12120     return cv;
12121 }
12122
12123 /* Add a stub CV to a typeglob.
12124  * This is the implementation of a forward declaration, 'sub foo';'
12125  */
12126
12127 CV *
12128 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12129 {
12130     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12131     GV *cvgv;
12132     PERL_ARGS_ASSERT_NEWSTUB;
12133     assert(!GvCVu(gv));
12134     GvCV_set(gv, cv);
12135     GvCVGEN(gv) = 0;
12136     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12137         gv_method_changed(gv);
12138     if (SvFAKE(gv)) {
12139         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12140         SvFAKE_off(cvgv);
12141     }
12142     else cvgv = gv;
12143     CvGV_set(cv, cvgv);
12144     CvFILE_set_from_cop(cv, PL_curcop);
12145     CvSTASH_set(cv, PL_curstash);
12146     GvMULTI_on(gv);
12147     return cv;
12148 }
12149
12150 void
12151 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12152 {
12153     CV *cv;
12154     GV *gv;
12155     OP *root;
12156     OP *start;
12157
12158     if (PL_parser && PL_parser->error_count) {
12159         op_free(block);
12160         goto finish;
12161     }
12162
12163     gv = o
12164         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12165         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12166
12167     GvMULTI_on(gv);
12168     if ((cv = GvFORM(gv))) {
12169         if (ckWARN(WARN_REDEFINE)) {
12170             const line_t oldline = CopLINE(PL_curcop);
12171             if (PL_parser && PL_parser->copline != NOLINE)
12172                 CopLINE_set(PL_curcop, PL_parser->copline);
12173             if (o) {
12174                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12175                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12176             } else {
12177                 /* diag_listed_as: Format %s redefined */
12178                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12179                             "Format STDOUT redefined");
12180             }
12181             CopLINE_set(PL_curcop, oldline);
12182         }
12183         SvREFCNT_dec(cv);
12184     }
12185     cv = PL_compcv;
12186     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12187     CvGV_set(cv, gv);
12188     CvFILE_set_from_cop(cv, PL_curcop);
12189
12190
12191     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12192     CvROOT(cv) = root;
12193     start = LINKLIST(root);
12194     root->op_next = 0;
12195     S_process_optree(aTHX_ cv, root, start);
12196     cv_forget_slab(cv);
12197
12198   finish:
12199     op_free(o);
12200     if (PL_parser)
12201         PL_parser->copline = NOLINE;
12202     LEAVE_SCOPE(floor);
12203     PL_compiling.cop_seq = 0;
12204 }
12205
12206 OP *
12207 Perl_newANONLIST(pTHX_ OP *o)
12208 {
12209     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12210 }
12211
12212 OP *
12213 Perl_newANONHASH(pTHX_ OP *o)
12214 {
12215     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12216 }
12217
12218 OP *
12219 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12220 {
12221     return newANONATTRSUB(floor, proto, NULL, block);
12222 }
12223
12224 OP *
12225 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12226 {
12227     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12228     OP * anoncode =
12229         newSVOP(OP_ANONCODE, 0,
12230                 cv);
12231     if (CvANONCONST(cv))
12232         anoncode = newUNOP(OP_ANONCONST, 0,
12233                            op_convert_list(OP_ENTERSUB,
12234                                            OPf_STACKED|OPf_WANT_SCALAR,
12235                                            anoncode));
12236     return newUNOP(OP_REFGEN, 0, anoncode);
12237 }
12238
12239 OP *
12240 Perl_oopsAV(pTHX_ OP *o)
12241 {
12242     dVAR;
12243
12244     PERL_ARGS_ASSERT_OOPSAV;
12245
12246     switch (o->op_type) {
12247     case OP_PADSV:
12248     case OP_PADHV:
12249         OpTYPE_set(o, OP_PADAV);
12250         return ref(o, OP_RV2AV);
12251
12252     case OP_RV2SV:
12253     case OP_RV2HV:
12254         OpTYPE_set(o, OP_RV2AV);
12255         ref(o, OP_RV2AV);
12256         break;
12257
12258     default:
12259         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12260         break;
12261     }
12262     return o;
12263 }
12264
12265 OP *
12266 Perl_oopsHV(pTHX_ OP *o)
12267 {
12268     dVAR;
12269
12270     PERL_ARGS_ASSERT_OOPSHV;
12271
12272     switch (o->op_type) {
12273     case OP_PADSV:
12274     case OP_PADAV:
12275         OpTYPE_set(o, OP_PADHV);
12276         return ref(o, OP_RV2HV);
12277
12278     case OP_RV2SV:
12279     case OP_RV2AV:
12280         OpTYPE_set(o, OP_RV2HV);
12281         /* rv2hv steals the bottom bit for its own uses */
12282         o->op_private &= ~OPpARG1_MASK;
12283         ref(o, OP_RV2HV);
12284         break;
12285
12286     default:
12287         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12288         break;
12289     }
12290     return o;
12291 }
12292
12293 OP *
12294 Perl_newAVREF(pTHX_ OP *o)
12295 {
12296     dVAR;
12297
12298     PERL_ARGS_ASSERT_NEWAVREF;
12299
12300     if (o->op_type == OP_PADANY) {
12301         OpTYPE_set(o, OP_PADAV);
12302         return o;
12303     }
12304     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12305         Perl_croak(aTHX_ "Can't use an array as a reference");
12306     }
12307     return newUNOP(OP_RV2AV, 0, scalar(o));
12308 }
12309
12310 OP *
12311 Perl_newGVREF(pTHX_ I32 type, OP *o)
12312 {
12313     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12314         return newUNOP(OP_NULL, 0, o);
12315     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12316 }
12317
12318 OP *
12319 Perl_newHVREF(pTHX_ OP *o)
12320 {
12321     dVAR;
12322
12323     PERL_ARGS_ASSERT_NEWHVREF;
12324
12325     if (o->op_type == OP_PADANY) {
12326         OpTYPE_set(o, OP_PADHV);
12327         return o;
12328     }
12329     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12330         Perl_croak(aTHX_ "Can't use a hash as a reference");
12331     }
12332     return newUNOP(OP_RV2HV, 0, scalar(o));
12333 }
12334
12335 OP *
12336 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12337 {
12338     if (o->op_type == OP_PADANY) {
12339         dVAR;
12340         OpTYPE_set(o, OP_PADCV);
12341     }
12342     return newUNOP(OP_RV2CV, flags, scalar(o));
12343 }
12344
12345 OP *
12346 Perl_newSVREF(pTHX_ OP *o)
12347 {
12348     dVAR;
12349
12350     PERL_ARGS_ASSERT_NEWSVREF;
12351
12352     if (o->op_type == OP_PADANY) {
12353         OpTYPE_set(o, OP_PADSV);
12354         scalar(o);
12355         return o;
12356     }
12357     return newUNOP(OP_RV2SV, 0, scalar(o));
12358 }
12359
12360 /* Check routines. See the comments at the top of this file for details
12361  * on when these are called */
12362
12363 OP *
12364 Perl_ck_anoncode(pTHX_ OP *o)
12365 {
12366     PERL_ARGS_ASSERT_CK_ANONCODE;
12367
12368     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12369     cSVOPo->op_sv = NULL;
12370     return o;
12371 }
12372
12373 static void
12374 S_io_hints(pTHX_ OP *o)
12375 {
12376 #if O_BINARY != 0 || O_TEXT != 0
12377     HV * const table =
12378         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12379     if (table) {
12380         SV **svp = hv_fetchs(table, "open_IN", FALSE);
12381         if (svp && *svp) {
12382             STRLEN len = 0;
12383             const char *d = SvPV_const(*svp, len);
12384             const I32 mode = mode_from_discipline(d, len);
12385             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12386 #  if O_BINARY != 0
12387             if (mode & O_BINARY)
12388                 o->op_private |= OPpOPEN_IN_RAW;
12389 #  endif
12390 #  if O_TEXT != 0
12391             if (mode & O_TEXT)
12392                 o->op_private |= OPpOPEN_IN_CRLF;
12393 #  endif
12394         }
12395
12396         svp = hv_fetchs(table, "open_OUT", FALSE);
12397         if (svp && *svp) {
12398             STRLEN len = 0;
12399             const char *d = SvPV_const(*svp, len);
12400             const I32 mode = mode_from_discipline(d, len);
12401             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12402 #  if O_BINARY != 0
12403             if (mode & O_BINARY)
12404                 o->op_private |= OPpOPEN_OUT_RAW;
12405 #  endif
12406 #  if O_TEXT != 0
12407             if (mode & O_TEXT)
12408                 o->op_private |= OPpOPEN_OUT_CRLF;
12409 #  endif
12410         }
12411     }
12412 #else
12413     PERL_UNUSED_CONTEXT;
12414     PERL_UNUSED_ARG(o);
12415 #endif
12416 }
12417
12418 OP *
12419 Perl_ck_backtick(pTHX_ OP *o)
12420 {
12421     GV *gv;
12422     OP *newop = NULL;
12423     OP *sibl;
12424     PERL_ARGS_ASSERT_CK_BACKTICK;
12425     o = ck_fun(o);
12426     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12427     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12428      && (gv = gv_override("readpipe",8)))
12429     {
12430         /* detach rest of siblings from o and its first child */
12431         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12432         newop = S_new_entersubop(aTHX_ gv, sibl);
12433     }
12434     else if (!(o->op_flags & OPf_KIDS))
12435         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12436     if (newop) {
12437         op_free(o);
12438         return newop;
12439     }
12440     S_io_hints(aTHX_ o);
12441     return o;
12442 }
12443
12444 OP *
12445 Perl_ck_bitop(pTHX_ OP *o)
12446 {
12447     PERL_ARGS_ASSERT_CK_BITOP;
12448
12449     o->op_private = (U8)(PL_hints & HINT_INTEGER);
12450
12451     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12452             && OP_IS_INFIX_BIT(o->op_type))
12453     {
12454         const OP * const left = cBINOPo->op_first;
12455         const OP * const right = OpSIBLING(left);
12456         if ((OP_IS_NUMCOMPARE(left->op_type) &&
12457                 (left->op_flags & OPf_PARENS) == 0) ||
12458             (OP_IS_NUMCOMPARE(right->op_type) &&
12459                 (right->op_flags & OPf_PARENS) == 0))
12460             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12461                           "Possible precedence problem on bitwise %s operator",
12462                            o->op_type ==  OP_BIT_OR
12463                          ||o->op_type == OP_NBIT_OR  ? "|"
12464                         :  o->op_type ==  OP_BIT_AND
12465                          ||o->op_type == OP_NBIT_AND ? "&"
12466                         :  o->op_type ==  OP_BIT_XOR
12467                          ||o->op_type == OP_NBIT_XOR ? "^"
12468                         :  o->op_type == OP_SBIT_OR  ? "|."
12469                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
12470                            );
12471     }
12472     return o;
12473 }
12474
12475 PERL_STATIC_INLINE bool
12476 is_dollar_bracket(pTHX_ const OP * const o)
12477 {
12478     const OP *kid;
12479     PERL_UNUSED_CONTEXT;
12480     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12481         && (kid = cUNOPx(o)->op_first)
12482         && kid->op_type == OP_GV
12483         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12484 }
12485
12486 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12487
12488 OP *
12489 Perl_ck_cmp(pTHX_ OP *o)
12490 {
12491     bool is_eq;
12492     bool neg;
12493     bool reverse;
12494     bool iv0;
12495     OP *indexop, *constop, *start;
12496     SV *sv;
12497     IV iv;
12498
12499     PERL_ARGS_ASSERT_CK_CMP;
12500
12501     is_eq = (   o->op_type == OP_EQ
12502              || o->op_type == OP_NE
12503              || o->op_type == OP_I_EQ
12504              || o->op_type == OP_I_NE);
12505
12506     if (!is_eq && ckWARN(WARN_SYNTAX)) {
12507         const OP *kid = cUNOPo->op_first;
12508         if (kid &&
12509             (
12510                 (   is_dollar_bracket(aTHX_ kid)
12511                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12512                 )
12513              || (   kid->op_type == OP_CONST
12514                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12515                 )
12516            )
12517         )
12518             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12519                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12520     }
12521
12522     /* convert (index(...) == -1) and variations into
12523      *   (r)index/BOOL(,NEG)
12524      */
12525
12526     reverse = FALSE;
12527
12528     indexop = cUNOPo->op_first;
12529     constop = OpSIBLING(indexop);
12530     start = NULL;
12531     if (indexop->op_type == OP_CONST) {
12532         constop = indexop;
12533         indexop = OpSIBLING(constop);
12534         start = constop;
12535         reverse = TRUE;
12536     }
12537
12538     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12539         return o;
12540
12541     /* ($lex = index(....)) == -1 */
12542     if (indexop->op_private & OPpTARGET_MY)
12543         return o;
12544
12545     if (constop->op_type != OP_CONST)
12546         return o;
12547
12548     sv = cSVOPx_sv(constop);
12549     if (!(sv && SvIOK_notUV(sv)))
12550         return o;
12551
12552     iv = SvIVX(sv);
12553     if (iv != -1 && iv != 0)
12554         return o;
12555     iv0 = (iv == 0);
12556
12557     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12558         if (!(iv0 ^ reverse))
12559             return o;
12560         neg = iv0;
12561     }
12562     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12563         if (iv0 ^ reverse)
12564             return o;
12565         neg = !iv0;
12566     }
12567     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12568         if (!(iv0 ^ reverse))
12569             return o;
12570         neg = !iv0;
12571     }
12572     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12573         if (iv0 ^ reverse)
12574             return o;
12575         neg = iv0;
12576     }
12577     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12578         if (iv0)
12579             return o;
12580         neg = TRUE;
12581     }
12582     else {
12583         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12584         if (iv0)
12585             return o;
12586         neg = FALSE;
12587     }
12588
12589     indexop->op_flags &= ~OPf_PARENS;
12590     indexop->op_flags |= (o->op_flags & OPf_PARENS);
12591     indexop->op_private |= OPpTRUEBOOL;
12592     if (neg)
12593         indexop->op_private |= OPpINDEX_BOOLNEG;
12594     /* cut out the index op and free the eq,const ops */
12595     (void)op_sibling_splice(o, start, 1, NULL);
12596     op_free(o);
12597
12598     return indexop;
12599 }
12600
12601
12602 OP *
12603 Perl_ck_concat(pTHX_ OP *o)
12604 {
12605     const OP * const kid = cUNOPo->op_first;
12606
12607     PERL_ARGS_ASSERT_CK_CONCAT;
12608     PERL_UNUSED_CONTEXT;
12609
12610     /* reuse the padtmp returned by the concat child */
12611     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12612             !(kUNOP->op_first->op_flags & OPf_MOD))
12613     {
12614         o->op_flags |= OPf_STACKED;
12615         o->op_private |= OPpCONCAT_NESTED;
12616     }
12617     return o;
12618 }
12619
12620 OP *
12621 Perl_ck_spair(pTHX_ OP *o)
12622 {
12623     dVAR;
12624
12625     PERL_ARGS_ASSERT_CK_SPAIR;
12626
12627     if (o->op_flags & OPf_KIDS) {
12628         OP* newop;
12629         OP* kid;
12630         OP* kidkid;
12631         const OPCODE type = o->op_type;
12632         o = modkids(ck_fun(o), type);
12633         kid    = cUNOPo->op_first;
12634         kidkid = kUNOP->op_first;
12635         newop = OpSIBLING(kidkid);
12636         if (newop) {
12637             const OPCODE type = newop->op_type;
12638             if (OpHAS_SIBLING(newop))
12639                 return o;
12640             if (o->op_type == OP_REFGEN
12641              && (  type == OP_RV2CV
12642                 || (  !(newop->op_flags & OPf_PARENS)
12643                    && (  type == OP_RV2AV || type == OP_PADAV
12644                       || type == OP_RV2HV || type == OP_PADHV))))
12645                 NOOP; /* OK (allow srefgen for \@a and \%h) */
12646             else if (OP_GIMME(newop,0) != G_SCALAR)
12647                 return o;
12648         }
12649         /* excise first sibling */
12650         op_sibling_splice(kid, NULL, 1, NULL);
12651         op_free(kidkid);
12652     }
12653     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12654      * and OP_CHOMP into OP_SCHOMP */
12655     o->op_ppaddr = PL_ppaddr[++o->op_type];
12656     return ck_fun(o);
12657 }
12658
12659 OP *
12660 Perl_ck_delete(pTHX_ OP *o)
12661 {
12662     PERL_ARGS_ASSERT_CK_DELETE;
12663
12664     o = ck_fun(o);
12665     o->op_private = 0;
12666     if (o->op_flags & OPf_KIDS) {
12667         OP * const kid = cUNOPo->op_first;
12668         switch (kid->op_type) {
12669         case OP_ASLICE:
12670             o->op_flags |= OPf_SPECIAL;
12671             /* FALLTHROUGH */
12672         case OP_HSLICE:
12673             o->op_private |= OPpSLICE;
12674             break;
12675         case OP_AELEM:
12676             o->op_flags |= OPf_SPECIAL;
12677             /* FALLTHROUGH */
12678         case OP_HELEM:
12679             break;
12680         case OP_KVASLICE:
12681             o->op_flags |= OPf_SPECIAL;
12682             /* FALLTHROUGH */
12683         case OP_KVHSLICE:
12684             o->op_private |= OPpKVSLICE;
12685             break;
12686         default:
12687             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12688                              "element or slice");
12689         }
12690         if (kid->op_private & OPpLVAL_INTRO)
12691             o->op_private |= OPpLVAL_INTRO;
12692         op_null(kid);
12693     }
12694     return o;
12695 }
12696
12697 OP *
12698 Perl_ck_eof(pTHX_ OP *o)
12699 {
12700     PERL_ARGS_ASSERT_CK_EOF;
12701
12702     if (o->op_flags & OPf_KIDS) {
12703         OP *kid;
12704         if (cLISTOPo->op_first->op_type == OP_STUB) {
12705             OP * const newop
12706                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12707             op_free(o);
12708             o = newop;
12709         }
12710         o = ck_fun(o);
12711         kid = cLISTOPo->op_first;
12712         if (kid->op_type == OP_RV2GV)
12713             kid->op_private |= OPpALLOW_FAKE;
12714     }
12715     return o;
12716 }
12717
12718
12719 OP *
12720 Perl_ck_eval(pTHX_ OP *o)
12721 {
12722     dVAR;
12723
12724     PERL_ARGS_ASSERT_CK_EVAL;
12725
12726     PL_hints |= HINT_BLOCK_SCOPE;
12727     if (o->op_flags & OPf_KIDS) {
12728         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12729         assert(kid);
12730
12731         if (o->op_type == OP_ENTERTRY) {
12732             LOGOP *enter;
12733
12734             /* cut whole sibling chain free from o */
12735             op_sibling_splice(o, NULL, -1, NULL);
12736             op_free(o);
12737
12738             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12739
12740             /* establish postfix order */
12741             enter->op_next = (OP*)enter;
12742
12743             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12744             OpTYPE_set(o, OP_LEAVETRY);
12745             enter->op_other = o;
12746             return o;
12747         }
12748         else {
12749             scalar((OP*)kid);
12750             S_set_haseval(aTHX);
12751         }
12752     }
12753     else {
12754         const U8 priv = o->op_private;
12755         op_free(o);
12756         /* the newUNOP will recursively call ck_eval(), which will handle
12757          * all the stuff at the end of this function, like adding
12758          * OP_HINTSEVAL
12759          */
12760         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12761     }
12762     o->op_targ = (PADOFFSET)PL_hints;
12763     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12764     if ((PL_hints & HINT_LOCALIZE_HH) != 0
12765      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12766         /* Store a copy of %^H that pp_entereval can pick up. */
12767         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12768         OP *hhop;
12769         STOREFEATUREBITSHH(hh);
12770         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12771         /* append hhop to only child  */
12772         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12773
12774         o->op_private |= OPpEVAL_HAS_HH;
12775     }
12776     if (!(o->op_private & OPpEVAL_BYTES)
12777          && FEATURE_UNIEVAL_IS_ENABLED)
12778             o->op_private |= OPpEVAL_UNICODE;
12779     return o;
12780 }
12781
12782 OP *
12783 Perl_ck_exec(pTHX_ OP *o)
12784 {
12785     PERL_ARGS_ASSERT_CK_EXEC;
12786
12787     if (o->op_flags & OPf_STACKED) {
12788         OP *kid;
12789         o = ck_fun(o);
12790         kid = OpSIBLING(cUNOPo->op_first);
12791         if (kid->op_type == OP_RV2GV)
12792             op_null(kid);
12793     }
12794     else
12795         o = listkids(o);
12796     return o;
12797 }
12798
12799 OP *
12800 Perl_ck_exists(pTHX_ OP *o)
12801 {
12802     PERL_ARGS_ASSERT_CK_EXISTS;
12803
12804     o = ck_fun(o);
12805     if (o->op_flags & OPf_KIDS) {
12806         OP * const kid = cUNOPo->op_first;
12807         if (kid->op_type == OP_ENTERSUB) {
12808             (void) ref(kid, o->op_type);
12809             if (kid->op_type != OP_RV2CV
12810                         && !(PL_parser && PL_parser->error_count))
12811                 Perl_croak(aTHX_
12812                           "exists argument is not a subroutine name");
12813             o->op_private |= OPpEXISTS_SUB;
12814         }
12815         else if (kid->op_type == OP_AELEM)
12816             o->op_flags |= OPf_SPECIAL;
12817         else if (kid->op_type != OP_HELEM)
12818             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12819                              "element or a subroutine");
12820         op_null(kid);
12821     }
12822     return o;
12823 }
12824
12825 OP *
12826 Perl_ck_rvconst(pTHX_ OP *o)
12827 {
12828     dVAR;
12829     SVOP * const kid = (SVOP*)cUNOPo->op_first;
12830
12831     PERL_ARGS_ASSERT_CK_RVCONST;
12832
12833     if (o->op_type == OP_RV2HV)
12834         /* rv2hv steals the bottom bit for its own uses */
12835         o->op_private &= ~OPpARG1_MASK;
12836
12837     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12838
12839     if (kid->op_type == OP_CONST) {
12840         int iscv;
12841         GV *gv;
12842         SV * const kidsv = kid->op_sv;
12843
12844         /* Is it a constant from cv_const_sv()? */
12845         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12846             return o;
12847         }
12848         if (SvTYPE(kidsv) == SVt_PVAV) return o;
12849         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12850             const char *badthing;
12851             switch (o->op_type) {
12852             case OP_RV2SV:
12853                 badthing = "a SCALAR";
12854                 break;
12855             case OP_RV2AV:
12856                 badthing = "an ARRAY";
12857                 break;
12858             case OP_RV2HV:
12859                 badthing = "a HASH";
12860                 break;
12861             default:
12862                 badthing = NULL;
12863                 break;
12864             }
12865             if (badthing)
12866                 Perl_croak(aTHX_
12867                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12868                            SVfARG(kidsv), badthing);
12869         }
12870         /*
12871          * This is a little tricky.  We only want to add the symbol if we
12872          * didn't add it in the lexer.  Otherwise we get duplicate strict
12873          * warnings.  But if we didn't add it in the lexer, we must at
12874          * least pretend like we wanted to add it even if it existed before,
12875          * or we get possible typo warnings.  OPpCONST_ENTERED says
12876          * whether the lexer already added THIS instance of this symbol.
12877          */
12878         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12879         gv = gv_fetchsv(kidsv,
12880                 o->op_type == OP_RV2CV
12881                         && o->op_private & OPpMAY_RETURN_CONSTANT
12882                     ? GV_NOEXPAND
12883                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
12884                 iscv
12885                     ? SVt_PVCV
12886                     : o->op_type == OP_RV2SV
12887                         ? SVt_PV
12888                         : o->op_type == OP_RV2AV
12889                             ? SVt_PVAV
12890                             : o->op_type == OP_RV2HV
12891                                 ? SVt_PVHV
12892                                 : SVt_PVGV);
12893         if (gv) {
12894             if (!isGV(gv)) {
12895                 assert(iscv);
12896                 assert(SvROK(gv));
12897                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12898                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
12899                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12900             }
12901             OpTYPE_set(kid, OP_GV);
12902             SvREFCNT_dec(kid->op_sv);
12903 #ifdef USE_ITHREADS
12904             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12905             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12906             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12907             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12908             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12909 #else
12910             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12911 #endif
12912             kid->op_private = 0;
12913             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12914             SvFAKE_off(gv);
12915         }
12916     }
12917     return o;
12918 }
12919
12920 OP *
12921 Perl_ck_ftst(pTHX_ OP *o)
12922 {
12923     dVAR;
12924     const I32 type = o->op_type;
12925
12926     PERL_ARGS_ASSERT_CK_FTST;
12927
12928     if (o->op_flags & OPf_REF) {
12929         NOOP;
12930     }
12931     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12932         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12933         const OPCODE kidtype = kid->op_type;
12934
12935         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12936          && !kid->op_folded) {
12937             OP * const newop = newGVOP(type, OPf_REF,
12938                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12939             op_free(o);
12940             return newop;
12941         }
12942
12943         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12944             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12945             if (name) {
12946                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12947                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12948                             array_passed_to_stat, name);
12949             }
12950             else {
12951                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12952                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12953             }
12954        }
12955         scalar((OP *) kid);
12956         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12957             o->op_private |= OPpFT_ACCESS;
12958         if (OP_IS_FILETEST(type)
12959             && OP_IS_FILETEST(kidtype)
12960         ) {
12961             o->op_private |= OPpFT_STACKED;
12962             kid->op_private |= OPpFT_STACKING;
12963             if (kidtype == OP_FTTTY && (
12964                    !(kid->op_private & OPpFT_STACKED)
12965                 || kid->op_private & OPpFT_AFTER_t
12966                ))
12967                 o->op_private |= OPpFT_AFTER_t;
12968         }
12969     }
12970     else {
12971         op_free(o);
12972         if (type == OP_FTTTY)
12973             o = newGVOP(type, OPf_REF, PL_stdingv);
12974         else
12975             o = newUNOP(type, 0, newDEFSVOP());
12976     }
12977     return o;
12978 }
12979
12980 OP *
12981 Perl_ck_fun(pTHX_ OP *o)
12982 {
12983     const int type = o->op_type;
12984     I32 oa = PL_opargs[type] >> OASHIFT;
12985
12986     PERL_ARGS_ASSERT_CK_FUN;
12987
12988     if (o->op_flags & OPf_STACKED) {
12989         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12990             oa &= ~OA_OPTIONAL;
12991         else
12992             return no_fh_allowed(o);
12993     }
12994
12995     if (o->op_flags & OPf_KIDS) {
12996         OP *prev_kid = NULL;
12997         OP *kid = cLISTOPo->op_first;
12998         I32 numargs = 0;
12999         bool seen_optional = FALSE;
13000
13001         if (kid->op_type == OP_PUSHMARK ||
13002             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13003         {
13004             prev_kid = kid;
13005             kid = OpSIBLING(kid);
13006         }
13007         if (kid && kid->op_type == OP_COREARGS) {
13008             bool optional = FALSE;
13009             while (oa) {
13010                 numargs++;
13011                 if (oa & OA_OPTIONAL) optional = TRUE;
13012                 oa = oa >> 4;
13013             }
13014             if (optional) o->op_private |= numargs;
13015             return o;
13016         }
13017
13018         while (oa) {
13019             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13020                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13021                     kid = newDEFSVOP();
13022                     /* append kid to chain */
13023                     op_sibling_splice(o, prev_kid, 0, kid);
13024                 }
13025                 seen_optional = TRUE;
13026             }
13027             if (!kid) break;
13028
13029             numargs++;
13030             switch (oa & 7) {
13031             case OA_SCALAR:
13032                 /* list seen where single (scalar) arg expected? */
13033                 if (numargs == 1 && !(oa >> 4)
13034                     && kid->op_type == OP_LIST && type != OP_SCALAR)
13035                 {
13036                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13037                 }
13038                 if (type != OP_DELETE) scalar(kid);
13039                 break;
13040             case OA_LIST:
13041                 if (oa < 16) {
13042                     kid = 0;
13043                     continue;
13044                 }
13045                 else
13046                     list(kid);
13047                 break;
13048             case OA_AVREF:
13049                 if ((type == OP_PUSH || type == OP_UNSHIFT)
13050                     && !OpHAS_SIBLING(kid))
13051                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13052                                    "Useless use of %s with no values",
13053                                    PL_op_desc[type]);
13054
13055                 if (kid->op_type == OP_CONST
13056                       && (  !SvROK(cSVOPx_sv(kid))
13057                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
13058                         )
13059                     bad_type_pv(numargs, "array", o, kid);
13060                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13061                          || kid->op_type == OP_RV2GV) {
13062                     bad_type_pv(1, "array", o, kid);
13063                 }
13064                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13065                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13066                                          PL_op_desc[type]), 0);
13067                 }
13068                 else {
13069                     op_lvalue(kid, type);
13070                 }
13071                 break;
13072             case OA_HVREF:
13073                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13074                     bad_type_pv(numargs, "hash", o, kid);
13075                 op_lvalue(kid, type);
13076                 break;
13077             case OA_CVREF:
13078                 {
13079                     /* replace kid with newop in chain */
13080                     OP * const newop =
13081                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13082                     newop->op_next = newop;
13083                     kid = newop;
13084                 }
13085                 break;
13086             case OA_FILEREF:
13087                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13088                     if (kid->op_type == OP_CONST &&
13089                         (kid->op_private & OPpCONST_BARE))
13090                     {
13091                         OP * const newop = newGVOP(OP_GV, 0,
13092                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13093                         /* replace kid with newop in chain */
13094                         op_sibling_splice(o, prev_kid, 1, newop);
13095                         op_free(kid);
13096                         kid = newop;
13097                     }
13098                     else if (kid->op_type == OP_READLINE) {
13099                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13100                         bad_type_pv(numargs, "HANDLE", o, kid);
13101                     }
13102                     else {
13103                         I32 flags = OPf_SPECIAL;
13104                         I32 priv = 0;
13105                         PADOFFSET targ = 0;
13106
13107                         /* is this op a FH constructor? */
13108                         if (is_handle_constructor(o,numargs)) {
13109                             const char *name = NULL;
13110                             STRLEN len = 0;
13111                             U32 name_utf8 = 0;
13112                             bool want_dollar = TRUE;
13113
13114                             flags = 0;
13115                             /* Set a flag to tell rv2gv to vivify
13116                              * need to "prove" flag does not mean something
13117                              * else already - NI-S 1999/05/07
13118                              */
13119                             priv = OPpDEREF;
13120                             if (kid->op_type == OP_PADSV) {
13121                                 PADNAME * const pn
13122                                     = PAD_COMPNAME_SV(kid->op_targ);
13123                                 name = PadnamePV (pn);
13124                                 len  = PadnameLEN(pn);
13125                                 name_utf8 = PadnameUTF8(pn);
13126                             }
13127                             else if (kid->op_type == OP_RV2SV
13128                                      && kUNOP->op_first->op_type == OP_GV)
13129                             {
13130                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13131                                 name = GvNAME(gv);
13132                                 len = GvNAMELEN(gv);
13133                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13134                             }
13135                             else if (kid->op_type == OP_AELEM
13136                                      || kid->op_type == OP_HELEM)
13137                             {
13138                                  OP *firstop;
13139                                  OP *op = ((BINOP*)kid)->op_first;
13140                                  name = NULL;
13141                                  if (op) {
13142                                       SV *tmpstr = NULL;
13143                                       const char * const a =
13144                                            kid->op_type == OP_AELEM ?
13145                                            "[]" : "{}";
13146                                       if (((op->op_type == OP_RV2AV) ||
13147                                            (op->op_type == OP_RV2HV)) &&
13148                                           (firstop = ((UNOP*)op)->op_first) &&
13149                                           (firstop->op_type == OP_GV)) {
13150                                            /* packagevar $a[] or $h{} */
13151                                            GV * const gv = cGVOPx_gv(firstop);
13152                                            if (gv)
13153                                                 tmpstr =
13154                                                      Perl_newSVpvf(aTHX_
13155                                                                    "%s%c...%c",
13156                                                                    GvNAME(gv),
13157                                                                    a[0], a[1]);
13158                                       }
13159                                       else if (op->op_type == OP_PADAV
13160                                                || op->op_type == OP_PADHV) {
13161                                            /* lexicalvar $a[] or $h{} */
13162                                            const char * const padname =
13163                                                 PAD_COMPNAME_PV(op->op_targ);
13164                                            if (padname)
13165                                                 tmpstr =
13166                                                      Perl_newSVpvf(aTHX_
13167                                                                    "%s%c...%c",
13168                                                                    padname + 1,
13169                                                                    a[0], a[1]);
13170                                       }
13171                                       if (tmpstr) {
13172                                            name = SvPV_const(tmpstr, len);
13173                                            name_utf8 = SvUTF8(tmpstr);
13174                                            sv_2mortal(tmpstr);
13175                                       }
13176                                  }
13177                                  if (!name) {
13178                                       name = "__ANONIO__";
13179                                       len = 10;
13180                                       want_dollar = FALSE;
13181                                  }
13182                                  op_lvalue(kid, type);
13183                             }
13184                             if (name) {
13185                                 SV *namesv;
13186                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13187                                 namesv = PAD_SVl(targ);
13188                                 if (want_dollar && *name != '$')
13189                                     sv_setpvs(namesv, "$");
13190                                 else
13191                                     SvPVCLEAR(namesv);
13192                                 sv_catpvn(namesv, name, len);
13193                                 if ( name_utf8 ) SvUTF8_on(namesv);
13194                             }
13195                         }
13196                         scalar(kid);
13197                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13198                                     OP_RV2GV, flags);
13199                         kid->op_targ = targ;
13200                         kid->op_private |= priv;
13201                     }
13202                 }
13203                 scalar(kid);
13204                 break;
13205             case OA_SCALARREF:
13206                 if ((type == OP_UNDEF || type == OP_POS)
13207                     && numargs == 1 && !(oa >> 4)
13208                     && kid->op_type == OP_LIST)
13209                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13210                 op_lvalue(scalar(kid), type);
13211                 break;
13212             }
13213             oa >>= 4;
13214             prev_kid = kid;
13215             kid = OpSIBLING(kid);
13216         }
13217         /* FIXME - should the numargs or-ing move after the too many
13218          * arguments check? */
13219         o->op_private |= numargs;
13220         if (kid)
13221             return too_many_arguments_pv(o,OP_DESC(o), 0);
13222         listkids(o);
13223     }
13224     else if (PL_opargs[type] & OA_DEFGV) {
13225         /* Ordering of these two is important to keep f_map.t passing.  */
13226         op_free(o);
13227         return newUNOP(type, 0, newDEFSVOP());
13228     }
13229
13230     if (oa) {
13231         while (oa & OA_OPTIONAL)
13232             oa >>= 4;
13233         if (oa && oa != OA_LIST)
13234             return too_few_arguments_pv(o,OP_DESC(o), 0);
13235     }
13236     return o;
13237 }
13238
13239 OP *
13240 Perl_ck_glob(pTHX_ OP *o)
13241 {
13242     GV *gv;
13243
13244     PERL_ARGS_ASSERT_CK_GLOB;
13245
13246     o = ck_fun(o);
13247     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13248         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13249
13250     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13251     {
13252         /* convert
13253          *     glob
13254          *       \ null - const(wildcard)
13255          * into
13256          *     null
13257          *       \ enter
13258          *            \ list
13259          *                 \ mark - glob - rv2cv
13260          *                             |        \ gv(CORE::GLOBAL::glob)
13261          *                             |
13262          *                              \ null - const(wildcard)
13263          */
13264         o->op_flags |= OPf_SPECIAL;
13265         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13266         o = S_new_entersubop(aTHX_ gv, o);
13267         o = newUNOP(OP_NULL, 0, o);
13268         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13269         return o;
13270     }
13271     else o->op_flags &= ~OPf_SPECIAL;
13272 #if !defined(PERL_EXTERNAL_GLOB)
13273     if (!PL_globhook) {
13274         ENTER;
13275         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13276                                newSVpvs("File::Glob"), NULL, NULL, NULL);
13277         LEAVE;
13278     }
13279 #endif /* !PERL_EXTERNAL_GLOB */
13280     gv = (GV *)newSV(0);
13281     gv_init(gv, 0, "", 0, 0);
13282     gv_IOadd(gv);
13283     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13284     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13285     scalarkids(o);
13286     return o;
13287 }
13288
13289 OP *
13290 Perl_ck_grep(pTHX_ OP *o)
13291 {
13292     LOGOP *gwop;
13293     OP *kid;
13294     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13295
13296     PERL_ARGS_ASSERT_CK_GREP;
13297
13298     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13299
13300     if (o->op_flags & OPf_STACKED) {
13301         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13302         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13303             return no_fh_allowed(o);
13304         o->op_flags &= ~OPf_STACKED;
13305     }
13306     kid = OpSIBLING(cLISTOPo->op_first);
13307     if (type == OP_MAPWHILE)
13308         list(kid);
13309     else
13310         scalar(kid);
13311     o = ck_fun(o);
13312     if (PL_parser && PL_parser->error_count)
13313         return o;
13314     kid = OpSIBLING(cLISTOPo->op_first);
13315     if (kid->op_type != OP_NULL)
13316         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13317     kid = kUNOP->op_first;
13318
13319     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13320     kid->op_next = (OP*)gwop;
13321     o->op_private = gwop->op_private = 0;
13322     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13323
13324     kid = OpSIBLING(cLISTOPo->op_first);
13325     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13326         op_lvalue(kid, OP_GREPSTART);
13327
13328     return (OP*)gwop;
13329 }
13330
13331 OP *
13332 Perl_ck_index(pTHX_ OP *o)
13333 {
13334     PERL_ARGS_ASSERT_CK_INDEX;
13335
13336     if (o->op_flags & OPf_KIDS) {
13337         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
13338         if (kid)
13339             kid = OpSIBLING(kid);                       /* get past "big" */
13340         if (kid && kid->op_type == OP_CONST) {
13341             const bool save_taint = TAINT_get;
13342             SV *sv = kSVOP->op_sv;
13343             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13344                 && SvOK(sv) && !SvROK(sv))
13345             {
13346                 sv = newSV(0);
13347                 sv_copypv(sv, kSVOP->op_sv);
13348                 SvREFCNT_dec_NN(kSVOP->op_sv);
13349                 kSVOP->op_sv = sv;
13350             }
13351             if (SvOK(sv)) fbm_compile(sv, 0);
13352             TAINT_set(save_taint);
13353 #ifdef NO_TAINT_SUPPORT
13354             PERL_UNUSED_VAR(save_taint);
13355 #endif
13356         }
13357     }
13358     return ck_fun(o);
13359 }
13360
13361 OP *
13362 Perl_ck_lfun(pTHX_ OP *o)
13363 {
13364     const OPCODE type = o->op_type;
13365
13366     PERL_ARGS_ASSERT_CK_LFUN;
13367
13368     return modkids(ck_fun(o), type);
13369 }
13370
13371 OP *
13372 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
13373 {
13374     PERL_ARGS_ASSERT_CK_DEFINED;
13375
13376     if ((o->op_flags & OPf_KIDS)) {
13377         switch (cUNOPo->op_first->op_type) {
13378         case OP_RV2AV:
13379         case OP_PADAV:
13380             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13381                              " (Maybe you should just omit the defined()?)");
13382             NOT_REACHED; /* NOTREACHED */
13383             break;
13384         case OP_RV2HV:
13385         case OP_PADHV:
13386             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13387                              " (Maybe you should just omit the defined()?)");
13388             NOT_REACHED; /* NOTREACHED */
13389             break;
13390         default:
13391             /* no warning */
13392             break;
13393         }
13394     }
13395     return ck_rfun(o);
13396 }
13397
13398 OP *
13399 Perl_ck_readline(pTHX_ OP *o)
13400 {
13401     PERL_ARGS_ASSERT_CK_READLINE;
13402
13403     if (o->op_flags & OPf_KIDS) {
13404          OP *kid = cLISTOPo->op_first;
13405          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13406          scalar(kid);
13407     }
13408     else {
13409         OP * const newop
13410             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13411         op_free(o);
13412         return newop;
13413     }
13414     return o;
13415 }
13416
13417 OP *
13418 Perl_ck_rfun(pTHX_ OP *o)
13419 {
13420     const OPCODE type = o->op_type;
13421
13422     PERL_ARGS_ASSERT_CK_RFUN;
13423
13424     return refkids(ck_fun(o), type);
13425 }
13426
13427 OP *
13428 Perl_ck_listiob(pTHX_ OP *o)
13429 {
13430     OP *kid;
13431
13432     PERL_ARGS_ASSERT_CK_LISTIOB;
13433
13434     kid = cLISTOPo->op_first;
13435     if (!kid) {
13436         o = force_list(o, 1);
13437         kid = cLISTOPo->op_first;
13438     }
13439     if (kid->op_type == OP_PUSHMARK)
13440         kid = OpSIBLING(kid);
13441     if (kid && o->op_flags & OPf_STACKED)
13442         kid = OpSIBLING(kid);
13443     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
13444         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13445          && !kid->op_folded) {
13446             o->op_flags |= OPf_STACKED; /* make it a filehandle */
13447             scalar(kid);
13448             /* replace old const op with new OP_RV2GV parent */
13449             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13450                                         OP_RV2GV, OPf_REF);
13451             kid = OpSIBLING(kid);
13452         }
13453     }
13454
13455     if (!kid)
13456         op_append_elem(o->op_type, o, newDEFSVOP());
13457
13458     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13459     return listkids(o);
13460 }
13461
13462 OP *
13463 Perl_ck_smartmatch(pTHX_ OP *o)
13464 {
13465     dVAR;
13466     PERL_ARGS_ASSERT_CK_SMARTMATCH;
13467     if (0 == (o->op_flags & OPf_SPECIAL)) {
13468         OP *first  = cBINOPo->op_first;
13469         OP *second = OpSIBLING(first);
13470
13471         /* Implicitly take a reference to an array or hash */
13472
13473         /* remove the original two siblings, then add back the
13474          * (possibly different) first and second sibs.
13475          */
13476         op_sibling_splice(o, NULL, 1, NULL);
13477         op_sibling_splice(o, NULL, 1, NULL);
13478         first  = ref_array_or_hash(first);
13479         second = ref_array_or_hash(second);
13480         op_sibling_splice(o, NULL, 0, second);
13481         op_sibling_splice(o, NULL, 0, first);
13482
13483         /* Implicitly take a reference to a regular expression */
13484         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13485             OpTYPE_set(first, OP_QR);
13486         }
13487         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13488             OpTYPE_set(second, OP_QR);
13489         }
13490     }
13491
13492     return o;
13493 }
13494
13495
13496 static OP *
13497 S_maybe_targlex(pTHX_ OP *o)
13498 {
13499     OP * const kid = cLISTOPo->op_first;
13500     /* has a disposable target? */
13501     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13502         && !(kid->op_flags & OPf_STACKED)
13503         /* Cannot steal the second time! */
13504         && !(kid->op_private & OPpTARGET_MY)
13505         )
13506     {
13507         OP * const kkid = OpSIBLING(kid);
13508
13509         /* Can just relocate the target. */
13510         if (kkid && kkid->op_type == OP_PADSV
13511             && (!(kkid->op_private & OPpLVAL_INTRO)
13512                || kkid->op_private & OPpPAD_STATE))
13513         {
13514             kid->op_targ = kkid->op_targ;
13515             kkid->op_targ = 0;
13516             /* Now we do not need PADSV and SASSIGN.
13517              * Detach kid and free the rest. */
13518             op_sibling_splice(o, NULL, 1, NULL);
13519             op_free(o);
13520             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
13521             return kid;
13522         }
13523     }
13524     return o;
13525 }
13526
13527 OP *
13528 Perl_ck_sassign(pTHX_ OP *o)
13529 {
13530     dVAR;
13531     OP * const kid = cBINOPo->op_first;
13532
13533     PERL_ARGS_ASSERT_CK_SASSIGN;
13534
13535     if (OpHAS_SIBLING(kid)) {
13536         OP *kkid = OpSIBLING(kid);
13537         /* For state variable assignment with attributes, kkid is a list op
13538            whose op_last is a padsv. */
13539         if ((kkid->op_type == OP_PADSV ||
13540              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13541               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13542              )
13543             )
13544                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13545                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13546             return S_newONCEOP(aTHX_ o, kkid);
13547         }
13548     }
13549     return S_maybe_targlex(aTHX_ o);
13550 }
13551
13552
13553 OP *
13554 Perl_ck_match(pTHX_ OP *o)
13555 {
13556     PERL_UNUSED_CONTEXT;
13557     PERL_ARGS_ASSERT_CK_MATCH;
13558
13559     return o;
13560 }
13561
13562 OP *
13563 Perl_ck_method(pTHX_ OP *o)
13564 {
13565     SV *sv, *methsv, *rclass;
13566     const char* method;
13567     char* compatptr;
13568     int utf8;
13569     STRLEN len, nsplit = 0, i;
13570     OP* new_op;
13571     OP * const kid = cUNOPo->op_first;
13572
13573     PERL_ARGS_ASSERT_CK_METHOD;
13574     if (kid->op_type != OP_CONST) return o;
13575
13576     sv = kSVOP->op_sv;
13577
13578     /* replace ' with :: */
13579     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13580                                         SvEND(sv) - SvPVX(sv) )))
13581     {
13582         *compatptr = ':';
13583         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13584     }
13585
13586     method = SvPVX_const(sv);
13587     len = SvCUR(sv);
13588     utf8 = SvUTF8(sv) ? -1 : 1;
13589
13590     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13591         nsplit = i+1;
13592         break;
13593     }
13594
13595     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13596
13597     if (!nsplit) { /* $proto->method() */
13598         op_free(o);
13599         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13600     }
13601
13602     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13603         op_free(o);
13604         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13605     }
13606
13607     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13608     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13609         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13610         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13611     } else {
13612         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13613         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13614     }
13615 #ifdef USE_ITHREADS
13616     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13617 #else
13618     cMETHOPx(new_op)->op_rclass_sv = rclass;
13619 #endif
13620     op_free(o);
13621     return new_op;
13622 }
13623
13624 OP *
13625 Perl_ck_null(pTHX_ OP *o)
13626 {
13627     PERL_ARGS_ASSERT_CK_NULL;
13628     PERL_UNUSED_CONTEXT;
13629     return o;
13630 }
13631
13632 OP *
13633 Perl_ck_open(pTHX_ OP *o)
13634 {
13635     PERL_ARGS_ASSERT_CK_OPEN;
13636
13637     S_io_hints(aTHX_ o);
13638     {
13639          /* In case of three-arg dup open remove strictness
13640           * from the last arg if it is a bareword. */
13641          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13642          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
13643          OP *oa;
13644          const char *mode;
13645
13646          if ((last->op_type == OP_CONST) &&             /* The bareword. */
13647              (last->op_private & OPpCONST_BARE) &&
13648              (last->op_private & OPpCONST_STRICT) &&
13649              (oa = OpSIBLING(first)) &&         /* The fh. */
13650              (oa = OpSIBLING(oa)) &&                    /* The mode. */
13651              (oa->op_type == OP_CONST) &&
13652              SvPOK(((SVOP*)oa)->op_sv) &&
13653              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13654              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
13655              (last == OpSIBLING(oa)))                   /* The bareword. */
13656               last->op_private &= ~OPpCONST_STRICT;
13657     }
13658     return ck_fun(o);
13659 }
13660
13661 OP *
13662 Perl_ck_prototype(pTHX_ OP *o)
13663 {
13664     PERL_ARGS_ASSERT_CK_PROTOTYPE;
13665     if (!(o->op_flags & OPf_KIDS)) {
13666         op_free(o);
13667         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13668     }
13669     return o;
13670 }
13671
13672 OP *
13673 Perl_ck_refassign(pTHX_ OP *o)
13674 {
13675     OP * const right = cLISTOPo->op_first;
13676     OP * const left = OpSIBLING(right);
13677     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13678     bool stacked = 0;
13679
13680     PERL_ARGS_ASSERT_CK_REFASSIGN;
13681     assert (left);
13682     assert (left->op_type == OP_SREFGEN);
13683
13684     o->op_private = 0;
13685     /* we use OPpPAD_STATE in refassign to mean either of those things,
13686      * and the code assumes the two flags occupy the same bit position
13687      * in the various ops below */
13688     assert(OPpPAD_STATE == OPpOUR_INTRO);
13689
13690     switch (varop->op_type) {
13691     case OP_PADAV:
13692         o->op_private |= OPpLVREF_AV;
13693         goto settarg;
13694     case OP_PADHV:
13695         o->op_private |= OPpLVREF_HV;
13696         /* FALLTHROUGH */
13697     case OP_PADSV:
13698       settarg:
13699         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13700         o->op_targ = varop->op_targ;
13701         varop->op_targ = 0;
13702         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13703         break;
13704
13705     case OP_RV2AV:
13706         o->op_private |= OPpLVREF_AV;
13707         goto checkgv;
13708         NOT_REACHED; /* NOTREACHED */
13709     case OP_RV2HV:
13710         o->op_private |= OPpLVREF_HV;
13711         /* FALLTHROUGH */
13712     case OP_RV2SV:
13713       checkgv:
13714         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13715         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13716       detach_and_stack:
13717         /* Point varop to its GV kid, detached.  */
13718         varop = op_sibling_splice(varop, NULL, -1, NULL);
13719         stacked = TRUE;
13720         break;
13721     case OP_RV2CV: {
13722         OP * const kidparent =
13723             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13724         OP * const kid = cUNOPx(kidparent)->op_first;
13725         o->op_private |= OPpLVREF_CV;
13726         if (kid->op_type == OP_GV) {
13727             SV *sv = (SV*)cGVOPx_gv(kid);
13728             varop = kidparent;
13729             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13730                 /* a CVREF here confuses pp_refassign, so make sure
13731                    it gets a GV */
13732                 CV *const cv = (CV*)SvRV(sv);
13733                 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13734                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13735                 assert(SvTYPE(sv) == SVt_PVGV);
13736             }
13737             goto detach_and_stack;
13738         }
13739         if (kid->op_type != OP_PADCV)   goto bad;
13740         o->op_targ = kid->op_targ;
13741         kid->op_targ = 0;
13742         break;
13743     }
13744     case OP_AELEM:
13745     case OP_HELEM:
13746         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13747         o->op_private |= OPpLVREF_ELEM;
13748         op_null(varop);
13749         stacked = TRUE;
13750         /* Detach varop.  */
13751         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13752         break;
13753     default:
13754       bad:
13755         /* diag_listed_as: Can't modify reference to %s in %s assignment */
13756         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13757                                 "assignment",
13758                                  OP_DESC(varop)));
13759         return o;
13760     }
13761     if (!FEATURE_REFALIASING_IS_ENABLED)
13762         Perl_croak(aTHX_
13763                   "Experimental aliasing via reference not enabled");
13764     Perl_ck_warner_d(aTHX_
13765                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
13766                     "Aliasing via reference is experimental");
13767     if (stacked) {
13768         o->op_flags |= OPf_STACKED;
13769         op_sibling_splice(o, right, 1, varop);
13770     }
13771     else {
13772         o->op_flags &=~ OPf_STACKED;
13773         op_sibling_splice(o, right, 1, NULL);
13774     }
13775     op_free(left);
13776     return o;
13777 }
13778
13779 OP *
13780 Perl_ck_repeat(pTHX_ OP *o)
13781 {
13782     PERL_ARGS_ASSERT_CK_REPEAT;
13783
13784     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13785         OP* kids;
13786         o->op_private |= OPpREPEAT_DOLIST;
13787         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13788         kids = force_list(kids, 1); /* promote it to a list */
13789         op_sibling_splice(o, NULL, 0, kids); /* and add back */
13790     }
13791     else
13792         scalar(o);
13793     return o;
13794 }
13795
13796 OP *
13797 Perl_ck_require(pTHX_ OP *o)
13798 {
13799     GV* gv;
13800
13801     PERL_ARGS_ASSERT_CK_REQUIRE;
13802
13803     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
13804         SVOP * const kid = (SVOP*)cUNOPo->op_first;
13805         U32 hash;
13806         char *s;
13807         STRLEN len;
13808         if (kid->op_type == OP_CONST) {
13809           SV * const sv = kid->op_sv;
13810           U32 const was_readonly = SvREADONLY(sv);
13811           if (kid->op_private & OPpCONST_BARE) {
13812             dVAR;
13813             const char *end;
13814             HEK *hek;
13815
13816             if (was_readonly) {
13817                 SvREADONLY_off(sv);
13818             }
13819
13820             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13821
13822             s = SvPVX(sv);
13823             len = SvCUR(sv);
13824             end = s + len;
13825             /* treat ::foo::bar as foo::bar */
13826             if (len >= 2 && s[0] == ':' && s[1] == ':')
13827                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13828             if (s == end)
13829                 DIE(aTHX_ "Bareword in require maps to empty filename");
13830
13831             for (; s < end; s++) {
13832                 if (*s == ':' && s[1] == ':') {
13833                     *s = '/';
13834                     Move(s+2, s+1, end - s - 1, char);
13835                     --end;
13836                 }
13837             }
13838             SvEND_set(sv, end);
13839             sv_catpvs(sv, ".pm");
13840             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13841             hek = share_hek(SvPVX(sv),
13842                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13843                             hash);
13844             sv_sethek(sv, hek);
13845             unshare_hek(hek);
13846             SvFLAGS(sv) |= was_readonly;
13847           }
13848           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13849                 && !SvVOK(sv)) {
13850             s = SvPV(sv, len);
13851             if (SvREFCNT(sv) > 1) {
13852                 kid->op_sv = newSVpvn_share(
13853                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13854                 SvREFCNT_dec_NN(sv);
13855             }
13856             else {
13857                 dVAR;
13858                 HEK *hek;
13859                 if (was_readonly) SvREADONLY_off(sv);
13860                 PERL_HASH(hash, s, len);
13861                 hek = share_hek(s,
13862                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13863                                 hash);
13864                 sv_sethek(sv, hek);
13865                 unshare_hek(hek);
13866                 SvFLAGS(sv) |= was_readonly;
13867             }
13868           }
13869         }
13870     }
13871
13872     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13873         /* handle override, if any */
13874      && (gv = gv_override("require", 7))) {
13875         OP *kid, *newop;
13876         if (o->op_flags & OPf_KIDS) {
13877             kid = cUNOPo->op_first;
13878             op_sibling_splice(o, NULL, -1, NULL);
13879         }
13880         else {
13881             kid = newDEFSVOP();
13882         }
13883         op_free(o);
13884         newop = S_new_entersubop(aTHX_ gv, kid);
13885         return newop;
13886     }
13887
13888     return ck_fun(o);
13889 }
13890
13891 OP *
13892 Perl_ck_return(pTHX_ OP *o)
13893 {
13894     OP *kid;
13895
13896     PERL_ARGS_ASSERT_CK_RETURN;
13897
13898     kid = OpSIBLING(cLISTOPo->op_first);
13899     if (PL_compcv && CvLVALUE(PL_compcv)) {
13900         for (; kid; kid = OpSIBLING(kid))
13901             op_lvalue(kid, OP_LEAVESUBLV);
13902     }
13903
13904     return o;
13905 }
13906
13907 OP *
13908 Perl_ck_select(pTHX_ OP *o)
13909 {
13910     dVAR;
13911     OP* kid;
13912
13913     PERL_ARGS_ASSERT_CK_SELECT;
13914
13915     if (o->op_flags & OPf_KIDS) {
13916         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13917         if (kid && OpHAS_SIBLING(kid)) {
13918             OpTYPE_set(o, OP_SSELECT);
13919             o = ck_fun(o);
13920             return fold_constants(op_integerize(op_std_init(o)));
13921         }
13922     }
13923     o = ck_fun(o);
13924     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13925     if (kid && kid->op_type == OP_RV2GV)
13926         kid->op_private &= ~HINT_STRICT_REFS;
13927     return o;
13928 }
13929
13930 OP *
13931 Perl_ck_shift(pTHX_ OP *o)
13932 {
13933     const I32 type = o->op_type;
13934
13935     PERL_ARGS_ASSERT_CK_SHIFT;
13936
13937     if (!(o->op_flags & OPf_KIDS)) {
13938         OP *argop;
13939
13940         if (!CvUNIQUE(PL_compcv)) {
13941             o->op_flags |= OPf_SPECIAL;
13942             return o;
13943         }
13944
13945         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13946         op_free(o);
13947         return newUNOP(type, 0, scalar(argop));
13948     }
13949     return scalar(ck_fun(o));
13950 }
13951
13952 OP *
13953 Perl_ck_sort(pTHX_ OP *o)
13954 {
13955     OP *firstkid;
13956     OP *kid;
13957     HV * const hinthv =
13958         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13959     U8 stacked;
13960
13961     PERL_ARGS_ASSERT_CK_SORT;
13962
13963     if (hinthv) {
13964             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13965             if (svp) {
13966                 const I32 sorthints = (I32)SvIV(*svp);
13967                 if ((sorthints & HINT_SORT_STABLE) != 0)
13968                     o->op_private |= OPpSORT_STABLE;
13969                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13970                     o->op_private |= OPpSORT_UNSTABLE;
13971             }
13972     }
13973
13974     if (o->op_flags & OPf_STACKED)
13975         simplify_sort(o);
13976     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
13977
13978     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
13979         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
13980
13981         /* if the first arg is a code block, process it and mark sort as
13982          * OPf_SPECIAL */
13983         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13984             LINKLIST(kid);
13985             if (kid->op_type == OP_LEAVE)
13986                     op_null(kid);                       /* wipe out leave */
13987             /* Prevent execution from escaping out of the sort block. */
13988             kid->op_next = 0;
13989
13990             /* provide scalar context for comparison function/block */
13991             kid = scalar(firstkid);
13992             kid->op_next = kid;
13993             o->op_flags |= OPf_SPECIAL;
13994         }
13995         else if (kid->op_type == OP_CONST
13996               && kid->op_private & OPpCONST_BARE) {
13997             char tmpbuf[256];
13998             STRLEN len;
13999             PADOFFSET off;
14000             const char * const name = SvPV(kSVOP_sv, len);
14001             *tmpbuf = '&';
14002             assert (len < 256);
14003             Copy(name, tmpbuf+1, len, char);
14004             off = pad_findmy_pvn(tmpbuf, len+1, 0);
14005             if (off != NOT_IN_PAD) {
14006                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14007                     SV * const fq =
14008                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14009                     sv_catpvs(fq, "::");
14010                     sv_catsv(fq, kSVOP_sv);
14011                     SvREFCNT_dec_NN(kSVOP_sv);
14012                     kSVOP->op_sv = fq;
14013                 }
14014                 else {
14015                     OP * const padop = newOP(OP_PADCV, 0);
14016                     padop->op_targ = off;
14017                     /* replace the const op with the pad op */
14018                     op_sibling_splice(firstkid, NULL, 1, padop);
14019                     op_free(kid);
14020                 }
14021             }
14022         }
14023
14024         firstkid = OpSIBLING(firstkid);
14025     }
14026
14027     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14028         /* provide list context for arguments */
14029         list(kid);
14030         if (stacked)
14031             op_lvalue(kid, OP_GREPSTART);
14032     }
14033
14034     return o;
14035 }
14036
14037 /* for sort { X } ..., where X is one of
14038  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14039  * elide the second child of the sort (the one containing X),
14040  * and set these flags as appropriate
14041         OPpSORT_NUMERIC;
14042         OPpSORT_INTEGER;
14043         OPpSORT_DESCEND;
14044  * Also, check and warn on lexical $a, $b.
14045  */
14046
14047 STATIC void
14048 S_simplify_sort(pTHX_ OP *o)
14049 {
14050     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
14051     OP *k;
14052     int descending;
14053     GV *gv;
14054     const char *gvname;
14055     bool have_scopeop;
14056
14057     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14058
14059     kid = kUNOP->op_first;                              /* get past null */
14060     if (!(have_scopeop = kid->op_type == OP_SCOPE)
14061      && kid->op_type != OP_LEAVE)
14062         return;
14063     kid = kLISTOP->op_last;                             /* get past scope */
14064     switch(kid->op_type) {
14065         case OP_NCMP:
14066         case OP_I_NCMP:
14067         case OP_SCMP:
14068             if (!have_scopeop) goto padkids;
14069             break;
14070         default:
14071             return;
14072     }
14073     k = kid;                                            /* remember this node*/
14074     if (kBINOP->op_first->op_type != OP_RV2SV
14075      || kBINOP->op_last ->op_type != OP_RV2SV)
14076     {
14077         /*
14078            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14079            then used in a comparison.  This catches most, but not
14080            all cases.  For instance, it catches
14081                sort { my($a); $a <=> $b }
14082            but not
14083                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14084            (although why you'd do that is anyone's guess).
14085         */
14086
14087        padkids:
14088         if (!ckWARN(WARN_SYNTAX)) return;
14089         kid = kBINOP->op_first;
14090         do {
14091             if (kid->op_type == OP_PADSV) {
14092                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14093                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14094                  && (  PadnamePV(name)[1] == 'a'
14095                     || PadnamePV(name)[1] == 'b'  ))
14096                     /* diag_listed_as: "my %s" used in sort comparison */
14097                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14098                                      "\"%s %s\" used in sort comparison",
14099                                       PadnameIsSTATE(name)
14100                                         ? "state"
14101                                         : "my",
14102                                       PadnamePV(name));
14103             }
14104         } while ((kid = OpSIBLING(kid)));
14105         return;
14106     }
14107     kid = kBINOP->op_first;                             /* get past cmp */
14108     if (kUNOP->op_first->op_type != OP_GV)
14109         return;
14110     kid = kUNOP->op_first;                              /* get past rv2sv */
14111     gv = kGVOP_gv;
14112     if (GvSTASH(gv) != PL_curstash)
14113         return;
14114     gvname = GvNAME(gv);
14115     if (*gvname == 'a' && gvname[1] == '\0')
14116         descending = 0;
14117     else if (*gvname == 'b' && gvname[1] == '\0')
14118         descending = 1;
14119     else
14120         return;
14121
14122     kid = k;                                            /* back to cmp */
14123     /* already checked above that it is rv2sv */
14124     kid = kBINOP->op_last;                              /* down to 2nd arg */
14125     if (kUNOP->op_first->op_type != OP_GV)
14126         return;
14127     kid = kUNOP->op_first;                              /* get past rv2sv */
14128     gv = kGVOP_gv;
14129     if (GvSTASH(gv) != PL_curstash)
14130         return;
14131     gvname = GvNAME(gv);
14132     if ( descending
14133          ? !(*gvname == 'a' && gvname[1] == '\0')
14134          : !(*gvname == 'b' && gvname[1] == '\0'))
14135         return;
14136     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14137     if (descending)
14138         o->op_private |= OPpSORT_DESCEND;
14139     if (k->op_type == OP_NCMP)
14140         o->op_private |= OPpSORT_NUMERIC;
14141     if (k->op_type == OP_I_NCMP)
14142         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14143     kid = OpSIBLING(cLISTOPo->op_first);
14144     /* cut out and delete old block (second sibling) */
14145     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14146     op_free(kid);
14147 }
14148
14149 OP *
14150 Perl_ck_split(pTHX_ OP *o)
14151 {
14152     dVAR;
14153     OP *kid;
14154     OP *sibs;
14155
14156     PERL_ARGS_ASSERT_CK_SPLIT;
14157
14158     assert(o->op_type == OP_LIST);
14159
14160     if (o->op_flags & OPf_STACKED)
14161         return no_fh_allowed(o);
14162
14163     kid = cLISTOPo->op_first;
14164     /* delete leading NULL node, then add a CONST if no other nodes */
14165     assert(kid->op_type == OP_NULL);
14166     op_sibling_splice(o, NULL, 1,
14167         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14168     op_free(kid);
14169     kid = cLISTOPo->op_first;
14170
14171     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14172         /* remove match expression, and replace with new optree with
14173          * a match op at its head */
14174         op_sibling_splice(o, NULL, 1, NULL);
14175         /* pmruntime will handle split " " behavior with flag==2 */
14176         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14177         op_sibling_splice(o, NULL, 0, kid);
14178     }
14179
14180     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14181
14182     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14183       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14184                      "Use of /g modifier is meaningless in split");
14185     }
14186
14187     /* eliminate the split op, and move the match op (plus any children)
14188      * into its place, then convert the match op into a split op. i.e.
14189      *
14190      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
14191      *    |                        |                     |
14192      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
14193      *    |                        |                     |
14194      *    R                        X - Y                 X - Y
14195      *    |
14196      *    X - Y
14197      *
14198      * (R, if it exists, will be a regcomp op)
14199      */
14200
14201     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14202     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14203     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14204     OpTYPE_set(kid, OP_SPLIT);
14205     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
14206     kid->op_private = o->op_private;
14207     op_free(o);
14208     o = kid;
14209     kid = sibs; /* kid is now the string arg of the split */
14210
14211     if (!kid) {
14212         kid = newDEFSVOP();
14213         op_append_elem(OP_SPLIT, o, kid);
14214     }
14215     scalar(kid);
14216
14217     kid = OpSIBLING(kid);
14218     if (!kid) {
14219         kid = newSVOP(OP_CONST, 0, newSViv(0));
14220         op_append_elem(OP_SPLIT, o, kid);
14221         o->op_private |= OPpSPLIT_IMPLIM;
14222     }
14223     scalar(kid);
14224
14225     if (OpHAS_SIBLING(kid))
14226         return too_many_arguments_pv(o,OP_DESC(o), 0);
14227
14228     return o;
14229 }
14230
14231 OP *
14232 Perl_ck_stringify(pTHX_ OP *o)
14233 {
14234     OP * const kid = OpSIBLING(cUNOPo->op_first);
14235     PERL_ARGS_ASSERT_CK_STRINGIFY;
14236     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14237          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
14238          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
14239         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14240     {
14241         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14242         op_free(o);
14243         return kid;
14244     }
14245     return ck_fun(o);
14246 }
14247
14248 OP *
14249 Perl_ck_join(pTHX_ OP *o)
14250 {
14251     OP * const kid = OpSIBLING(cLISTOPo->op_first);
14252
14253     PERL_ARGS_ASSERT_CK_JOIN;
14254
14255     if (kid && kid->op_type == OP_MATCH) {
14256         if (ckWARN(WARN_SYNTAX)) {
14257             const REGEXP *re = PM_GETRE(kPMOP);
14258             const SV *msg = re
14259                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14260                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14261                     : newSVpvs_flags( "STRING", SVs_TEMP );
14262             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14263                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
14264                         SVfARG(msg), SVfARG(msg));
14265         }
14266     }
14267     if (kid
14268      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14269         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14270         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14271            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14272     {
14273         const OP * const bairn = OpSIBLING(kid); /* the list */
14274         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14275          && OP_GIMME(bairn,0) == G_SCALAR)
14276         {
14277             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14278                                      op_sibling_splice(o, kid, 1, NULL));
14279             op_free(o);
14280             return ret;
14281         }
14282     }
14283
14284     return ck_fun(o);
14285 }
14286
14287 /*
14288 =for apidoc rv2cv_op_cv
14289
14290 Examines an op, which is expected to identify a subroutine at runtime,
14291 and attempts to determine at compile time which subroutine it identifies.
14292 This is normally used during Perl compilation to determine whether
14293 a prototype can be applied to a function call.  C<cvop> is the op
14294 being considered, normally an C<rv2cv> op.  A pointer to the identified
14295 subroutine is returned, if it could be determined statically, and a null
14296 pointer is returned if it was not possible to determine statically.
14297
14298 Currently, the subroutine can be identified statically if the RV that the
14299 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14300 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
14301 suitable if the constant value must be an RV pointing to a CV.  Details of
14302 this process may change in future versions of Perl.  If the C<rv2cv> op
14303 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14304 the subroutine statically: this flag is used to suppress compile-time
14305 magic on a subroutine call, forcing it to use default runtime behaviour.
14306
14307 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14308 of a GV reference is modified.  If a GV was examined and its CV slot was
14309 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14310 If the op is not optimised away, and the CV slot is later populated with
14311 a subroutine having a prototype, that flag eventually triggers the warning
14312 "called too early to check prototype".
14313
14314 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14315 of returning a pointer to the subroutine it returns a pointer to the
14316 GV giving the most appropriate name for the subroutine in this context.
14317 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14318 (C<CvANON>) subroutine that is referenced through a GV it will be the
14319 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
14320 A null pointer is returned as usual if there is no statically-determinable
14321 subroutine.
14322
14323 =for apidoc Amnh||OPpEARLY_CV
14324 =for apidoc Amnh||OPpENTERSUB_AMPER
14325 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14326 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14327
14328 =cut
14329 */
14330
14331 /* shared by toke.c:yylex */
14332 CV *
14333 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14334 {
14335     PADNAME *name = PAD_COMPNAME(off);
14336     CV *compcv = PL_compcv;
14337     while (PadnameOUTER(name)) {
14338         assert(PARENT_PAD_INDEX(name));
14339         compcv = CvOUTSIDE(compcv);
14340         name = PadlistNAMESARRAY(CvPADLIST(compcv))
14341                 [off = PARENT_PAD_INDEX(name)];
14342     }
14343     assert(!PadnameIsOUR(name));
14344     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14345         return PadnamePROTOCV(name);
14346     }
14347     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14348 }
14349
14350 CV *
14351 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14352 {
14353     OP *rvop;
14354     CV *cv;
14355     GV *gv;
14356     PERL_ARGS_ASSERT_RV2CV_OP_CV;
14357     if (flags & ~RV2CVOPCV_FLAG_MASK)
14358         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14359     if (cvop->op_type != OP_RV2CV)
14360         return NULL;
14361     if (cvop->op_private & OPpENTERSUB_AMPER)
14362         return NULL;
14363     if (!(cvop->op_flags & OPf_KIDS))
14364         return NULL;
14365     rvop = cUNOPx(cvop)->op_first;
14366     switch (rvop->op_type) {
14367         case OP_GV: {
14368             gv = cGVOPx_gv(rvop);
14369             if (!isGV(gv)) {
14370                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14371                     cv = MUTABLE_CV(SvRV(gv));
14372                     gv = NULL;
14373                     break;
14374                 }
14375                 if (flags & RV2CVOPCV_RETURN_STUB)
14376                     return (CV *)gv;
14377                 else return NULL;
14378             }
14379             cv = GvCVu(gv);
14380             if (!cv) {
14381                 if (flags & RV2CVOPCV_MARK_EARLY)
14382                     rvop->op_private |= OPpEARLY_CV;
14383                 return NULL;
14384             }
14385         } break;
14386         case OP_CONST: {
14387             SV *rv = cSVOPx_sv(rvop);
14388             if (!SvROK(rv))
14389                 return NULL;
14390             cv = (CV*)SvRV(rv);
14391             gv = NULL;
14392         } break;
14393         case OP_PADCV: {
14394             cv = find_lexical_cv(rvop->op_targ);
14395             gv = NULL;
14396         } break;
14397         default: {
14398             return NULL;
14399         } NOT_REACHED; /* NOTREACHED */
14400     }
14401     if (SvTYPE((SV*)cv) != SVt_PVCV)
14402         return NULL;
14403     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14404         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14405             gv = CvGV(cv);
14406         return (CV*)gv;
14407     }
14408     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14409         if (CvLEXICAL(cv) || CvNAMED(cv))
14410             return NULL;
14411         if (!CvANON(cv) || !gv)
14412             gv = CvGV(cv);
14413         return (CV*)gv;
14414
14415     } else {
14416         return cv;
14417     }
14418 }
14419
14420 /*
14421 =for apidoc ck_entersub_args_list
14422
14423 Performs the default fixup of the arguments part of an C<entersub>
14424 op tree.  This consists of applying list context to each of the
14425 argument ops.  This is the standard treatment used on a call marked
14426 with C<&>, or a method call, or a call through a subroutine reference,
14427 or any other call where the callee can't be identified at compile time,
14428 or a call where the callee has no prototype.
14429
14430 =cut
14431 */
14432
14433 OP *
14434 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14435 {
14436     OP *aop;
14437
14438     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14439
14440     aop = cUNOPx(entersubop)->op_first;
14441     if (!OpHAS_SIBLING(aop))
14442         aop = cUNOPx(aop)->op_first;
14443     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14444         /* skip the extra attributes->import() call implicitly added in
14445          * something like foo(my $x : bar)
14446          */
14447         if (   aop->op_type == OP_ENTERSUB
14448             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14449         )
14450             continue;
14451         list(aop);
14452         op_lvalue(aop, OP_ENTERSUB);
14453     }
14454     return entersubop;
14455 }
14456
14457 /*
14458 =for apidoc ck_entersub_args_proto
14459
14460 Performs the fixup of the arguments part of an C<entersub> op tree
14461 based on a subroutine prototype.  This makes various modifications to
14462 the argument ops, from applying context up to inserting C<refgen> ops,
14463 and checking the number and syntactic types of arguments, as directed by
14464 the prototype.  This is the standard treatment used on a subroutine call,
14465 not marked with C<&>, where the callee can be identified at compile time
14466 and has a prototype.
14467
14468 C<protosv> supplies the subroutine prototype to be applied to the call.
14469 It may be a normal defined scalar, of which the string value will be used.
14470 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14471 that has been cast to C<SV*>) which has a prototype.  The prototype
14472 supplied, in whichever form, does not need to match the actual callee
14473 referenced by the op tree.
14474
14475 If the argument ops disagree with the prototype, for example by having
14476 an unacceptable number of arguments, a valid op tree is returned anyway.
14477 The error is reflected in the parser state, normally resulting in a single
14478 exception at the top level of parsing which covers all the compilation
14479 errors that occurred.  In the error message, the callee is referred to
14480 by the name defined by the C<namegv> parameter.
14481
14482 =cut
14483 */
14484
14485 OP *
14486 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14487 {
14488     STRLEN proto_len;
14489     const char *proto, *proto_end;
14490     OP *aop, *prev, *cvop, *parent;
14491     int optional = 0;
14492     I32 arg = 0;
14493     I32 contextclass = 0;
14494     const char *e = NULL;
14495     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14496     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14497         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14498                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
14499     if (SvTYPE(protosv) == SVt_PVCV)
14500          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14501     else proto = SvPV(protosv, proto_len);
14502     proto = S_strip_spaces(aTHX_ proto, &proto_len);
14503     proto_end = proto + proto_len;
14504     parent = entersubop;
14505     aop = cUNOPx(entersubop)->op_first;
14506     if (!OpHAS_SIBLING(aop)) {
14507         parent = aop;
14508         aop = cUNOPx(aop)->op_first;
14509     }
14510     prev = aop;
14511     aop = OpSIBLING(aop);
14512     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14513     while (aop != cvop) {
14514         OP* o3 = aop;
14515
14516         if (proto >= proto_end)
14517         {
14518             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14519             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14520                                         SVfARG(namesv)), SvUTF8(namesv));
14521             return entersubop;
14522         }
14523
14524         switch (*proto) {
14525             case ';':
14526                 optional = 1;
14527                 proto++;
14528                 continue;
14529             case '_':
14530                 /* _ must be at the end */
14531                 if (proto[1] && !memCHRs(";@%", proto[1]))
14532                     goto oops;
14533                 /* FALLTHROUGH */
14534             case '$':
14535                 proto++;
14536                 arg++;
14537                 scalar(aop);
14538                 break;
14539             case '%':
14540             case '@':
14541                 list(aop);
14542                 arg++;
14543                 break;
14544             case '&':
14545                 proto++;
14546                 arg++;
14547                 if (    o3->op_type != OP_UNDEF
14548                     && (o3->op_type != OP_SREFGEN
14549                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14550                                 != OP_ANONCODE
14551                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14552                                 != OP_RV2CV)))
14553                     bad_type_gv(arg, namegv, o3,
14554                             arg == 1 ? "block or sub {}" : "sub {}");
14555                 break;
14556             case '*':
14557                 /* '*' allows any scalar type, including bareword */
14558                 proto++;
14559                 arg++;
14560                 if (o3->op_type == OP_RV2GV)
14561                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
14562                 else if (o3->op_type == OP_CONST)
14563                     o3->op_private &= ~OPpCONST_STRICT;
14564                 scalar(aop);
14565                 break;
14566             case '+':
14567                 proto++;
14568                 arg++;
14569                 if (o3->op_type == OP_RV2AV ||
14570                     o3->op_type == OP_PADAV ||
14571                     o3->op_type == OP_RV2HV ||
14572                     o3->op_type == OP_PADHV
14573                 ) {
14574                     goto wrapref;
14575                 }
14576                 scalar(aop);
14577                 break;
14578             case '[': case ']':
14579                 goto oops;
14580
14581             case '\\':
14582                 proto++;
14583                 arg++;
14584             again:
14585                 switch (*proto++) {
14586                     case '[':
14587                         if (contextclass++ == 0) {
14588                             e = (char *) memchr(proto, ']', proto_end - proto);
14589                             if (!e || e == proto)
14590                                 goto oops;
14591                         }
14592                         else
14593                             goto oops;
14594                         goto again;
14595
14596                     case ']':
14597                         if (contextclass) {
14598                             const char *p = proto;
14599                             const char *const end = proto;
14600                             contextclass = 0;
14601                             while (*--p != '[')
14602                                 /* \[$] accepts any scalar lvalue */
14603                                 if (*p == '$'
14604                                  && Perl_op_lvalue_flags(aTHX_
14605                                      scalar(o3),
14606                                      OP_READ, /* not entersub */
14607                                      OP_LVALUE_NO_CROAK
14608                                     )) goto wrapref;
14609                             bad_type_gv(arg, namegv, o3,
14610                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14611                         } else
14612                             goto oops;
14613                         break;
14614                     case '*':
14615                         if (o3->op_type == OP_RV2GV)
14616                             goto wrapref;
14617                         if (!contextclass)
14618                             bad_type_gv(arg, namegv, o3, "symbol");
14619                         break;
14620                     case '&':
14621                         if (o3->op_type == OP_ENTERSUB
14622                          && !(o3->op_flags & OPf_STACKED))
14623                             goto wrapref;
14624                         if (!contextclass)
14625                             bad_type_gv(arg, namegv, o3, "subroutine");
14626                         break;
14627                     case '$':
14628                         if (o3->op_type == OP_RV2SV ||
14629                                 o3->op_type == OP_PADSV ||
14630                                 o3->op_type == OP_HELEM ||
14631                                 o3->op_type == OP_AELEM)
14632                             goto wrapref;
14633                         if (!contextclass) {
14634                             /* \$ accepts any scalar lvalue */
14635                             if (Perl_op_lvalue_flags(aTHX_
14636                                     scalar(o3),
14637                                     OP_READ,  /* not entersub */
14638                                     OP_LVALUE_NO_CROAK
14639                                )) goto wrapref;
14640                             bad_type_gv(arg, namegv, o3, "scalar");
14641                         }
14642                         break;
14643                     case '@':
14644                         if (o3->op_type == OP_RV2AV ||
14645                                 o3->op_type == OP_PADAV)
14646                         {
14647                             o3->op_flags &=~ OPf_PARENS;
14648                             goto wrapref;
14649                         }
14650                         if (!contextclass)
14651                             bad_type_gv(arg, namegv, o3, "array");
14652                         break;
14653                     case '%':
14654                         if (o3->op_type == OP_RV2HV ||
14655                                 o3->op_type == OP_PADHV)
14656                         {
14657                             o3->op_flags &=~ OPf_PARENS;
14658                             goto wrapref;
14659                         }
14660                         if (!contextclass)
14661                             bad_type_gv(arg, namegv, o3, "hash");
14662                         break;
14663                     wrapref:
14664                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14665                                                 OP_REFGEN, 0);
14666                         if (contextclass && e) {
14667                             proto = e + 1;
14668                             contextclass = 0;
14669                         }
14670                         break;
14671                     default: goto oops;
14672                 }
14673                 if (contextclass)
14674                     goto again;
14675                 break;
14676             case ' ':
14677                 proto++;
14678                 continue;
14679             default:
14680             oops: {
14681                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14682                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
14683                                   SVfARG(protosv));
14684             }
14685         }
14686
14687         op_lvalue(aop, OP_ENTERSUB);
14688         prev = aop;
14689         aop = OpSIBLING(aop);
14690     }
14691     if (aop == cvop && *proto == '_') {
14692         /* generate an access to $_ */
14693         op_sibling_splice(parent, prev, 0, newDEFSVOP());
14694     }
14695     if (!optional && proto_end > proto &&
14696         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14697     {
14698         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14699         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14700                                     SVfARG(namesv)), SvUTF8(namesv));
14701     }
14702     return entersubop;
14703 }
14704
14705 /*
14706 =for apidoc ck_entersub_args_proto_or_list
14707
14708 Performs the fixup of the arguments part of an C<entersub> op tree either
14709 based on a subroutine prototype or using default list-context processing.
14710 This is the standard treatment used on a subroutine call, not marked
14711 with C<&>, where the callee can be identified at compile time.
14712
14713 C<protosv> supplies the subroutine prototype to be applied to the call,
14714 or indicates that there is no prototype.  It may be a normal scalar,
14715 in which case if it is defined then the string value will be used
14716 as a prototype, and if it is undefined then there is no prototype.
14717 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14718 that has been cast to C<SV*>), of which the prototype will be used if it
14719 has one.  The prototype (or lack thereof) supplied, in whichever form,
14720 does not need to match the actual callee referenced by the op tree.
14721
14722 If the argument ops disagree with the prototype, for example by having
14723 an unacceptable number of arguments, a valid op tree is returned anyway.
14724 The error is reflected in the parser state, normally resulting in a single
14725 exception at the top level of parsing which covers all the compilation
14726 errors that occurred.  In the error message, the callee is referred to
14727 by the name defined by the C<namegv> parameter.
14728
14729 =cut
14730 */
14731
14732 OP *
14733 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14734         GV *namegv, SV *protosv)
14735 {
14736     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14737     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14738         return ck_entersub_args_proto(entersubop, namegv, protosv);
14739     else
14740         return ck_entersub_args_list(entersubop);
14741 }
14742
14743 OP *
14744 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14745 {
14746     IV cvflags = SvIVX(protosv);
14747     int opnum = cvflags & 0xffff;
14748     OP *aop = cUNOPx(entersubop)->op_first;
14749
14750     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14751
14752     if (!opnum) {
14753         OP *cvop;
14754         if (!OpHAS_SIBLING(aop))
14755             aop = cUNOPx(aop)->op_first;
14756         aop = OpSIBLING(aop);
14757         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14758         if (aop != cvop) {
14759             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14760             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14761                 SVfARG(namesv)), SvUTF8(namesv));
14762         }
14763
14764         op_free(entersubop);
14765         switch(cvflags >> 16) {
14766         case 'F': return newSVOP(OP_CONST, 0,
14767                                         newSVpv(CopFILE(PL_curcop),0));
14768         case 'L': return newSVOP(
14769                            OP_CONST, 0,
14770                            Perl_newSVpvf(aTHX_
14771                              "%" IVdf, (IV)CopLINE(PL_curcop)
14772                            )
14773                          );
14774         case 'P': return newSVOP(OP_CONST, 0,
14775                                    (PL_curstash
14776                                      ? newSVhek(HvNAME_HEK(PL_curstash))
14777                                      : &PL_sv_undef
14778                                    )
14779                                 );
14780         }
14781         NOT_REACHED; /* NOTREACHED */
14782     }
14783     else {
14784         OP *prev, *cvop, *first, *parent;
14785         U32 flags = 0;
14786
14787         parent = entersubop;
14788         if (!OpHAS_SIBLING(aop)) {
14789             parent = aop;
14790             aop = cUNOPx(aop)->op_first;
14791         }
14792
14793         first = prev = aop;
14794         aop = OpSIBLING(aop);
14795         /* find last sibling */
14796         for (cvop = aop;
14797              OpHAS_SIBLING(cvop);
14798              prev = cvop, cvop = OpSIBLING(cvop))
14799             ;
14800         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14801             /* Usually, OPf_SPECIAL on an op with no args means that it had
14802              * parens, but these have their own meaning for that flag: */
14803             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14804             && opnum != OP_DELETE && opnum != OP_EXISTS)
14805                 flags |= OPf_SPECIAL;
14806         /* excise cvop from end of sibling chain */
14807         op_sibling_splice(parent, prev, 1, NULL);
14808         op_free(cvop);
14809         if (aop == cvop) aop = NULL;
14810
14811         /* detach remaining siblings from the first sibling, then
14812          * dispose of original optree */
14813
14814         if (aop)
14815             op_sibling_splice(parent, first, -1, NULL);
14816         op_free(entersubop);
14817
14818         if (cvflags == (OP_ENTEREVAL | (1<<16)))
14819             flags |= OPpEVAL_BYTES <<8;
14820
14821         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14822         case OA_UNOP:
14823         case OA_BASEOP_OR_UNOP:
14824         case OA_FILESTATOP:
14825             if (!aop)
14826                 return newOP(opnum,flags);       /* zero args */
14827             if (aop == prev)
14828                 return newUNOP(opnum,flags,aop); /* one arg */
14829             /* too many args */
14830             /* FALLTHROUGH */
14831         case OA_BASEOP:
14832             if (aop) {
14833                 SV *namesv;
14834                 OP *nextop;
14835
14836                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14837                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14838                     SVfARG(namesv)), SvUTF8(namesv));
14839                 while (aop) {
14840                     nextop = OpSIBLING(aop);
14841                     op_free(aop);
14842                     aop = nextop;
14843                 }
14844
14845             }
14846             return opnum == OP_RUNCV
14847                 ? newPVOP(OP_RUNCV,0,NULL)
14848                 : newOP(opnum,0);
14849         default:
14850             return op_convert_list(opnum,0,aop);
14851         }
14852     }
14853     NOT_REACHED; /* NOTREACHED */
14854     return entersubop;
14855 }
14856
14857 /*
14858 =for apidoc cv_get_call_checker_flags
14859
14860 Retrieves the function that will be used to fix up a call to C<cv>.
14861 Specifically, the function is applied to an C<entersub> op tree for a
14862 subroutine call, not marked with C<&>, where the callee can be identified
14863 at compile time as C<cv>.
14864
14865 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14866 for it is returned in C<*ckobj_p>, and control flags are returned in
14867 C<*ckflags_p>.  The function is intended to be called in this manner:
14868
14869  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14870
14871 In this call, C<entersubop> is a pointer to the C<entersub> op,
14872 which may be replaced by the check function, and C<namegv> supplies
14873 the name that should be used by the check function to refer
14874 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14875 It is permitted to apply the check function in non-standard situations,
14876 such as to a call to a different subroutine or to a method call.
14877
14878 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
14879 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14880 instead, anything that can be used as the first argument to L</cv_name>.
14881 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14882 check function requires C<namegv> to be a genuine GV.
14883
14884 By default, the check function is
14885 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14886 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14887 flag is clear.  This implements standard prototype processing.  It can
14888 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14889
14890 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14891 indicates that the caller only knows about the genuine GV version of
14892 C<namegv>, and accordingly the corresponding bit will always be set in
14893 C<*ckflags_p>, regardless of the check function's recorded requirements.
14894 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14895 indicates the caller knows about the possibility of passing something
14896 other than a GV as C<namegv>, and accordingly the corresponding bit may
14897 be either set or clear in C<*ckflags_p>, indicating the check function's
14898 recorded requirements.
14899
14900 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14901 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14902 (for which see above).  All other bits should be clear.
14903
14904 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14905
14906 =for apidoc cv_get_call_checker
14907
14908 The original form of L</cv_get_call_checker_flags>, which does not return
14909 checker flags.  When using a checker function returned by this function,
14910 it is only safe to call it with a genuine GV as its C<namegv> argument.
14911
14912 =cut
14913 */
14914
14915 void
14916 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14917         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14918 {
14919     MAGIC *callmg;
14920     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14921     PERL_UNUSED_CONTEXT;
14922     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14923     if (callmg) {
14924         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14925         *ckobj_p = callmg->mg_obj;
14926         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14927     } else {
14928         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14929         *ckobj_p = (SV*)cv;
14930         *ckflags_p = gflags & MGf_REQUIRE_GV;
14931     }
14932 }
14933
14934 void
14935 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14936 {
14937     U32 ckflags;
14938     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14939     PERL_UNUSED_CONTEXT;
14940     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14941         &ckflags);
14942 }
14943
14944 /*
14945 =for apidoc cv_set_call_checker_flags
14946
14947 Sets the function that will be used to fix up a call to C<cv>.
14948 Specifically, the function is applied to an C<entersub> op tree for a
14949 subroutine call, not marked with C<&>, where the callee can be identified
14950 at compile time as C<cv>.
14951
14952 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14953 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14954 The function should be defined like this:
14955
14956     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14957
14958 It is intended to be called in this manner:
14959
14960     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14961
14962 In this call, C<entersubop> is a pointer to the C<entersub> op,
14963 which may be replaced by the check function, and C<namegv> supplies
14964 the name that should be used by the check function to refer
14965 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14966 It is permitted to apply the check function in non-standard situations,
14967 such as to a call to a different subroutine or to a method call.
14968
14969 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14970 CV or other SV instead.  Whatever is passed can be used as the first
14971 argument to L</cv_name>.  You can force perl to pass a GV by including
14972 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14973
14974 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14975 bit currently has a defined meaning (for which see above).  All other
14976 bits should be clear.
14977
14978 The current setting for a particular CV can be retrieved by
14979 L</cv_get_call_checker_flags>.
14980
14981 =for apidoc cv_set_call_checker
14982
14983 The original form of L</cv_set_call_checker_flags>, which passes it the
14984 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
14985 of that flag setting is that the check function is guaranteed to get a
14986 genuine GV as its C<namegv> argument.
14987
14988 =cut
14989 */
14990
14991 void
14992 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14993 {
14994     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14995     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14996 }
14997
14998 void
14999 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15000                                      SV *ckobj, U32 ckflags)
15001 {
15002     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15003     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15004         if (SvMAGICAL((SV*)cv))
15005             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15006     } else {
15007         MAGIC *callmg;
15008         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15009         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15010         assert(callmg);
15011         if (callmg->mg_flags & MGf_REFCOUNTED) {
15012             SvREFCNT_dec(callmg->mg_obj);
15013             callmg->mg_flags &= ~MGf_REFCOUNTED;
15014         }
15015         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15016         callmg->mg_obj = ckobj;
15017         if (ckobj != (SV*)cv) {
15018             SvREFCNT_inc_simple_void_NN(ckobj);
15019             callmg->mg_flags |= MGf_REFCOUNTED;
15020         }
15021         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15022                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15023     }
15024 }
15025
15026 static void
15027 S_entersub_alloc_targ(pTHX_ OP * const o)
15028 {
15029     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15030     o->op_private |= OPpENTERSUB_HASTARG;
15031 }
15032
15033 OP *
15034 Perl_ck_subr(pTHX_ OP *o)
15035 {
15036     OP *aop, *cvop;
15037     CV *cv;
15038     GV *namegv;
15039     SV **const_class = NULL;
15040
15041     PERL_ARGS_ASSERT_CK_SUBR;
15042
15043     aop = cUNOPx(o)->op_first;
15044     if (!OpHAS_SIBLING(aop))
15045         aop = cUNOPx(aop)->op_first;
15046     aop = OpSIBLING(aop);
15047     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15048     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15049     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15050
15051     o->op_private &= ~1;
15052     o->op_private |= (PL_hints & HINT_STRICT_REFS);
15053     if (PERLDB_SUB && PL_curstash != PL_debstash)
15054         o->op_private |= OPpENTERSUB_DB;
15055     switch (cvop->op_type) {
15056         case OP_RV2CV:
15057             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15058             op_null(cvop);
15059             break;
15060         case OP_METHOD:
15061         case OP_METHOD_NAMED:
15062         case OP_METHOD_SUPER:
15063         case OP_METHOD_REDIR:
15064         case OP_METHOD_REDIR_SUPER:
15065             o->op_flags |= OPf_REF;
15066             if (aop->op_type == OP_CONST) {
15067                 aop->op_private &= ~OPpCONST_STRICT;
15068                 const_class = &cSVOPx(aop)->op_sv;
15069             }
15070             else if (aop->op_type == OP_LIST) {
15071                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15072                 if (sib && sib->op_type == OP_CONST) {
15073                     sib->op_private &= ~OPpCONST_STRICT;
15074                     const_class = &cSVOPx(sib)->op_sv;
15075                 }
15076             }
15077             /* make class name a shared cow string to speedup method calls */
15078             /* constant string might be replaced with object, f.e. bigint */
15079             if (const_class && SvPOK(*const_class)) {
15080                 STRLEN len;
15081                 const char* str = SvPV(*const_class, len);
15082                 if (len) {
15083                     SV* const shared = newSVpvn_share(
15084                         str, SvUTF8(*const_class)
15085                                     ? -(SSize_t)len : (SSize_t)len,
15086                         0
15087                     );
15088                     if (SvREADONLY(*const_class))
15089                         SvREADONLY_on(shared);
15090                     SvREFCNT_dec(*const_class);
15091                     *const_class = shared;
15092                 }
15093             }
15094             break;
15095     }
15096
15097     if (!cv) {
15098         S_entersub_alloc_targ(aTHX_ o);
15099         return ck_entersub_args_list(o);
15100     } else {
15101         Perl_call_checker ckfun;
15102         SV *ckobj;
15103         U32 ckflags;
15104         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15105         if (CvISXSUB(cv) || !CvROOT(cv))
15106             S_entersub_alloc_targ(aTHX_ o);
15107         if (!namegv) {
15108             /* The original call checker API guarantees that a GV will be
15109                be provided with the right name.  So, if the old API was
15110                used (or the REQUIRE_GV flag was passed), we have to reify
15111                the CV’s GV, unless this is an anonymous sub.  This is not
15112                ideal for lexical subs, as its stringification will include
15113                the package.  But it is the best we can do.  */
15114             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15115                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15116                     namegv = CvGV(cv);
15117             }
15118             else namegv = MUTABLE_GV(cv);
15119             /* After a syntax error in a lexical sub, the cv that
15120                rv2cv_op_cv returns may be a nameless stub. */
15121             if (!namegv) return ck_entersub_args_list(o);
15122
15123         }
15124         return ckfun(aTHX_ o, namegv, ckobj);
15125     }
15126 }
15127
15128 OP *
15129 Perl_ck_svconst(pTHX_ OP *o)
15130 {
15131     SV * const sv = cSVOPo->op_sv;
15132     PERL_ARGS_ASSERT_CK_SVCONST;
15133     PERL_UNUSED_CONTEXT;
15134 #ifdef PERL_COPY_ON_WRITE
15135     /* Since the read-only flag may be used to protect a string buffer, we
15136        cannot do copy-on-write with existing read-only scalars that are not
15137        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
15138        that constant, mark the constant as COWable here, if it is not
15139        already read-only. */
15140     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15141         SvIsCOW_on(sv);
15142         CowREFCNT(sv) = 0;
15143 # ifdef PERL_DEBUG_READONLY_COW
15144         sv_buf_to_ro(sv);
15145 # endif
15146     }
15147 #endif
15148     SvREADONLY_on(sv);
15149     return o;
15150 }
15151
15152 OP *
15153 Perl_ck_trunc(pTHX_ OP *o)
15154 {
15155     PERL_ARGS_ASSERT_CK_TRUNC;
15156
15157     if (o->op_flags & OPf_KIDS) {
15158         SVOP *kid = (SVOP*)cUNOPo->op_first;
15159
15160         if (kid->op_type == OP_NULL)
15161             kid = (SVOP*)OpSIBLING(kid);
15162         if (kid && kid->op_type == OP_CONST &&
15163             (kid->op_private & OPpCONST_BARE) &&
15164             !kid->op_folded)
15165         {
15166             o->op_flags |= OPf_SPECIAL;
15167             kid->op_private &= ~OPpCONST_STRICT;
15168         }
15169     }
15170     return ck_fun(o);
15171 }
15172
15173 OP *
15174 Perl_ck_substr(pTHX_ OP *o)
15175 {
15176     PERL_ARGS_ASSERT_CK_SUBSTR;
15177
15178     o = ck_fun(o);
15179     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15180         OP *kid = cLISTOPo->op_first;
15181
15182         if (kid->op_type == OP_NULL)
15183             kid = OpSIBLING(kid);
15184         if (kid)
15185             /* Historically, substr(delete $foo{bar},...) has been allowed
15186                with 4-arg substr.  Keep it working by applying entersub
15187                lvalue context.  */
15188             op_lvalue(kid, OP_ENTERSUB);
15189
15190     }
15191     return o;
15192 }
15193
15194 OP *
15195 Perl_ck_tell(pTHX_ OP *o)
15196 {
15197     PERL_ARGS_ASSERT_CK_TELL;
15198     o = ck_fun(o);
15199     if (o->op_flags & OPf_KIDS) {
15200      OP *kid = cLISTOPo->op_first;
15201      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15202      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15203     }
15204     return o;
15205 }
15206
15207 OP *
15208 Perl_ck_each(pTHX_ OP *o)
15209 {
15210     dVAR;
15211     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15212     const unsigned orig_type  = o->op_type;
15213
15214     PERL_ARGS_ASSERT_CK_EACH;
15215
15216     if (kid) {
15217         switch (kid->op_type) {
15218             case OP_PADHV:
15219             case OP_RV2HV:
15220                 break;
15221             case OP_PADAV:
15222             case OP_RV2AV:
15223                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15224                             : orig_type == OP_KEYS ? OP_AKEYS
15225                             :                        OP_AVALUES);
15226                 break;
15227             case OP_CONST:
15228                 if (kid->op_private == OPpCONST_BARE
15229                  || !SvROK(cSVOPx_sv(kid))
15230                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15231                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
15232                    )
15233                     goto bad;
15234                 /* FALLTHROUGH */
15235             default:
15236                 qerror(Perl_mess(aTHX_
15237                     "Experimental %s on scalar is now forbidden",
15238                      PL_op_desc[orig_type]));
15239                bad:
15240                 bad_type_pv(1, "hash or array", o, kid);
15241                 return o;
15242         }
15243     }
15244     return ck_fun(o);
15245 }
15246
15247 OP *
15248 Perl_ck_length(pTHX_ OP *o)
15249 {
15250     PERL_ARGS_ASSERT_CK_LENGTH;
15251
15252     o = ck_fun(o);
15253
15254     if (ckWARN(WARN_SYNTAX)) {
15255         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15256
15257         if (kid) {
15258             SV *name = NULL;
15259             const bool hash = kid->op_type == OP_PADHV
15260                            || kid->op_type == OP_RV2HV;
15261             switch (kid->op_type) {
15262                 case OP_PADHV:
15263                 case OP_PADAV:
15264                 case OP_RV2HV:
15265                 case OP_RV2AV:
15266                     name = S_op_varname(aTHX_ kid);
15267                     break;
15268                 default:
15269                     return o;
15270             }
15271             if (name)
15272                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15273                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15274                     ")\"?)",
15275                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
15276                 );
15277             else if (hash)
15278      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15279                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15280                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15281             else
15282      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15283                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15284                     "length() used on @array (did you mean \"scalar(@array)\"?)");
15285         }
15286     }
15287
15288     return o;
15289 }
15290
15291
15292 OP *
15293 Perl_ck_isa(pTHX_ OP *o)
15294 {
15295     OP *classop = cBINOPo->op_last;
15296
15297     PERL_ARGS_ASSERT_CK_ISA;
15298
15299     /* Convert barename into PV */
15300     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15301         /* TODO: Optionally convert package to raw HV here */
15302         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15303     }
15304
15305     return o;
15306 }
15307
15308
15309 /*
15310    ---------------------------------------------------------
15311
15312    Common vars in list assignment
15313
15314    There now follows some enums and static functions for detecting
15315    common variables in list assignments. Here is a little essay I wrote
15316    for myself when trying to get my head around this. DAPM.
15317
15318    ----
15319
15320    First some random observations:
15321
15322    * If a lexical var is an alias of something else, e.g.
15323        for my $x ($lex, $pkg, $a[0]) {...}
15324      then the act of aliasing will increase the reference count of the SV
15325
15326    * If a package var is an alias of something else, it may still have a
15327      reference count of 1, depending on how the alias was created, e.g.
15328      in *a = *b, $a may have a refcount of 1 since the GP is shared
15329      with a single GvSV pointer to the SV. So If it's an alias of another
15330      package var, then RC may be 1; if it's an alias of another scalar, e.g.
15331      a lexical var or an array element, then it will have RC > 1.
15332
15333    * There are many ways to create a package alias; ultimately, XS code
15334      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15335      run-time tracing mechanisms are unlikely to be able to catch all cases.
15336
15337    * When the LHS is all my declarations, the same vars can't appear directly
15338      on the RHS, but they can indirectly via closures, aliasing and lvalue
15339      subs. But those techniques all involve an increase in the lexical
15340      scalar's ref count.
15341
15342    * When the LHS is all lexical vars (but not necessarily my declarations),
15343      it is possible for the same lexicals to appear directly on the RHS, and
15344      without an increased ref count, since the stack isn't refcounted.
15345      This case can be detected at compile time by scanning for common lex
15346      vars with PL_generation.
15347
15348    * lvalue subs defeat common var detection, but they do at least
15349      return vars with a temporary ref count increment. Also, you can't
15350      tell at compile time whether a sub call is lvalue.
15351
15352
15353    So...
15354
15355    A: There are a few circumstances where there definitely can't be any
15356      commonality:
15357
15358        LHS empty:  () = (...);
15359        RHS empty:  (....) = ();
15360        RHS contains only constants or other 'can't possibly be shared'
15361            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
15362            i.e. they only contain ops not marked as dangerous, whose children
15363            are also not dangerous;
15364        LHS ditto;
15365        LHS contains a single scalar element: e.g. ($x) = (....); because
15366            after $x has been modified, it won't be used again on the RHS;
15367        RHS contains a single element with no aggregate on LHS: e.g.
15368            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
15369            won't be used again.
15370
15371    B: If LHS are all 'my' lexical var declarations (or safe ops, which
15372      we can ignore):
15373
15374        my ($a, $b, @c) = ...;
15375
15376        Due to closure and goto tricks, these vars may already have content.
15377        For the same reason, an element on the RHS may be a lexical or package
15378        alias of one of the vars on the left, or share common elements, for
15379        example:
15380
15381            my ($x,$y) = f(); # $x and $y on both sides
15382            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15383
15384        and
15385
15386            my $ra = f();
15387            my @a = @$ra;  # elements of @a on both sides
15388            sub f { @a = 1..4; \@a }
15389
15390
15391        First, just consider scalar vars on LHS:
15392
15393            RHS is safe only if (A), or in addition,
15394                * contains only lexical *scalar* vars, where neither side's
15395                  lexicals have been flagged as aliases
15396
15397            If RHS is not safe, then it's always legal to check LHS vars for
15398            RC==1, since the only RHS aliases will always be associated
15399            with an RC bump.
15400
15401            Note that in particular, RHS is not safe if:
15402
15403                * it contains package scalar vars; e.g.:
15404
15405                    f();
15406                    my ($x, $y) = (2, $x_alias);
15407                    sub f { $x = 1; *x_alias = \$x; }
15408
15409                * It contains other general elements, such as flattened or
15410                * spliced or single array or hash elements, e.g.
15411
15412                    f();
15413                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15414
15415                    sub f {
15416                        ($x, $y) = (1,2);
15417                        use feature 'refaliasing';
15418                        \($a[0], $a[1]) = \($y,$x);
15419                    }
15420
15421                  It doesn't matter if the array/hash is lexical or package.
15422
15423                * it contains a function call that happens to be an lvalue
15424                  sub which returns one or more of the above, e.g.
15425
15426                    f();
15427                    my ($x,$y) = f();
15428
15429                    sub f : lvalue {
15430                        ($x, $y) = (1,2);
15431                        *x1 = \$x;
15432                        $y, $x1;
15433                    }
15434
15435                    (so a sub call on the RHS should be treated the same
15436                    as having a package var on the RHS).
15437
15438                * any other "dangerous" thing, such an op or built-in that
15439                  returns one of the above, e.g. pp_preinc
15440
15441
15442            If RHS is not safe, what we can do however is at compile time flag
15443            that the LHS are all my declarations, and at run time check whether
15444            all the LHS have RC == 1, and if so skip the full scan.
15445
15446        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15447
15448            Here the issue is whether there can be elements of @a on the RHS
15449            which will get prematurely freed when @a is cleared prior to
15450            assignment. This is only a problem if the aliasing mechanism
15451            is one which doesn't increase the refcount - only if RC == 1
15452            will the RHS element be prematurely freed.
15453
15454            Because the array/hash is being INTROed, it or its elements
15455            can't directly appear on the RHS:
15456
15457                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15458
15459            but can indirectly, e.g.:
15460
15461                my $r = f();
15462                my (@a) = @$r;
15463                sub f { @a = 1..3; \@a }
15464
15465            So if the RHS isn't safe as defined by (A), we must always
15466            mortalise and bump the ref count of any remaining RHS elements
15467            when assigning to a non-empty LHS aggregate.
15468
15469            Lexical scalars on the RHS aren't safe if they've been involved in
15470            aliasing, e.g.
15471
15472                use feature 'refaliasing';
15473
15474                f();
15475                \(my $lex) = \$pkg;
15476                my @a = ($lex,3); # equivalent to ($a[0],3)
15477
15478                sub f {
15479                    @a = (1,2);
15480                    \$pkg = \$a[0];
15481                }
15482
15483            Similarly with lexical arrays and hashes on the RHS:
15484
15485                f();
15486                my @b;
15487                my @a = (@b);
15488
15489                sub f {
15490                    @a = (1,2);
15491                    \$b[0] = \$a[1];
15492                    \$b[1] = \$a[0];
15493                }
15494
15495
15496
15497    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15498        my $a; ($a, my $b) = (....);
15499
15500        The difference between (B) and (C) is that it is now physically
15501        possible for the LHS vars to appear on the RHS too, where they
15502        are not reference counted; but in this case, the compile-time
15503        PL_generation sweep will detect such common vars.
15504
15505        So the rules for (C) differ from (B) in that if common vars are
15506        detected, the runtime "test RC==1" optimisation can no longer be used,
15507        and a full mark and sweep is required
15508
15509    D: As (C), but in addition the LHS may contain package vars.
15510
15511        Since package vars can be aliased without a corresponding refcount
15512        increase, all bets are off. It's only safe if (A). E.g.
15513
15514            my ($x, $y) = (1,2);
15515
15516            for $x_alias ($x) {
15517                ($x_alias, $y) = (3, $x); # whoops
15518            }
15519
15520        Ditto for LHS aggregate package vars.
15521
15522    E: Any other dangerous ops on LHS, e.g.
15523            (f(), $a[0], @$r) = (...);
15524
15525        this is similar to (E) in that all bets are off. In addition, it's
15526        impossible to determine at compile time whether the LHS
15527        contains a scalar or an aggregate, e.g.
15528
15529            sub f : lvalue { @a }
15530            (f()) = 1..3;
15531
15532 * ---------------------------------------------------------
15533 */
15534
15535
15536 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15537  * that at least one of the things flagged was seen.
15538  */
15539
15540 enum {
15541     AAS_MY_SCALAR       = 0x001, /* my $scalar */
15542     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
15543     AAS_LEX_SCALAR      = 0x004, /* $lexical */
15544     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
15545     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15546     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
15547     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
15548     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
15549                                          that's flagged OA_DANGEROUS */
15550     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
15551                                         not in any of the categories above */
15552     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
15553 };
15554
15555
15556
15557 /* helper function for S_aassign_scan().
15558  * check a PAD-related op for commonality and/or set its generation number.
15559  * Returns a boolean indicating whether its shared */
15560
15561 static bool
15562 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15563 {
15564     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15565         /* lexical used in aliasing */
15566         return TRUE;
15567
15568     if (rhs)
15569         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15570     else
15571         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15572
15573     return FALSE;
15574 }
15575
15576
15577 /*
15578   Helper function for OPpASSIGN_COMMON* detection in rpeep().
15579   It scans the left or right hand subtree of the aassign op, and returns a
15580   set of flags indicating what sorts of things it found there.
15581   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15582   set PL_generation on lexical vars; if the latter, we see if
15583   PL_generation matches.
15584   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15585   This fn will increment it by the number seen. It's not intended to
15586   be an accurate count (especially as many ops can push a variable
15587   number of SVs onto the stack); rather it's used as to test whether there
15588   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15589 */
15590
15591 static int
15592 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15593 {
15594     OP *top_op           = o;
15595     OP *effective_top_op = o;
15596     int all_flags = 0;
15597
15598     while (1) {
15599     bool top = o == effective_top_op;
15600     int flags = 0;
15601     OP* next_kid = NULL;
15602
15603     /* first, look for a solitary @_ on the RHS */
15604     if (   rhs
15605         && top
15606         && (o->op_flags & OPf_KIDS)
15607         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15608     ) {
15609         OP *kid = cUNOPo->op_first;
15610         if (   (   kid->op_type == OP_PUSHMARK
15611                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15612             && ((kid = OpSIBLING(kid)))
15613             && !OpHAS_SIBLING(kid)
15614             && kid->op_type == OP_RV2AV
15615             && !(kid->op_flags & OPf_REF)
15616             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15617             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15618             && ((kid = cUNOPx(kid)->op_first))
15619             && kid->op_type == OP_GV
15620             && cGVOPx_gv(kid) == PL_defgv
15621         )
15622             flags = AAS_DEFAV;
15623     }
15624
15625     switch (o->op_type) {
15626     case OP_GVSV:
15627         (*scalars_p)++;
15628         all_flags |= AAS_PKG_SCALAR;
15629         goto do_next;
15630
15631     case OP_PADAV:
15632     case OP_PADHV:
15633         (*scalars_p) += 2;
15634         /* if !top, could be e.g. @a[0,1] */
15635         all_flags |=  (top && (o->op_flags & OPf_REF))
15636                         ? ((o->op_private & OPpLVAL_INTRO)
15637                             ? AAS_MY_AGG : AAS_LEX_AGG)
15638                         : AAS_DANGEROUS;
15639         goto do_next;
15640
15641     case OP_PADSV:
15642         {
15643             int comm = S_aassign_padcheck(aTHX_ o, rhs)
15644                         ?  AAS_LEX_SCALAR_COMM : 0;
15645             (*scalars_p)++;
15646             all_flags |= (o->op_private & OPpLVAL_INTRO)
15647                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15648             goto do_next;
15649
15650         }
15651
15652     case OP_RV2AV:
15653     case OP_RV2HV:
15654         (*scalars_p) += 2;
15655         if (cUNOPx(o)->op_first->op_type != OP_GV)
15656             all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15657         /* @pkg, %pkg */
15658         /* if !top, could be e.g. @a[0,1] */
15659         else if (top && (o->op_flags & OPf_REF))
15660             all_flags |= AAS_PKG_AGG;
15661         else
15662             all_flags |= AAS_DANGEROUS;
15663         goto do_next;
15664
15665     case OP_RV2SV:
15666         (*scalars_p)++;
15667         if (cUNOPx(o)->op_first->op_type != OP_GV) {
15668             (*scalars_p) += 2;
15669             all_flags |= AAS_DANGEROUS; /* ${expr} */
15670         }
15671         else
15672             all_flags |= AAS_PKG_SCALAR; /* $pkg */
15673         goto do_next;
15674
15675     case OP_SPLIT:
15676         if (o->op_private & OPpSPLIT_ASSIGN) {
15677             /* the assign in @a = split() has been optimised away
15678              * and the @a attached directly to the split op
15679              * Treat the array as appearing on the RHS, i.e.
15680              *    ... = (@a = split)
15681              * is treated like
15682              *    ... = @a;
15683              */
15684
15685             if (o->op_flags & OPf_STACKED) {
15686                 /* @{expr} = split() - the array expression is tacked
15687                  * on as an extra child to split - process kid */
15688                 next_kid = cLISTOPo->op_last;
15689                 goto do_next;
15690             }
15691
15692             /* ... else array is directly attached to split op */
15693             (*scalars_p) += 2;
15694             all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15695                             ? ((o->op_private & OPpLVAL_INTRO)
15696                                 ? AAS_MY_AGG : AAS_LEX_AGG)
15697                             : AAS_PKG_AGG;
15698             goto do_next;
15699         }
15700         (*scalars_p)++;
15701         /* other args of split can't be returned */
15702         all_flags |= AAS_SAFE_SCALAR;
15703         goto do_next;
15704
15705     case OP_UNDEF:
15706         /* undef counts as a scalar on the RHS:
15707          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
15708          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
15709          */
15710         if (rhs)
15711             (*scalars_p)++;
15712         flags = AAS_SAFE_SCALAR;
15713         break;
15714
15715     case OP_PUSHMARK:
15716     case OP_STUB:
15717         /* these are all no-ops; they don't push a potentially common SV
15718          * onto the stack, so they are neither AAS_DANGEROUS nor
15719          * AAS_SAFE_SCALAR */
15720         goto do_next;
15721
15722     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15723         break;
15724
15725     case OP_NULL:
15726     case OP_LIST:
15727         /* these do nothing, but may have children */
15728         break;
15729
15730     default:
15731         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15732             (*scalars_p) += 2;
15733             flags = AAS_DANGEROUS;
15734             break;
15735         }
15736
15737         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
15738             && (o->op_private & OPpTARGET_MY))
15739         {
15740             (*scalars_p)++;
15741             all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15742                             ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15743             goto do_next;
15744         }
15745
15746         /* if its an unrecognised, non-dangerous op, assume that it
15747          * it the cause of at least one safe scalar */
15748         (*scalars_p)++;
15749         flags = AAS_SAFE_SCALAR;
15750         break;
15751     }
15752
15753     all_flags |= flags;
15754
15755     /* by default, process all kids next
15756      * XXX this assumes that all other ops are "transparent" - i.e. that
15757      * they can return some of their children. While this true for e.g.
15758      * sort and grep, it's not true for e.g. map. We really need a
15759      * 'transparent' flag added to regen/opcodes
15760      */
15761     if (o->op_flags & OPf_KIDS) {
15762         next_kid = cUNOPo->op_first;
15763         /* these ops do nothing but may have children; but their
15764          * children should also be treated as top-level */
15765         if (   o == effective_top_op
15766             && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15767         )
15768             effective_top_op = next_kid;
15769     }
15770
15771
15772     /* If next_kid is set, someone in the code above wanted us to process
15773      * that kid and all its remaining siblings.  Otherwise, work our way
15774      * back up the tree */
15775   do_next:
15776     while (!next_kid) {
15777         if (o == top_op)
15778             return all_flags; /* at top; no parents/siblings to try */
15779         if (OpHAS_SIBLING(o)) {
15780             next_kid = o->op_sibparent;
15781             if (o == effective_top_op)
15782                 effective_top_op = next_kid;
15783         }
15784         else
15785             if (o == effective_top_op)
15786                 effective_top_op = o->op_sibparent;
15787             o = o->op_sibparent; /* try parent's next sibling */
15788
15789     }
15790     o = next_kid;
15791     } /* while */
15792
15793 }
15794
15795
15796 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15797    and modify the optree to make them work inplace */
15798
15799 STATIC void
15800 S_inplace_aassign(pTHX_ OP *o) {
15801
15802     OP *modop, *modop_pushmark;
15803     OP *oright;
15804     OP *oleft, *oleft_pushmark;
15805
15806     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15807
15808     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15809
15810     assert(cUNOPo->op_first->op_type == OP_NULL);
15811     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15812     assert(modop_pushmark->op_type == OP_PUSHMARK);
15813     modop = OpSIBLING(modop_pushmark);
15814
15815     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15816         return;
15817
15818     /* no other operation except sort/reverse */
15819     if (OpHAS_SIBLING(modop))
15820         return;
15821
15822     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15823     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15824
15825     if (modop->op_flags & OPf_STACKED) {
15826         /* skip sort subroutine/block */
15827         assert(oright->op_type == OP_NULL);
15828         oright = OpSIBLING(oright);
15829     }
15830
15831     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15832     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15833     assert(oleft_pushmark->op_type == OP_PUSHMARK);
15834     oleft = OpSIBLING(oleft_pushmark);
15835
15836     /* Check the lhs is an array */
15837     if (!oleft ||
15838         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15839         || OpHAS_SIBLING(oleft)
15840         || (oleft->op_private & OPpLVAL_INTRO)
15841     )
15842         return;
15843
15844     /* Only one thing on the rhs */
15845     if (OpHAS_SIBLING(oright))
15846         return;
15847
15848     /* check the array is the same on both sides */
15849     if (oleft->op_type == OP_RV2AV) {
15850         if (oright->op_type != OP_RV2AV
15851             || !cUNOPx(oright)->op_first
15852             || cUNOPx(oright)->op_first->op_type != OP_GV
15853             || cUNOPx(oleft )->op_first->op_type != OP_GV
15854             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15855                cGVOPx_gv(cUNOPx(oright)->op_first)
15856         )
15857             return;
15858     }
15859     else if (oright->op_type != OP_PADAV
15860         || oright->op_targ != oleft->op_targ
15861     )
15862         return;
15863
15864     /* This actually is an inplace assignment */
15865
15866     modop->op_private |= OPpSORT_INPLACE;
15867
15868     /* transfer MODishness etc from LHS arg to RHS arg */
15869     oright->op_flags = oleft->op_flags;
15870
15871     /* remove the aassign op and the lhs */
15872     op_null(o);
15873     op_null(oleft_pushmark);
15874     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15875         op_null(cUNOPx(oleft)->op_first);
15876     op_null(oleft);
15877 }
15878
15879
15880
15881 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15882  * that potentially represent a series of one or more aggregate derefs
15883  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15884  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15885  * additional ops left in too).
15886  *
15887  * The caller will have already verified that the first few ops in the
15888  * chain following 'start' indicate a multideref candidate, and will have
15889  * set 'orig_o' to the point further on in the chain where the first index
15890  * expression (if any) begins.  'orig_action' specifies what type of
15891  * beginning has already been determined by the ops between start..orig_o
15892  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
15893  *
15894  * 'hints' contains any hints flags that need adding (currently just
15895  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15896  */
15897
15898 STATIC void
15899 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15900 {
15901     dVAR;
15902     int pass;
15903     UNOP_AUX_item *arg_buf = NULL;
15904     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
15905     int index_skip         = -1;    /* don't output index arg on this action */
15906
15907     /* similar to regex compiling, do two passes; the first pass
15908      * determines whether the op chain is convertible and calculates the
15909      * buffer size; the second pass populates the buffer and makes any
15910      * changes necessary to ops (such as moving consts to the pad on
15911      * threaded builds).
15912      *
15913      * NB: for things like Coverity, note that both passes take the same
15914      * path through the logic tree (except for 'if (pass)' bits), since
15915      * both passes are following the same op_next chain; and in
15916      * particular, if it would return early on the second pass, it would
15917      * already have returned early on the first pass.
15918      */
15919     for (pass = 0; pass < 2; pass++) {
15920         OP *o                = orig_o;
15921         UV action            = orig_action;
15922         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
15923         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
15924         int action_count     = 0;     /* number of actions seen so far */
15925         int action_ix        = 0;     /* action_count % (actions per IV) */
15926         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
15927         bool is_last         = FALSE; /* no more derefs to follow */
15928         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15929         UV action_word       = 0;     /* all actions so far */
15930         UNOP_AUX_item *arg     = arg_buf;
15931         UNOP_AUX_item *action_ptr = arg_buf;
15932
15933         arg++; /* reserve slot for first action word */
15934
15935         switch (action) {
15936         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15937         case MDEREF_HV_gvhv_helem:
15938             next_is_hash = TRUE;
15939             /* FALLTHROUGH */
15940         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15941         case MDEREF_AV_gvav_aelem:
15942             if (pass) {
15943 #ifdef USE_ITHREADS
15944                 arg->pad_offset = cPADOPx(start)->op_padix;
15945                 /* stop it being swiped when nulled */
15946                 cPADOPx(start)->op_padix = 0;
15947 #else
15948                 arg->sv = cSVOPx(start)->op_sv;
15949                 cSVOPx(start)->op_sv = NULL;
15950 #endif
15951             }
15952             arg++;
15953             break;
15954
15955         case MDEREF_HV_padhv_helem:
15956         case MDEREF_HV_padsv_vivify_rv2hv_helem:
15957             next_is_hash = TRUE;
15958             /* FALLTHROUGH */
15959         case MDEREF_AV_padav_aelem:
15960         case MDEREF_AV_padsv_vivify_rv2av_aelem:
15961             if (pass) {
15962                 arg->pad_offset = start->op_targ;
15963                 /* we skip setting op_targ = 0 for now, since the intact
15964                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15965                 reset_start_targ = TRUE;
15966             }
15967             arg++;
15968             break;
15969
15970         case MDEREF_HV_pop_rv2hv_helem:
15971             next_is_hash = TRUE;
15972             /* FALLTHROUGH */
15973         case MDEREF_AV_pop_rv2av_aelem:
15974             break;
15975
15976         default:
15977             NOT_REACHED; /* NOTREACHED */
15978             return;
15979         }
15980
15981         while (!is_last) {
15982             /* look for another (rv2av/hv; get index;
15983              * aelem/helem/exists/delele) sequence */
15984
15985             OP *kid;
15986             bool is_deref;
15987             bool ok;
15988             UV index_type = MDEREF_INDEX_none;
15989
15990             if (action_count) {
15991                 /* if this is not the first lookup, consume the rv2av/hv  */
15992
15993                 /* for N levels of aggregate lookup, we normally expect
15994                  * that the first N-1 [ah]elem ops will be flagged as
15995                  * /DEREF (so they autovivifiy if necessary), and the last
15996                  * lookup op not to be.
15997                  * For other things (like @{$h{k1}{k2}}) extra scope or
15998                  * leave ops can appear, so abandon the effort in that
15999                  * case */
16000                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16001                     return;
16002
16003                 /* rv2av or rv2hv sKR/1 */
16004
16005                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16006                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16007                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16008                     return;
16009
16010                 /* at this point, we wouldn't expect any of these
16011                  * possible private flags:
16012                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16013                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16014                  */
16015                 ASSUME(!(o->op_private &
16016                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16017
16018                 hints = (o->op_private & OPpHINT_STRICT_REFS);
16019
16020                 /* make sure the type of the previous /DEREF matches the
16021                  * type of the next lookup */
16022                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16023                 top_op = o;
16024
16025                 action = next_is_hash
16026                             ? MDEREF_HV_vivify_rv2hv_helem
16027                             : MDEREF_AV_vivify_rv2av_aelem;
16028                 o = o->op_next;
16029             }
16030
16031             /* if this is the second pass, and we're at the depth where
16032              * previously we encountered a non-simple index expression,
16033              * stop processing the index at this point */
16034             if (action_count != index_skip) {
16035
16036                 /* look for one or more simple ops that return an array
16037                  * index or hash key */
16038
16039                 switch (o->op_type) {
16040                 case OP_PADSV:
16041                     /* it may be a lexical var index */
16042                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16043                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16044                     ASSUME(!(o->op_private &
16045                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16046
16047                     if (   OP_GIMME(o,0) == G_SCALAR
16048                         && !(o->op_flags & (OPf_REF|OPf_MOD))
16049                         && o->op_private == 0)
16050                     {
16051                         if (pass)
16052                             arg->pad_offset = o->op_targ;
16053                         arg++;
16054                         index_type = MDEREF_INDEX_padsv;
16055                         o = o->op_next;
16056                     }
16057                     break;
16058
16059                 case OP_CONST:
16060                     if (next_is_hash) {
16061                         /* it's a constant hash index */
16062                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16063                             /* "use constant foo => FOO; $h{+foo}" for
16064                              * some weird FOO, can leave you with constants
16065                              * that aren't simple strings. It's not worth
16066                              * the extra hassle for those edge cases */
16067                             break;
16068
16069                         {
16070                             UNOP *rop = NULL;
16071                             OP * helem_op = o->op_next;
16072
16073                             ASSUME(   helem_op->op_type == OP_HELEM
16074                                    || helem_op->op_type == OP_NULL
16075                                    || pass == 0);
16076                             if (helem_op->op_type == OP_HELEM) {
16077                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16078                                 if (   helem_op->op_private & OPpLVAL_INTRO
16079                                     || rop->op_type != OP_RV2HV
16080                                 )
16081                                     rop = NULL;
16082                             }
16083                             /* on first pass just check; on second pass
16084                              * hekify */
16085                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16086                                                             pass);
16087                         }
16088
16089                         if (pass) {
16090 #ifdef USE_ITHREADS
16091                             /* Relocate sv to the pad for thread safety */
16092                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16093                             arg->pad_offset = o->op_targ;
16094                             o->op_targ = 0;
16095 #else
16096                             arg->sv = cSVOPx_sv(o);
16097 #endif
16098                         }
16099                     }
16100                     else {
16101                         /* it's a constant array index */
16102                         IV iv;
16103                         SV *ix_sv = cSVOPo->op_sv;
16104                         if (!SvIOK(ix_sv))
16105                             break;
16106                         iv = SvIV(ix_sv);
16107
16108                         if (   action_count == 0
16109                             && iv >= -128
16110                             && iv <= 127
16111                             && (   action == MDEREF_AV_padav_aelem
16112                                 || action == MDEREF_AV_gvav_aelem)
16113                         )
16114                             maybe_aelemfast = TRUE;
16115
16116                         if (pass) {
16117                             arg->iv = iv;
16118                             SvREFCNT_dec_NN(cSVOPo->op_sv);
16119                         }
16120                     }
16121                     if (pass)
16122                         /* we've taken ownership of the SV */
16123                         cSVOPo->op_sv = NULL;
16124                     arg++;
16125                     index_type = MDEREF_INDEX_const;
16126                     o = o->op_next;
16127                     break;
16128
16129                 case OP_GV:
16130                     /* it may be a package var index */
16131
16132                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16133                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16134                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16135                         || o->op_private != 0
16136                     )
16137                         break;
16138
16139                     kid = o->op_next;
16140                     if (kid->op_type != OP_RV2SV)
16141                         break;
16142
16143                     ASSUME(!(kid->op_flags &
16144                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16145                              |OPf_SPECIAL|OPf_PARENS)));
16146                     ASSUME(!(kid->op_private &
16147                                     ~(OPpARG1_MASK
16148                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16149                                      |OPpDEREF|OPpLVAL_INTRO)));
16150                     if(   (kid->op_flags &~ OPf_PARENS)
16151                             != (OPf_WANT_SCALAR|OPf_KIDS)
16152                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16153                     )
16154                         break;
16155
16156                     if (pass) {
16157 #ifdef USE_ITHREADS
16158                         arg->pad_offset = cPADOPx(o)->op_padix;
16159                         /* stop it being swiped when nulled */
16160                         cPADOPx(o)->op_padix = 0;
16161 #else
16162                         arg->sv = cSVOPx(o)->op_sv;
16163                         cSVOPo->op_sv = NULL;
16164 #endif
16165                     }
16166                     arg++;
16167                     index_type = MDEREF_INDEX_gvsv;
16168                     o = kid->op_next;
16169                     break;
16170
16171                 } /* switch */
16172             } /* action_count != index_skip */
16173
16174             action |= index_type;
16175
16176
16177             /* at this point we have either:
16178              *   * detected what looks like a simple index expression,
16179              *     and expect the next op to be an [ah]elem, or
16180              *     an nulled  [ah]elem followed by a delete or exists;
16181              *  * found a more complex expression, so something other
16182              *    than the above follows.
16183              */
16184
16185             /* possibly an optimised away [ah]elem (where op_next is
16186              * exists or delete) */
16187             if (o->op_type == OP_NULL)
16188                 o = o->op_next;
16189
16190             /* at this point we're looking for an OP_AELEM, OP_HELEM,
16191              * OP_EXISTS or OP_DELETE */
16192
16193             /* if a custom array/hash access checker is in scope,
16194              * abandon optimisation attempt */
16195             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16196                && PL_check[o->op_type] != Perl_ck_null)
16197                 return;
16198             /* similarly for customised exists and delete */
16199             if (  (o->op_type == OP_EXISTS)
16200                && PL_check[o->op_type] != Perl_ck_exists)
16201                 return;
16202             if (  (o->op_type == OP_DELETE)
16203                && PL_check[o->op_type] != Perl_ck_delete)
16204                 return;
16205
16206             if (   o->op_type != OP_AELEM
16207                 || (o->op_private &
16208                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16209                 )
16210                 maybe_aelemfast = FALSE;
16211
16212             /* look for aelem/helem/exists/delete. If it's not the last elem
16213              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16214              * flags; if it's the last, then it mustn't have
16215              * OPpDEREF_AV/HV, but may have lots of other flags, like
16216              * OPpLVAL_INTRO etc
16217              */
16218
16219             if (   index_type == MDEREF_INDEX_none
16220                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
16221                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16222             )
16223                 ok = FALSE;
16224             else {
16225                 /* we have aelem/helem/exists/delete with valid simple index */
16226
16227                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16228                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
16229                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16230
16231                 /* This doesn't make much sense but is legal:
16232                  *    @{ local $x[0][0] } = 1
16233                  * Since scope exit will undo the autovivification,
16234                  * don't bother in the first place. The OP_LEAVE
16235                  * assertion is in case there are other cases of both
16236                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16237                  * exit that would undo the local - in which case this
16238                  * block of code would need rethinking.
16239                  */
16240                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16241 #ifdef DEBUGGING
16242                     OP *n = o->op_next;
16243                     while (n && (  n->op_type == OP_NULL
16244                                 || n->op_type == OP_LIST
16245                                 || n->op_type == OP_SCALAR))
16246                         n = n->op_next;
16247                     assert(n && n->op_type == OP_LEAVE);
16248 #endif
16249                     o->op_private &= ~OPpDEREF;
16250                     is_deref = FALSE;
16251                 }
16252
16253                 if (is_deref) {
16254                     ASSUME(!(o->op_flags &
16255                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16256                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16257
16258                     ok =    (o->op_flags &~ OPf_PARENS)
16259                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16260                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16261                 }
16262                 else if (o->op_type == OP_EXISTS) {
16263                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16264                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16265                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16266                     ok =  !(o->op_private & ~OPpARG1_MASK);
16267                 }
16268                 else if (o->op_type == OP_DELETE) {
16269                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16270                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16271                     ASSUME(!(o->op_private &
16272                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16273                     /* don't handle slices or 'local delete'; the latter
16274                      * is fairly rare, and has a complex runtime */
16275                     ok =  !(o->op_private & ~OPpARG1_MASK);
16276                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16277                         /* skip handling run-tome error */
16278                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16279                 }
16280                 else {
16281                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16282                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16283                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16284                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16285                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16286                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16287                 }
16288             }
16289
16290             if (ok) {
16291                 if (!first_elem_op)
16292                     first_elem_op = o;
16293                 top_op = o;
16294                 if (is_deref) {
16295                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16296                     o = o->op_next;
16297                 }
16298                 else {
16299                     is_last = TRUE;
16300                     action |= MDEREF_FLAG_last;
16301                 }
16302             }
16303             else {
16304                 /* at this point we have something that started
16305                  * promisingly enough (with rv2av or whatever), but failed
16306                  * to find a simple index followed by an
16307                  * aelem/helem/exists/delete. If this is the first action,
16308                  * give up; but if we've already seen at least one
16309                  * aelem/helem, then keep them and add a new action with
16310                  * MDEREF_INDEX_none, which causes it to do the vivify
16311                  * from the end of the previous lookup, and do the deref,
16312                  * but stop at that point. So $a[0][expr] will do one
16313                  * av_fetch, vivify and deref, then continue executing at
16314                  * expr */
16315                 if (!action_count)
16316                     return;
16317                 is_last = TRUE;
16318                 index_skip = action_count;
16319                 action |= MDEREF_FLAG_last;
16320                 if (index_type != MDEREF_INDEX_none)
16321                     arg--;
16322             }
16323
16324             action_word |= (action << (action_ix * MDEREF_SHIFT));
16325             action_ix++;
16326             action_count++;
16327             /* if there's no space for the next action, reserve a new slot
16328              * for it *before* we start adding args for that action */
16329             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16330                 if (pass)
16331                     action_ptr->uv = action_word;
16332                 action_word = 0;
16333                 action_ptr = arg;
16334                 arg++;
16335                 action_ix = 0;
16336             }
16337         } /* while !is_last */
16338
16339         /* success! */
16340
16341         if (!action_ix)
16342             /* slot reserved for next action word not now needed */
16343             arg--;
16344         else if (pass)
16345             action_ptr->uv = action_word;
16346
16347         if (pass) {
16348             OP *mderef;
16349             OP *p, *q;
16350
16351             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16352             if (index_skip == -1) {
16353                 mderef->op_flags = o->op_flags
16354                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16355                 if (o->op_type == OP_EXISTS)
16356                     mderef->op_private = OPpMULTIDEREF_EXISTS;
16357                 else if (o->op_type == OP_DELETE)
16358                     mderef->op_private = OPpMULTIDEREF_DELETE;
16359                 else
16360                     mderef->op_private = o->op_private
16361                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16362             }
16363             /* accumulate strictness from every level (although I don't think
16364              * they can actually vary) */
16365             mderef->op_private |= hints;
16366
16367             /* integrate the new multideref op into the optree and the
16368              * op_next chain.
16369              *
16370              * In general an op like aelem or helem has two child
16371              * sub-trees: the aggregate expression (a_expr) and the
16372              * index expression (i_expr):
16373              *
16374              *     aelem
16375              *       |
16376              *     a_expr - i_expr
16377              *
16378              * The a_expr returns an AV or HV, while the i-expr returns an
16379              * index. In general a multideref replaces most or all of a
16380              * multi-level tree, e.g.
16381              *
16382              *     exists
16383              *       |
16384              *     ex-aelem
16385              *       |
16386              *     rv2av  - i_expr1
16387              *       |
16388              *     helem
16389              *       |
16390              *     rv2hv  - i_expr2
16391              *       |
16392              *     aelem
16393              *       |
16394              *     a_expr - i_expr3
16395              *
16396              * With multideref, all the i_exprs will be simple vars or
16397              * constants, except that i_expr1 may be arbitrary in the case
16398              * of MDEREF_INDEX_none.
16399              *
16400              * The bottom-most a_expr will be either:
16401              *   1) a simple var (so padXv or gv+rv2Xv);
16402              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
16403              *      so a simple var with an extra rv2Xv;
16404              *   3) or an arbitrary expression.
16405              *
16406              * 'start', the first op in the execution chain, will point to
16407              *   1),2): the padXv or gv op;
16408              *   3):    the rv2Xv which forms the last op in the a_expr
16409              *          execution chain, and the top-most op in the a_expr
16410              *          subtree.
16411              *
16412              * For all cases, the 'start' node is no longer required,
16413              * but we can't free it since one or more external nodes
16414              * may point to it. E.g. consider
16415              *     $h{foo} = $a ? $b : $c
16416              * Here, both the op_next and op_other branches of the
16417              * cond_expr point to the gv[*h] of the hash expression, so
16418              * we can't free the 'start' op.
16419              *
16420              * For expr->[...], we need to save the subtree containing the
16421              * expression; for the other cases, we just need to save the
16422              * start node.
16423              * So in all cases, we null the start op and keep it around by
16424              * making it the child of the multideref op; for the expr->
16425              * case, the expr will be a subtree of the start node.
16426              *
16427              * So in the simple 1,2 case the  optree above changes to
16428              *
16429              *     ex-exists
16430              *       |
16431              *     multideref
16432              *       |
16433              *     ex-gv (or ex-padxv)
16434              *
16435              *  with the op_next chain being
16436              *
16437              *  -> ex-gv -> multideref -> op-following-ex-exists ->
16438              *
16439              *  In the 3 case, we have
16440              *
16441              *     ex-exists
16442              *       |
16443              *     multideref
16444              *       |
16445              *     ex-rv2xv
16446              *       |
16447              *    rest-of-a_expr
16448              *      subtree
16449              *
16450              *  and
16451              *
16452              *  -> rest-of-a_expr subtree ->
16453              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
16454              *
16455              *
16456              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16457              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16458              * multideref attached as the child, e.g.
16459              *
16460              *     exists
16461              *       |
16462              *     ex-aelem
16463              *       |
16464              *     ex-rv2av  - i_expr1
16465              *       |
16466              *     multideref
16467              *       |
16468              *     ex-whatever
16469              *
16470              */
16471
16472             /* if we free this op, don't free the pad entry */
16473             if (reset_start_targ)
16474                 start->op_targ = 0;
16475
16476
16477             /* Cut the bit we need to save out of the tree and attach to
16478              * the multideref op, then free the rest of the tree */
16479
16480             /* find parent of node to be detached (for use by splice) */
16481             p = first_elem_op;
16482             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
16483                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16484             {
16485                 /* there is an arbitrary expression preceding us, e.g.
16486                  * expr->[..]? so we need to save the 'expr' subtree */
16487                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16488                     p = cUNOPx(p)->op_first;
16489                 ASSUME(   start->op_type == OP_RV2AV
16490                        || start->op_type == OP_RV2HV);
16491             }
16492             else {
16493                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16494                  * above for exists/delete. */
16495                 while (   (p->op_flags & OPf_KIDS)
16496                        && cUNOPx(p)->op_first != start
16497                 )
16498                     p = cUNOPx(p)->op_first;
16499             }
16500             ASSUME(cUNOPx(p)->op_first == start);
16501
16502             /* detach from main tree, and re-attach under the multideref */
16503             op_sibling_splice(mderef, NULL, 0,
16504                     op_sibling_splice(p, NULL, 1, NULL));
16505             op_null(start);
16506
16507             start->op_next = mderef;
16508
16509             mderef->op_next = index_skip == -1 ? o->op_next : o;
16510
16511             /* excise and free the original tree, and replace with
16512              * the multideref op */
16513             p = op_sibling_splice(top_op, NULL, -1, mderef);
16514             while (p) {
16515                 q = OpSIBLING(p);
16516                 op_free(p);
16517                 p = q;
16518             }
16519             op_null(top_op);
16520         }
16521         else {
16522             Size_t size = arg - arg_buf;
16523
16524             if (maybe_aelemfast && action_count == 1)
16525                 return;
16526
16527             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16528                                 sizeof(UNOP_AUX_item) * (size + 1));
16529             /* for dumping etc: store the length in a hidden first slot;
16530              * we set the op_aux pointer to the second slot */
16531             arg_buf->uv = size;
16532             arg_buf++;
16533         }
16534     } /* for (pass = ...) */
16535 }
16536
16537 /* See if the ops following o are such that o will always be executed in
16538  * boolean context: that is, the SV which o pushes onto the stack will
16539  * only ever be consumed by later ops via SvTRUE(sv) or similar.
16540  * If so, set a suitable private flag on o. Normally this will be
16541  * bool_flag; but see below why maybe_flag is needed too.
16542  *
16543  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16544  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16545  * already be taken, so you'll have to give that op two different flags.
16546  *
16547  * More explanation of 'maybe_flag' and 'safe_and' parameters.
16548  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16549  * those underlying ops) short-circuit, which means that rather than
16550  * necessarily returning a truth value, they may return the LH argument,
16551  * which may not be boolean. For example in $x = (keys %h || -1), keys
16552  * should return a key count rather than a boolean, even though its
16553  * sort-of being used in boolean context.
16554  *
16555  * So we only consider such logical ops to provide boolean context to
16556  * their LH argument if they themselves are in void or boolean context.
16557  * However, sometimes the context isn't known until run-time. In this
16558  * case the op is marked with the maybe_flag flag it.
16559  *
16560  * Consider the following.
16561  *
16562  *     sub f { ....;  if (%h) { .... } }
16563  *
16564  * This is actually compiled as
16565  *
16566  *     sub f { ....;  %h && do { .... } }
16567  *
16568  * Here we won't know until runtime whether the final statement (and hence
16569  * the &&) is in void context and so is safe to return a boolean value.
16570  * So mark o with maybe_flag rather than the bool_flag.
16571  * Note that there is cost associated with determining context at runtime
16572  * (e.g. a call to block_gimme()), so it may not be worth setting (at
16573  * compile time) and testing (at runtime) maybe_flag if the scalar verses
16574  * boolean costs savings are marginal.
16575  *
16576  * However, we can do slightly better with && (compared to || and //):
16577  * this op only returns its LH argument when that argument is false. In
16578  * this case, as long as the op promises to return a false value which is
16579  * valid in both boolean and scalar contexts, we can mark an op consumed
16580  * by && with bool_flag rather than maybe_flag.
16581  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16582  * than &PL_sv_no for a false result in boolean context, then it's safe. An
16583  * op which promises to handle this case is indicated by setting safe_and
16584  * to true.
16585  */
16586
16587 static void
16588 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16589 {
16590     OP *lop;
16591     U8 flag = 0;
16592
16593     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16594
16595     /* OPpTARGET_MY and boolean context probably don't mix well.
16596      * If someone finds a valid use case, maybe add an extra flag to this
16597      * function which indicates its safe to do so for this op? */
16598     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
16599              && (o->op_private & OPpTARGET_MY)));
16600
16601     lop = o->op_next;
16602
16603     while (lop) {
16604         switch (lop->op_type) {
16605         case OP_NULL:
16606         case OP_SCALAR:
16607             break;
16608
16609         /* these two consume the stack argument in the scalar case,
16610          * and treat it as a boolean in the non linenumber case */
16611         case OP_FLIP:
16612         case OP_FLOP:
16613             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16614                 || (lop->op_private & OPpFLIP_LINENUM))
16615             {
16616                 lop = NULL;
16617                 break;
16618             }
16619             /* FALLTHROUGH */
16620         /* these never leave the original value on the stack */
16621         case OP_NOT:
16622         case OP_XOR:
16623         case OP_COND_EXPR:
16624         case OP_GREPWHILE:
16625             flag = bool_flag;
16626             lop = NULL;
16627             break;
16628
16629         /* OR DOR and AND evaluate their arg as a boolean, but then may
16630          * leave the original scalar value on the stack when following the
16631          * op_next route. If not in void context, we need to ensure
16632          * that whatever follows consumes the arg only in boolean context
16633          * too.
16634          */
16635         case OP_AND:
16636             if (safe_and) {
16637                 flag = bool_flag;
16638                 lop = NULL;
16639                 break;
16640             }
16641             /* FALLTHROUGH */
16642         case OP_OR:
16643         case OP_DOR:
16644             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16645                 flag = bool_flag;
16646                 lop = NULL;
16647             }
16648             else if (!(lop->op_flags & OPf_WANT)) {
16649                 /* unknown context - decide at runtime */
16650                 flag = maybe_flag;
16651                 lop = NULL;
16652             }
16653             break;
16654
16655         default:
16656             lop = NULL;
16657             break;
16658         }
16659
16660         if (lop)
16661             lop = lop->op_next;
16662     }
16663
16664     o->op_private |= flag;
16665 }
16666
16667
16668
16669 /* mechanism for deferring recursion in rpeep() */
16670
16671 #define MAX_DEFERRED 4
16672
16673 #define DEFER(o) \
16674   STMT_START { \
16675     if (defer_ix == (MAX_DEFERRED-1)) { \
16676         OP **defer = defer_queue[defer_base]; \
16677         CALL_RPEEP(*defer); \
16678         S_prune_chain_head(defer); \
16679         defer_base = (defer_base + 1) % MAX_DEFERRED; \
16680         defer_ix--; \
16681     } \
16682     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16683   } STMT_END
16684
16685 #define IS_AND_OP(o)   (o->op_type == OP_AND)
16686 #define IS_OR_OP(o)    (o->op_type == OP_OR)
16687
16688
16689 /* A peephole optimizer.  We visit the ops in the order they're to execute.
16690  * See the comments at the top of this file for more details about when
16691  * peep() is called */
16692
16693 void
16694 Perl_rpeep(pTHX_ OP *o)
16695 {
16696     dVAR;
16697     OP* oldop = NULL;
16698     OP* oldoldop = NULL;
16699     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16700     int defer_base = 0;
16701     int defer_ix = -1;
16702
16703     if (!o || o->op_opt)
16704         return;
16705
16706     assert(o->op_type != OP_FREED);
16707
16708     ENTER;
16709     SAVEOP();
16710     SAVEVPTR(PL_curcop);
16711     for (;; o = o->op_next) {
16712         if (o && o->op_opt)
16713             o = NULL;
16714         if (!o) {
16715             while (defer_ix >= 0) {
16716                 OP **defer =
16717                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16718                 CALL_RPEEP(*defer);
16719                 S_prune_chain_head(defer);
16720             }
16721             break;
16722         }
16723
16724       redo:
16725
16726         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16727         assert(!oldoldop || oldoldop->op_next == oldop);
16728         assert(!oldop    || oldop->op_next    == o);
16729
16730         /* By default, this op has now been optimised. A couple of cases below
16731            clear this again.  */
16732         o->op_opt = 1;
16733         PL_op = o;
16734
16735         /* look for a series of 1 or more aggregate derefs, e.g.
16736          *   $a[1]{foo}[$i]{$k}
16737          * and replace with a single OP_MULTIDEREF op.
16738          * Each index must be either a const, or a simple variable,
16739          *
16740          * First, look for likely combinations of starting ops,
16741          * corresponding to (global and lexical variants of)
16742          *     $a[...]   $h{...}
16743          *     $r->[...] $r->{...}
16744          *     (preceding expression)->[...]
16745          *     (preceding expression)->{...}
16746          * and if so, call maybe_multideref() to do a full inspection
16747          * of the op chain and if appropriate, replace with an
16748          * OP_MULTIDEREF
16749          */
16750         {
16751             UV action;
16752             OP *o2 = o;
16753             U8 hints = 0;
16754
16755             switch (o2->op_type) {
16756             case OP_GV:
16757                 /* $pkg[..]   :   gv[*pkg]
16758                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
16759
16760                 /* Fail if there are new op flag combinations that we're
16761                  * not aware of, rather than:
16762                  *  * silently failing to optimise, or
16763                  *  * silently optimising the flag away.
16764                  * If this ASSUME starts failing, examine what new flag
16765                  * has been added to the op, and decide whether the
16766                  * optimisation should still occur with that flag, then
16767                  * update the code accordingly. This applies to all the
16768                  * other ASSUMEs in the block of code too.
16769                  */
16770                 ASSUME(!(o2->op_flags &
16771                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16772                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16773
16774                 o2 = o2->op_next;
16775
16776                 if (o2->op_type == OP_RV2AV) {
16777                     action = MDEREF_AV_gvav_aelem;
16778                     goto do_deref;
16779                 }
16780
16781                 if (o2->op_type == OP_RV2HV) {
16782                     action = MDEREF_HV_gvhv_helem;
16783                     goto do_deref;
16784                 }
16785
16786                 if (o2->op_type != OP_RV2SV)
16787                     break;
16788
16789                 /* at this point we've seen gv,rv2sv, so the only valid
16790                  * construct left is $pkg->[] or $pkg->{} */
16791
16792                 ASSUME(!(o2->op_flags & OPf_STACKED));
16793                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16794                             != (OPf_WANT_SCALAR|OPf_MOD))
16795                     break;
16796
16797                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16798                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16799                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16800                     break;
16801                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
16802                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16803                     break;
16804
16805                 o2 = o2->op_next;
16806                 if (o2->op_type == OP_RV2AV) {
16807                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16808                     goto do_deref;
16809                 }
16810                 if (o2->op_type == OP_RV2HV) {
16811                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16812                     goto do_deref;
16813                 }
16814                 break;
16815
16816             case OP_PADSV:
16817                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16818
16819                 ASSUME(!(o2->op_flags &
16820                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16821                 if ((o2->op_flags &
16822                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16823                      != (OPf_WANT_SCALAR|OPf_MOD))
16824                     break;
16825
16826                 ASSUME(!(o2->op_private &
16827                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16828                 /* skip if state or intro, or not a deref */
16829                 if (      o2->op_private != OPpDEREF_AV
16830                        && o2->op_private != OPpDEREF_HV)
16831                     break;
16832
16833                 o2 = o2->op_next;
16834                 if (o2->op_type == OP_RV2AV) {
16835                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16836                     goto do_deref;
16837                 }
16838                 if (o2->op_type == OP_RV2HV) {
16839                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16840                     goto do_deref;
16841                 }
16842                 break;
16843
16844             case OP_PADAV:
16845             case OP_PADHV:
16846                 /*    $lex[..]:  padav[@lex:1,2] sR *
16847                  * or $lex{..}:  padhv[%lex:1,2] sR */
16848                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16849                                             OPf_REF|OPf_SPECIAL)));
16850                 if ((o2->op_flags &
16851                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16852                      != (OPf_WANT_SCALAR|OPf_REF))
16853                     break;
16854                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16855                     break;
16856                 /* OPf_PARENS isn't currently used in this case;
16857                  * if that changes, let us know! */
16858                 ASSUME(!(o2->op_flags & OPf_PARENS));
16859
16860                 /* at this point, we wouldn't expect any of the remaining
16861                  * possible private flags:
16862                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16863                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16864                  *
16865                  * OPpSLICEWARNING shouldn't affect runtime
16866                  */
16867                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16868
16869                 action = o2->op_type == OP_PADAV
16870                             ? MDEREF_AV_padav_aelem
16871                             : MDEREF_HV_padhv_helem;
16872                 o2 = o2->op_next;
16873                 S_maybe_multideref(aTHX_ o, o2, action, 0);
16874                 break;
16875
16876
16877             case OP_RV2AV:
16878             case OP_RV2HV:
16879                 action = o2->op_type == OP_RV2AV
16880                             ? MDEREF_AV_pop_rv2av_aelem
16881                             : MDEREF_HV_pop_rv2hv_helem;
16882                 /* FALLTHROUGH */
16883             do_deref:
16884                 /* (expr)->[...]:  rv2av sKR/1;
16885                  * (expr)->{...}:  rv2hv sKR/1; */
16886
16887                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16888
16889                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16890                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16891                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16892                     break;
16893
16894                 /* at this point, we wouldn't expect any of these
16895                  * possible private flags:
16896                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16897                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16898                  */
16899                 ASSUME(!(o2->op_private &
16900                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16901                      |OPpOUR_INTRO)));
16902                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16903
16904                 o2 = o2->op_next;
16905
16906                 S_maybe_multideref(aTHX_ o, o2, action, hints);
16907                 break;
16908
16909             default:
16910                 break;
16911             }
16912         }
16913
16914
16915         switch (o->op_type) {
16916         case OP_DBSTATE:
16917             PL_curcop = ((COP*)o);              /* for warnings */
16918             break;
16919         case OP_NEXTSTATE:
16920             PL_curcop = ((COP*)o);              /* for warnings */
16921
16922             /* Optimise a "return ..." at the end of a sub to just be "...".
16923              * This saves 2 ops. Before:
16924              * 1  <;> nextstate(main 1 -e:1) v ->2
16925              * 4  <@> return K ->5
16926              * 2    <0> pushmark s ->3
16927              * -    <1> ex-rv2sv sK/1 ->4
16928              * 3      <#> gvsv[*cat] s ->4
16929              *
16930              * After:
16931              * -  <@> return K ->-
16932              * -    <0> pushmark s ->2
16933              * -    <1> ex-rv2sv sK/1 ->-
16934              * 2      <$> gvsv(*cat) s ->3
16935              */
16936             {
16937                 OP *next = o->op_next;
16938                 OP *sibling = OpSIBLING(o);
16939                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
16940                     && OP_TYPE_IS(sibling, OP_RETURN)
16941                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16942                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16943                        ||OP_TYPE_IS(sibling->op_next->op_next,
16944                                     OP_LEAVESUBLV))
16945                     && cUNOPx(sibling)->op_first == next
16946                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16947                     && next->op_next
16948                 ) {
16949                     /* Look through the PUSHMARK's siblings for one that
16950                      * points to the RETURN */
16951                     OP *top = OpSIBLING(next);
16952                     while (top && top->op_next) {
16953                         if (top->op_next == sibling) {
16954                             top->op_next = sibling->op_next;
16955                             o->op_next = next->op_next;
16956                             break;
16957                         }
16958                         top = OpSIBLING(top);
16959                     }
16960                 }
16961             }
16962
16963             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16964              *
16965              * This latter form is then suitable for conversion into padrange
16966              * later on. Convert:
16967              *
16968              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16969              *
16970              * into:
16971              *
16972              *   nextstate1 ->     listop     -> nextstate3
16973              *                 /            \
16974              *         pushmark -> padop1 -> padop2
16975              */
16976             if (o->op_next && (
16977                     o->op_next->op_type == OP_PADSV
16978                  || o->op_next->op_type == OP_PADAV
16979                  || o->op_next->op_type == OP_PADHV
16980                 )
16981                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16982                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16983                 && o->op_next->op_next->op_next && (
16984                     o->op_next->op_next->op_next->op_type == OP_PADSV
16985                  || o->op_next->op_next->op_next->op_type == OP_PADAV
16986                  || o->op_next->op_next->op_next->op_type == OP_PADHV
16987                 )
16988                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16989                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16990                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16991                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16992             ) {
16993                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16994
16995                 pad1 =    o->op_next;
16996                 ns2  = pad1->op_next;
16997                 pad2 =  ns2->op_next;
16998                 ns3  = pad2->op_next;
16999
17000                 /* we assume here that the op_next chain is the same as
17001                  * the op_sibling chain */
17002                 assert(OpSIBLING(o)    == pad1);
17003                 assert(OpSIBLING(pad1) == ns2);
17004                 assert(OpSIBLING(ns2)  == pad2);
17005                 assert(OpSIBLING(pad2) == ns3);
17006
17007                 /* excise and delete ns2 */
17008                 op_sibling_splice(NULL, pad1, 1, NULL);
17009                 op_free(ns2);
17010
17011                 /* excise pad1 and pad2 */
17012                 op_sibling_splice(NULL, o, 2, NULL);
17013
17014                 /* create new listop, with children consisting of:
17015                  * a new pushmark, pad1, pad2. */
17016                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17017                 newop->op_flags |= OPf_PARENS;
17018                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17019
17020                 /* insert newop between o and ns3 */
17021                 op_sibling_splice(NULL, o, 0, newop);
17022
17023                 /*fixup op_next chain */
17024                 newpm = cUNOPx(newop)->op_first; /* pushmark */
17025                 o    ->op_next = newpm;
17026                 newpm->op_next = pad1;
17027                 pad1 ->op_next = pad2;
17028                 pad2 ->op_next = newop; /* listop */
17029                 newop->op_next = ns3;
17030
17031                 /* Ensure pushmark has this flag if padops do */
17032                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17033                     newpm->op_flags |= OPf_MOD;
17034                 }
17035
17036                 break;
17037             }
17038
17039             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17040                to carry two labels. For now, take the easier option, and skip
17041                this optimisation if the first NEXTSTATE has a label.  */
17042             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17043                 OP *nextop = o->op_next;
17044                 while (nextop) {
17045                     switch (nextop->op_type) {
17046                         case OP_NULL:
17047                         case OP_SCALAR:
17048                         case OP_LINESEQ:
17049                         case OP_SCOPE:
17050                             nextop = nextop->op_next;
17051                             continue;
17052                     }
17053                     break;
17054                 }
17055
17056                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17057                     op_null(o);
17058                     if (oldop)
17059                         oldop->op_next = nextop;
17060                     o = nextop;
17061                     /* Skip (old)oldop assignment since the current oldop's
17062                        op_next already points to the next op.  */
17063                     goto redo;
17064                 }
17065             }
17066             break;
17067
17068         case OP_CONCAT:
17069             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17070                 if (o->op_next->op_private & OPpTARGET_MY) {
17071                     if (o->op_flags & OPf_STACKED) /* chained concats */
17072                         break; /* ignore_optimization */
17073                     else {
17074                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17075                         o->op_targ = o->op_next->op_targ;
17076                         o->op_next->op_targ = 0;
17077                         o->op_private |= OPpTARGET_MY;
17078                     }
17079                 }
17080                 op_null(o->op_next);
17081             }
17082             break;
17083         case OP_STUB:
17084             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17085                 break; /* Scalar stub must produce undef.  List stub is noop */
17086             }
17087             goto nothin;
17088         case OP_NULL:
17089             if (o->op_targ == OP_NEXTSTATE
17090                 || o->op_targ == OP_DBSTATE)
17091             {
17092                 PL_curcop = ((COP*)o);
17093             }
17094             /* XXX: We avoid setting op_seq here to prevent later calls
17095                to rpeep() from mistakenly concluding that optimisation
17096                has already occurred. This doesn't fix the real problem,
17097                though (See 20010220.007 (#5874)). AMS 20010719 */
17098             /* op_seq functionality is now replaced by op_opt */
17099             o->op_opt = 0;
17100             /* FALLTHROUGH */
17101         case OP_SCALAR:
17102         case OP_LINESEQ:
17103         case OP_SCOPE:
17104         nothin:
17105             if (oldop) {
17106                 oldop->op_next = o->op_next;
17107                 o->op_opt = 0;
17108                 continue;
17109             }
17110             break;
17111
17112         case OP_PUSHMARK:
17113
17114             /* Given
17115                  5 repeat/DOLIST
17116                  3   ex-list
17117                  1     pushmark
17118                  2     scalar or const
17119                  4   const[0]
17120                convert repeat into a stub with no kids.
17121              */
17122             if (o->op_next->op_type == OP_CONST
17123              || (  o->op_next->op_type == OP_PADSV
17124                 && !(o->op_next->op_private & OPpLVAL_INTRO))
17125              || (  o->op_next->op_type == OP_GV
17126                 && o->op_next->op_next->op_type == OP_RV2SV
17127                 && !(o->op_next->op_next->op_private
17128                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17129             {
17130                 const OP *kid = o->op_next->op_next;
17131                 if (o->op_next->op_type == OP_GV)
17132                    kid = kid->op_next;
17133                 /* kid is now the ex-list.  */
17134                 if (kid->op_type == OP_NULL
17135                  && (kid = kid->op_next)->op_type == OP_CONST
17136                     /* kid is now the repeat count.  */
17137                  && kid->op_next->op_type == OP_REPEAT
17138                  && kid->op_next->op_private & OPpREPEAT_DOLIST
17139                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17140                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17141                  && oldop)
17142                 {
17143                     o = kid->op_next; /* repeat */
17144                     oldop->op_next = o;
17145                     op_free(cBINOPo->op_first);
17146                     op_free(cBINOPo->op_last );
17147                     o->op_flags &=~ OPf_KIDS;
17148                     /* stub is a baseop; repeat is a binop */
17149                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17150                     OpTYPE_set(o, OP_STUB);
17151                     o->op_private = 0;
17152                     break;
17153                 }
17154             }
17155
17156             /* Convert a series of PAD ops for my vars plus support into a
17157              * single padrange op. Basically
17158              *
17159              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17160              *
17161              * becomes, depending on circumstances, one of
17162              *
17163              *    padrange  ----------------------------------> (list) -> rest
17164              *    padrange  --------------------------------------------> rest
17165              *
17166              * where all the pad indexes are sequential and of the same type
17167              * (INTRO or not).
17168              * We convert the pushmark into a padrange op, then skip
17169              * any other pad ops, and possibly some trailing ops.
17170              * Note that we don't null() the skipped ops, to make it
17171              * easier for Deparse to undo this optimisation (and none of
17172              * the skipped ops are holding any resourses). It also makes
17173              * it easier for find_uninit_var(), as it can just ignore
17174              * padrange, and examine the original pad ops.
17175              */
17176         {
17177             OP *p;
17178             OP *followop = NULL; /* the op that will follow the padrange op */
17179             U8 count = 0;
17180             U8 intro = 0;
17181             PADOFFSET base = 0; /* init only to stop compiler whining */
17182             bool gvoid = 0;     /* init only to stop compiler whining */
17183             bool defav = 0;  /* seen (...) = @_ */
17184             bool reuse = 0;  /* reuse an existing padrange op */
17185
17186             /* look for a pushmark -> gv[_] -> rv2av */
17187
17188             {
17189                 OP *rv2av, *q;
17190                 p = o->op_next;
17191                 if (   p->op_type == OP_GV
17192                     && cGVOPx_gv(p) == PL_defgv
17193                     && (rv2av = p->op_next)
17194                     && rv2av->op_type == OP_RV2AV
17195                     && !(rv2av->op_flags & OPf_REF)
17196                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17197                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17198                 ) {
17199                     q = rv2av->op_next;
17200                     if (q->op_type == OP_NULL)
17201                         q = q->op_next;
17202                     if (q->op_type == OP_PUSHMARK) {
17203                         defav = 1;
17204                         p = q;
17205                     }
17206                 }
17207             }
17208             if (!defav) {
17209                 p = o;
17210             }
17211
17212             /* scan for PAD ops */
17213
17214             for (p = p->op_next; p; p = p->op_next) {
17215                 if (p->op_type == OP_NULL)
17216                     continue;
17217
17218                 if ((     p->op_type != OP_PADSV
17219                        && p->op_type != OP_PADAV
17220                        && p->op_type != OP_PADHV
17221                     )
17222                       /* any private flag other than INTRO? e.g. STATE */
17223                    || (p->op_private & ~OPpLVAL_INTRO)
17224                 )
17225                     break;
17226
17227                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17228                  * instead */
17229                 if (   p->op_type == OP_PADAV
17230                     && p->op_next
17231                     && p->op_next->op_type == OP_CONST
17232                     && p->op_next->op_next
17233                     && p->op_next->op_next->op_type == OP_AELEM
17234                 )
17235                     break;
17236
17237                 /* for 1st padop, note what type it is and the range
17238                  * start; for the others, check that it's the same type
17239                  * and that the targs are contiguous */
17240                 if (count == 0) {
17241                     intro = (p->op_private & OPpLVAL_INTRO);
17242                     base = p->op_targ;
17243                     gvoid = OP_GIMME(p,0) == G_VOID;
17244                 }
17245                 else {
17246                     if ((p->op_private & OPpLVAL_INTRO) != intro)
17247                         break;
17248                     /* Note that you'd normally  expect targs to be
17249                      * contiguous in my($a,$b,$c), but that's not the case
17250                      * when external modules start doing things, e.g.
17251                      * Function::Parameters */
17252                     if (p->op_targ != base + count)
17253                         break;
17254                     assert(p->op_targ == base + count);
17255                     /* Either all the padops or none of the padops should
17256                        be in void context.  Since we only do the optimisa-
17257                        tion for av/hv when the aggregate itself is pushed
17258                        on to the stack (one item), there is no need to dis-
17259                        tinguish list from scalar context.  */
17260                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
17261                         break;
17262                 }
17263
17264                 /* for AV, HV, only when we're not flattening */
17265                 if (   p->op_type != OP_PADSV
17266                     && !gvoid
17267                     && !(p->op_flags & OPf_REF)
17268                 )
17269                     break;
17270
17271                 if (count >= OPpPADRANGE_COUNTMASK)
17272                     break;
17273
17274                 /* there's a biggest base we can fit into a
17275                  * SAVEt_CLEARPADRANGE in pp_padrange.
17276                  * (The sizeof() stuff will be constant-folded, and is
17277                  * intended to avoid getting "comparison is always false"
17278                  * compiler warnings. See the comments above
17279                  * MEM_WRAP_CHECK for more explanation on why we do this
17280                  * in a weird way to avoid compiler warnings.)
17281                  */
17282                 if (   intro
17283                     && (8*sizeof(base) >
17284                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17285                         ? (Size_t)base
17286                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17287                         ) >
17288                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17289                 )
17290                     break;
17291
17292                 /* Success! We've got another valid pad op to optimise away */
17293                 count++;
17294                 followop = p->op_next;
17295             }
17296
17297             if (count < 1 || (count == 1 && !defav))
17298                 break;
17299
17300             /* pp_padrange in specifically compile-time void context
17301              * skips pushing a mark and lexicals; in all other contexts
17302              * (including unknown till runtime) it pushes a mark and the
17303              * lexicals. We must be very careful then, that the ops we
17304              * optimise away would have exactly the same effect as the
17305              * padrange.
17306              * In particular in void context, we can only optimise to
17307              * a padrange if we see the complete sequence
17308              *     pushmark, pad*v, ...., list
17309              * which has the net effect of leaving the markstack as it
17310              * was.  Not pushing onto the stack (whereas padsv does touch
17311              * the stack) makes no difference in void context.
17312              */
17313             assert(followop);
17314             if (gvoid) {
17315                 if (followop->op_type == OP_LIST
17316                         && OP_GIMME(followop,0) == G_VOID
17317                    )
17318                 {
17319                     followop = followop->op_next; /* skip OP_LIST */
17320
17321                     /* consolidate two successive my(...);'s */
17322
17323                     if (   oldoldop
17324                         && oldoldop->op_type == OP_PADRANGE
17325                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17326                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17327                         && !(oldoldop->op_flags & OPf_SPECIAL)
17328                     ) {
17329                         U8 old_count;
17330                         assert(oldoldop->op_next == oldop);
17331                         assert(   oldop->op_type == OP_NEXTSTATE
17332                                || oldop->op_type == OP_DBSTATE);
17333                         assert(oldop->op_next == o);
17334
17335                         old_count
17336                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17337
17338                        /* Do not assume pad offsets for $c and $d are con-
17339                           tiguous in
17340                             my ($a,$b,$c);
17341                             my ($d,$e,$f);
17342                         */
17343                         if (  oldoldop->op_targ + old_count == base
17344                            && old_count < OPpPADRANGE_COUNTMASK - count) {
17345                             base = oldoldop->op_targ;
17346                             count += old_count;
17347                             reuse = 1;
17348                         }
17349                     }
17350
17351                     /* if there's any immediately following singleton
17352                      * my var's; then swallow them and the associated
17353                      * nextstates; i.e.
17354                      *    my ($a,$b); my $c; my $d;
17355                      * is treated as
17356                      *    my ($a,$b,$c,$d);
17357                      */
17358
17359                     while (    ((p = followop->op_next))
17360                             && (  p->op_type == OP_PADSV
17361                                || p->op_type == OP_PADAV
17362                                || p->op_type == OP_PADHV)
17363                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17364                             && (p->op_private & OPpLVAL_INTRO) == intro
17365                             && !(p->op_private & ~OPpLVAL_INTRO)
17366                             && p->op_next
17367                             && (   p->op_next->op_type == OP_NEXTSTATE
17368                                 || p->op_next->op_type == OP_DBSTATE)
17369                             && count < OPpPADRANGE_COUNTMASK
17370                             && base + count == p->op_targ
17371                     ) {
17372                         count++;
17373                         followop = p->op_next;
17374                     }
17375                 }
17376                 else
17377                     break;
17378             }
17379
17380             if (reuse) {
17381                 assert(oldoldop->op_type == OP_PADRANGE);
17382                 oldoldop->op_next = followop;
17383                 oldoldop->op_private = (intro | count);
17384                 o = oldoldop;
17385                 oldop = NULL;
17386                 oldoldop = NULL;
17387             }
17388             else {
17389                 /* Convert the pushmark into a padrange.
17390                  * To make Deparse easier, we guarantee that a padrange was
17391                  * *always* formerly a pushmark */
17392                 assert(o->op_type == OP_PUSHMARK);
17393                 o->op_next = followop;
17394                 OpTYPE_set(o, OP_PADRANGE);
17395                 o->op_targ = base;
17396                 /* bit 7: INTRO; bit 6..0: count */
17397                 o->op_private = (intro | count);
17398                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17399                               | gvoid * OPf_WANT_VOID
17400                               | (defav ? OPf_SPECIAL : 0));
17401             }
17402             break;
17403         }
17404
17405         case OP_RV2AV:
17406             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17407                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17408             break;
17409
17410         case OP_RV2HV:
17411         case OP_PADHV:
17412             /*'keys %h' in void or scalar context: skip the OP_KEYS
17413              * and perform the functionality directly in the RV2HV/PADHV
17414              * op
17415              */
17416             if (o->op_flags & OPf_REF) {
17417                 OP *k = o->op_next;
17418                 U8 want = (k->op_flags & OPf_WANT);
17419                 if (   k
17420                     && k->op_type == OP_KEYS
17421                     && (   want == OPf_WANT_VOID
17422                         || want == OPf_WANT_SCALAR)
17423                     && !(k->op_private & OPpMAYBE_LVSUB)
17424                     && !(k->op_flags & OPf_MOD)
17425                 ) {
17426                     o->op_next     = k->op_next;
17427                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
17428                     o->op_flags   |= want;
17429                     o->op_private |= (o->op_type == OP_PADHV ?
17430                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17431                     /* for keys(%lex), hold onto the OP_KEYS's targ
17432                      * since padhv doesn't have its own targ to return
17433                      * an int with */
17434                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17435                         op_null(k);
17436                 }
17437             }
17438
17439             /* see if %h is used in boolean context */
17440             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17441                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17442
17443
17444             if (o->op_type != OP_PADHV)
17445                 break;
17446             /* FALLTHROUGH */
17447         case OP_PADAV:
17448             if (   o->op_type == OP_PADAV
17449                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17450             )
17451                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17452             /* FALLTHROUGH */
17453         case OP_PADSV:
17454             /* Skip over state($x) in void context.  */
17455             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17456              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17457             {
17458                 oldop->op_next = o->op_next;
17459                 goto redo_nextstate;
17460             }
17461             if (o->op_type != OP_PADAV)
17462                 break;
17463             /* FALLTHROUGH */
17464         case OP_GV:
17465             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17466                 OP* const pop = (o->op_type == OP_PADAV) ?
17467                             o->op_next : o->op_next->op_next;
17468                 IV i;
17469                 if (pop && pop->op_type == OP_CONST &&
17470                     ((PL_op = pop->op_next)) &&
17471                     pop->op_next->op_type == OP_AELEM &&
17472                     !(pop->op_next->op_private &
17473                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17474                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17475                 {
17476                     GV *gv;
17477                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17478                         no_bareword_allowed(pop);
17479                     if (o->op_type == OP_GV)
17480                         op_null(o->op_next);
17481                     op_null(pop->op_next);
17482                     op_null(pop);
17483                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17484                     o->op_next = pop->op_next->op_next;
17485                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17486                     o->op_private = (U8)i;
17487                     if (o->op_type == OP_GV) {
17488                         gv = cGVOPo_gv;
17489                         GvAVn(gv);
17490                         o->op_type = OP_AELEMFAST;
17491                     }
17492                     else
17493                         o->op_type = OP_AELEMFAST_LEX;
17494                 }
17495                 if (o->op_type != OP_GV)
17496                     break;
17497             }
17498
17499             /* Remove $foo from the op_next chain in void context.  */
17500             if (oldop
17501              && (  o->op_next->op_type == OP_RV2SV
17502                 || o->op_next->op_type == OP_RV2AV
17503                 || o->op_next->op_type == OP_RV2HV  )
17504              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17505              && !(o->op_next->op_private & OPpLVAL_INTRO))
17506             {
17507                 oldop->op_next = o->op_next->op_next;
17508                 /* Reprocess the previous op if it is a nextstate, to
17509                    allow double-nextstate optimisation.  */
17510               redo_nextstate:
17511                 if (oldop->op_type == OP_NEXTSTATE) {
17512                     oldop->op_opt = 0;
17513                     o = oldop;
17514                     oldop = oldoldop;
17515                     oldoldop = NULL;
17516                     goto redo;
17517                 }
17518                 o = oldop->op_next;
17519                 goto redo;
17520             }
17521             else if (o->op_next->op_type == OP_RV2SV) {
17522                 if (!(o->op_next->op_private & OPpDEREF)) {
17523                     op_null(o->op_next);
17524                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17525                                                                | OPpOUR_INTRO);
17526                     o->op_next = o->op_next->op_next;
17527                     OpTYPE_set(o, OP_GVSV);
17528                 }
17529             }
17530             else if (o->op_next->op_type == OP_READLINE
17531                     && o->op_next->op_next->op_type == OP_CONCAT
17532                     && (o->op_next->op_next->op_flags & OPf_STACKED))
17533             {
17534                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17535                 OpTYPE_set(o, OP_RCATLINE);
17536                 o->op_flags |= OPf_STACKED;
17537                 op_null(o->op_next->op_next);
17538                 op_null(o->op_next);
17539             }
17540
17541             break;
17542
17543         case OP_NOT:
17544             break;
17545
17546         case OP_AND:
17547         case OP_OR:
17548         case OP_DOR:
17549         case OP_CMPCHAIN_AND:
17550             while (cLOGOP->op_other->op_type == OP_NULL)
17551                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17552             while (o->op_next && (   o->op_type == o->op_next->op_type
17553                                   || o->op_next->op_type == OP_NULL))
17554                 o->op_next = o->op_next->op_next;
17555
17556             /* If we're an OR and our next is an AND in void context, we'll
17557                follow its op_other on short circuit, same for reverse.
17558                We can't do this with OP_DOR since if it's true, its return
17559                value is the underlying value which must be evaluated
17560                by the next op. */
17561             if (o->op_next &&
17562                 (
17563                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17564                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17565                 )
17566                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17567             ) {
17568                 o->op_next = ((LOGOP*)o->op_next)->op_other;
17569             }
17570             DEFER(cLOGOP->op_other);
17571             o->op_opt = 1;
17572             break;
17573
17574         case OP_GREPWHILE:
17575             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17576                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17577             /* FALLTHROUGH */
17578         case OP_COND_EXPR:
17579         case OP_MAPWHILE:
17580         case OP_ANDASSIGN:
17581         case OP_ORASSIGN:
17582         case OP_DORASSIGN:
17583         case OP_RANGE:
17584         case OP_ONCE:
17585         case OP_ARGDEFELEM:
17586             while (cLOGOP->op_other->op_type == OP_NULL)
17587                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17588             DEFER(cLOGOP->op_other);
17589             break;
17590
17591         case OP_ENTERLOOP:
17592         case OP_ENTERITER:
17593             while (cLOOP->op_redoop->op_type == OP_NULL)
17594                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17595             while (cLOOP->op_nextop->op_type == OP_NULL)
17596                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17597             while (cLOOP->op_lastop->op_type == OP_NULL)
17598                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17599             /* a while(1) loop doesn't have an op_next that escapes the
17600              * loop, so we have to explicitly follow the op_lastop to
17601              * process the rest of the code */
17602             DEFER(cLOOP->op_lastop);
17603             break;
17604
17605         case OP_ENTERTRY:
17606             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17607             DEFER(cLOGOPo->op_other);
17608             break;
17609
17610         case OP_SUBST:
17611             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17612                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17613             assert(!(cPMOP->op_pmflags & PMf_ONCE));
17614             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17615                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17616                 cPMOP->op_pmstashstartu.op_pmreplstart
17617                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17618             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17619             break;
17620
17621         case OP_SORT: {
17622             OP *oright;
17623
17624             if (o->op_flags & OPf_SPECIAL) {
17625                 /* first arg is a code block */
17626                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17627                 OP * kid          = cUNOPx(nullop)->op_first;
17628
17629                 assert(nullop->op_type == OP_NULL);
17630                 assert(kid->op_type == OP_SCOPE
17631                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17632                 /* since OP_SORT doesn't have a handy op_other-style
17633                  * field that can point directly to the start of the code
17634                  * block, store it in the otherwise-unused op_next field
17635                  * of the top-level OP_NULL. This will be quicker at
17636                  * run-time, and it will also allow us to remove leading
17637                  * OP_NULLs by just messing with op_nexts without
17638                  * altering the basic op_first/op_sibling layout. */
17639                 kid = kLISTOP->op_first;
17640                 assert(
17641                       (kid->op_type == OP_NULL
17642                       && (  kid->op_targ == OP_NEXTSTATE
17643                          || kid->op_targ == OP_DBSTATE  ))
17644                     || kid->op_type == OP_STUB
17645                     || kid->op_type == OP_ENTER
17646                     || (PL_parser && PL_parser->error_count));
17647                 nullop->op_next = kid->op_next;
17648                 DEFER(nullop->op_next);
17649             }
17650
17651             /* check that RHS of sort is a single plain array */
17652             oright = cUNOPo->op_first;
17653             if (!oright || oright->op_type != OP_PUSHMARK)
17654                 break;
17655
17656             if (o->op_private & OPpSORT_INPLACE)
17657                 break;
17658
17659             /* reverse sort ... can be optimised.  */
17660             if (!OpHAS_SIBLING(cUNOPo)) {
17661                 /* Nothing follows us on the list. */
17662                 OP * const reverse = o->op_next;
17663
17664                 if (reverse->op_type == OP_REVERSE &&
17665                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17666                     OP * const pushmark = cUNOPx(reverse)->op_first;
17667                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17668                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17669                         /* reverse -> pushmark -> sort */
17670                         o->op_private |= OPpSORT_REVERSE;
17671                         op_null(reverse);
17672                         pushmark->op_next = oright->op_next;
17673                         op_null(oright);
17674                     }
17675                 }
17676             }
17677
17678             break;
17679         }
17680
17681         case OP_REVERSE: {
17682             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17683             OP *gvop = NULL;
17684             LISTOP *enter, *exlist;
17685
17686             if (o->op_private & OPpSORT_INPLACE)
17687                 break;
17688
17689             enter = (LISTOP *) o->op_next;
17690             if (!enter)
17691                 break;
17692             if (enter->op_type == OP_NULL) {
17693                 enter = (LISTOP *) enter->op_next;
17694                 if (!enter)
17695                     break;
17696             }
17697             /* for $a (...) will have OP_GV then OP_RV2GV here.
17698                for (...) just has an OP_GV.  */
17699             if (enter->op_type == OP_GV) {
17700                 gvop = (OP *) enter;
17701                 enter = (LISTOP *) enter->op_next;
17702                 if (!enter)
17703                     break;
17704                 if (enter->op_type == OP_RV2GV) {
17705                   enter = (LISTOP *) enter->op_next;
17706                   if (!enter)
17707                     break;
17708                 }
17709             }
17710
17711             if (enter->op_type != OP_ENTERITER)
17712                 break;
17713
17714             iter = enter->op_next;
17715             if (!iter || iter->op_type != OP_ITER)
17716                 break;
17717
17718             expushmark = enter->op_first;
17719             if (!expushmark || expushmark->op_type != OP_NULL
17720                 || expushmark->op_targ != OP_PUSHMARK)
17721                 break;
17722
17723             exlist = (LISTOP *) OpSIBLING(expushmark);
17724             if (!exlist || exlist->op_type != OP_NULL
17725                 || exlist->op_targ != OP_LIST)
17726                 break;
17727
17728             if (exlist->op_last != o) {
17729                 /* Mmm. Was expecting to point back to this op.  */
17730                 break;
17731             }
17732             theirmark = exlist->op_first;
17733             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17734                 break;
17735
17736             if (OpSIBLING(theirmark) != o) {
17737                 /* There's something between the mark and the reverse, eg
17738                    for (1, reverse (...))
17739                    so no go.  */
17740                 break;
17741             }
17742
17743             ourmark = ((LISTOP *)o)->op_first;
17744             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17745                 break;
17746
17747             ourlast = ((LISTOP *)o)->op_last;
17748             if (!ourlast || ourlast->op_next != o)
17749                 break;
17750
17751             rv2av = OpSIBLING(ourmark);
17752             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17753                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17754                 /* We're just reversing a single array.  */
17755                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17756                 enter->op_flags |= OPf_STACKED;
17757             }
17758
17759             /* We don't have control over who points to theirmark, so sacrifice
17760                ours.  */
17761             theirmark->op_next = ourmark->op_next;
17762             theirmark->op_flags = ourmark->op_flags;
17763             ourlast->op_next = gvop ? gvop : (OP *) enter;
17764             op_null(ourmark);
17765             op_null(o);
17766             enter->op_private |= OPpITER_REVERSED;
17767             iter->op_private |= OPpITER_REVERSED;
17768
17769             oldoldop = NULL;
17770             oldop    = ourlast;
17771             o        = oldop->op_next;
17772             goto redo;
17773             NOT_REACHED; /* NOTREACHED */
17774             break;
17775         }
17776
17777         case OP_QR:
17778         case OP_MATCH:
17779             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17780                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17781             }
17782             break;
17783
17784         case OP_RUNCV:
17785             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17786              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17787             {
17788                 SV *sv;
17789                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17790                 else {
17791                     sv = newRV((SV *)PL_compcv);
17792                     sv_rvweaken(sv);
17793                     SvREADONLY_on(sv);
17794                 }
17795                 OpTYPE_set(o, OP_CONST);
17796                 o->op_flags |= OPf_SPECIAL;
17797                 cSVOPo->op_sv = sv;
17798             }
17799             break;
17800
17801         case OP_SASSIGN:
17802             if (OP_GIMME(o,0) == G_VOID
17803              || (  o->op_next->op_type == OP_LINESEQ
17804                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
17805                    || (  o->op_next->op_next->op_type == OP_RETURN
17806                       && !CvLVALUE(PL_compcv)))))
17807             {
17808                 OP *right = cBINOP->op_first;
17809                 if (right) {
17810                     /*   sassign
17811                     *      RIGHT
17812                     *      substr
17813                     *         pushmark
17814                     *         arg1
17815                     *         arg2
17816                     *         ...
17817                     * becomes
17818                     *
17819                     *  ex-sassign
17820                     *     substr
17821                     *        pushmark
17822                     *        RIGHT
17823                     *        arg1
17824                     *        arg2
17825                     *        ...
17826                     */
17827                     OP *left = OpSIBLING(right);
17828                     if (left->op_type == OP_SUBSTR
17829                          && (left->op_private & 7) < 4) {
17830                         op_null(o);
17831                         /* cut out right */
17832                         op_sibling_splice(o, NULL, 1, NULL);
17833                         /* and insert it as second child of OP_SUBSTR */
17834                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17835                                     right);
17836                         left->op_private |= OPpSUBSTR_REPL_FIRST;
17837                         left->op_flags =
17838                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17839                     }
17840                 }
17841             }
17842             break;
17843
17844         case OP_AASSIGN: {
17845             int l, r, lr, lscalars, rscalars;
17846
17847             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17848                Note that we do this now rather than in newASSIGNOP(),
17849                since only by now are aliased lexicals flagged as such
17850
17851                See the essay "Common vars in list assignment" above for
17852                the full details of the rationale behind all the conditions
17853                below.
17854
17855                PL_generation sorcery:
17856                To detect whether there are common vars, the global var
17857                PL_generation is incremented for each assign op we scan.
17858                Then we run through all the lexical variables on the LHS,
17859                of the assignment, setting a spare slot in each of them to
17860                PL_generation.  Then we scan the RHS, and if any lexicals
17861                already have that value, we know we've got commonality.
17862                Also, if the generation number is already set to
17863                PERL_INT_MAX, then the variable is involved in aliasing, so
17864                we also have potential commonality in that case.
17865              */
17866
17867             PL_generation++;
17868             /* scan LHS */
17869             lscalars = 0;
17870             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, &lscalars);
17871             /* scan RHS */
17872             rscalars = 0;
17873             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17874             lr = (l|r);
17875
17876
17877             /* After looking for things which are *always* safe, this main
17878              * if/else chain selects primarily based on the type of the
17879              * LHS, gradually working its way down from the more dangerous
17880              * to the more restrictive and thus safer cases */
17881
17882             if (   !l                      /* () = ....; */
17883                 || !r                      /* .... = (); */
17884                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17885                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17886                 || (lscalars < 2)          /* ($x, undef) = ... */
17887             ) {
17888                 NOOP; /* always safe */
17889             }
17890             else if (l & AAS_DANGEROUS) {
17891                 /* always dangerous */
17892                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17893                 o->op_private |= OPpASSIGN_COMMON_AGG;
17894             }
17895             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17896                 /* package vars are always dangerous - too many
17897                  * aliasing possibilities */
17898                 if (l & AAS_PKG_SCALAR)
17899                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
17900                 if (l & AAS_PKG_AGG)
17901                     o->op_private |= OPpASSIGN_COMMON_AGG;
17902             }
17903             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17904                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
17905             {
17906                 /* LHS contains only lexicals and safe ops */
17907
17908                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17909                     o->op_private |= OPpASSIGN_COMMON_AGG;
17910
17911                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17912                     if (lr & AAS_LEX_SCALAR_COMM)
17913                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
17914                     else if (   !(l & AAS_LEX_SCALAR)
17915                              && (r & AAS_DEFAV))
17916                     {
17917                         /* falsely mark
17918                          *    my (...) = @_
17919                          * as scalar-safe for performance reasons.
17920                          * (it will still have been marked _AGG if necessary */
17921                         NOOP;
17922                     }
17923                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17924                         /* if there are only lexicals on the LHS and no
17925                          * common ones on the RHS, then we assume that the
17926                          * only way those lexicals could also get
17927                          * on the RHS is via some sort of dereffing or
17928                          * closure, e.g.
17929                          *    $r = \$lex;
17930                          *    ($lex, $x) = (1, $$r)
17931                          * and in this case we assume the var must have
17932                          *  a bumped ref count. So if its ref count is 1,
17933                          *  it must only be on the LHS.
17934                          */
17935                         o->op_private |= OPpASSIGN_COMMON_RC1;
17936                 }
17937             }
17938
17939             /* ... = ($x)
17940              * may have to handle aggregate on LHS, but we can't
17941              * have common scalars. */
17942             if (rscalars < 2)
17943                 o->op_private &=
17944                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17945
17946             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17947                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17948             break;
17949         }
17950
17951         case OP_REF:
17952             /* see if ref() is used in boolean context */
17953             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17954                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17955             break;
17956
17957         case OP_LENGTH:
17958             /* see if the op is used in known boolean context,
17959              * but not if OA_TARGLEX optimisation is enabled */
17960             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17961                 && !(o->op_private & OPpTARGET_MY)
17962             )
17963                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17964             break;
17965
17966         case OP_POS:
17967             /* see if the op is used in known boolean context */
17968             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17969                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17970             break;
17971
17972         case OP_CUSTOM: {
17973             Perl_cpeep_t cpeep =
17974                 XopENTRYCUSTOM(o, xop_peep);
17975             if (cpeep)
17976                 cpeep(aTHX_ o, oldop);
17977             break;
17978         }
17979
17980         }
17981         /* did we just null the current op? If so, re-process it to handle
17982          * eliding "empty" ops from the chain */
17983         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17984             o->op_opt = 0;
17985             o = oldop;
17986         }
17987         else {
17988             oldoldop = oldop;
17989             oldop = o;
17990         }
17991     }
17992     LEAVE;
17993 }
17994
17995 void
17996 Perl_peep(pTHX_ OP *o)
17997 {
17998     CALL_RPEEP(o);
17999 }
18000
18001 /*
18002 =head1 Custom Operators
18003
18004 =for apidoc Perl_custom_op_xop
18005 Return the XOP structure for a given custom op.  This macro should be
18006 considered internal to C<OP_NAME> and the other access macros: use them instead.
18007 This macro does call a function.  Prior
18008 to 5.19.6, this was implemented as a
18009 function.
18010
18011 =cut
18012 */
18013
18014
18015 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18016  * freeing PL_custom_ops */
18017
18018 static int
18019 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18020 {
18021     XOP *xop;
18022
18023     PERL_UNUSED_ARG(mg);
18024     xop = INT2PTR(XOP *, SvIV(sv));
18025     Safefree(xop->xop_name);
18026     Safefree(xop->xop_desc);
18027     Safefree(xop);
18028     return 0;
18029 }
18030
18031
18032 static const MGVTBL custom_op_register_vtbl = {
18033     0,                          /* get */
18034     0,                          /* set */
18035     0,                          /* len */
18036     0,                          /* clear */
18037     custom_op_register_free,     /* free */
18038     0,                          /* copy */
18039     0,                          /* dup */
18040 #ifdef MGf_LOCAL
18041     0,                          /* local */
18042 #endif
18043 };
18044
18045
18046 XOPRETANY
18047 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18048 {
18049     SV *keysv;
18050     HE *he = NULL;
18051     XOP *xop;
18052
18053     static const XOP xop_null = { 0, 0, 0, 0, 0 };
18054
18055     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18056     assert(o->op_type == OP_CUSTOM);
18057
18058     /* This is wrong. It assumes a function pointer can be cast to IV,
18059      * which isn't guaranteed, but this is what the old custom OP code
18060      * did. In principle it should be safer to Copy the bytes of the
18061      * pointer into a PV: since the new interface is hidden behind
18062      * functions, this can be changed later if necessary.  */
18063     /* Change custom_op_xop if this ever happens */
18064     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18065
18066     if (PL_custom_ops)
18067         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18068
18069     /* See if the op isn't registered, but its name *is* registered.
18070      * That implies someone is using the pre-5.14 API,where only name and
18071      * description could be registered. If so, fake up a real
18072      * registration.
18073      * We only check for an existing name, and assume no one will have
18074      * just registered a desc */
18075     if (!he && PL_custom_op_names &&
18076         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18077     ) {
18078         const char *pv;
18079         STRLEN l;
18080
18081         /* XXX does all this need to be shared mem? */
18082         Newxz(xop, 1, XOP);
18083         pv = SvPV(HeVAL(he), l);
18084         XopENTRY_set(xop, xop_name, savepvn(pv, l));
18085         if (PL_custom_op_descs &&
18086             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18087         ) {
18088             pv = SvPV(HeVAL(he), l);
18089             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18090         }
18091         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18092         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18093         /* add magic to the SV so that the xop struct (pointed to by
18094          * SvIV(sv)) is freed. Normally a static xop is registered, but
18095          * for this backcompat hack, we've alloced one */
18096         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18097                 &custom_op_register_vtbl, NULL, 0);
18098
18099     }
18100     else {
18101         if (!he)
18102             xop = (XOP *)&xop_null;
18103         else
18104             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18105     }
18106     {
18107         XOPRETANY any;
18108         if(field == XOPe_xop_ptr) {
18109             any.xop_ptr = xop;
18110         } else {
18111             const U32 flags = XopFLAGS(xop);
18112             if(flags & field) {
18113                 switch(field) {
18114                 case XOPe_xop_name:
18115                     any.xop_name = xop->xop_name;
18116                     break;
18117                 case XOPe_xop_desc:
18118                     any.xop_desc = xop->xop_desc;
18119                     break;
18120                 case XOPe_xop_class:
18121                     any.xop_class = xop->xop_class;
18122                     break;
18123                 case XOPe_xop_peep:
18124                     any.xop_peep = xop->xop_peep;
18125                     break;
18126                 default:
18127                     NOT_REACHED; /* NOTREACHED */
18128                     break;
18129                 }
18130             } else {
18131                 switch(field) {
18132                 case XOPe_xop_name:
18133                     any.xop_name = XOPd_xop_name;
18134                     break;
18135                 case XOPe_xop_desc:
18136                     any.xop_desc = XOPd_xop_desc;
18137                     break;
18138                 case XOPe_xop_class:
18139                     any.xop_class = XOPd_xop_class;
18140                     break;
18141                 case XOPe_xop_peep:
18142                     any.xop_peep = XOPd_xop_peep;
18143                     break;
18144                 default:
18145                     NOT_REACHED; /* NOTREACHED */
18146                     break;
18147                 }
18148             }
18149         }
18150         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18151          * op.c: In function 'Perl_custom_op_get_field':
18152          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18153          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18154          * expands to assert(0), which expands to ((0) ? (void)0 :
18155          * __assert(...)), and gcc doesn't know that __assert can never return. */
18156         return any;
18157     }
18158 }
18159
18160 /*
18161 =for apidoc custom_op_register
18162 Register a custom op.  See L<perlguts/"Custom Operators">.
18163
18164 =cut
18165 */
18166
18167 void
18168 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18169 {
18170     SV *keysv;
18171
18172     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18173
18174     /* see the comment in custom_op_xop */
18175     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18176
18177     if (!PL_custom_ops)
18178         PL_custom_ops = newHV();
18179
18180     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18181         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18182 }
18183
18184 /*
18185
18186 =for apidoc core_prototype
18187
18188 This function assigns the prototype of the named core function to C<sv>, or
18189 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
18190 C<NULL> if the core function has no prototype.  C<code> is a code as returned
18191 by C<keyword()>.  It must not be equal to 0.
18192
18193 =cut
18194 */
18195
18196 SV *
18197 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18198                           int * const opnum)
18199 {
18200     int i = 0, n = 0, seen_question = 0, defgv = 0;
18201     I32 oa;
18202 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18203     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18204     bool nullret = FALSE;
18205
18206     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18207
18208     assert (code);
18209
18210     if (!sv) sv = sv_newmortal();
18211
18212 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18213
18214     switch (code < 0 ? -code : code) {
18215     case KEY_and   : case KEY_chop: case KEY_chomp:
18216     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
18217     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
18218     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
18219     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
18220     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
18221     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
18222     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
18223     case KEY_x     : case KEY_xor    :
18224         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18225     case KEY_glob:    retsetpvs("_;", OP_GLOB);
18226     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
18227     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
18228     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
18229     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
18230     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18231         retsetpvs("", 0);
18232     case KEY_evalbytes:
18233         name = "entereval"; break;
18234     case KEY_readpipe:
18235         name = "backtick";
18236     }
18237
18238 #undef retsetpvs
18239
18240   findopnum:
18241     while (i < MAXO) {  /* The slow way. */
18242         if (strEQ(name, PL_op_name[i])
18243             || strEQ(name, PL_op_desc[i]))
18244         {
18245             if (nullret) { assert(opnum); *opnum = i; return NULL; }
18246             goto found;
18247         }
18248         i++;
18249     }
18250     return NULL;
18251   found:
18252     defgv = PL_opargs[i] & OA_DEFGV;
18253     oa = PL_opargs[i] >> OASHIFT;
18254     while (oa) {
18255         if (oa & OA_OPTIONAL && !seen_question && (
18256               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18257         )) {
18258             seen_question = 1;
18259             str[n++] = ';';
18260         }
18261         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18262             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18263             /* But globs are already references (kinda) */
18264             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18265         ) {
18266             str[n++] = '\\';
18267         }
18268         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18269          && !scalar_mod_type(NULL, i)) {
18270             str[n++] = '[';
18271             str[n++] = '$';
18272             str[n++] = '@';
18273             str[n++] = '%';
18274             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18275             str[n++] = '*';
18276             str[n++] = ']';
18277         }
18278         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18279         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18280             str[n-1] = '_'; defgv = 0;
18281         }
18282         oa = oa >> 4;
18283     }
18284     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18285     str[n++] = '\0';
18286     sv_setpvn(sv, str, n - 1);
18287     if (opnum) *opnum = i;
18288     return sv;
18289 }
18290
18291 OP *
18292 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18293                       const int opnum)
18294 {
18295     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18296                                         newSVOP(OP_COREARGS,0,coreargssv);
18297     OP *o;
18298
18299     PERL_ARGS_ASSERT_CORESUB_OP;
18300
18301     switch(opnum) {
18302     case 0:
18303         return op_append_elem(OP_LINESEQ,
18304                        argop,
18305                        newSLICEOP(0,
18306                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18307                                   newOP(OP_CALLER,0)
18308                        )
18309                );
18310     case OP_EACH:
18311     case OP_KEYS:
18312     case OP_VALUES:
18313         o = newUNOP(OP_AVHVSWITCH,0,argop);
18314         o->op_private = opnum-OP_EACH;
18315         return o;
18316     case OP_SELECT: /* which represents OP_SSELECT as well */
18317         if (code)
18318             return newCONDOP(
18319                          0,
18320                          newBINOP(OP_GT, 0,
18321                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18322                                   newSVOP(OP_CONST, 0, newSVuv(1))
18323                                  ),
18324                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
18325                                     OP_SSELECT),
18326                          coresub_op(coreargssv, 0, OP_SELECT)
18327                    );
18328         /* FALLTHROUGH */
18329     default:
18330         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18331         case OA_BASEOP:
18332             return op_append_elem(
18333                         OP_LINESEQ, argop,
18334                         newOP(opnum,
18335                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
18336                                 ? OPpOFFBYONE << 8 : 0)
18337                    );
18338         case OA_BASEOP_OR_UNOP:
18339             if (opnum == OP_ENTEREVAL) {
18340                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18341                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18342             }
18343             else o = newUNOP(opnum,0,argop);
18344             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18345             else {
18346           onearg:
18347               if (is_handle_constructor(o, 1))
18348                 argop->op_private |= OPpCOREARGS_DEREF1;
18349               if (scalar_mod_type(NULL, opnum))
18350                 argop->op_private |= OPpCOREARGS_SCALARMOD;
18351             }
18352             return o;
18353         default:
18354             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18355             if (is_handle_constructor(o, 2))
18356                 argop->op_private |= OPpCOREARGS_DEREF2;
18357             if (opnum == OP_SUBSTR) {
18358                 o->op_private |= OPpMAYBE_LVSUB;
18359                 return o;
18360             }
18361             else goto onearg;
18362         }
18363     }
18364 }
18365
18366 void
18367 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18368                                SV * const *new_const_svp)
18369 {
18370     const char *hvname;
18371     bool is_const = !!CvCONST(old_cv);
18372     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18373
18374     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18375
18376     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18377         return;
18378         /* They are 2 constant subroutines generated from
18379            the same constant. This probably means that
18380            they are really the "same" proxy subroutine
18381            instantiated in 2 places. Most likely this is
18382            when a constant is exported twice.  Don't warn.
18383         */
18384     if (
18385         (ckWARN(WARN_REDEFINE)
18386          && !(
18387                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18388              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18389              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18390                  strEQ(hvname, "autouse"))
18391              )
18392         )
18393      || (is_const
18394          && ckWARN_d(WARN_REDEFINE)
18395          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18396         )
18397     )
18398         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18399                           is_const
18400                             ? "Constant subroutine %" SVf " redefined"
18401                             : "Subroutine %" SVf " redefined",
18402                           SVfARG(name));
18403 }
18404
18405 /*
18406 =head1 Hook manipulation
18407
18408 These functions provide convenient and thread-safe means of manipulating
18409 hook variables.
18410
18411 =cut
18412 */
18413
18414 /*
18415 =for apidoc wrap_op_checker
18416
18417 Puts a C function into the chain of check functions for a specified op
18418 type.  This is the preferred way to manipulate the L</PL_check> array.
18419 C<opcode> specifies which type of op is to be affected.  C<new_checker>
18420 is a pointer to the C function that is to be added to that opcode's
18421 check chain, and C<old_checker_p> points to the storage location where a
18422 pointer to the next function in the chain will be stored.  The value of
18423 C<new_checker> is written into the L</PL_check> array, while the value
18424 previously stored there is written to C<*old_checker_p>.
18425
18426 L</PL_check> is global to an entire process, and a module wishing to
18427 hook op checking may find itself invoked more than once per process,
18428 typically in different threads.  To handle that situation, this function
18429 is idempotent.  The location C<*old_checker_p> must initially (once
18430 per process) contain a null pointer.  A C variable of static duration
18431 (declared at file scope, typically also marked C<static> to give
18432 it internal linkage) will be implicitly initialised appropriately,
18433 if it does not have an explicit initialiser.  This function will only
18434 actually modify the check chain if it finds C<*old_checker_p> to be null.
18435 This function is also thread safe on the small scale.  It uses appropriate
18436 locking to avoid race conditions in accessing L</PL_check>.
18437
18438 When this function is called, the function referenced by C<new_checker>
18439 must be ready to be called, except for C<*old_checker_p> being unfilled.
18440 In a threading situation, C<new_checker> may be called immediately,
18441 even before this function has returned.  C<*old_checker_p> will always
18442 be appropriately set before C<new_checker> is called.  If C<new_checker>
18443 decides not to do anything special with an op that it is given (which
18444 is the usual case for most uses of op check hooking), it must chain the
18445 check function referenced by C<*old_checker_p>.
18446
18447 Taken all together, XS code to hook an op checker should typically look
18448 something like this:
18449
18450     static Perl_check_t nxck_frob;
18451     static OP *myck_frob(pTHX_ OP *op) {
18452         ...
18453         op = nxck_frob(aTHX_ op);
18454         ...
18455         return op;
18456     }
18457     BOOT:
18458         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18459
18460 If you want to influence compilation of calls to a specific subroutine,
18461 then use L</cv_set_call_checker_flags> rather than hooking checking of
18462 all C<entersub> ops.
18463
18464 =cut
18465 */
18466
18467 void
18468 Perl_wrap_op_checker(pTHX_ Optype opcode,
18469     Perl_check_t new_checker, Perl_check_t *old_checker_p)
18470 {
18471     dVAR;
18472
18473     PERL_UNUSED_CONTEXT;
18474     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18475     if (*old_checker_p) return;
18476     OP_CHECK_MUTEX_LOCK;
18477     if (!*old_checker_p) {
18478         *old_checker_p = PL_check[opcode];
18479         PL_check[opcode] = new_checker;
18480     }
18481     OP_CHECK_MUTEX_UNLOCK;
18482 }
18483
18484 #include "XSUB.h"
18485
18486 /* Efficient sub that returns a constant scalar value. */
18487 static void
18488 const_sv_xsub(pTHX_ CV* cv)
18489 {
18490     dXSARGS;
18491     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18492     PERL_UNUSED_ARG(items);
18493     if (!sv) {
18494         XSRETURN(0);
18495     }
18496     EXTEND(sp, 1);
18497     ST(0) = sv;
18498     XSRETURN(1);
18499 }
18500
18501 static void
18502 const_av_xsub(pTHX_ CV* cv)
18503 {
18504     dXSARGS;
18505     AV * const av = MUTABLE_AV(XSANY.any_ptr);
18506     SP -= items;
18507     assert(av);
18508 #ifndef DEBUGGING
18509     if (!av) {
18510         XSRETURN(0);
18511     }
18512 #endif
18513     if (SvRMAGICAL(av))
18514         Perl_croak(aTHX_ "Magical list constants are not supported");
18515     if (GIMME_V != G_ARRAY) {
18516         EXTEND(SP, 1);
18517         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18518         XSRETURN(1);
18519     }
18520     EXTEND(SP, AvFILLp(av)+1);
18521     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18522     XSRETURN(AvFILLp(av)+1);
18523 }
18524
18525 /* Copy an existing cop->cop_warnings field.
18526  * If it's one of the standard addresses, just re-use the address.
18527  * This is the e implementation for the DUP_WARNINGS() macro
18528  */
18529
18530 STRLEN*
18531 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18532 {
18533     Size_t size;
18534     STRLEN *new_warnings;
18535
18536     if (warnings == NULL || specialWARN(warnings))
18537         return warnings;
18538
18539     size = sizeof(*warnings) + *warnings;
18540
18541     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18542     Copy(warnings, new_warnings, size, char);
18543     return new_warnings;
18544 }
18545
18546 /*
18547  * ex: set ts=8 sts=4 sw=4 et:
18548  */