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     dVAR;
5506     BINOP *bop;
5507     OP *op;
5508
5509     if (!left)
5510         left = newOP(OP_NULL, 0);
5511     if (!right)
5512         right = newOP(OP_NULL, 0);
5513     scalar(left);
5514     scalar(right);
5515     NewOp(0, bop, 1, BINOP);
5516     op = (OP*)bop;
5517     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5518     OpTYPE_set(op, type);
5519     cBINOPx(op)->op_flags = OPf_KIDS;
5520     cBINOPx(op)->op_private = 2;
5521     cBINOPx(op)->op_first = left;
5522     cBINOPx(op)->op_last = right;
5523     OpMORESIB_set(left, right);
5524     OpLASTSIB_set(right, op);
5525     return op;
5526 }
5527
5528 OP *
5529 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
5530 {
5531     dVAR;
5532     BINOP *bop;
5533     OP *op;
5534
5535     PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
5536     if (!right)
5537         right = newOP(OP_NULL, 0);
5538     scalar(right);
5539     NewOp(0, bop, 1, BINOP);
5540     op = (OP*)bop;
5541     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
5542     OpTYPE_set(op, type);
5543     if (ch->op_type != OP_NULL) {
5544         UNOP *lch;
5545         OP *nch, *cleft, *cright;
5546         NewOp(0, lch, 1, UNOP);
5547         nch = (OP*)lch;
5548         OpTYPE_set(nch, OP_NULL);
5549         nch->op_flags = OPf_KIDS;
5550         cleft = cBINOPx(ch)->op_first;
5551         cright = cBINOPx(ch)->op_last;
5552         cBINOPx(ch)->op_first = NULL;
5553         cBINOPx(ch)->op_last = NULL;
5554         cBINOPx(ch)->op_private = 0;
5555         cBINOPx(ch)->op_flags = 0;
5556         cUNOPx(nch)->op_first = cright;
5557         OpMORESIB_set(cright, ch);
5558         OpMORESIB_set(ch, cleft);
5559         OpLASTSIB_set(cleft, nch);
5560         ch = nch;
5561     }
5562     OpMORESIB_set(right, op);
5563     OpMORESIB_set(op, cUNOPx(ch)->op_first);
5564     cUNOPx(ch)->op_first = right;
5565     return ch;
5566 }
5567
5568 OP *
5569 Perl_cmpchain_finish(pTHX_ OP *ch)
5570 {
5571     dVAR;
5572
5573     PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
5574     if (ch->op_type != OP_NULL) {
5575         OPCODE cmpoptype = ch->op_type;
5576         ch = CHECKOP(cmpoptype, ch);
5577         if(!ch->op_next && ch->op_type == cmpoptype)
5578             ch = fold_constants(op_integerize(op_std_init(ch)));
5579         return ch;
5580     } else {
5581         OP *condop = NULL;
5582         OP *rightarg = cUNOPx(ch)->op_first;
5583         cUNOPx(ch)->op_first = OpSIBLING(rightarg);
5584         OpLASTSIB_set(rightarg, NULL);
5585         while (1) {
5586             OP *cmpop = cUNOPx(ch)->op_first;
5587             OP *leftarg = OpSIBLING(cmpop);
5588             OPCODE cmpoptype = cmpop->op_type;
5589             OP *nextrightarg;
5590             bool is_last;
5591             is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
5592             OpLASTSIB_set(cmpop, NULL);
5593             OpLASTSIB_set(leftarg, NULL);
5594             if (is_last) {
5595                 ch->op_flags = 0;
5596                 op_free(ch);
5597                 nextrightarg = NULL;
5598             } else {
5599                 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
5600                 leftarg = newOP(OP_NULL, 0);
5601             }
5602             cBINOPx(cmpop)->op_first = leftarg;
5603             cBINOPx(cmpop)->op_last = rightarg;
5604             OpMORESIB_set(leftarg, rightarg);
5605             OpLASTSIB_set(rightarg, cmpop);
5606             cmpop->op_flags = OPf_KIDS;
5607             cmpop->op_private = 2;
5608             cmpop = CHECKOP(cmpoptype, cmpop);
5609             if(!cmpop->op_next && cmpop->op_type == cmpoptype)
5610                 cmpop = fold_constants(op_integerize(op_std_init(cmpop)));
5611             condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
5612                         cmpop;
5613             if (!nextrightarg)
5614                 return condop;
5615             rightarg = nextrightarg;
5616         }
5617     }
5618 }
5619
5620 /*
5621 =for apidoc op_scope
5622
5623 Wraps up an op tree with some additional ops so that at runtime a dynamic
5624 scope will be created.  The original ops run in the new dynamic scope,
5625 and then, provided that they exit normally, the scope will be unwound.
5626 The additional ops used to create and unwind the dynamic scope will
5627 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5628 instead if the ops are simple enough to not need the full dynamic scope
5629 structure.
5630
5631 =cut
5632 */
5633
5634 OP *
5635 Perl_op_scope(pTHX_ OP *o)
5636 {
5637     dVAR;
5638     if (o) {
5639         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5640             o = op_prepend_elem(OP_LINESEQ,
5641                     newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5642             OpTYPE_set(o, OP_LEAVE);
5643         }
5644         else if (o->op_type == OP_LINESEQ) {
5645             OP *kid;
5646             OpTYPE_set(o, OP_SCOPE);
5647             kid = ((LISTOP*)o)->op_first;
5648             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5649                 op_null(kid);
5650
5651                 /* The following deals with things like 'do {1 for 1}' */
5652                 kid = OpSIBLING(kid);
5653                 if (kid &&
5654                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5655                     op_null(kid);
5656             }
5657         }
5658         else
5659             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5660     }
5661     return o;
5662 }
5663
5664 OP *
5665 Perl_op_unscope(pTHX_ OP *o)
5666 {
5667     if (o && o->op_type == OP_LINESEQ) {
5668         OP *kid = cLISTOPo->op_first;
5669         for(; kid; kid = OpSIBLING(kid))
5670             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5671                 op_null(kid);
5672     }
5673     return o;
5674 }
5675
5676 /*
5677 =for apidoc block_start
5678
5679 Handles compile-time scope entry.
5680 Arranges for hints to be restored on block
5681 exit and also handles pad sequence numbers to make lexical variables scope
5682 right.  Returns a savestack index for use with C<block_end>.
5683
5684 =cut
5685 */
5686
5687 int
5688 Perl_block_start(pTHX_ int full)
5689 {
5690     const int retval = PL_savestack_ix;
5691
5692     PL_compiling.cop_seq = PL_cop_seqmax;
5693     COP_SEQMAX_INC;
5694     pad_block_start(full);
5695     SAVEHINTS();
5696     PL_hints &= ~HINT_BLOCK_SCOPE;
5697     SAVECOMPILEWARNINGS();
5698     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5699     SAVEI32(PL_compiling.cop_seq);
5700     PL_compiling.cop_seq = 0;
5701
5702     CALL_BLOCK_HOOKS(bhk_start, full);
5703
5704     return retval;
5705 }
5706
5707 /*
5708 =for apidoc block_end
5709
5710 Handles compile-time scope exit.  C<floor>
5711 is the savestack index returned by
5712 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5713 possibly modified.
5714
5715 =cut
5716 */
5717
5718 OP*
5719 Perl_block_end(pTHX_ I32 floor, OP *seq)
5720 {
5721     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5722     OP* retval = scalarseq(seq);
5723     OP *o;
5724
5725     /* XXX Is the null PL_parser check necessary here? */
5726     assert(PL_parser); /* Let’s find out under debugging builds.  */
5727     if (PL_parser && PL_parser->parsed_sub) {
5728         o = newSTATEOP(0, NULL, NULL);
5729         op_null(o);
5730         retval = op_append_elem(OP_LINESEQ, retval, o);
5731     }
5732
5733     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5734
5735     LEAVE_SCOPE(floor);
5736     if (needblockscope)
5737         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5738     o = pad_leavemy();
5739
5740     if (o) {
5741         /* pad_leavemy has created a sequence of introcv ops for all my
5742            subs declared in the block.  We have to replicate that list with
5743            clonecv ops, to deal with this situation:
5744
5745                sub {
5746                    my sub s1;
5747                    my sub s2;
5748                    sub s1 { state sub foo { \&s2 } }
5749                }->()
5750
5751            Originally, I was going to have introcv clone the CV and turn
5752            off the stale flag.  Since &s1 is declared before &s2, the
5753            introcv op for &s1 is executed (on sub entry) before the one for
5754            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5755            cloned, since it is a state sub) closes over &s2 and expects
5756            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5757            then &s2 is still marked stale.  Since &s1 is not active, and
5758            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5759            ble will not stay shared’ warning.  Because it is the same stub
5760            that will be used when the introcv op for &s2 is executed, clos-
5761            ing over it is safe.  Hence, we have to turn off the stale flag
5762            on all lexical subs in the block before we clone any of them.
5763            Hence, having introcv clone the sub cannot work.  So we create a
5764            list of ops like this:
5765
5766                lineseq
5767                   |
5768                   +-- introcv
5769                   |
5770                   +-- introcv
5771                   |
5772                   +-- introcv
5773                   |
5774                   .
5775                   .
5776                   .
5777                   |
5778                   +-- clonecv
5779                   |
5780                   +-- clonecv
5781                   |
5782                   +-- clonecv
5783                   |
5784                   .
5785                   .
5786                   .
5787          */
5788         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5789         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5790         for (;; kid = OpSIBLING(kid)) {
5791             OP *newkid = newOP(OP_CLONECV, 0);
5792             newkid->op_targ = kid->op_targ;
5793             o = op_append_elem(OP_LINESEQ, o, newkid);
5794             if (kid == last) break;
5795         }
5796         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5797     }
5798
5799     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5800
5801     return retval;
5802 }
5803
5804 /*
5805 =head1 Compile-time scope hooks
5806
5807 =for apidoc blockhook_register
5808
5809 Register a set of hooks to be called when the Perl lexical scope changes
5810 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5811
5812 =cut
5813 */
5814
5815 void
5816 Perl_blockhook_register(pTHX_ BHK *hk)
5817 {
5818     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5819
5820     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5821 }
5822
5823 void
5824 Perl_newPROG(pTHX_ OP *o)
5825 {
5826     OP *start;
5827
5828     PERL_ARGS_ASSERT_NEWPROG;
5829
5830     if (PL_in_eval) {
5831         PERL_CONTEXT *cx;
5832         I32 i;
5833         if (PL_eval_root)
5834                 return;
5835         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5836                                ((PL_in_eval & EVAL_KEEPERR)
5837                                 ? OPf_SPECIAL : 0), o);
5838
5839         cx = CX_CUR();
5840         assert(CxTYPE(cx) == CXt_EVAL);
5841
5842         if ((cx->blk_gimme & G_WANT) == G_VOID)
5843             scalarvoid(PL_eval_root);
5844         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5845             list(PL_eval_root);
5846         else
5847             scalar(PL_eval_root);
5848
5849         start = op_linklist(PL_eval_root);
5850         PL_eval_root->op_next = 0;
5851         i = PL_savestack_ix;
5852         SAVEFREEOP(o);
5853         ENTER;
5854         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5855         LEAVE;
5856         PL_savestack_ix = i;
5857     }
5858     else {
5859         if (o->op_type == OP_STUB) {
5860             /* This block is entered if nothing is compiled for the main
5861                program. This will be the case for an genuinely empty main
5862                program, or one which only has BEGIN blocks etc, so already
5863                run and freed.
5864
5865                Historically (5.000) the guard above was !o. However, commit
5866                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5867                c71fccf11fde0068, changed perly.y so that newPROG() is now
5868                called with the output of block_end(), which returns a new
5869                OP_STUB for the case of an empty optree. ByteLoader (and
5870                maybe other things) also take this path, because they set up
5871                PL_main_start and PL_main_root directly, without generating an
5872                optree.
5873
5874                If the parsing the main program aborts (due to parse errors,
5875                or due to BEGIN or similar calling exit), then newPROG()
5876                isn't even called, and hence this code path and its cleanups
5877                are skipped. This shouldn't make a make a difference:
5878                * a non-zero return from perl_parse is a failure, and
5879                  perl_destruct() should be called immediately.
5880                * however, if exit(0) is called during the parse, then
5881                  perl_parse() returns 0, and perl_run() is called. As
5882                  PL_main_start will be NULL, perl_run() will return
5883                  promptly, and the exit code will remain 0.
5884             */
5885
5886             PL_comppad_name = 0;
5887             PL_compcv = 0;
5888             S_op_destroy(aTHX_ o);
5889             return;
5890         }
5891         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5892         PL_curcop = &PL_compiling;
5893         start = LINKLIST(PL_main_root);
5894         PL_main_root->op_next = 0;
5895         S_process_optree(aTHX_ NULL, PL_main_root, start);
5896         if (!PL_parser->error_count)
5897             /* on error, leave CV slabbed so that ops left lying around
5898              * will eb cleaned up. Else unslab */
5899             cv_forget_slab(PL_compcv);
5900         PL_compcv = 0;
5901
5902         /* Register with debugger */
5903         if (PERLDB_INTER) {
5904             CV * const cv = get_cvs("DB::postponed", 0);
5905             if (cv) {
5906                 dSP;
5907                 PUSHMARK(SP);
5908                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5909                 PUTBACK;
5910                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5911             }
5912         }
5913     }
5914 }
5915
5916 OP *
5917 Perl_localize(pTHX_ OP *o, I32 lex)
5918 {
5919     PERL_ARGS_ASSERT_LOCALIZE;
5920
5921     if (o->op_flags & OPf_PARENS)
5922 /* [perl #17376]: this appears to be premature, and results in code such as
5923    C< our(%x); > executing in list mode rather than void mode */
5924 #if 0
5925         list(o);
5926 #else
5927         NOOP;
5928 #endif
5929     else {
5930         if ( PL_parser->bufptr > PL_parser->oldbufptr
5931             && PL_parser->bufptr[-1] == ','
5932             && ckWARN(WARN_PARENTHESIS))
5933         {
5934             char *s = PL_parser->bufptr;
5935             bool sigil = FALSE;
5936
5937             /* some heuristics to detect a potential error */
5938             while (*s && (memCHRs(", \t\n", *s)))
5939                 s++;
5940
5941             while (1) {
5942                 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5943                        && *++s
5944                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5945                     s++;
5946                     sigil = TRUE;
5947                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5948                         s++;
5949                     while (*s && (memCHRs(", \t\n", *s)))
5950                         s++;
5951                 }
5952                 else
5953                     break;
5954             }
5955             if (sigil && (*s == ';' || *s == '=')) {
5956                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5957                                 "Parentheses missing around \"%s\" list",
5958                                 lex
5959                                     ? (PL_parser->in_my == KEY_our
5960                                         ? "our"
5961                                         : PL_parser->in_my == KEY_state
5962                                             ? "state"
5963                                             : "my")
5964                                     : "local");
5965             }
5966         }
5967     }
5968     if (lex)
5969         o = my(o);
5970     else
5971         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5972     PL_parser->in_my = FALSE;
5973     PL_parser->in_my_stash = NULL;
5974     return o;
5975 }
5976
5977 OP *
5978 Perl_jmaybe(pTHX_ OP *o)
5979 {
5980     PERL_ARGS_ASSERT_JMAYBE;
5981
5982     if (o->op_type == OP_LIST) {
5983         OP * const o2
5984             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5985         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5986     }
5987     return o;
5988 }
5989
5990 PERL_STATIC_INLINE OP *
5991 S_op_std_init(pTHX_ OP *o)
5992 {
5993     I32 type = o->op_type;
5994
5995     PERL_ARGS_ASSERT_OP_STD_INIT;
5996
5997     if (PL_opargs[type] & OA_RETSCALAR)
5998         scalar(o);
5999     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
6000         o->op_targ = pad_alloc(type, SVs_PADTMP);
6001
6002     return o;
6003 }
6004
6005 PERL_STATIC_INLINE OP *
6006 S_op_integerize(pTHX_ OP *o)
6007 {
6008     I32 type = o->op_type;
6009
6010     PERL_ARGS_ASSERT_OP_INTEGERIZE;
6011
6012     /* integerize op. */
6013     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
6014     {
6015         dVAR;
6016         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
6017     }
6018
6019     if (type == OP_NEGATE)
6020         /* XXX might want a ck_negate() for this */
6021         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
6022
6023     return o;
6024 }
6025
6026 /* This function exists solely to provide a scope to limit
6027    setjmp/longjmp() messing with auto variables.  It cannot be inlined because
6028    it uses setjmp
6029  */
6030 STATIC int
6031 S_fold_constants_eval(pTHX) {
6032     int ret = 0;
6033     dJMPENV;
6034
6035     JMPENV_PUSH(ret);
6036
6037     if (ret == 0) {
6038         CALLRUNOPS(aTHX);
6039     }
6040
6041     JMPENV_POP;
6042
6043     return ret;
6044 }
6045
6046 static OP *
6047 S_fold_constants(pTHX_ OP *const o)
6048 {
6049     dVAR;
6050     OP *curop;
6051     OP *newop;
6052     I32 type = o->op_type;
6053     bool is_stringify;
6054     SV *sv = NULL;
6055     int ret = 0;
6056     OP *old_next;
6057     SV * const oldwarnhook = PL_warnhook;
6058     SV * const olddiehook  = PL_diehook;
6059     COP not_compiling;
6060     U8 oldwarn = PL_dowarn;
6061     I32 old_cxix;
6062
6063     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
6064
6065     if (!(PL_opargs[type] & OA_FOLDCONST))
6066         goto nope;
6067
6068     switch (type) {
6069     case OP_UCFIRST:
6070     case OP_LCFIRST:
6071     case OP_UC:
6072     case OP_LC:
6073     case OP_FC:
6074 #ifdef USE_LOCALE_CTYPE
6075         if (IN_LC_COMPILETIME(LC_CTYPE))
6076             goto nope;
6077 #endif
6078         break;
6079     case OP_SLT:
6080     case OP_SGT:
6081     case OP_SLE:
6082     case OP_SGE:
6083     case OP_SCMP:
6084 #ifdef USE_LOCALE_COLLATE
6085         if (IN_LC_COMPILETIME(LC_COLLATE))
6086             goto nope;
6087 #endif
6088         break;
6089     case OP_SPRINTF:
6090         /* XXX what about the numeric ops? */
6091 #ifdef USE_LOCALE_NUMERIC
6092         if (IN_LC_COMPILETIME(LC_NUMERIC))
6093             goto nope;
6094 #endif
6095         break;
6096     case OP_PACK:
6097         if (!OpHAS_SIBLING(cLISTOPo->op_first)
6098           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
6099             goto nope;
6100         {
6101             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
6102             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
6103             {
6104                 const char *s = SvPVX_const(sv);
6105                 while (s < SvEND(sv)) {
6106                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
6107                     s++;
6108                 }
6109             }
6110         }
6111         break;
6112     case OP_REPEAT:
6113         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
6114         break;
6115     case OP_SREFGEN:
6116         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
6117          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
6118             goto nope;
6119     }
6120
6121     if (PL_parser && PL_parser->error_count)
6122         goto nope;              /* Don't try to run w/ errors */
6123
6124     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
6125         switch (curop->op_type) {
6126         case OP_CONST:
6127             if (   (curop->op_private & OPpCONST_BARE)
6128                 && (curop->op_private & OPpCONST_STRICT)) {
6129                 no_bareword_allowed(curop);
6130                 goto nope;
6131             }
6132             /* FALLTHROUGH */
6133         case OP_LIST:
6134         case OP_SCALAR:
6135         case OP_NULL:
6136         case OP_PUSHMARK:
6137             /* Foldable; move to next op in list */
6138             break;
6139
6140         default:
6141             /* No other op types are considered foldable */
6142             goto nope;
6143         }
6144     }
6145
6146     curop = LINKLIST(o);
6147     old_next = o->op_next;
6148     o->op_next = 0;
6149     PL_op = curop;
6150
6151     old_cxix = cxstack_ix;
6152     create_eval_scope(NULL, G_FAKINGEVAL);
6153
6154     /* Verify that we don't need to save it:  */
6155     assert(PL_curcop == &PL_compiling);
6156     StructCopy(&PL_compiling, &not_compiling, COP);
6157     PL_curcop = &not_compiling;
6158     /* The above ensures that we run with all the correct hints of the
6159        currently compiling COP, but that IN_PERL_RUNTIME is true. */
6160     assert(IN_PERL_RUNTIME);
6161     PL_warnhook = PERL_WARNHOOK_FATAL;
6162     PL_diehook  = NULL;
6163
6164     /* Effective $^W=1.  */
6165     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6166         PL_dowarn |= G_WARN_ON;
6167
6168     ret = S_fold_constants_eval(aTHX);
6169
6170     switch (ret) {
6171     case 0:
6172         sv = *(PL_stack_sp--);
6173         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
6174             pad_swipe(o->op_targ,  FALSE);
6175         }
6176         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
6177             SvREFCNT_inc_simple_void(sv);
6178             SvTEMP_off(sv);
6179         }
6180         else { assert(SvIMMORTAL(sv)); }
6181         break;
6182     case 3:
6183         /* Something tried to die.  Abandon constant folding.  */
6184         /* Pretend the error never happened.  */
6185         CLEAR_ERRSV();
6186         o->op_next = old_next;
6187         break;
6188     default:
6189         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
6190         PL_warnhook = oldwarnhook;
6191         PL_diehook  = olddiehook;
6192         /* XXX note that this croak may fail as we've already blown away
6193          * the stack - eg any nested evals */
6194         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6195     }
6196     PL_dowarn   = oldwarn;
6197     PL_warnhook = oldwarnhook;
6198     PL_diehook  = olddiehook;
6199     PL_curcop = &PL_compiling;
6200
6201     /* if we croaked, depending on how we croaked the eval scope
6202      * may or may not have already been popped */
6203     if (cxstack_ix > old_cxix) {
6204         assert(cxstack_ix == old_cxix + 1);
6205         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6206         delete_eval_scope();
6207     }
6208     if (ret)
6209         goto nope;
6210
6211     /* OP_STRINGIFY and constant folding are used to implement qq.
6212        Here the constant folding is an implementation detail that we
6213        want to hide.  If the stringify op is itself already marked
6214        folded, however, then it is actually a folded join.  */
6215     is_stringify = type == OP_STRINGIFY && !o->op_folded;
6216     op_free(o);
6217     assert(sv);
6218     if (is_stringify)
6219         SvPADTMP_off(sv);
6220     else if (!SvIMMORTAL(sv)) {
6221         SvPADTMP_on(sv);
6222         SvREADONLY_on(sv);
6223     }
6224     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6225     if (!is_stringify) newop->op_folded = 1;
6226     return newop;
6227
6228  nope:
6229     return o;
6230 }
6231
6232 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6233  * the constant value being an AV holding the flattened range.
6234  */
6235
6236 static void
6237 S_gen_constant_list(pTHX_ OP *o)
6238 {
6239     dVAR;
6240     OP *curop, *old_next;
6241     SV * const oldwarnhook = PL_warnhook;
6242     SV * const olddiehook  = PL_diehook;
6243     COP *old_curcop;
6244     U8 oldwarn = PL_dowarn;
6245     SV **svp;
6246     AV *av;
6247     I32 old_cxix;
6248     COP not_compiling;
6249     int ret = 0;
6250     dJMPENV;
6251     bool op_was_null;
6252
6253     list(o);
6254     if (PL_parser && PL_parser->error_count)
6255         return;         /* Don't attempt to run with errors */
6256
6257     curop = LINKLIST(o);
6258     old_next = o->op_next;
6259     o->op_next = 0;
6260     op_was_null = o->op_type == OP_NULL;
6261     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6262         o->op_type = OP_CUSTOM;
6263     CALL_PEEP(curop);
6264     if (op_was_null)
6265         o->op_type = OP_NULL;
6266     S_prune_chain_head(&curop);
6267     PL_op = curop;
6268
6269     old_cxix = cxstack_ix;
6270     create_eval_scope(NULL, G_FAKINGEVAL);
6271
6272     old_curcop = PL_curcop;
6273     StructCopy(old_curcop, &not_compiling, COP);
6274     PL_curcop = &not_compiling;
6275     /* The above ensures that we run with all the correct hints of the
6276        current COP, but that IN_PERL_RUNTIME is true. */
6277     assert(IN_PERL_RUNTIME);
6278     PL_warnhook = PERL_WARNHOOK_FATAL;
6279     PL_diehook  = NULL;
6280     JMPENV_PUSH(ret);
6281
6282     /* Effective $^W=1.  */
6283     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6284         PL_dowarn |= G_WARN_ON;
6285
6286     switch (ret) {
6287     case 0:
6288 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6289         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6290 #endif
6291         Perl_pp_pushmark(aTHX);
6292         CALLRUNOPS(aTHX);
6293         PL_op = curop;
6294         assert (!(curop->op_flags & OPf_SPECIAL));
6295         assert(curop->op_type == OP_RANGE);
6296         Perl_pp_anonlist(aTHX);
6297         break;
6298     case 3:
6299         CLEAR_ERRSV();
6300         o->op_next = old_next;
6301         break;
6302     default:
6303         JMPENV_POP;
6304         PL_warnhook = oldwarnhook;
6305         PL_diehook = olddiehook;
6306         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6307             ret);
6308     }
6309
6310     JMPENV_POP;
6311     PL_dowarn = oldwarn;
6312     PL_warnhook = oldwarnhook;
6313     PL_diehook = olddiehook;
6314     PL_curcop = old_curcop;
6315
6316     if (cxstack_ix > old_cxix) {
6317         assert(cxstack_ix == old_cxix + 1);
6318         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6319         delete_eval_scope();
6320     }
6321     if (ret)
6322         return;
6323
6324     OpTYPE_set(o, OP_RV2AV);
6325     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
6326     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
6327     o->op_opt = 0;              /* needs to be revisited in rpeep() */
6328     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6329
6330     /* replace subtree with an OP_CONST */
6331     curop = ((UNOP*)o)->op_first;
6332     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6333     op_free(curop);
6334
6335     if (AvFILLp(av) != -1)
6336         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6337         {
6338             SvPADTMP_on(*svp);
6339             SvREADONLY_on(*svp);
6340         }
6341     LINKLIST(o);
6342     list(o);
6343     return;
6344 }
6345
6346 /*
6347 =head1 Optree Manipulation Functions
6348 */
6349
6350 /* List constructors */
6351
6352 /*
6353 =for apidoc op_append_elem
6354
6355 Append an item to the list of ops contained directly within a list-type
6356 op, returning the lengthened list.  C<first> is the list-type op,
6357 and C<last> is the op to append to the list.  C<optype> specifies the
6358 intended opcode for the list.  If C<first> is not already a list of the
6359 right type, it will be upgraded into one.  If either C<first> or C<last>
6360 is null, the other is returned unchanged.
6361
6362 =cut
6363 */
6364
6365 OP *
6366 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6367 {
6368     if (!first)
6369         return last;
6370
6371     if (!last)
6372         return first;
6373
6374     if (first->op_type != (unsigned)type
6375         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6376     {
6377         return newLISTOP(type, 0, first, last);
6378     }
6379
6380     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6381     first->op_flags |= OPf_KIDS;
6382     return first;
6383 }
6384
6385 /*
6386 =for apidoc op_append_list
6387
6388 Concatenate the lists of ops contained directly within two list-type ops,
6389 returning the combined list.  C<first> and C<last> are the list-type ops
6390 to concatenate.  C<optype> specifies the intended opcode for the list.
6391 If either C<first> or C<last> is not already a list of the right type,
6392 it will be upgraded into one.  If either C<first> or C<last> is null,
6393 the other is returned unchanged.
6394
6395 =cut
6396 */
6397
6398 OP *
6399 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6400 {
6401     if (!first)
6402         return last;
6403
6404     if (!last)
6405         return first;
6406
6407     if (first->op_type != (unsigned)type)
6408         return op_prepend_elem(type, first, last);
6409
6410     if (last->op_type != (unsigned)type)
6411         return op_append_elem(type, first, last);
6412
6413     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6414     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6415     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6416     first->op_flags |= (last->op_flags & OPf_KIDS);
6417
6418     S_op_destroy(aTHX_ last);
6419
6420     return first;
6421 }
6422
6423 /*
6424 =for apidoc op_prepend_elem
6425
6426 Prepend an item to the list of ops contained directly within a list-type
6427 op, returning the lengthened list.  C<first> is the op to prepend to the
6428 list, and C<last> is the list-type op.  C<optype> specifies the intended
6429 opcode for the list.  If C<last> is not already a list of the right type,
6430 it will be upgraded into one.  If either C<first> or C<last> is null,
6431 the other is returned unchanged.
6432
6433 =cut
6434 */
6435
6436 OP *
6437 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6438 {
6439     if (!first)
6440         return last;
6441
6442     if (!last)
6443         return first;
6444
6445     if (last->op_type == (unsigned)type) {
6446         if (type == OP_LIST) {  /* already a PUSHMARK there */
6447             /* insert 'first' after pushmark */
6448             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6449             if (!(first->op_flags & OPf_PARENS))
6450                 last->op_flags &= ~OPf_PARENS;
6451         }
6452         else
6453             op_sibling_splice(last, NULL, 0, first);
6454         last->op_flags |= OPf_KIDS;
6455         return last;
6456     }
6457
6458     return newLISTOP(type, 0, first, last);
6459 }
6460
6461 /*
6462 =for apidoc op_convert_list
6463
6464 Converts C<o> into a list op if it is not one already, and then converts it
6465 into the specified C<type>, calling its check function, allocating a target if
6466 it needs one, and folding constants.
6467
6468 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6469 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
6470 C<op_convert_list> to make it the right type.
6471
6472 =cut
6473 */
6474
6475 OP *
6476 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6477 {
6478     dVAR;
6479     if (type < 0) type = -type, flags |= OPf_SPECIAL;
6480     if (!o || o->op_type != OP_LIST)
6481         o = force_list(o, 0);
6482     else
6483     {
6484         o->op_flags &= ~OPf_WANT;
6485         o->op_private &= ~OPpLVAL_INTRO;
6486     }
6487
6488     if (!(PL_opargs[type] & OA_MARK))
6489         op_null(cLISTOPo->op_first);
6490     else {
6491         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6492         if (kid2 && kid2->op_type == OP_COREARGS) {
6493             op_null(cLISTOPo->op_first);
6494             kid2->op_private |= OPpCOREARGS_PUSHMARK;
6495         }
6496     }
6497
6498     if (type != OP_SPLIT)
6499         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6500          * ck_split() create a real PMOP and leave the op's type as listop
6501          * for now. Otherwise op_free() etc will crash.
6502          */
6503         OpTYPE_set(o, type);
6504
6505     o->op_flags |= flags;
6506     if (flags & OPf_FOLDED)
6507         o->op_folded = 1;
6508
6509     o = CHECKOP(type, o);
6510     if (o->op_type != (unsigned)type)
6511         return o;
6512
6513     return fold_constants(op_integerize(op_std_init(o)));
6514 }
6515
6516 /* Constructors */
6517
6518
6519 /*
6520 =head1 Optree construction
6521
6522 =for apidoc newNULLLIST
6523
6524 Constructs, checks, and returns a new C<stub> op, which represents an
6525 empty list expression.
6526
6527 =cut
6528 */
6529
6530 OP *
6531 Perl_newNULLLIST(pTHX)
6532 {
6533     return newOP(OP_STUB, 0);
6534 }
6535
6536 /* promote o and any siblings to be a list if its not already; i.e.
6537  *
6538  *  o - A - B
6539  *
6540  * becomes
6541  *
6542  *  list
6543  *    |
6544  *  pushmark - o - A - B
6545  *
6546  * If nullit it true, the list op is nulled.
6547  */
6548
6549 static OP *
6550 S_force_list(pTHX_ OP *o, bool nullit)
6551 {
6552     if (!o || o->op_type != OP_LIST) {
6553         OP *rest = NULL;
6554         if (o) {
6555             /* manually detach any siblings then add them back later */
6556             rest = OpSIBLING(o);
6557             OpLASTSIB_set(o, NULL);
6558         }
6559         o = newLISTOP(OP_LIST, 0, o, NULL);
6560         if (rest)
6561             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6562     }
6563     if (nullit)
6564         op_null(o);
6565     return o;
6566 }
6567
6568 /*
6569 =for apidoc newLISTOP
6570
6571 Constructs, checks, and returns an op of any list type.  C<type> is
6572 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6573 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6574 supply up to two ops to be direct children of the list op; they are
6575 consumed by this function and become part of the constructed op tree.
6576
6577 For most list operators, the check function expects all the kid ops to be
6578 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6579 appropriate.  What you want to do in that case is create an op of type
6580 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6581 See L</op_convert_list> for more information.
6582
6583
6584 =cut
6585 */
6586
6587 OP *
6588 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6589 {
6590     dVAR;
6591     LISTOP *listop;
6592     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6593      * pushmark is banned. So do it now while existing ops are in a
6594      * consistent state, in case they suddenly get freed */
6595     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6596
6597     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6598         || type == OP_CUSTOM);
6599
6600     NewOp(1101, listop, 1, LISTOP);
6601     OpTYPE_set(listop, type);
6602     if (first || last)
6603         flags |= OPf_KIDS;
6604     listop->op_flags = (U8)flags;
6605
6606     if (!last && first)
6607         last = first;
6608     else if (!first && last)
6609         first = last;
6610     else if (first)
6611         OpMORESIB_set(first, last);
6612     listop->op_first = first;
6613     listop->op_last = last;
6614
6615     if (pushop) {
6616         OpMORESIB_set(pushop, first);
6617         listop->op_first = pushop;
6618         listop->op_flags |= OPf_KIDS;
6619         if (!last)
6620             listop->op_last = pushop;
6621     }
6622     if (listop->op_last)
6623         OpLASTSIB_set(listop->op_last, (OP*)listop);
6624
6625     return CHECKOP(type, listop);
6626 }
6627
6628 /*
6629 =for apidoc newOP
6630
6631 Constructs, checks, and returns an op of any base type (any type that
6632 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6633 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6634 of C<op_private>.
6635
6636 =cut
6637 */
6638
6639 OP *
6640 Perl_newOP(pTHX_ I32 type, I32 flags)
6641 {
6642     dVAR;
6643     OP *o;
6644
6645     if (type == -OP_ENTEREVAL) {
6646         type = OP_ENTEREVAL;
6647         flags |= OPpEVAL_BYTES<<8;
6648     }
6649
6650     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6651         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6652         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6653         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6654
6655     NewOp(1101, o, 1, OP);
6656     OpTYPE_set(o, type);
6657     o->op_flags = (U8)flags;
6658
6659     o->op_next = o;
6660     o->op_private = (U8)(0 | (flags >> 8));
6661     if (PL_opargs[type] & OA_RETSCALAR)
6662         scalar(o);
6663     if (PL_opargs[type] & OA_TARGET)
6664         o->op_targ = pad_alloc(type, SVs_PADTMP);
6665     return CHECKOP(type, o);
6666 }
6667
6668 /*
6669 =for apidoc newUNOP
6670
6671 Constructs, checks, and returns an op of any unary type.  C<type> is
6672 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6673 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6674 bits, the eight bits of C<op_private>, except that the bit with value 1
6675 is automatically set.  C<first> supplies an optional op to be the direct
6676 child of the unary op; it is consumed by this function and become part
6677 of the constructed op tree.
6678
6679 =for apidoc Amnh||OPf_KIDS
6680
6681 =cut
6682 */
6683
6684 OP *
6685 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6686 {
6687     dVAR;
6688     UNOP *unop;
6689
6690     if (type == -OP_ENTEREVAL) {
6691         type = OP_ENTEREVAL;
6692         flags |= OPpEVAL_BYTES<<8;
6693     }
6694
6695     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6696         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6697         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6698         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6699         || type == OP_SASSIGN
6700         || type == OP_ENTERTRY
6701         || type == OP_CUSTOM
6702         || type == OP_NULL );
6703
6704     if (!first)
6705         first = newOP(OP_STUB, 0);
6706     if (PL_opargs[type] & OA_MARK)
6707         first = force_list(first, 1);
6708
6709     NewOp(1101, unop, 1, UNOP);
6710     OpTYPE_set(unop, type);
6711     unop->op_first = first;
6712     unop->op_flags = (U8)(flags | OPf_KIDS);
6713     unop->op_private = (U8)(1 | (flags >> 8));
6714
6715     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6716         OpLASTSIB_set(first, (OP*)unop);
6717
6718     unop = (UNOP*) CHECKOP(type, unop);
6719     if (unop->op_next)
6720         return (OP*)unop;
6721
6722     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6723 }
6724
6725 /*
6726 =for apidoc newUNOP_AUX
6727
6728 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6729 initialised to C<aux>
6730
6731 =cut
6732 */
6733
6734 OP *
6735 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6736 {
6737     dVAR;
6738     UNOP_AUX *unop;
6739
6740     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6741         || type == OP_CUSTOM);
6742
6743     NewOp(1101, unop, 1, UNOP_AUX);
6744     unop->op_type = (OPCODE)type;
6745     unop->op_ppaddr = PL_ppaddr[type];
6746     unop->op_first = first;
6747     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6748     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6749     unop->op_aux = aux;
6750
6751     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6752         OpLASTSIB_set(first, (OP*)unop);
6753
6754     unop = (UNOP_AUX*) CHECKOP(type, unop);
6755
6756     return op_std_init((OP *) unop);
6757 }
6758
6759 /*
6760 =for apidoc newMETHOP
6761
6762 Constructs, checks, and returns an op of method type with a method name
6763 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6764 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6765 and, shifted up eight bits, the eight bits of C<op_private>, except that
6766 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6767 op which evaluates method name; it is consumed by this function and
6768 become part of the constructed op tree.
6769 Supported optypes: C<OP_METHOD>.
6770
6771 =cut
6772 */
6773
6774 static OP*
6775 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6776     dVAR;
6777     METHOP *methop;
6778
6779     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6780         || type == OP_CUSTOM);
6781
6782     NewOp(1101, methop, 1, METHOP);
6783     if (dynamic_meth) {
6784         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6785         methop->op_flags = (U8)(flags | OPf_KIDS);
6786         methop->op_u.op_first = dynamic_meth;
6787         methop->op_private = (U8)(1 | (flags >> 8));
6788
6789         if (!OpHAS_SIBLING(dynamic_meth))
6790             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6791     }
6792     else {
6793         assert(const_meth);
6794         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6795         methop->op_u.op_meth_sv = const_meth;
6796         methop->op_private = (U8)(0 | (flags >> 8));
6797         methop->op_next = (OP*)methop;
6798     }
6799
6800 #ifdef USE_ITHREADS
6801     methop->op_rclass_targ = 0;
6802 #else
6803     methop->op_rclass_sv = NULL;
6804 #endif
6805
6806     OpTYPE_set(methop, type);
6807     return CHECKOP(type, methop);
6808 }
6809
6810 OP *
6811 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6812     PERL_ARGS_ASSERT_NEWMETHOP;
6813     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6814 }
6815
6816 /*
6817 =for apidoc newMETHOP_named
6818
6819 Constructs, checks, and returns an op of method type with a constant
6820 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6821 C<op_flags>, and, shifted up eight bits, the eight bits of
6822 C<op_private>.  C<const_meth> supplies a constant method name;
6823 it must be a shared COW string.
6824 Supported optypes: C<OP_METHOD_NAMED>.
6825
6826 =cut
6827 */
6828
6829 OP *
6830 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6831     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6832     return newMETHOP_internal(type, flags, NULL, const_meth);
6833 }
6834
6835 /*
6836 =for apidoc newBINOP
6837
6838 Constructs, checks, and returns an op of any binary type.  C<type>
6839 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6840 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6841 the eight bits of C<op_private>, except that the bit with value 1 or
6842 2 is automatically set as required.  C<first> and C<last> supply up to
6843 two ops to be the direct children of the binary op; they are consumed
6844 by this function and become part of the constructed op tree.
6845
6846 =cut
6847 */
6848
6849 OP *
6850 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6851 {
6852     dVAR;
6853     BINOP *binop;
6854
6855     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6856         || type == OP_NULL || type == OP_CUSTOM);
6857
6858     NewOp(1101, binop, 1, BINOP);
6859
6860     if (!first)
6861         first = newOP(OP_NULL, 0);
6862
6863     OpTYPE_set(binop, type);
6864     binop->op_first = first;
6865     binop->op_flags = (U8)(flags | OPf_KIDS);
6866     if (!last) {
6867         last = first;
6868         binop->op_private = (U8)(1 | (flags >> 8));
6869     }
6870     else {
6871         binop->op_private = (U8)(2 | (flags >> 8));
6872         OpMORESIB_set(first, last);
6873     }
6874
6875     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6876         OpLASTSIB_set(last, (OP*)binop);
6877
6878     binop->op_last = OpSIBLING(binop->op_first);
6879     if (binop->op_last)
6880         OpLASTSIB_set(binop->op_last, (OP*)binop);
6881
6882     binop = (BINOP*)CHECKOP(type, binop);
6883     if (binop->op_next || binop->op_type != (OPCODE)type)
6884         return (OP*)binop;
6885
6886     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6887 }
6888
6889 void
6890 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6891 {
6892     const char indent[] = "    ";
6893
6894     UV len = _invlist_len(invlist);
6895     UV * array = invlist_array(invlist);
6896     UV i;
6897
6898     PERL_ARGS_ASSERT_INVMAP_DUMP;
6899
6900     for (i = 0; i < len; i++) {
6901         UV start = array[i];
6902         UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6903
6904         PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6905         if (end == IV_MAX) {
6906             PerlIO_printf(Perl_debug_log, " .. INFTY");
6907         }
6908         else if (end != start) {
6909             PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6910         }
6911         else {
6912             PerlIO_printf(Perl_debug_log, "            ");
6913         }
6914
6915         PerlIO_printf(Perl_debug_log, "\t");
6916
6917         if (map[i] == TR_UNLISTED) {
6918             PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6919         }
6920         else if (map[i] == TR_SPECIAL_HANDLING) {
6921             PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6922         }
6923         else {
6924             PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6925         }
6926     }
6927 }
6928
6929 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6930  * containing the search and replacement strings, assemble into
6931  * a translation table attached as o->op_pv.
6932  * Free expr and repl.
6933  * It expects the toker to have already set the
6934  *   OPpTRANS_COMPLEMENT
6935  *   OPpTRANS_SQUASH
6936  *   OPpTRANS_DELETE
6937  * flags as appropriate; this function may add
6938  *   OPpTRANS_USE_SVOP
6939  *   OPpTRANS_CAN_FORCE_UTF8
6940  *   OPpTRANS_IDENTICAL
6941  *   OPpTRANS_GROWS
6942  * flags
6943  */
6944
6945 static OP *
6946 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6947 {
6948     /* This function compiles a tr///, from data gathered from toke.c, into a
6949      * form suitable for use by do_trans() in doop.c at runtime.
6950      *
6951      * It first normalizes the data, while discarding extraneous inputs; then
6952      * writes out the compiled data.  The normalization allows for complete
6953      * analysis, and avoids some false negatives and positives earlier versions
6954      * of this code had.
6955      *
6956      * The normalization form is an inversion map (described below in detail).
6957      * This is essentially the compiled form for tr///'s that require UTF-8,
6958      * and its easy to use it to write the 257-byte table for tr///'s that
6959      * don't need UTF-8.  That table is identical to what's been in use for
6960      * many perl versions, except that it doesn't handle some edge cases that
6961      * it used to, involving code points above 255.  The UTF-8 form now handles
6962      * these.  (This could be changed with extra coding should it shown to be
6963      * desirable.)
6964      *
6965      * If the complement (/c) option is specified, the lhs string (tstr) is
6966      * parsed into an inversion list.  Complementing these is trivial.  Then a
6967      * complemented tstr is built from that, and used thenceforth.  This hides
6968      * the fact that it was complemented from almost all successive code.
6969      *
6970      * One of the important characteristics to know about the input is whether
6971      * the transliteration may be done in place, or does a temporary need to be
6972      * allocated, then copied.  If the replacement for every character in every
6973      * possible string takes up no more bytes than the the character it
6974      * replaces, then it can be edited in place.  Otherwise the replacement
6975      * could overwrite a byte we are about to read, depending on the strings
6976      * being processed.  The comments and variable names here refer to this as
6977      * "growing".  Some inputs won't grow, and might even shrink under /d, but
6978      * some inputs could grow, so we have to assume any given one might grow.
6979      * On very long inputs, the temporary could eat up a lot of memory, so we
6980      * want to avoid it if possible.  For non-UTF-8 inputs, everything is
6981      * single-byte, so can be edited in place, unless there is something in the
6982      * pattern that could force it into UTF-8.  The inversion map makes it
6983      * feasible to determine this.  Previous versions of this code pretty much
6984      * punted on determining if UTF-8 could be edited in place.  Now, this code
6985      * is rigorous in making that determination.
6986      *
6987      * Another characteristic we need to know is whether the lhs and rhs are
6988      * identical.  If so, and no other flags are present, the only effect of
6989      * the tr/// is to count the characters present in the input that are
6990      * mentioned in the lhs string.  The implementation of that is easier and
6991      * runs faster than the more general case.  Normalizing here allows for
6992      * accurate determination of this.  Previously there were false negatives
6993      * possible.
6994      *
6995      * Instead of 'transliterated', the comments here use 'unmapped' for the
6996      * characters that are left unchanged by the operation; otherwise they are
6997      * 'mapped'
6998      *
6999      * The lhs of the tr/// is here referred to as the t side.
7000      * The rhs of the tr/// is here referred to as the r side.
7001      */
7002
7003     SV * const tstr = ((SVOP*)expr)->op_sv;
7004     SV * const rstr = ((SVOP*)repl)->op_sv;
7005     STRLEN tlen;
7006     STRLEN rlen;
7007     const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
7008     const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
7009     const U8 * t = t0;
7010     const U8 * r = r0;
7011     UV t_count = 0, r_count = 0;  /* Number of characters in search and
7012                                          replacement lists */
7013
7014     /* khw thinks some of the private flags for this op are quaintly named.
7015      * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
7016      * character when represented in UTF-8 is longer than the original
7017      * character's UTF-8 representation */
7018     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
7019     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
7020     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
7021
7022     /* Set to true if there is some character < 256 in the lhs that maps to
7023      * above 255.  If so, a non-UTF-8 match string can be forced into being in
7024      * UTF-8 by a tr/// operation. */
7025     bool can_force_utf8 = FALSE;
7026
7027     /* What is the maximum expansion factor in UTF-8 transliterations.  If a
7028      * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
7029      * expansion factor is 1.5.  This number is used at runtime to calculate
7030      * how much space to allocate for non-inplace transliterations.  Without
7031      * this number, the worst case is 14, which is extremely unlikely to happen
7032      * in real life, and could require significant memory overhead. */
7033     NV max_expansion = 1.;
7034
7035     UV t_range_count, r_range_count, min_range_count;
7036     UV* t_array;
7037     SV* t_invlist;
7038     UV* r_map;
7039     UV r_cp, t_cp;
7040     UV t_cp_end = (UV) -1;
7041     UV r_cp_end;
7042     Size_t len;
7043     AV* invmap;
7044     UV final_map = TR_UNLISTED;    /* The final character in the replacement
7045                                       list, updated as we go along.  Initialize
7046                                       to something illegal */
7047
7048     bool rstr_utf8 = cBOOL(SvUTF8(rstr));
7049     bool tstr_utf8 = cBOOL(SvUTF8(tstr));
7050
7051     const U8* tend = t + tlen;
7052     const U8* rend = r + rlen;
7053
7054     SV * inverted_tstr = NULL;
7055
7056     Size_t i;
7057     unsigned int pass2;
7058
7059     /* This routine implements detection of a transliteration having a longer
7060      * UTF-8 representation than its source, by partitioning all the possible
7061      * code points of the platform into equivalence classes of the same UTF-8
7062      * byte length in the first pass.  As it constructs the mappings, it carves
7063      * these up into smaller chunks, but doesn't merge any together.  This
7064      * makes it easy to find the instances it's looking for.  A second pass is
7065      * done after this has been determined which merges things together to
7066      * shrink the table for runtime.  For ASCII platforms, the table is
7067      * trivial, given below, and uses the fundamental characteristics of UTF-8
7068      * to construct the values.  For EBCDIC, it isn't so, and we rely on a
7069      * table constructed by the perl script that generates these kinds of
7070      * things */
7071 #ifndef EBCDIC
7072     UV PL_partition_by_byte_length[] = {
7073         0,
7074         0x80,   /* Below this is 1 byte representations */
7075         (32 * (1UL << (    UTF_ACCUMULATION_SHIFT))),   /* 2 bytes below this */
7076         (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),   /* 3 bytes below this */
7077         ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),   /* 4 bytes below this */
7078         ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),   /* 5 bytes below this */
7079         ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))    /* 6 bytes below this */
7080
7081 #  ifdef UV_IS_QUAD
7082                                                     ,
7083         ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))    /* 7 bytes below this */
7084 #  endif
7085
7086     };
7087
7088 #endif
7089
7090     PERL_ARGS_ASSERT_PMTRANS;
7091
7092     PL_hints |= HINT_BLOCK_SCOPE;
7093
7094     /* If /c, the search list is sorted and complemented.  This is now done by
7095      * creating an inversion list from it, and then trivially inverting that.
7096      * The previous implementation used qsort, but creating the list
7097      * automatically keeps it sorted as we go along */
7098     if (complement) {
7099         UV start, end;
7100         SV * inverted_tlist = _new_invlist(tlen);
7101         Size_t temp_len;
7102
7103         DEBUG_y(PerlIO_printf(Perl_debug_log,
7104                     "%s: %d: tstr before inversion=\n%s\n",
7105                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7106
7107         while (t < tend) {
7108
7109             /* Non-utf8 strings don't have ranges, so each character is listed
7110              * out */
7111             if (! tstr_utf8) {
7112                 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
7113                 t++;
7114             }
7115             else {  /* But UTF-8 strings have been parsed in toke.c to have
7116                  * ranges if appropriate. */
7117                 UV t_cp;
7118                 Size_t t_char_len;
7119
7120                 /* Get the first character */
7121                 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7122                 t += t_char_len;
7123
7124                 /* If the next byte indicates that this wasn't the first
7125                  * element of a range, the range is just this one */
7126                 if (t >= tend || *t != RANGE_INDICATOR) {
7127                     inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
7128                 }
7129                 else { /* Otherwise, ignore the indicator byte, and get the
7130                           final element, and add the whole range */
7131                     t++;
7132                     t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
7133                     t += t_char_len;
7134
7135                     inverted_tlist = _add_range_to_invlist(inverted_tlist,
7136                                                       t_cp, t_cp_end);
7137                 }
7138             }
7139         } /* End of parse through tstr */
7140
7141         /* The inversion list is done; now invert it */
7142         _invlist_invert(inverted_tlist);
7143
7144         /* Now go through the inverted list and create a new tstr for the rest
7145          * of the routine to use.  Since the UTF-8 version can have ranges, and
7146          * can be much more compact than the non-UTF-8 version, we create the
7147          * string in UTF-8 even if not necessary.  (This is just an intermediate
7148          * value that gets thrown away anyway.) */
7149         invlist_iterinit(inverted_tlist);
7150         inverted_tstr = newSVpvs("");
7151         while (invlist_iternext(inverted_tlist, &start, &end)) {
7152             U8 temp[UTF8_MAXBYTES];
7153             U8 * temp_end_pos;
7154
7155             /* IV_MAX keeps things from going out of bounds */
7156             start = MIN(IV_MAX, start);
7157             end   = MIN(IV_MAX, end);
7158
7159             temp_end_pos = uvchr_to_utf8(temp, start);
7160             sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7161
7162             if (start != end) {
7163                 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7164                 temp_end_pos = uvchr_to_utf8(temp, end);
7165                 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7166             }
7167         }
7168
7169         /* Set up so the remainder of the routine uses this complement, instead
7170          * of the actual input */
7171         t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7172         tend = t0 + temp_len;
7173         tstr_utf8 = TRUE;
7174
7175         SvREFCNT_dec_NN(inverted_tlist);
7176     }
7177
7178     /* For non-/d, an empty rhs means to use the lhs */
7179     if (rlen == 0 && ! del) {
7180         r0 = t0;
7181         rend = tend;
7182         rstr_utf8  = tstr_utf8;
7183     }
7184
7185     t_invlist = _new_invlist(1);
7186
7187     /* Initialize to a single range */
7188     t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7189
7190     /* For the first pass, the lhs is partitioned such that the
7191      * number of UTF-8 bytes required to represent a code point in each
7192      * partition is the same as the number for any other code point in
7193      * that partion.  We copy the pre-compiled partion. */
7194     len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7195     invlist_extend(t_invlist, len);
7196     t_array = invlist_array(t_invlist);
7197     Copy(PL_partition_by_byte_length, t_array, len, UV);
7198     invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7199     Newx(r_map, len + 1, UV);
7200
7201     /* Parse the (potentially adjusted) input, creating the inversion map.
7202      * This is done in two passes.  The first pass is to determine if the
7203      * transliteration can be done in place.  The inversion map it creates
7204      * could be used, but generally would be larger and slower to run than the
7205      * output of the second pass, which starts with a more compact table and
7206      * allows more ranges to be merged */
7207     for (pass2 = 0; pass2 < 2; pass2++) {
7208         if (pass2) {
7209             /* Initialize to a single range */
7210             t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7211
7212             /* In the second pass, we just have the single range */
7213             len = 1;
7214             t_array = invlist_array(t_invlist);
7215         }
7216
7217         /* And the mapping of each of the ranges is initialized.  Initially,
7218          * everything is TR_UNLISTED. */
7219         for (i = 0; i < len; i++) {
7220             r_map[i] = TR_UNLISTED;
7221         }
7222
7223         t = t0;
7224         t_count = 0;
7225         r = r0;
7226         r_count = 0;
7227         t_range_count = r_range_count = 0;
7228
7229         DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7230                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7231         DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7232                                         _byte_dump_string(r, rend - r, 0)));
7233         DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7234                                                   complement, squash, del));
7235         DEBUG_y(invmap_dump(t_invlist, r_map));
7236
7237         /* Now go through the search list constructing an inversion map.  The
7238          * input is not necessarily in any particular order.  Making it an
7239          * inversion map orders it, potentially simplifying, and makes it easy
7240          * to deal with at run time.  This is the only place in core that
7241          * generates an inversion map; if others were introduced, it might be
7242          * better to create general purpose routines to handle them.
7243          * (Inversion maps are created in perl in other places.)
7244          *
7245          * An inversion map consists of two parallel arrays.  One is
7246          * essentially an inversion list: an ordered list of code points such
7247          * that each element gives the first code point of a range of
7248          * consecutive code points that map to the element in the other array
7249          * that has the same index as this one (in other words, the
7250          * corresponding element).  Thus the range extends up to (but not
7251          * including) the code point given by the next higher element.  In a
7252          * true inversion map, the corresponding element in the other array
7253          * gives the mapping of the first code point in the range, with the
7254          * understanding that the next higher code point in the inversion
7255          * list's range will map to the next higher code point in the map.
7256          *
7257          * So if at element [i], let's say we have:
7258          *
7259          *     t_invlist  r_map
7260          * [i]    A         a
7261          *
7262          * This means that A => a, B => b, C => c....  Let's say that the
7263          * situation is such that:
7264          *
7265          * [i+1]  L        -1
7266          *
7267          * This means the sequence that started at [i] stops at K => k.  This
7268          * illustrates that you need to look at the next element to find where
7269          * a sequence stops.  Except, the highest element in the inversion list
7270          * begins a range that is understood to extend to the platform's
7271          * infinity.
7272          *
7273          * This routine modifies traditional inversion maps to reserve two
7274          * mappings:
7275          *
7276          *  TR_UNLISTED (or -1) indicates that no code point in the range
7277          *      is listed in the tr/// searchlist.  At runtime, these are
7278          *      always passed through unchanged.  In the inversion map, all
7279          *      points in the range are mapped to -1, instead of increasing,
7280          *      like the 'L' in the example above.
7281          *
7282          *      We start the parse with every code point mapped to this, and as
7283          *      we parse and find ones that are listed in the search list, we
7284          *      carve out ranges as we go along that override that.
7285          *
7286          *  TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7287          *      range needs special handling.  Again, all code points in the
7288          *      range are mapped to -2, instead of increasing.
7289          *
7290          *      Under /d this value means the code point should be deleted from
7291          *      the transliteration when encountered.
7292          *
7293          *      Otherwise, it marks that every code point in the range is to
7294          *      map to the final character in the replacement list.  This
7295          *      happens only when the replacement list is shorter than the
7296          *      search one, so there are things in the search list that have no
7297          *      correspondence in the replacement list.  For example, in
7298          *      tr/a-z/A/, 'A' is the final value, and the inversion map
7299          *      generated for this would be like this:
7300          *          \0  =>  -1
7301          *          a   =>   A
7302          *          b-z =>  -2
7303          *          z+1 =>  -1
7304          *      'A' appears once, then the remainder of the range maps to -2.
7305          *      The use of -2 isn't strictly necessary, as an inversion map is
7306          *      capable of representing this situation, but not nearly so
7307          *      compactly, and this is actually quite commonly encountered.
7308          *      Indeed, the original design of this code used a full inversion
7309          *      map for this.  But things like
7310          *          tr/\0-\x{FFFF}/A/
7311          *      generated huge data structures, slowly, and the execution was
7312          *      also slow.  So the current scheme was implemented.
7313          *
7314          *  So, if the next element in our example is:
7315          *
7316          * [i+2]  Q        q
7317          *
7318          * Then all of L, M, N, O, and P map to TR_UNLISTED.  If the next
7319          * elements are
7320          *
7321          * [i+3]  R        z
7322          * [i+4]  S       TR_UNLISTED
7323          *
7324          * Then Q => q; R => z; and S => TR_UNLISTED.  If [i+4] (the 'S') is
7325          * the final element in the arrays, every code point from S to infinity
7326          * maps to TR_UNLISTED.
7327          *
7328          */
7329                            /* Finish up range started in what otherwise would
7330                             * have been the final iteration */
7331         while (t < tend || t_range_count > 0) {
7332             bool adjacent_to_range_above = FALSE;
7333             bool adjacent_to_range_below = FALSE;
7334
7335             bool merge_with_range_above = FALSE;
7336             bool merge_with_range_below = FALSE;
7337
7338             UV span, invmap_range_length_remaining;
7339             SSize_t j;
7340             Size_t i;
7341
7342             /* If we are in the middle of processing a range in the 'target'
7343              * side, the previous iteration has set us up.  Otherwise, look at
7344              * the next character in the search list */
7345             if (t_range_count <= 0) {
7346                 if (! tstr_utf8) {
7347
7348                     /* Here, not in the middle of a range, and not UTF-8.  The
7349                      * next code point is the single byte where we're at */
7350                     t_cp = *t;
7351                     t_range_count = 1;
7352                     t++;
7353                 }
7354                 else {
7355                     Size_t t_char_len;
7356
7357                     /* Here, not in the middle of a range, and is UTF-8.  The
7358                      * next code point is the next UTF-8 char in the input.  We
7359                      * know the input is valid, because the toker constructed
7360                      * it */
7361                     t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7362                     t += t_char_len;
7363
7364                     /* UTF-8 strings (only) have been parsed in toke.c to have
7365                      * ranges.  See if the next byte indicates that this was
7366                      * the first element of a range.  If so, get the final
7367                      * element and calculate the range size.  If not, the range
7368                      * size is 1 */
7369                     if (t < tend && *t == RANGE_INDICATOR) {
7370                         t++;
7371                         t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7372                                       - t_cp + 1;
7373                         t += t_char_len;
7374                     }
7375                     else {
7376                         t_range_count = 1;
7377                     }
7378                 }
7379
7380                 /* Count the total number of listed code points * */
7381                 t_count += t_range_count;
7382             }
7383
7384             /* Similarly, get the next character in the replacement list */
7385             if (r_range_count <= 0) {
7386                 if (r >= rend) {
7387
7388                     /* But if we've exhausted the rhs, there is nothing to map
7389                      * to, except the special handling one, and we make the
7390                      * range the same size as the lhs one. */
7391                     r_cp = TR_SPECIAL_HANDLING;
7392                     r_range_count = t_range_count;
7393
7394                     if (! del) {
7395                         DEBUG_yv(PerlIO_printf(Perl_debug_log,
7396                                         "final_map =%" UVXf "\n", final_map));
7397                     }
7398                 }
7399                 else {
7400                     if (! rstr_utf8) {
7401                         r_cp = *r;
7402                         r_range_count = 1;
7403                         r++;
7404                     }
7405                     else {
7406                         Size_t r_char_len;
7407
7408                         r_cp = valid_utf8_to_uvchr(r, &r_char_len);
7409                         r += r_char_len;
7410                         if (r < rend && *r == RANGE_INDICATOR) {
7411                             r++;
7412                             r_range_count = valid_utf8_to_uvchr(r,
7413                                                     &r_char_len) - r_cp + 1;
7414                             r += r_char_len;
7415                         }
7416                         else {
7417                             r_range_count = 1;
7418                         }
7419                     }
7420
7421                     if (r_cp == TR_SPECIAL_HANDLING) {
7422                         r_range_count = t_range_count;
7423                     }
7424
7425                     /* This is the final character so far */
7426                     final_map = r_cp + r_range_count - 1;
7427
7428                     r_count += r_range_count;
7429                 }
7430             }
7431
7432             /* Here, we have the next things ready in both sides.  They are
7433              * potentially ranges.  We try to process as big a chunk as
7434              * possible at once, but the lhs and rhs must be synchronized, so
7435              * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7436              * */
7437             min_range_count = MIN(t_range_count, r_range_count);
7438
7439             /* Search the inversion list for the entry that contains the input
7440              * code point <cp>.  The inversion map was initialized to cover the
7441              * entire range of possible inputs, so this should not fail.  So
7442              * the return value is the index into the list's array of the range
7443              * that contains <cp>, that is, 'i' such that array[i] <= cp <
7444              * array[i+1] */
7445             j = _invlist_search(t_invlist, t_cp);
7446             assert(j >= 0);
7447             i = j;
7448
7449             /* Here, the data structure might look like:
7450              *
7451              * index    t   r     Meaning
7452              * [i-1]    J   j   # J-L => j-l
7453              * [i]      M  -1   # M => default; as do N, O, P, Q
7454              * [i+1]    R   x   # R => x, S => x+1, T => x+2
7455              * [i+2]    U   y   # U => y, V => y+1, ...
7456              * ...
7457              * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7458              *
7459              * where 'x' and 'y' above are not to be taken literally.
7460              *
7461              * The maximum chunk we can handle in this loop iteration, is the
7462              * smallest of the three components: the lhs 't_', the rhs 'r_',
7463              * and the remainder of the range in element [i].  (In pass 1, that
7464              * range will have everything in it be of the same class; we can't
7465              * cross into another class.)  'min_range_count' already contains
7466              * the smallest of the first two values.  The final one is
7467              * irrelevant if the map is to the special indicator */
7468
7469             invmap_range_length_remaining = (i + 1 < len)
7470                                             ? t_array[i+1] - t_cp
7471                                             : IV_MAX - t_cp;
7472             span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7473
7474             /* The end point of this chunk is where we are, plus the span, but
7475              * never larger than the platform's infinity */
7476             t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7477
7478             if (r_cp == TR_SPECIAL_HANDLING) {
7479
7480                 /* If unmatched lhs code points map to the final map, use that
7481                  * value.  This being set to TR_SPECIAL_HANDLING indicates that
7482                  * we don't have a final map: unmatched lhs code points are
7483                  * simply deleted */
7484                 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
7485             }
7486             else {
7487                 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7488
7489                 /* If something on the lhs is below 256, and something on the
7490                  * rhs is above, there is a potential mapping here across that
7491                  * boundary.  Indeed the only way there isn't is if both sides
7492                  * start at the same point.  That means they both cross at the
7493                  * same time.  But otherwise one crosses before the other */
7494                 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7495                     can_force_utf8 = TRUE;
7496                 }
7497             }
7498
7499             /* If a character appears in the search list more than once, the
7500              * 2nd and succeeding occurrences are ignored, so only do this
7501              * range if haven't already processed this character.  (The range
7502              * has been set up so that all members in it will be of the same
7503              * ilk) */
7504             if (r_map[i] == TR_UNLISTED) {
7505                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7506                     "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7507                     t_cp, t_cp_end, r_cp, r_cp_end));
7508
7509                 /* This is the first definition for this chunk, hence is valid
7510                  * and needs to be processed.  Here and in the comments below,
7511                  * we use the above sample data.  The t_cp chunk must be any
7512                  * contiguous subset of M, N, O, P, and/or Q.
7513                  *
7514                  * In the first pass, calculate if there is any possible input
7515                  * string that has a character whose transliteration will be
7516                  * longer than it.  If none, the transliteration may be done
7517                  * in-place, as it can't write over a so-far unread byte.
7518                  * Otherwise, a copy must first be made.  This could be
7519                  * expensive for long inputs.
7520                  *
7521                  * In the first pass, the t_invlist has been partitioned so
7522                  * that all elements in any single range have the same number
7523                  * of bytes in their UTF-8 representations.  And the r space is
7524                  * either a single byte, or a range of strictly monotonically
7525                  * increasing code points.  So the final element in the range
7526                  * will be represented by no fewer bytes than the initial one.
7527                  * That means that if the final code point in the t range has
7528                  * at least as many bytes as the final code point in the r,
7529                  * then all code points in the t range have at least as many
7530                  * bytes as their corresponding r range element.  But if that's
7531                  * not true, the transliteration of at least the final code
7532                  * point grows in length.  As an example, suppose we had
7533                  *      tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7534                  * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7535                  * platforms.  We have deliberately set up the data structure
7536                  * so that any range in the lhs gets split into chunks for
7537                  * processing, such that every code point in a chunk has the
7538                  * same number of UTF-8 bytes.  We only have to check the final
7539                  * code point in the rhs against any code point in the lhs. */
7540                 if ( ! pass2
7541                     && r_cp_end != TR_SPECIAL_HANDLING
7542                     && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end))
7543                 {
7544                     /* Here, we will need to make a copy of the input string
7545                      * before doing the transliteration.  The worst possible
7546                      * case is an expansion ratio of 14:1. This is rare, and
7547                      * we'd rather allocate only the necessary amount of extra
7548                      * memory for that copy.  We can calculate the worst case
7549                      * for this particular transliteration is by keeping track
7550                      * of the expansion factor for each range.
7551                      *
7552                      * Consider tr/\xCB/\X{E000}/.  The maximum expansion
7553                      * factor is 1 byte going to 3 if the target string is not
7554                      * UTF-8, but 2 bytes going to 3 if it is in UTF-8.  We
7555                      * could pass two different values so doop could choose
7556                      * based on the UTF-8ness of the target.  But khw thinks
7557                      * (perhaps wrongly) that is overkill.  It is used only to
7558                      * make sure we malloc enough space.
7559                      *
7560                      * If no target string can force the result to be UTF-8,
7561                      * then we don't have to worry about the case of the target
7562                      * string not being UTF-8 */
7563                     NV t_size = (can_force_utf8 && t_cp < 256)
7564                                 ? 1
7565                                 : UVCHR_SKIP(t_cp_end);
7566                     NV ratio = UVCHR_SKIP(r_cp_end) / t_size;
7567
7568                     o->op_private |= OPpTRANS_GROWS;
7569
7570                     /* Now that we know it grows, we can keep track of the
7571                      * largest ratio */
7572                     if (ratio > max_expansion) {
7573                         max_expansion = ratio;
7574                         DEBUG_y(PerlIO_printf(Perl_debug_log,
7575                                         "New expansion factor: %" NVgf "\n",
7576                                         max_expansion));
7577                     }
7578                 }
7579
7580                 /* The very first range is marked as adjacent to the
7581                  * non-existent range below it, as it causes things to "just
7582                  * work" (TradeMark)
7583                  *
7584                  * If the lowest code point in this chunk is M, it adjoins the
7585                  * J-L range */
7586                 if (t_cp == t_array[i]) {
7587                     adjacent_to_range_below = TRUE;
7588
7589                     /* And if the map has the same offset from the beginning of
7590                      * the range as does this new code point (or both are for
7591                      * TR_SPECIAL_HANDLING), this chunk can be completely
7592                      * merged with the range below.  EXCEPT, in the first pass,
7593                      * we don't merge ranges whose UTF-8 byte representations
7594                      * have different lengths, so that we can more easily
7595                      * detect if a replacement is longer than the source, that
7596                      * is if it 'grows'.  But in the 2nd pass, there's no
7597                      * reason to not merge */
7598                     if (   (i > 0 && (   pass2
7599                                       || UVCHR_SKIP(t_array[i-1])
7600                                                         == UVCHR_SKIP(t_cp)))
7601                         && (   (   r_cp == TR_SPECIAL_HANDLING
7602                                 && r_map[i-1] == TR_SPECIAL_HANDLING)
7603                             || (   r_cp != TR_SPECIAL_HANDLING
7604                                 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7605                     {
7606                         merge_with_range_below = TRUE;
7607                     }
7608                 }
7609
7610                 /* Similarly, if the highest code point in this chunk is 'Q',
7611                  * it adjoins the range above, and if the map is suitable, can
7612                  * be merged with it */
7613                 if (    t_cp_end >= IV_MAX - 1
7614                     || (   i + 1 < len
7615                         && t_cp_end + 1 == t_array[i+1]))
7616                 {
7617                     adjacent_to_range_above = TRUE;
7618                     if (i + 1 < len)
7619                     if (    (   pass2
7620                              || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1]))
7621                         && (   (   r_cp == TR_SPECIAL_HANDLING
7622                                 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7623                             || (   r_cp != TR_SPECIAL_HANDLING
7624                                 && r_cp_end == r_map[i+1] - 1)))
7625                     {
7626                         merge_with_range_above = TRUE;
7627                     }
7628                 }
7629
7630                 if (merge_with_range_below && merge_with_range_above) {
7631
7632                     /* Here the new chunk looks like M => m, ... Q => q; and
7633                      * the range above is like R => r, ....  Thus, the [i-1]
7634                      * and [i+1] ranges should be seamlessly melded so the
7635                      * result looks like
7636                      *
7637                      * [i-1]    J   j   # J-T => j-t
7638                      * [i]      U   y   # U => y, V => y+1, ...
7639                      * ...
7640                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7641                      */
7642                     Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7643                     Move(r_map   + i + 2, r_map   + i, len - i - 2, UV);
7644                     len -= 2;
7645                     invlist_set_len(t_invlist,
7646                                     len,
7647                                     *(get_invlist_offset_addr(t_invlist)));
7648                 }
7649                 else if (merge_with_range_below) {
7650
7651                     /* Here the new chunk looks like M => m, .... But either
7652                      * (or both) it doesn't extend all the way up through Q; or
7653                      * the range above doesn't start with R => r. */
7654                     if (! adjacent_to_range_above) {
7655
7656                         /* In the first case, let's say the new chunk extends
7657                          * through O.  We then want:
7658                          *
7659                          * [i-1]    J   j   # J-O => j-o
7660                          * [i]      P  -1   # P => -1, Q => -1
7661                          * [i+1]    R   x   # R => x, S => x+1, T => x+2
7662                          * [i+2]    U   y   # U => y, V => y+1, ...
7663                          * ...
7664                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7665                          *                                            infinity
7666                          */
7667                         t_array[i] = t_cp_end + 1;
7668                         r_map[i] = TR_UNLISTED;
7669                     }
7670                     else { /* Adjoins the range above, but can't merge with it
7671                               (because 'x' is not the next map after q) */
7672                         /*
7673                          * [i-1]    J   j   # J-Q => j-q
7674                          * [i]      R   x   # R => x, S => x+1, T => x+2
7675                          * [i+1]    U   y   # U => y, V => y+1, ...
7676                          * ...
7677                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7678                          *                                          infinity
7679                          */
7680
7681                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7682                         Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7683                         len--;
7684                         invlist_set_len(t_invlist, len,
7685                                         *(get_invlist_offset_addr(t_invlist)));
7686                     }
7687                 }
7688                 else if (merge_with_range_above) {
7689
7690                     /* Here the new chunk ends with Q => q, and the range above
7691                      * must start with R => r, so the two can be merged. But
7692                      * either (or both) the new chunk doesn't extend all the
7693                      * way down to M; or the mapping of the final code point
7694                      * range below isn't m */
7695                     if (! adjacent_to_range_below) {
7696
7697                         /* In the first case, let's assume the new chunk starts
7698                          * with P => p.  Then, because it's merge-able with the
7699                          * range above, that range must be R => r.  We want:
7700                          *
7701                          * [i-1]    J   j   # J-L => j-l
7702                          * [i]      M  -1   # M => -1, N => -1
7703                          * [i+1]    P   p   # P-T => p-t
7704                          * [i+2]    U   y   # U => y, V => y+1, ...
7705                          * ...
7706                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7707                          *                                          infinity
7708                          */
7709                         t_array[i+1] = t_cp;
7710                         r_map[i+1] = r_cp;
7711                     }
7712                     else { /* Adjoins the range below, but can't merge with it
7713                             */
7714                         /*
7715                          * [i-1]    J   j   # J-L => j-l
7716                          * [i]      M   x   # M-T => x-5 .. x+2
7717                          * [i+1]    U   y   # U => y, V => y+1, ...
7718                          * ...
7719                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
7720                          *                                          infinity
7721                          */
7722                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7723                         Move(r_map   + i + 1, r_map   + i, len - i - 1, UV);
7724                         len--;
7725                         t_array[i] = t_cp;
7726                         r_map[i] = r_cp;
7727                         invlist_set_len(t_invlist, len,
7728                                         *(get_invlist_offset_addr(t_invlist)));
7729                     }
7730                 }
7731                 else if (adjacent_to_range_below && adjacent_to_range_above) {
7732                     /* The new chunk completely fills the gap between the
7733                      * ranges on either side, but can't merge with either of
7734                      * them.
7735                      *
7736                      * [i-1]    J   j   # J-L => j-l
7737                      * [i]      M   z   # M => z, N => z+1 ... Q => z+4
7738                      * [i+1]    R   x   # R => x, S => x+1, T => x+2
7739                      * [i+2]    U   y   # U => y, V => y+1, ...
7740                      * ...
7741                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7742                      */
7743                     r_map[i] = r_cp;
7744                 }
7745                 else if (adjacent_to_range_below) {
7746                     /* The new chunk adjoins the range below, but not the range
7747                      * above, and can't merge.  Let's assume the chunk ends at
7748                      * O.
7749                      *
7750                      * [i-1]    J   j   # J-L => j-l
7751                      * [i]      M   z   # M => z, N => z+1, O => z+2
7752                      * [i+1]    P   -1  # P => -1, Q => -1
7753                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
7754                      * [i+3]    U   y   # U => y, V => y+1, ...
7755                      * ...
7756                      * [-w]     Z  -1   # Z => default; as do Z+1, ... infinity
7757                      */
7758                     invlist_extend(t_invlist, len + 1);
7759                     t_array = invlist_array(t_invlist);
7760                     Renew(r_map, len + 1, UV);
7761
7762                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7763                     Move(r_map + i + 1,   r_map   + i + 2, len - i - 1, UV);
7764                     r_map[i] = r_cp;
7765                     t_array[i+1] = t_cp_end + 1;
7766                     r_map[i+1] = TR_UNLISTED;
7767                     len++;
7768                     invlist_set_len(t_invlist, len,
7769                                     *(get_invlist_offset_addr(t_invlist)));
7770                 }
7771                 else if (adjacent_to_range_above) {
7772                     /* The new chunk adjoins the range above, but not the range
7773                      * below, and can't merge.  Let's assume the new chunk
7774                      * starts at O
7775                      *
7776                      * [i-1]    J   j   # J-L => j-l
7777                      * [i]      M  -1   # M => default, N => default
7778                      * [i+1]    O   z   # O => z, P => z+1, Q => z+2
7779                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
7780                      * [i+3]    U   y   # U => y, V => y+1, ...
7781                      * ...
7782                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7783                      */
7784                     invlist_extend(t_invlist, len + 1);
7785                     t_array = invlist_array(t_invlist);
7786                     Renew(r_map, len + 1, UV);
7787
7788                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7789                     Move(r_map   + i + 1, r_map   + i + 2, len - i - 1, UV);
7790                     t_array[i+1] = t_cp;
7791                     r_map[i+1] = r_cp;
7792                     len++;
7793                     invlist_set_len(t_invlist, len,
7794                                     *(get_invlist_offset_addr(t_invlist)));
7795                 }
7796                 else {
7797                     /* The new chunk adjoins neither the range above, nor the
7798                      * range below.  Lets assume it is N..P => n..p
7799                      *
7800                      * [i-1]    J   j   # J-L => j-l
7801                      * [i]      M  -1   # M => default
7802                      * [i+1]    N   n   # N..P => n..p
7803                      * [i+2]    Q  -1   # Q => default
7804                      * [i+3]    R   x   # R => x, S => x+1, T => x+2
7805                      * [i+4]    U   y   # U => y, V => y+1, ...
7806                      * ...
7807                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
7808                      */
7809
7810                     DEBUG_yv(PerlIO_printf(Perl_debug_log,
7811                                         "Before fixing up: len=%d, i=%d\n",
7812                                         (int) len, (int) i));
7813                     DEBUG_yv(invmap_dump(t_invlist, r_map));
7814
7815                     invlist_extend(t_invlist, len + 2);
7816                     t_array = invlist_array(t_invlist);
7817                     Renew(r_map, len + 2, UV);
7818
7819                     Move(t_array + i + 1,
7820                          t_array + i + 2 + 1, len - i - (2 - 1), UV);
7821                     Move(r_map   + i + 1,
7822                          r_map   + i + 2 + 1, len - i - (2 - 1), UV);
7823
7824                     len += 2;
7825                     invlist_set_len(t_invlist, len,
7826                                     *(get_invlist_offset_addr(t_invlist)));
7827
7828                     t_array[i+1] = t_cp;
7829                     r_map[i+1] = r_cp;
7830
7831                     t_array[i+2] = t_cp_end + 1;
7832                     r_map[i+2] = TR_UNLISTED;
7833                 }
7834                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7835                           "After iteration: span=%" UVuf ", t_range_count=%"
7836                           UVuf " r_range_count=%" UVuf "\n",
7837                           span, t_range_count, r_range_count));
7838                 DEBUG_yv(invmap_dump(t_invlist, r_map));
7839             } /* End of this chunk needs to be processed */
7840
7841             /* Done with this chunk. */
7842             t_cp += span;
7843             if (t_cp >= IV_MAX) {
7844                 break;
7845             }
7846             t_range_count -= span;
7847             if (r_cp != TR_SPECIAL_HANDLING) {
7848                 r_cp += span;
7849                 r_range_count -= span;
7850             }
7851             else {
7852                 r_range_count = 0;
7853             }
7854
7855         } /* End of loop through the search list */
7856
7857         /* We don't need an exact count, but we do need to know if there is
7858          * anything left over in the replacement list.  So, just assume it's
7859          * one byte per character */
7860         if (rend > r) {
7861             r_count++;
7862         }
7863     } /* End of passes */
7864
7865     SvREFCNT_dec(inverted_tstr);
7866
7867     DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7868     DEBUG_y(invmap_dump(t_invlist, r_map));
7869
7870     /* We now have normalized the input into an inversion map.
7871      *
7872      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
7873      * except for the count, and streamlined runtime code can be used */
7874     if (!del && !squash) {
7875
7876         /* They are identical if they point to same address, or if everything
7877          * maps to UNLISTED or to itself.  This catches things that not looking
7878          * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7879          * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104}  */
7880         if (r0 != t0) {
7881             for (i = 0; i < len; i++) {
7882                 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7883                     goto done_identical_check;
7884                 }
7885             }
7886         }
7887
7888         /* Here have gone through entire list, and didn't find any
7889          * non-identical mappings */
7890         o->op_private |= OPpTRANS_IDENTICAL;
7891
7892       done_identical_check: ;
7893     }
7894
7895     t_array = invlist_array(t_invlist);
7896
7897     /* If has components above 255, we generally need to use the inversion map
7898      * implementation */
7899     if (   can_force_utf8
7900         || (   len > 0
7901             && t_array[len-1] > 255
7902                  /* If the final range is 0x100-INFINITY and is a special
7903                   * mapping, the table implementation can handle it */
7904             && ! (   t_array[len-1] == 256
7905                   && (   r_map[len-1] == TR_UNLISTED
7906                       || r_map[len-1] == TR_SPECIAL_HANDLING))))
7907     {
7908         SV* r_map_sv;
7909
7910         /* A UTF-8 op is generated, indicated by this flag.  This op is an
7911          * sv_op */
7912         o->op_private |= OPpTRANS_USE_SVOP;
7913
7914         if (can_force_utf8) {
7915             o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7916         }
7917
7918         /* The inversion map is pushed; first the list. */
7919         invmap = MUTABLE_AV(newAV());
7920         av_push(invmap, t_invlist);
7921
7922         /* 2nd is the mapping */
7923         r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7924         av_push(invmap, r_map_sv);
7925
7926         /* 3rd is the max possible expansion factor */
7927         av_push(invmap, newSVnv(max_expansion));
7928
7929         /* Characters that are in the search list, but not in the replacement
7930          * list are mapped to the final character in the replacement list */
7931         if (! del && r_count < t_count) {
7932             av_push(invmap, newSVuv(final_map));
7933         }
7934
7935 #ifdef USE_ITHREADS
7936         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7937         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7938         PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7939         SvPADTMP_on(invmap);
7940         SvREADONLY_on(invmap);
7941 #else
7942         cSVOPo->op_sv = (SV *) invmap;
7943 #endif
7944
7945     }
7946     else {
7947         OPtrans_map *tbl;
7948         unsigned short i;
7949
7950         /* The OPtrans_map struct already contains one slot; hence the -1. */
7951         SSize_t struct_size = sizeof(OPtrans_map)
7952                             + (256 - 1 + 1)*sizeof(short);
7953
7954         /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7955         * table. Entries with the value TR_UNMAPPED indicate chars not to be
7956         * translated, while TR_DELETE indicates a search char without a
7957         * corresponding replacement char under /d.
7958         *
7959         * In addition, an extra slot at the end is used to store the final
7960         * repeating char, or TR_R_EMPTY under an empty replacement list, or
7961         * TR_DELETE under /d; which makes the runtime code easier.
7962         */
7963
7964         /* Indicate this is an op_pv */
7965         o->op_private &= ~OPpTRANS_USE_SVOP;
7966
7967         tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7968         tbl->size = 256;
7969         cPVOPo->op_pv = (char*)tbl;
7970
7971         for (i = 0; i < len; i++) {
7972             STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7973             short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7974             short to = (short) r_map[i];
7975             short j;
7976             bool do_increment = TRUE;
7977
7978             /* Any code points above our limit should be irrelevant */
7979             if (t_array[i] >= tbl->size) break;
7980
7981             /* Set up the map */
7982             if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7983                 to = (short) final_map;
7984                 do_increment = FALSE;
7985             }
7986             else if (to < 0) {
7987                 do_increment = FALSE;
7988             }
7989
7990             /* Create a map for everything in this range.  The value increases
7991              * except for the special cases */
7992             for (j = (short) t_array[i]; j < upper; j++) {
7993                 tbl->map[j] = to;
7994                 if (do_increment) to++;
7995             }
7996         }
7997
7998         tbl->map[tbl->size] = del
7999                               ? (short) TR_DELETE
8000                               : (short) rlen
8001                                 ? (short) final_map
8002                                 : (short) TR_R_EMPTY;
8003         DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
8004         for (i = 0; i < tbl->size; i++) {
8005             if (tbl->map[i] < 0) {
8006                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
8007                                                 (unsigned) i, tbl->map[i]));
8008             }
8009             else {
8010                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
8011                                                 (unsigned) i, tbl->map[i]));
8012             }
8013             if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
8014                 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
8015             }
8016         }
8017         DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
8018                                 (unsigned) tbl->size, tbl->map[tbl->size]));
8019
8020         SvREFCNT_dec(t_invlist);
8021
8022 #if 0   /* code that added excess above-255 chars at the end of the table, in
8023            case we ever want to not use the inversion map implementation for
8024            this */
8025
8026         ASSUME(j <= rlen);
8027         excess = rlen - j;
8028
8029         if (excess) {
8030             /* More replacement chars than search chars:
8031              * store excess replacement chars at end of main table.
8032              */
8033
8034             struct_size += excess;
8035             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
8036                         struct_size + excess * sizeof(short));
8037             tbl->size += excess;
8038             cPVOPo->op_pv = (char*)tbl;
8039
8040             for (i = 0; i < excess; i++)
8041                 tbl->map[i + 256] = r[j+i];
8042         }
8043         else {
8044             /* no more replacement chars than search chars */
8045         }
8046 #endif
8047
8048     }
8049
8050     DEBUG_y(PerlIO_printf(Perl_debug_log,
8051             "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
8052             " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
8053             del, squash, complement,
8054             cBOOL(o->op_private & OPpTRANS_IDENTICAL),
8055             cBOOL(o->op_private & OPpTRANS_USE_SVOP),
8056             cBOOL(o->op_private & OPpTRANS_GROWS),
8057             cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
8058             max_expansion));
8059
8060     Safefree(r_map);
8061
8062     if(del && rlen != 0 && r_count == t_count) {
8063         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
8064     } else if(r_count > t_count) {
8065         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
8066     }
8067
8068     op_free(expr);
8069     op_free(repl);
8070
8071     return o;
8072 }
8073
8074
8075 /*
8076 =for apidoc newPMOP
8077
8078 Constructs, checks, and returns an op of any pattern matching type.
8079 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
8080 and, shifted up eight bits, the eight bits of C<op_private>.
8081
8082 =cut
8083 */
8084
8085 OP *
8086 Perl_newPMOP(pTHX_ I32 type, I32 flags)
8087 {
8088     dVAR;
8089     PMOP *pmop;
8090
8091     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
8092         || type == OP_CUSTOM);
8093
8094     NewOp(1101, pmop, 1, PMOP);
8095     OpTYPE_set(pmop, type);
8096     pmop->op_flags = (U8)flags;
8097     pmop->op_private = (U8)(0 | (flags >> 8));
8098     if (PL_opargs[type] & OA_RETSCALAR)
8099         scalar((OP *)pmop);
8100
8101     if (PL_hints & HINT_RE_TAINT)
8102         pmop->op_pmflags |= PMf_RETAINT;
8103 #ifdef USE_LOCALE_CTYPE
8104     if (IN_LC_COMPILETIME(LC_CTYPE)) {
8105         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
8106     }
8107     else
8108 #endif
8109          if (IN_UNI_8_BIT) {
8110         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
8111     }
8112     if (PL_hints & HINT_RE_FLAGS) {
8113         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8114          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
8115         );
8116         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
8117         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
8118          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
8119         );
8120         if (reflags && SvOK(reflags)) {
8121             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
8122         }
8123     }
8124
8125
8126 #ifdef USE_ITHREADS
8127     assert(SvPOK(PL_regex_pad[0]));
8128     if (SvCUR(PL_regex_pad[0])) {
8129         /* Pop off the "packed" IV from the end.  */
8130         SV *const repointer_list = PL_regex_pad[0];
8131         const char *p = SvEND(repointer_list) - sizeof(IV);
8132         const IV offset = *((IV*)p);
8133
8134         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
8135
8136         SvEND_set(repointer_list, p);
8137
8138         pmop->op_pmoffset = offset;
8139         /* This slot should be free, so assert this:  */
8140         assert(PL_regex_pad[offset] == &PL_sv_undef);
8141     } else {
8142         SV * const repointer = &PL_sv_undef;
8143         av_push(PL_regex_padav, repointer);
8144         pmop->op_pmoffset = av_tindex(PL_regex_padav);
8145         PL_regex_pad = AvARRAY(PL_regex_padav);
8146     }
8147 #endif
8148
8149     return CHECKOP(type, pmop);
8150 }
8151
8152 static void
8153 S_set_haseval(pTHX)
8154 {
8155     PADOFFSET i = 1;
8156     PL_cv_has_eval = 1;
8157     /* Any pad names in scope are potentially lvalues.  */
8158     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
8159         PADNAME *pn = PAD_COMPNAME_SV(i);
8160         if (!pn || !PadnameLEN(pn))
8161             continue;
8162         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
8163             S_mark_padname_lvalue(aTHX_ pn);
8164     }
8165 }
8166
8167 /* Given some sort of match op o, and an expression expr containing a
8168  * pattern, either compile expr into a regex and attach it to o (if it's
8169  * constant), or convert expr into a runtime regcomp op sequence (if it's
8170  * not)
8171  *
8172  * Flags currently has 2 bits of meaning:
8173  * 1: isreg indicates that the pattern is part of a regex construct, eg
8174  *      $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
8175  *      split "pattern", which aren't. In the former case, expr will be a list
8176  *      if the pattern contains more than one term (eg /a$b/).
8177  * 2: The pattern is for a split.
8178  *
8179  * When the pattern has been compiled within a new anon CV (for
8180  * qr/(?{...})/ ), then floor indicates the savestack level just before
8181  * the new sub was created
8182  *
8183  * tr/// is also handled.
8184  */
8185
8186 OP *
8187 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8188 {
8189     PMOP *pm;
8190     LOGOP *rcop;
8191     I32 repl_has_vars = 0;
8192     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8193     bool is_compiletime;
8194     bool has_code;
8195     bool isreg    = cBOOL(flags & 1);
8196     bool is_split = cBOOL(flags & 2);
8197
8198     PERL_ARGS_ASSERT_PMRUNTIME;
8199
8200     if (is_trans) {
8201         return pmtrans(o, expr, repl);
8202     }
8203
8204     /* find whether we have any runtime or code elements;
8205      * at the same time, temporarily set the op_next of each DO block;
8206      * then when we LINKLIST, this will cause the DO blocks to be excluded
8207      * from the op_next chain (and from having LINKLIST recursively
8208      * applied to them). We fix up the DOs specially later */
8209
8210     is_compiletime = 1;
8211     has_code = 0;
8212     if (expr->op_type == OP_LIST) {
8213         OP *child;
8214         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8215             if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8216                 has_code = 1;
8217                 assert(!child->op_next);
8218                 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8219                     assert(PL_parser && PL_parser->error_count);
8220                     /* This can happen with qr/ (?{(^{})/.  Just fake up
8221                        the op we were expecting to see, to avoid crashing
8222                        elsewhere.  */
8223                     op_sibling_splice(expr, child, 0,
8224                               newSVOP(OP_CONST, 0, &PL_sv_no));
8225                 }
8226                 child->op_next = OpSIBLING(child);
8227             }
8228             else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8229             is_compiletime = 0;
8230         }
8231     }
8232     else if (expr->op_type != OP_CONST)
8233         is_compiletime = 0;
8234
8235     LINKLIST(expr);
8236
8237     /* fix up DO blocks; treat each one as a separate little sub;
8238      * also, mark any arrays as LIST/REF */
8239
8240     if (expr->op_type == OP_LIST) {
8241         OP *child;
8242         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8243
8244             if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8245                 assert( !(child->op_flags  & OPf_WANT));
8246                 /* push the array rather than its contents. The regex
8247                  * engine will retrieve and join the elements later */
8248                 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8249                 continue;
8250             }
8251
8252             if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8253                 continue;
8254             child->op_next = NULL; /* undo temporary hack from above */
8255             scalar(child);
8256             LINKLIST(child);
8257             if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8258                 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8259                 /* skip ENTER */
8260                 assert(leaveop->op_first->op_type == OP_ENTER);
8261                 assert(OpHAS_SIBLING(leaveop->op_first));
8262                 child->op_next = OpSIBLING(leaveop->op_first);
8263                 /* skip leave */
8264                 assert(leaveop->op_flags & OPf_KIDS);
8265                 assert(leaveop->op_last->op_next == (OP*)leaveop);
8266                 leaveop->op_next = NULL; /* stop on last op */
8267                 op_null((OP*)leaveop);
8268             }
8269             else {
8270                 /* skip SCOPE */
8271                 OP *scope = cLISTOPx(child)->op_first;
8272                 assert(scope->op_type == OP_SCOPE);
8273                 assert(scope->op_flags & OPf_KIDS);
8274                 scope->op_next = NULL; /* stop on last op */
8275                 op_null(scope);
8276             }
8277
8278             /* XXX optimize_optree() must be called on o before
8279              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8280              * currently cope with a peephole-optimised optree.
8281              * Calling optimize_optree() here ensures that condition
8282              * is met, but may mean optimize_optree() is applied
8283              * to the same optree later (where hopefully it won't do any
8284              * harm as it can't convert an op to multiconcat if it's
8285              * already been converted */
8286             optimize_optree(child);
8287
8288             /* have to peep the DOs individually as we've removed it from
8289              * the op_next chain */
8290             CALL_PEEP(child);
8291             S_prune_chain_head(&(child->op_next));
8292             if (is_compiletime)
8293                 /* runtime finalizes as part of finalizing whole tree */
8294                 finalize_optree(child);
8295         }
8296     }
8297     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8298         assert( !(expr->op_flags  & OPf_WANT));
8299         /* push the array rather than its contents. The regex
8300          * engine will retrieve and join the elements later */
8301         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8302     }
8303
8304     PL_hints |= HINT_BLOCK_SCOPE;
8305     pm = (PMOP*)o;
8306     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8307
8308     if (is_compiletime) {
8309         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8310         regexp_engine const *eng = current_re_engine();
8311
8312         if (is_split) {
8313             /* make engine handle split ' ' specially */
8314             pm->op_pmflags |= PMf_SPLIT;
8315             rx_flags |= RXf_SPLIT;
8316         }
8317
8318         if (!has_code || !eng->op_comp) {
8319             /* compile-time simple constant pattern */
8320
8321             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8322                 /* whoops! we guessed that a qr// had a code block, but we
8323                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8324                  * that isn't required now. Note that we have to be pretty
8325                  * confident that nothing used that CV's pad while the
8326                  * regex was parsed, except maybe op targets for \Q etc.
8327                  * If there were any op targets, though, they should have
8328                  * been stolen by constant folding.
8329                  */
8330 #ifdef DEBUGGING
8331                 SSize_t i = 0;
8332                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8333                 while (++i <= AvFILLp(PL_comppad)) {
8334 #  ifdef USE_PAD_RESET
8335                     /* under USE_PAD_RESET, pad swipe replaces a swiped
8336                      * folded constant with a fresh padtmp */
8337                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8338 #  else
8339                     assert(!PL_curpad[i]);
8340 #  endif
8341                 }
8342 #endif
8343                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8344                  * outer CV (the one whose slab holds the pm op). The
8345                  * inner CV (which holds expr) will be freed later, once
8346                  * all the entries on the parse stack have been popped on
8347                  * return from this function. Which is why its safe to
8348                  * call op_free(expr) below.
8349                  */
8350                 LEAVE_SCOPE(floor);
8351                 pm->op_pmflags &= ~PMf_HAS_CV;
8352             }
8353
8354             /* Skip compiling if parser found an error for this pattern */
8355             if (pm->op_pmflags & PMf_HAS_ERROR) {
8356                 return o;
8357             }
8358
8359             PM_SETRE(pm,
8360                 eng->op_comp
8361                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8362                                         rx_flags, pm->op_pmflags)
8363                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8364                                         rx_flags, pm->op_pmflags)
8365             );
8366             op_free(expr);
8367         }
8368         else {
8369             /* compile-time pattern that includes literal code blocks */
8370
8371             REGEXP* re;
8372
8373             /* Skip compiling if parser found an error for this pattern */
8374             if (pm->op_pmflags & PMf_HAS_ERROR) {
8375                 return o;
8376             }
8377
8378             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8379                         rx_flags,
8380                         (pm->op_pmflags |
8381                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8382                     );
8383             PM_SETRE(pm, re);
8384             if (pm->op_pmflags & PMf_HAS_CV) {
8385                 CV *cv;
8386                 /* this QR op (and the anon sub we embed it in) is never
8387                  * actually executed. It's just a placeholder where we can
8388                  * squirrel away expr in op_code_list without the peephole
8389                  * optimiser etc processing it for a second time */
8390                 OP *qr = newPMOP(OP_QR, 0);
8391                 ((PMOP*)qr)->op_code_list = expr;
8392
8393                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8394                 SvREFCNT_inc_simple_void(PL_compcv);
8395                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8396                 ReANY(re)->qr_anoncv = cv;
8397
8398                 /* attach the anon CV to the pad so that
8399                  * pad_fixup_inner_anons() can find it */
8400                 (void)pad_add_anon(cv, o->op_type);
8401                 SvREFCNT_inc_simple_void(cv);
8402             }
8403             else {
8404                 pm->op_code_list = expr;
8405             }
8406         }
8407     }
8408     else {
8409         /* runtime pattern: build chain of regcomp etc ops */
8410         bool reglist;
8411         PADOFFSET cv_targ = 0;
8412
8413         reglist = isreg && expr->op_type == OP_LIST;
8414         if (reglist)
8415             op_null(expr);
8416
8417         if (has_code) {
8418             pm->op_code_list = expr;
8419             /* don't free op_code_list; its ops are embedded elsewhere too */
8420             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8421         }
8422
8423         if (is_split)
8424             /* make engine handle split ' ' specially */
8425             pm->op_pmflags |= PMf_SPLIT;
8426
8427         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8428          * to allow its op_next to be pointed past the regcomp and
8429          * preceding stacking ops;
8430          * OP_REGCRESET is there to reset taint before executing the
8431          * stacking ops */
8432         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8433             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8434
8435         if (pm->op_pmflags & PMf_HAS_CV) {
8436             /* we have a runtime qr with literal code. This means
8437              * that the qr// has been wrapped in a new CV, which
8438              * means that runtime consts, vars etc will have been compiled
8439              * against a new pad. So... we need to execute those ops
8440              * within the environment of the new CV. So wrap them in a call
8441              * to a new anon sub. i.e. for
8442              *
8443              *     qr/a$b(?{...})/,
8444              *
8445              * we build an anon sub that looks like
8446              *
8447              *     sub { "a", $b, '(?{...})' }
8448              *
8449              * and call it, passing the returned list to regcomp.
8450              * Or to put it another way, the list of ops that get executed
8451              * are:
8452              *
8453              *     normal              PMf_HAS_CV
8454              *     ------              -------------------
8455              *                         pushmark (for regcomp)
8456              *                         pushmark (for entersub)
8457              *                         anoncode
8458              *                         srefgen
8459              *                         entersub
8460              *     regcreset                  regcreset
8461              *     pushmark                   pushmark
8462              *     const("a")                 const("a")
8463              *     gvsv(b)                    gvsv(b)
8464              *     const("(?{...})")          const("(?{...})")
8465              *                                leavesub
8466              *     regcomp             regcomp
8467              */
8468
8469             SvREFCNT_inc_simple_void(PL_compcv);
8470             CvLVALUE_on(PL_compcv);
8471             /* these lines are just an unrolled newANONATTRSUB */
8472             expr = newSVOP(OP_ANONCODE, 0,
8473                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8474             cv_targ = expr->op_targ;
8475             expr = newUNOP(OP_REFGEN, 0, expr);
8476
8477             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8478         }
8479
8480         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8481         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8482                            | (reglist ? OPf_STACKED : 0);
8483         rcop->op_targ = cv_targ;
8484
8485         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
8486         if (PL_hints & HINT_RE_EVAL)
8487             S_set_haseval(aTHX);
8488
8489         /* establish postfix order */
8490         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8491             LINKLIST(expr);
8492             rcop->op_next = expr;
8493             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8494         }
8495         else {
8496             rcop->op_next = LINKLIST(expr);
8497             expr->op_next = (OP*)rcop;
8498         }
8499
8500         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8501     }
8502
8503     if (repl) {
8504         OP *curop = repl;
8505         bool konst;
8506         /* If we are looking at s//.../e with a single statement, get past
8507            the implicit do{}. */
8508         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8509              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8510              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8511          {
8512             OP *sib;
8513             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8514             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8515              && !OpHAS_SIBLING(sib))
8516                 curop = sib;
8517         }
8518         if (curop->op_type == OP_CONST)
8519             konst = TRUE;
8520         else if (( (curop->op_type == OP_RV2SV ||
8521                     curop->op_type == OP_RV2AV ||
8522                     curop->op_type == OP_RV2HV ||
8523                     curop->op_type == OP_RV2GV)
8524                    && cUNOPx(curop)->op_first
8525                    && cUNOPx(curop)->op_first->op_type == OP_GV )
8526                 || curop->op_type == OP_PADSV
8527                 || curop->op_type == OP_PADAV
8528                 || curop->op_type == OP_PADHV
8529                 || curop->op_type == OP_PADANY) {
8530             repl_has_vars = 1;
8531             konst = TRUE;
8532         }
8533         else konst = FALSE;
8534         if (konst
8535             && !(repl_has_vars
8536                  && (!PM_GETRE(pm)
8537                      || !RX_PRELEN(PM_GETRE(pm))
8538                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8539         {
8540             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
8541             op_prepend_elem(o->op_type, scalar(repl), o);
8542         }
8543         else {
8544             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8545             rcop->op_private = 1;
8546
8547             /* establish postfix order */
8548             rcop->op_next = LINKLIST(repl);
8549             repl->op_next = (OP*)rcop;
8550
8551             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8552             assert(!(pm->op_pmflags & PMf_ONCE));
8553             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8554             rcop->op_next = 0;
8555         }
8556     }
8557
8558     return (OP*)pm;
8559 }
8560
8561 /*
8562 =for apidoc newSVOP
8563
8564 Constructs, checks, and returns an op of any type that involves an
8565 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
8566 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
8567 takes ownership of one reference to it.
8568
8569 =cut
8570 */
8571
8572 OP *
8573 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8574 {
8575     dVAR;
8576     SVOP *svop;
8577
8578     PERL_ARGS_ASSERT_NEWSVOP;
8579
8580     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8581         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8582         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8583         || type == OP_CUSTOM);
8584
8585     NewOp(1101, svop, 1, SVOP);
8586     OpTYPE_set(svop, type);
8587     svop->op_sv = sv;
8588     svop->op_next = (OP*)svop;
8589     svop->op_flags = (U8)flags;
8590     svop->op_private = (U8)(0 | (flags >> 8));
8591     if (PL_opargs[type] & OA_RETSCALAR)
8592         scalar((OP*)svop);
8593     if (PL_opargs[type] & OA_TARGET)
8594         svop->op_targ = pad_alloc(type, SVs_PADTMP);
8595     return CHECKOP(type, svop);
8596 }
8597
8598 /*
8599 =for apidoc newDEFSVOP
8600
8601 Constructs and returns an op to access C<$_>.
8602
8603 =cut
8604 */
8605
8606 OP *
8607 Perl_newDEFSVOP(pTHX)
8608 {
8609         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8610 }
8611
8612 #ifdef USE_ITHREADS
8613
8614 /*
8615 =for apidoc newPADOP
8616
8617 Constructs, checks, and returns an op of any type that involves a
8618 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
8619 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
8620 is populated with C<sv>; this function takes ownership of one reference
8621 to it.
8622
8623 This function only exists if Perl has been compiled to use ithreads.
8624
8625 =cut
8626 */
8627
8628 OP *
8629 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8630 {
8631     dVAR;
8632     PADOP *padop;
8633
8634     PERL_ARGS_ASSERT_NEWPADOP;
8635
8636     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8637         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8638         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8639         || type == OP_CUSTOM);
8640
8641     NewOp(1101, padop, 1, PADOP);
8642     OpTYPE_set(padop, type);
8643     padop->op_padix =
8644         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8645     SvREFCNT_dec(PAD_SVl(padop->op_padix));
8646     PAD_SETSV(padop->op_padix, sv);
8647     assert(sv);
8648     padop->op_next = (OP*)padop;
8649     padop->op_flags = (U8)flags;
8650     if (PL_opargs[type] & OA_RETSCALAR)
8651         scalar((OP*)padop);
8652     if (PL_opargs[type] & OA_TARGET)
8653         padop->op_targ = pad_alloc(type, SVs_PADTMP);
8654     return CHECKOP(type, padop);
8655 }
8656
8657 #endif /* USE_ITHREADS */
8658
8659 /*
8660 =for apidoc newGVOP
8661
8662 Constructs, checks, and returns an op of any type that involves an
8663 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
8664 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
8665 reference; calling this function does not transfer ownership of any
8666 reference to it.
8667
8668 =cut
8669 */
8670
8671 OP *
8672 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8673 {
8674     PERL_ARGS_ASSERT_NEWGVOP;
8675
8676 #ifdef USE_ITHREADS
8677     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8678 #else
8679     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8680 #endif
8681 }
8682
8683 /*
8684 =for apidoc newPVOP
8685
8686 Constructs, checks, and returns an op of any type that involves an
8687 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
8688 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
8689 Depending on the op type, the memory referenced by C<pv> may be freed
8690 when the op is destroyed.  If the op is of a freeing type, C<pv> must
8691 have been allocated using C<PerlMemShared_malloc>.
8692
8693 =cut
8694 */
8695
8696 OP *
8697 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8698 {
8699     dVAR;
8700     const bool utf8 = cBOOL(flags & SVf_UTF8);
8701     PVOP *pvop;
8702
8703     flags &= ~SVf_UTF8;
8704
8705     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8706         || type == OP_RUNCV || type == OP_CUSTOM
8707         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8708
8709     NewOp(1101, pvop, 1, PVOP);
8710     OpTYPE_set(pvop, type);
8711     pvop->op_pv = pv;
8712     pvop->op_next = (OP*)pvop;
8713     pvop->op_flags = (U8)flags;
8714     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8715     if (PL_opargs[type] & OA_RETSCALAR)
8716         scalar((OP*)pvop);
8717     if (PL_opargs[type] & OA_TARGET)
8718         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8719     return CHECKOP(type, pvop);
8720 }
8721
8722 void
8723 Perl_package(pTHX_ OP *o)
8724 {
8725     SV *const sv = cSVOPo->op_sv;
8726
8727     PERL_ARGS_ASSERT_PACKAGE;
8728
8729     SAVEGENERICSV(PL_curstash);
8730     save_item(PL_curstname);
8731
8732     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8733
8734     sv_setsv(PL_curstname, sv);
8735
8736     PL_hints |= HINT_BLOCK_SCOPE;
8737     PL_parser->copline = NOLINE;
8738
8739     op_free(o);
8740 }
8741
8742 void
8743 Perl_package_version( pTHX_ OP *v )
8744 {
8745     U32 savehints = PL_hints;
8746     PERL_ARGS_ASSERT_PACKAGE_VERSION;
8747     PL_hints &= ~HINT_STRICT_VARS;
8748     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8749     PL_hints = savehints;
8750     op_free(v);
8751 }
8752
8753 void
8754 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8755 {
8756     OP *pack;
8757     OP *imop;
8758     OP *veop;
8759     SV *use_version = NULL;
8760
8761     PERL_ARGS_ASSERT_UTILIZE;
8762
8763     if (idop->op_type != OP_CONST)
8764         Perl_croak(aTHX_ "Module name must be constant");
8765
8766     veop = NULL;
8767
8768     if (version) {
8769         SV * const vesv = ((SVOP*)version)->op_sv;
8770
8771         if (!arg && !SvNIOKp(vesv)) {
8772             arg = version;
8773         }
8774         else {
8775             OP *pack;
8776             SV *meth;
8777
8778             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8779                 Perl_croak(aTHX_ "Version number must be a constant number");
8780
8781             /* Make copy of idop so we don't free it twice */
8782             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8783
8784             /* Fake up a method call to VERSION */
8785             meth = newSVpvs_share("VERSION");
8786             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8787                             op_append_elem(OP_LIST,
8788                                         op_prepend_elem(OP_LIST, pack, version),
8789                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8790         }
8791     }
8792
8793     /* Fake up an import/unimport */
8794     if (arg && arg->op_type == OP_STUB) {
8795         imop = arg;             /* no import on explicit () */
8796     }
8797     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8798         imop = NULL;            /* use 5.0; */
8799         if (aver)
8800             use_version = ((SVOP*)idop)->op_sv;
8801         else
8802             idop->op_private |= OPpCONST_NOVER;
8803     }
8804     else {
8805         SV *meth;
8806
8807         /* Make copy of idop so we don't free it twice */
8808         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8809
8810         /* Fake up a method call to import/unimport */
8811         meth = aver
8812             ? newSVpvs_share("import") : newSVpvs_share("unimport");
8813         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8814                        op_append_elem(OP_LIST,
8815                                    op_prepend_elem(OP_LIST, pack, arg),
8816                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8817                        ));
8818     }
8819
8820     /* Fake up the BEGIN {}, which does its thing immediately. */
8821     newATTRSUB(floor,
8822         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8823         NULL,
8824         NULL,
8825         op_append_elem(OP_LINESEQ,
8826             op_append_elem(OP_LINESEQ,
8827                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8828                 newSTATEOP(0, NULL, veop)),
8829             newSTATEOP(0, NULL, imop) ));
8830
8831     if (use_version) {
8832         /* Enable the
8833          * feature bundle that corresponds to the required version. */
8834         use_version = sv_2mortal(new_version(use_version));
8835         S_enable_feature_bundle(aTHX_ use_version);
8836
8837         /* If a version >= 5.11.0 is requested, strictures are on by default! */
8838         if (vcmp(use_version,
8839                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8840             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8841                 PL_hints |= HINT_STRICT_REFS;
8842             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8843                 PL_hints |= HINT_STRICT_SUBS;
8844             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8845                 PL_hints |= HINT_STRICT_VARS;
8846         }
8847         /* otherwise they are off */
8848         else {
8849             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8850                 PL_hints &= ~HINT_STRICT_REFS;
8851             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8852                 PL_hints &= ~HINT_STRICT_SUBS;
8853             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8854                 PL_hints &= ~HINT_STRICT_VARS;
8855         }
8856     }
8857
8858     /* The "did you use incorrect case?" warning used to be here.
8859      * The problem is that on case-insensitive filesystems one
8860      * might get false positives for "use" (and "require"):
8861      * "use Strict" or "require CARP" will work.  This causes
8862      * portability problems for the script: in case-strict
8863      * filesystems the script will stop working.
8864      *
8865      * The "incorrect case" warning checked whether "use Foo"
8866      * imported "Foo" to your namespace, but that is wrong, too:
8867      * there is no requirement nor promise in the language that
8868      * a Foo.pm should or would contain anything in package "Foo".
8869      *
8870      * There is very little Configure-wise that can be done, either:
8871      * the case-sensitivity of the build filesystem of Perl does not
8872      * help in guessing the case-sensitivity of the runtime environment.
8873      */
8874
8875     PL_hints |= HINT_BLOCK_SCOPE;
8876     PL_parser->copline = NOLINE;
8877     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8878 }
8879
8880 /*
8881 =head1 Embedding Functions
8882
8883 =for apidoc load_module
8884
8885 Loads the module whose name is pointed to by the string part of C<name>.
8886 Note that the actual module name, not its filename, should be given.
8887 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8888 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8889 trailing arguments can be used to specify arguments to the module's C<import()>
8890 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8891 on the flags. The flags argument is a bitwise-ORed collection of any of
8892 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8893 (or 0 for no flags).
8894
8895 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8896 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8897 the trailing optional arguments may be omitted entirely. Otherwise, if
8898 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8899 exactly one C<OP*>, containing the op tree that produces the relevant import
8900 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8901 will be used as import arguments; and the list must be terminated with C<(SV*)
8902 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8903 set, the trailing C<NULL> pointer is needed even if no import arguments are
8904 desired. The reference count for each specified C<SV*> argument is
8905 decremented. In addition, the C<name> argument is modified.
8906
8907 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8908 than C<use>.
8909
8910 =for apidoc Amnh||PERL_LOADMOD_DENY
8911 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8912 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8913
8914 =cut */
8915
8916 void
8917 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8918 {
8919     va_list args;
8920
8921     PERL_ARGS_ASSERT_LOAD_MODULE;
8922
8923     va_start(args, ver);
8924     vload_module(flags, name, ver, &args);
8925     va_end(args);
8926 }
8927
8928 #ifdef PERL_IMPLICIT_CONTEXT
8929 void
8930 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8931 {
8932     dTHX;
8933     va_list args;
8934     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8935     va_start(args, ver);
8936     vload_module(flags, name, ver, &args);
8937     va_end(args);
8938 }
8939 #endif
8940
8941 void
8942 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8943 {
8944     OP *veop, *imop;
8945     OP * modname;
8946     I32 floor;
8947
8948     PERL_ARGS_ASSERT_VLOAD_MODULE;
8949
8950     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8951      * that it has a PL_parser to play with while doing that, and also
8952      * that it doesn't mess with any existing parser, by creating a tmp
8953      * new parser with lex_start(). This won't actually be used for much,
8954      * since pp_require() will create another parser for the real work.
8955      * The ENTER/LEAVE pair protect callers from any side effects of use.
8956      *
8957      * start_subparse() creates a new PL_compcv. This means that any ops
8958      * allocated below will be allocated from that CV's op slab, and so
8959      * will be automatically freed if the utilise() fails
8960      */
8961
8962     ENTER;
8963     SAVEVPTR(PL_curcop);
8964     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8965     floor = start_subparse(FALSE, 0);
8966
8967     modname = newSVOP(OP_CONST, 0, name);
8968     modname->op_private |= OPpCONST_BARE;
8969     if (ver) {
8970         veop = newSVOP(OP_CONST, 0, ver);
8971     }
8972     else
8973         veop = NULL;
8974     if (flags & PERL_LOADMOD_NOIMPORT) {
8975         imop = sawparens(newNULLLIST());
8976     }
8977     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8978         imop = va_arg(*args, OP*);
8979     }
8980     else {
8981         SV *sv;
8982         imop = NULL;
8983         sv = va_arg(*args, SV*);
8984         while (sv) {
8985             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8986             sv = va_arg(*args, SV*);
8987         }
8988     }
8989
8990     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8991     LEAVE;
8992 }
8993
8994 PERL_STATIC_INLINE OP *
8995 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8996 {
8997     return newUNOP(OP_ENTERSUB, OPf_STACKED,
8998                    newLISTOP(OP_LIST, 0, arg,
8999                              newUNOP(OP_RV2CV, 0,
9000                                      newGVOP(OP_GV, 0, gv))));
9001 }
9002
9003 OP *
9004 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
9005 {
9006     OP *doop;
9007     GV *gv;
9008
9009     PERL_ARGS_ASSERT_DOFILE;
9010
9011     if (!force_builtin && (gv = gv_override("do", 2))) {
9012         doop = S_new_entersubop(aTHX_ gv, term);
9013     }
9014     else {
9015         doop = newUNOP(OP_DOFILE, 0, scalar(term));
9016     }
9017     return doop;
9018 }
9019
9020 /*
9021 =head1 Optree construction
9022
9023 =for apidoc newSLICEOP
9024
9025 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
9026 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
9027 be set automatically, and, shifted up eight bits, the eight bits of
9028 C<op_private>, except that the bit with value 1 or 2 is automatically
9029 set as required.  C<listval> and C<subscript> supply the parameters of
9030 the slice; they are consumed by this function and become part of the
9031 constructed op tree.
9032
9033 =cut
9034 */
9035
9036 OP *
9037 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
9038 {
9039     return newBINOP(OP_LSLICE, flags,
9040             list(force_list(subscript, 1)),
9041             list(force_list(listval,   1)) );
9042 }
9043
9044 #define ASSIGN_SCALAR 0
9045 #define ASSIGN_LIST   1
9046 #define ASSIGN_REF    2
9047
9048 /* given the optree o on the LHS of an assignment, determine whether its:
9049  *  ASSIGN_SCALAR   $x  = ...
9050  *  ASSIGN_LIST    ($x) = ...
9051  *  ASSIGN_REF     \$x  = ...
9052  */
9053
9054 STATIC I32
9055 S_assignment_type(pTHX_ const OP *o)
9056 {
9057     unsigned type;
9058     U8 flags;
9059     U8 ret;
9060
9061     if (!o)
9062         return ASSIGN_LIST;
9063
9064     if (o->op_type == OP_SREFGEN)
9065     {
9066         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
9067         type = kid->op_type;
9068         flags = o->op_flags | kid->op_flags;
9069         if (!(flags & OPf_PARENS)
9070           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
9071               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
9072             return ASSIGN_REF;
9073         ret = ASSIGN_REF;
9074     } else {
9075         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
9076             o = cUNOPo->op_first;
9077         flags = o->op_flags;
9078         type = o->op_type;
9079         ret = ASSIGN_SCALAR;
9080     }
9081
9082     if (type == OP_COND_EXPR) {
9083         OP * const sib = OpSIBLING(cLOGOPo->op_first);
9084         const I32 t = assignment_type(sib);
9085         const I32 f = assignment_type(OpSIBLING(sib));
9086
9087         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
9088             return ASSIGN_LIST;
9089         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
9090             yyerror("Assignment to both a list and a scalar");
9091         return ASSIGN_SCALAR;
9092     }
9093
9094     if (type == OP_LIST &&
9095         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
9096         o->op_private & OPpLVAL_INTRO)
9097         return ret;
9098
9099     if (type == OP_LIST || flags & OPf_PARENS ||
9100         type == OP_RV2AV || type == OP_RV2HV ||
9101         type == OP_ASLICE || type == OP_HSLICE ||
9102         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
9103         return ASSIGN_LIST;
9104
9105     if (type == OP_PADAV || type == OP_PADHV)
9106         return ASSIGN_LIST;
9107
9108     if (type == OP_RV2SV)
9109         return ret;
9110
9111     return ret;
9112 }
9113
9114 static OP *
9115 S_newONCEOP(pTHX_ OP *initop, OP *padop)
9116 {
9117     dVAR;
9118     const PADOFFSET target = padop->op_targ;
9119     OP *const other = newOP(OP_PADSV,
9120                             padop->op_flags
9121                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
9122     OP *const first = newOP(OP_NULL, 0);
9123     OP *const nullop = newCONDOP(0, first, initop, other);
9124     /* XXX targlex disabled for now; see ticket #124160
9125         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
9126      */
9127     OP *const condop = first->op_next;
9128
9129     OpTYPE_set(condop, OP_ONCE);
9130     other->op_targ = target;
9131     nullop->op_flags |= OPf_WANT_SCALAR;
9132
9133     /* Store the initializedness of state vars in a separate
9134        pad entry.  */
9135     condop->op_targ =
9136       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
9137     /* hijacking PADSTALE for uninitialized state variables */
9138     SvPADSTALE_on(PAD_SVl(condop->op_targ));
9139
9140     return nullop;
9141 }
9142
9143 /*
9144 =for apidoc newASSIGNOP
9145
9146 Constructs, checks, and returns an assignment op.  C<left> and C<right>
9147 supply the parameters of the assignment; they are consumed by this
9148 function and become part of the constructed op tree.
9149
9150 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
9151 a suitable conditional optree is constructed.  If C<optype> is the opcode
9152 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
9153 performs the binary operation and assigns the result to the left argument.
9154 Either way, if C<optype> is non-zero then C<flags> has no effect.
9155
9156 If C<optype> is zero, then a plain scalar or list assignment is
9157 constructed.  Which type of assignment it is is automatically determined.
9158 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9159 will be set automatically, and, shifted up eight bits, the eight bits
9160 of C<op_private>, except that the bit with value 1 or 2 is automatically
9161 set as required.
9162
9163 =cut
9164 */
9165
9166 OP *
9167 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
9168 {
9169     OP *o;
9170     I32 assign_type;
9171
9172     if (optype) {
9173         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
9174             right = scalar(right);
9175             return newLOGOP(optype, 0,
9176                 op_lvalue(scalar(left), optype),
9177                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
9178         }
9179         else {
9180             return newBINOP(optype, OPf_STACKED,
9181                 op_lvalue(scalar(left), optype), scalar(right));
9182         }
9183     }
9184
9185     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9186         OP *state_var_op = NULL;
9187         static const char no_list_state[] = "Initialization of state variables"
9188             " in list currently forbidden";
9189         OP *curop;
9190
9191         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9192             left->op_private &= ~ OPpSLICEWARNING;
9193
9194         PL_modcount = 0;
9195         left = op_lvalue(left, OP_AASSIGN);
9196         curop = list(force_list(left, 1));
9197         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9198         o->op_private = (U8)(0 | (flags >> 8));
9199
9200         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9201         {
9202             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9203             if (!(left->op_flags & OPf_PARENS) &&
9204                     lop->op_type == OP_PUSHMARK &&
9205                     (vop = OpSIBLING(lop)) &&
9206                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9207                     !(vop->op_flags & OPf_PARENS) &&
9208                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9209                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
9210                     (eop = OpSIBLING(vop)) &&
9211                     eop->op_type == OP_ENTERSUB &&
9212                     !OpHAS_SIBLING(eop)) {
9213                 state_var_op = vop;
9214             } else {
9215                 while (lop) {
9216                     if ((lop->op_type == OP_PADSV ||
9217                          lop->op_type == OP_PADAV ||
9218                          lop->op_type == OP_PADHV ||
9219                          lop->op_type == OP_PADANY)
9220                       && (lop->op_private & OPpPAD_STATE)
9221                     )
9222                         yyerror(no_list_state);
9223                     lop = OpSIBLING(lop);
9224                 }
9225             }
9226         }
9227         else if (  (left->op_private & OPpLVAL_INTRO)
9228                 && (left->op_private & OPpPAD_STATE)
9229                 && (   left->op_type == OP_PADSV
9230                     || left->op_type == OP_PADAV
9231                     || left->op_type == OP_PADHV
9232                     || left->op_type == OP_PADANY)
9233         ) {
9234                 /* All single variable list context state assignments, hence
9235                    state ($a) = ...
9236                    (state $a) = ...
9237                    state @a = ...
9238                    state (@a) = ...
9239                    (state @a) = ...
9240                    state %a = ...
9241                    state (%a) = ...
9242                    (state %a) = ...
9243                 */
9244                 if (left->op_flags & OPf_PARENS)
9245                     yyerror(no_list_state);
9246                 else
9247                     state_var_op = left;
9248         }
9249
9250         /* optimise @a = split(...) into:
9251         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
9252         * @a, my @a, local @a:  split(...)          (where @a is attached to
9253         *                                            the split op itself)
9254         */
9255
9256         if (   right
9257             && right->op_type == OP_SPLIT
9258             /* don't do twice, e.g. @b = (@a = split) */
9259             && !(right->op_private & OPpSPLIT_ASSIGN))
9260         {
9261             OP *gvop = NULL;
9262
9263             if (   (  left->op_type == OP_RV2AV
9264                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9265                 || left->op_type == OP_PADAV)
9266             {
9267                 /* @pkg or @lex or local @pkg' or 'my @lex' */
9268                 OP *tmpop;
9269                 if (gvop) {
9270 #ifdef USE_ITHREADS
9271                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9272                         = cPADOPx(gvop)->op_padix;
9273                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
9274 #else
9275                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9276                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9277                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
9278 #endif
9279                     right->op_private |=
9280                         left->op_private & OPpOUR_INTRO;
9281                 }
9282                 else {
9283                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9284                     left->op_targ = 0;  /* steal it */
9285                     right->op_private |= OPpSPLIT_LEX;
9286                 }
9287                 right->op_private |= left->op_private & OPpLVAL_INTRO;
9288
9289               detach_split:
9290                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
9291                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9292                 assert(OpSIBLING(tmpop) == right);
9293                 assert(!OpHAS_SIBLING(right));
9294                 /* detach the split subtreee from the o tree,
9295                  * then free the residual o tree */
9296                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9297                 op_free(o);                     /* blow off assign */
9298                 right->op_private |= OPpSPLIT_ASSIGN;
9299                 right->op_flags &= ~OPf_WANT;
9300                         /* "I don't know and I don't care." */
9301                 return right;
9302             }
9303             else if (left->op_type == OP_RV2AV) {
9304                 /* @{expr} */
9305
9306                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9307                 assert(OpSIBLING(pushop) == left);
9308                 /* Detach the array ...  */
9309                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9310                 /* ... and attach it to the split.  */
9311                 op_sibling_splice(right, cLISTOPx(right)->op_last,
9312                                   0, left);
9313                 right->op_flags |= OPf_STACKED;
9314                 /* Detach split and expunge aassign as above.  */
9315                 goto detach_split;
9316             }
9317             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9318                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
9319             {
9320                 /* convert split(...,0) to split(..., PL_modcount+1) */
9321                 SV ** const svp =
9322                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9323                 SV * const sv = *svp;
9324                 if (SvIOK(sv) && SvIVX(sv) == 0)
9325                 {
9326                   if (right->op_private & OPpSPLIT_IMPLIM) {
9327                     /* our own SV, created in ck_split */
9328                     SvREADONLY_off(sv);
9329                     sv_setiv(sv, PL_modcount+1);
9330                   }
9331                   else {
9332                     /* SV may belong to someone else */
9333                     SvREFCNT_dec(sv);
9334                     *svp = newSViv(PL_modcount+1);
9335                   }
9336                 }
9337             }
9338         }
9339
9340         if (state_var_op)
9341             o = S_newONCEOP(aTHX_ o, state_var_op);
9342         return o;
9343     }
9344     if (assign_type == ASSIGN_REF)
9345         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9346     if (!right)
9347         right = newOP(OP_UNDEF, 0);
9348     if (right->op_type == OP_READLINE) {
9349         right->op_flags |= OPf_STACKED;
9350         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9351                 scalar(right));
9352     }
9353     else {
9354         o = newBINOP(OP_SASSIGN, flags,
9355             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9356     }
9357     return o;
9358 }
9359
9360 /*
9361 =for apidoc newSTATEOP
9362
9363 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
9364 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9365 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9366 If C<label> is non-null, it supplies the name of a label to attach to
9367 the state op; this function takes ownership of the memory pointed at by
9368 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
9369 for the state op.
9370
9371 If C<o> is null, the state op is returned.  Otherwise the state op is
9372 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
9373 is consumed by this function and becomes part of the returned op tree.
9374
9375 =cut
9376 */
9377
9378 OP *
9379 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9380 {
9381     dVAR;
9382     const U32 seq = intro_my();
9383     const U32 utf8 = flags & SVf_UTF8;
9384     COP *cop;
9385
9386     PL_parser->parsed_sub = 0;
9387
9388     flags &= ~SVf_UTF8;
9389
9390     NewOp(1101, cop, 1, COP);
9391     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9392         OpTYPE_set(cop, OP_DBSTATE);
9393     }
9394     else {
9395         OpTYPE_set(cop, OP_NEXTSTATE);
9396     }
9397     cop->op_flags = (U8)flags;
9398     CopHINTS_set(cop, PL_hints);
9399 #ifdef VMS
9400     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9401 #endif
9402     cop->op_next = (OP*)cop;
9403
9404     cop->cop_seq = seq;
9405     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9406     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9407     if (label) {
9408         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9409
9410         PL_hints |= HINT_BLOCK_SCOPE;
9411         /* It seems that we need to defer freeing this pointer, as other parts
9412            of the grammar end up wanting to copy it after this op has been
9413            created. */
9414         SAVEFREEPV(label);
9415     }
9416
9417     if (PL_parser->preambling != NOLINE) {
9418         CopLINE_set(cop, PL_parser->preambling);
9419         PL_parser->copline = NOLINE;
9420     }
9421     else if (PL_parser->copline == NOLINE)
9422         CopLINE_set(cop, CopLINE(PL_curcop));
9423     else {
9424         CopLINE_set(cop, PL_parser->copline);
9425         PL_parser->copline = NOLINE;
9426     }
9427 #ifdef USE_ITHREADS
9428     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
9429 #else
9430     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9431 #endif
9432     CopSTASH_set(cop, PL_curstash);
9433
9434     if (cop->op_type == OP_DBSTATE) {
9435         /* this line can have a breakpoint - store the cop in IV */
9436         AV *av = CopFILEAVx(PL_curcop);
9437         if (av) {
9438             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9439             if (svp && *svp != &PL_sv_undef ) {
9440                 (void)SvIOK_on(*svp);
9441                 SvIV_set(*svp, PTR2IV(cop));
9442             }
9443         }
9444     }
9445
9446     if (flags & OPf_SPECIAL)
9447         op_null((OP*)cop);
9448     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9449 }
9450
9451 /*
9452 =for apidoc newLOGOP
9453
9454 Constructs, checks, and returns a logical (flow control) op.  C<type>
9455 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
9456 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9457 the eight bits of C<op_private>, except that the bit with value 1 is
9458 automatically set.  C<first> supplies the expression controlling the
9459 flow, and C<other> supplies the side (alternate) chain of ops; they are
9460 consumed by this function and become part of the constructed op tree.
9461
9462 =cut
9463 */
9464
9465 OP *
9466 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9467 {
9468     PERL_ARGS_ASSERT_NEWLOGOP;
9469
9470     return new_logop(type, flags, &first, &other);
9471 }
9472
9473
9474 /* See if the optree o contains a single OP_CONST (plus possibly
9475  * surrounding enter/nextstate/null etc). If so, return it, else return
9476  * NULL.
9477  */
9478
9479 STATIC OP *
9480 S_search_const(pTHX_ OP *o)
9481 {
9482     PERL_ARGS_ASSERT_SEARCH_CONST;
9483
9484   redo:
9485     switch (o->op_type) {
9486         case OP_CONST:
9487             return o;
9488         case OP_NULL:
9489             if (o->op_flags & OPf_KIDS) {
9490                 o = cUNOPo->op_first;
9491                 goto redo;
9492             }
9493             break;
9494         case OP_LEAVE:
9495         case OP_SCOPE:
9496         case OP_LINESEQ:
9497         {
9498             OP *kid;
9499             if (!(o->op_flags & OPf_KIDS))
9500                 return NULL;
9501             kid = cLISTOPo->op_first;
9502
9503             do {
9504                 switch (kid->op_type) {
9505                     case OP_ENTER:
9506                     case OP_NULL:
9507                     case OP_NEXTSTATE:
9508                         kid = OpSIBLING(kid);
9509                         break;
9510                     default:
9511                         if (kid != cLISTOPo->op_last)
9512                             return NULL;
9513                         goto last;
9514                 }
9515             } while (kid);
9516
9517             if (!kid)
9518                 kid = cLISTOPo->op_last;
9519           last:
9520              o = kid;
9521              goto redo;
9522         }
9523     }
9524
9525     return NULL;
9526 }
9527
9528
9529 STATIC OP *
9530 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9531 {
9532     dVAR;
9533     LOGOP *logop;
9534     OP *o;
9535     OP *first;
9536     OP *other;
9537     OP *cstop = NULL;
9538     int prepend_not = 0;
9539
9540     PERL_ARGS_ASSERT_NEW_LOGOP;
9541
9542     first = *firstp;
9543     other = *otherp;
9544
9545     /* [perl #59802]: Warn about things like "return $a or $b", which
9546        is parsed as "(return $a) or $b" rather than "return ($a or
9547        $b)".  NB: This also applies to xor, which is why we do it
9548        here.
9549      */
9550     switch (first->op_type) {
9551     case OP_NEXT:
9552     case OP_LAST:
9553     case OP_REDO:
9554         /* XXX: Perhaps we should emit a stronger warning for these.
9555            Even with the high-precedence operator they don't seem to do
9556            anything sensible.
9557
9558            But until we do, fall through here.
9559          */
9560     case OP_RETURN:
9561     case OP_EXIT:
9562     case OP_DIE:
9563     case OP_GOTO:
9564         /* XXX: Currently we allow people to "shoot themselves in the
9565            foot" by explicitly writing "(return $a) or $b".
9566
9567            Warn unless we are looking at the result from folding or if
9568            the programmer explicitly grouped the operators like this.
9569            The former can occur with e.g.
9570
9571                 use constant FEATURE => ( $] >= ... );
9572                 sub { not FEATURE and return or do_stuff(); }
9573          */
9574         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9575             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9576                            "Possible precedence issue with control flow operator");
9577         /* XXX: Should we optimze this to "return $a;" (i.e. remove
9578            the "or $b" part)?
9579         */
9580         break;
9581     }
9582
9583     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
9584         return newBINOP(type, flags, scalar(first), scalar(other));
9585
9586     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9587         || type == OP_CUSTOM);
9588
9589     scalarboolean(first);
9590
9591     /* search for a constant op that could let us fold the test */
9592     if ((cstop = search_const(first))) {
9593         if (cstop->op_private & OPpCONST_STRICT)
9594             no_bareword_allowed(cstop);
9595         else if ((cstop->op_private & OPpCONST_BARE))
9596                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9597         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
9598             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9599             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9600             /* Elide the (constant) lhs, since it can't affect the outcome */
9601             *firstp = NULL;
9602             if (other->op_type == OP_CONST)
9603                 other->op_private |= OPpCONST_SHORTCIRCUIT;
9604             op_free(first);
9605             if (other->op_type == OP_LEAVE)
9606                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9607             else if (other->op_type == OP_MATCH
9608                   || other->op_type == OP_SUBST
9609                   || other->op_type == OP_TRANSR
9610                   || other->op_type == OP_TRANS)
9611                 /* Mark the op as being unbindable with =~ */
9612                 other->op_flags |= OPf_SPECIAL;
9613
9614             other->op_folded = 1;
9615             return other;
9616         }
9617         else {
9618             /* Elide the rhs, since the outcome is entirely determined by
9619              * the (constant) lhs */
9620
9621             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9622             const OP *o2 = other;
9623             if ( ! (o2->op_type == OP_LIST
9624                     && (( o2 = cUNOPx(o2)->op_first))
9625                     && o2->op_type == OP_PUSHMARK
9626                     && (( o2 = OpSIBLING(o2))) )
9627             )
9628                 o2 = other;
9629             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9630                         || o2->op_type == OP_PADHV)
9631                 && o2->op_private & OPpLVAL_INTRO
9632                 && !(o2->op_private & OPpPAD_STATE))
9633             {
9634         Perl_croak(aTHX_ "This use of my() in false conditional is "
9635                           "no longer allowed");
9636             }
9637
9638             *otherp = NULL;
9639             if (cstop->op_type == OP_CONST)
9640                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9641             op_free(other);
9642             return first;
9643         }
9644     }
9645     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9646         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9647     {
9648         const OP * const k1 = ((UNOP*)first)->op_first;
9649         const OP * const k2 = OpSIBLING(k1);
9650         OPCODE warnop = 0;
9651         switch (first->op_type)
9652         {
9653         case OP_NULL:
9654             if (k2 && k2->op_type == OP_READLINE
9655                   && (k2->op_flags & OPf_STACKED)
9656                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9657             {
9658                 warnop = k2->op_type;
9659             }
9660             break;
9661
9662         case OP_SASSIGN:
9663             if (k1->op_type == OP_READDIR
9664                   || k1->op_type == OP_GLOB
9665                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9666                  || k1->op_type == OP_EACH
9667                  || k1->op_type == OP_AEACH)
9668             {
9669                 warnop = ((k1->op_type == OP_NULL)
9670                           ? (OPCODE)k1->op_targ : k1->op_type);
9671             }
9672             break;
9673         }
9674         if (warnop) {
9675             const line_t oldline = CopLINE(PL_curcop);
9676             /* This ensures that warnings are reported at the first line
9677                of the construction, not the last.  */
9678             CopLINE_set(PL_curcop, PL_parser->copline);
9679             Perl_warner(aTHX_ packWARN(WARN_MISC),
9680                  "Value of %s%s can be \"0\"; test with defined()",
9681                  PL_op_desc[warnop],
9682                  ((warnop == OP_READLINE || warnop == OP_GLOB)
9683                   ? " construct" : "() operator"));
9684             CopLINE_set(PL_curcop, oldline);
9685         }
9686     }
9687
9688     /* optimize AND and OR ops that have NOTs as children */
9689     if (first->op_type == OP_NOT
9690         && (first->op_flags & OPf_KIDS)
9691         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9692             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
9693         ) {
9694         if (type == OP_AND || type == OP_OR) {
9695             if (type == OP_AND)
9696                 type = OP_OR;
9697             else
9698                 type = OP_AND;
9699             op_null(first);
9700             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9701                 op_null(other);
9702                 prepend_not = 1; /* prepend a NOT op later */
9703             }
9704         }
9705     }
9706
9707     logop = alloc_LOGOP(type, first, LINKLIST(other));
9708     logop->op_flags |= (U8)flags;
9709     logop->op_private = (U8)(1 | (flags >> 8));
9710
9711     /* establish postfix order */
9712     logop->op_next = LINKLIST(first);
9713     first->op_next = (OP*)logop;
9714     assert(!OpHAS_SIBLING(first));
9715     op_sibling_splice((OP*)logop, first, 0, other);
9716
9717     CHECKOP(type,logop);
9718
9719     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9720                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9721                 (OP*)logop);
9722     other->op_next = o;
9723
9724     return o;
9725 }
9726
9727 /*
9728 =for apidoc newCONDOP
9729
9730 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9731 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9732 will be set automatically, and, shifted up eight bits, the eight bits of
9733 C<op_private>, except that the bit with value 1 is automatically set.
9734 C<first> supplies the expression selecting between the two branches,
9735 and C<trueop> and C<falseop> supply the branches; they are consumed by
9736 this function and become part of the constructed op tree.
9737
9738 =cut
9739 */
9740
9741 OP *
9742 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9743 {
9744     dVAR;
9745     LOGOP *logop;
9746     OP *start;
9747     OP *o;
9748     OP *cstop;
9749
9750     PERL_ARGS_ASSERT_NEWCONDOP;
9751
9752     if (!falseop)
9753         return newLOGOP(OP_AND, 0, first, trueop);
9754     if (!trueop)
9755         return newLOGOP(OP_OR, 0, first, falseop);
9756
9757     scalarboolean(first);
9758     if ((cstop = search_const(first))) {
9759         /* Left or right arm of the conditional?  */
9760         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9761         OP *live = left ? trueop : falseop;
9762         OP *const dead = left ? falseop : trueop;
9763         if (cstop->op_private & OPpCONST_BARE &&
9764             cstop->op_private & OPpCONST_STRICT) {
9765             no_bareword_allowed(cstop);
9766         }
9767         op_free(first);
9768         op_free(dead);
9769         if (live->op_type == OP_LEAVE)
9770             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9771         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9772               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9773             /* Mark the op as being unbindable with =~ */
9774             live->op_flags |= OPf_SPECIAL;
9775         live->op_folded = 1;
9776         return live;
9777     }
9778     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9779     logop->op_flags |= (U8)flags;
9780     logop->op_private = (U8)(1 | (flags >> 8));
9781     logop->op_next = LINKLIST(falseop);
9782
9783     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9784             logop);
9785
9786     /* establish postfix order */
9787     start = LINKLIST(first);
9788     first->op_next = (OP*)logop;
9789
9790     /* make first, trueop, falseop siblings */
9791     op_sibling_splice((OP*)logop, first,  0, trueop);
9792     op_sibling_splice((OP*)logop, trueop, 0, falseop);
9793
9794     o = newUNOP(OP_NULL, 0, (OP*)logop);
9795
9796     trueop->op_next = falseop->op_next = o;
9797
9798     o->op_next = start;
9799     return o;
9800 }
9801
9802 /*
9803 =for apidoc newRANGE
9804
9805 Constructs and returns a C<range> op, with subordinate C<flip> and
9806 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
9807 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9808 for both the C<flip> and C<range> ops, except that the bit with value
9809 1 is automatically set.  C<left> and C<right> supply the expressions
9810 controlling the endpoints of the range; they are consumed by this function
9811 and become part of the constructed op tree.
9812
9813 =cut
9814 */
9815
9816 OP *
9817 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9818 {
9819     LOGOP *range;
9820     OP *flip;
9821     OP *flop;
9822     OP *leftstart;
9823     OP *o;
9824
9825     PERL_ARGS_ASSERT_NEWRANGE;
9826
9827     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9828     range->op_flags = OPf_KIDS;
9829     leftstart = LINKLIST(left);
9830     range->op_private = (U8)(1 | (flags >> 8));
9831
9832     /* make left and right siblings */
9833     op_sibling_splice((OP*)range, left, 0, right);
9834
9835     range->op_next = (OP*)range;
9836     flip = newUNOP(OP_FLIP, flags, (OP*)range);
9837     flop = newUNOP(OP_FLOP, 0, flip);
9838     o = newUNOP(OP_NULL, 0, flop);
9839     LINKLIST(flop);
9840     range->op_next = leftstart;
9841
9842     left->op_next = flip;
9843     right->op_next = flop;
9844
9845     range->op_targ =
9846         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9847     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9848     flip->op_targ =
9849         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9850     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9851     SvPADTMP_on(PAD_SV(flip->op_targ));
9852
9853     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9854     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9855
9856     /* check barewords before they might be optimized aways */
9857     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9858         no_bareword_allowed(left);
9859     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9860         no_bareword_allowed(right);
9861
9862     flip->op_next = o;
9863     if (!flip->op_private || !flop->op_private)
9864         LINKLIST(o);            /* blow off optimizer unless constant */
9865
9866     return o;
9867 }
9868
9869 /*
9870 =for apidoc newLOOPOP
9871
9872 Constructs, checks, and returns an op tree expressing a loop.  This is
9873 only a loop in the control flow through the op tree; it does not have
9874 the heavyweight loop structure that allows exiting the loop by C<last>
9875 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
9876 top-level op, except that some bits will be set automatically as required.
9877 C<expr> supplies the expression controlling loop iteration, and C<block>
9878 supplies the body of the loop; they are consumed by this function and
9879 become part of the constructed op tree.  C<debuggable> is currently
9880 unused and should always be 1.
9881
9882 =cut
9883 */
9884
9885 OP *
9886 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9887 {
9888     OP* listop;
9889     OP* o;
9890     const bool once = block && block->op_flags & OPf_SPECIAL &&
9891                       block->op_type == OP_NULL;
9892
9893     PERL_UNUSED_ARG(debuggable);
9894
9895     if (expr) {
9896         if (once && (
9897               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9898            || (  expr->op_type == OP_NOT
9899               && cUNOPx(expr)->op_first->op_type == OP_CONST
9900               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9901               )
9902            ))
9903             /* Return the block now, so that S_new_logop does not try to
9904                fold it away. */
9905         {
9906             op_free(expr);
9907             return block;       /* do {} while 0 does once */
9908         }
9909
9910         if (expr->op_type == OP_READLINE
9911             || expr->op_type == OP_READDIR
9912             || expr->op_type == OP_GLOB
9913             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9914             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9915             expr = newUNOP(OP_DEFINED, 0,
9916                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9917         } else if (expr->op_flags & OPf_KIDS) {
9918             const OP * const k1 = ((UNOP*)expr)->op_first;
9919             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9920             switch (expr->op_type) {
9921               case OP_NULL:
9922                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9923                       && (k2->op_flags & OPf_STACKED)
9924                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9925                     expr = newUNOP(OP_DEFINED, 0, expr);
9926                 break;
9927
9928               case OP_SASSIGN:
9929                 if (k1 && (k1->op_type == OP_READDIR
9930                       || k1->op_type == OP_GLOB
9931                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9932                      || k1->op_type == OP_EACH
9933                      || k1->op_type == OP_AEACH))
9934                     expr = newUNOP(OP_DEFINED, 0, expr);
9935                 break;
9936             }
9937         }
9938     }
9939
9940     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9941      * op, in listop. This is wrong. [perl #27024] */
9942     if (!block)
9943         block = newOP(OP_NULL, 0);
9944     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9945     o = new_logop(OP_AND, 0, &expr, &listop);
9946
9947     if (once) {
9948         ASSUME(listop);
9949     }
9950
9951     if (listop)
9952         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9953
9954     if (once && o != listop)
9955     {
9956         assert(cUNOPo->op_first->op_type == OP_AND
9957             || cUNOPo->op_first->op_type == OP_OR);
9958         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9959     }
9960
9961     if (o == listop)
9962         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
9963
9964     o->op_flags |= flags;
9965     o = op_scope(o);
9966     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9967     return o;
9968 }
9969
9970 /*
9971 =for apidoc newWHILEOP
9972
9973 Constructs, checks, and returns an op tree expressing a C<while> loop.
9974 This is a heavyweight loop, with structure that allows exiting the loop
9975 by C<last> and suchlike.
9976
9977 C<loop> is an optional preconstructed C<enterloop> op to use in the
9978 loop; if it is null then a suitable op will be constructed automatically.
9979 C<expr> supplies the loop's controlling expression.  C<block> supplies the
9980 main body of the loop, and C<cont> optionally supplies a C<continue> block
9981 that operates as a second half of the body.  All of these optree inputs
9982 are consumed by this function and become part of the constructed op tree.
9983
9984 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9985 op and, shifted up eight bits, the eight bits of C<op_private> for
9986 the C<leaveloop> op, except that (in both cases) some bits will be set
9987 automatically.  C<debuggable> is currently unused and should always be 1.
9988 C<has_my> can be supplied as true to force the
9989 loop body to be enclosed in its own scope.
9990
9991 =cut
9992 */
9993
9994 OP *
9995 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9996         OP *expr, OP *block, OP *cont, I32 has_my)
9997 {
9998     dVAR;
9999     OP *redo;
10000     OP *next = NULL;
10001     OP *listop;
10002     OP *o;
10003     U8 loopflags = 0;
10004
10005     PERL_UNUSED_ARG(debuggable);
10006
10007     if (expr) {
10008         if (expr->op_type == OP_READLINE
10009          || expr->op_type == OP_READDIR
10010          || expr->op_type == OP_GLOB
10011          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
10012                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
10013             expr = newUNOP(OP_DEFINED, 0,
10014                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
10015         } else if (expr->op_flags & OPf_KIDS) {
10016             const OP * const k1 = ((UNOP*)expr)->op_first;
10017             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
10018             switch (expr->op_type) {
10019               case OP_NULL:
10020                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
10021                       && (k2->op_flags & OPf_STACKED)
10022                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
10023                     expr = newUNOP(OP_DEFINED, 0, expr);
10024                 break;
10025
10026               case OP_SASSIGN:
10027                 if (k1 && (k1->op_type == OP_READDIR
10028                       || k1->op_type == OP_GLOB
10029                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
10030                      || k1->op_type == OP_EACH
10031                      || k1->op_type == OP_AEACH))
10032                     expr = newUNOP(OP_DEFINED, 0, expr);
10033                 break;
10034             }
10035         }
10036     }
10037
10038     if (!block)
10039         block = newOP(OP_NULL, 0);
10040     else if (cont || has_my) {
10041         block = op_scope(block);
10042     }
10043
10044     if (cont) {
10045         next = LINKLIST(cont);
10046     }
10047     if (expr) {
10048         OP * const unstack = newOP(OP_UNSTACK, 0);
10049         if (!next)
10050             next = unstack;
10051         cont = op_append_elem(OP_LINESEQ, cont, unstack);
10052     }
10053
10054     assert(block);
10055     listop = op_append_list(OP_LINESEQ, block, cont);
10056     assert(listop);
10057     redo = LINKLIST(listop);
10058
10059     if (expr) {
10060         scalar(listop);
10061         o = new_logop(OP_AND, 0, &expr, &listop);
10062         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
10063             op_free((OP*)loop);
10064             return expr;                /* listop already freed by new_logop */
10065         }
10066         if (listop)
10067             ((LISTOP*)listop)->op_last->op_next =
10068                 (o == listop ? redo : LINKLIST(o));
10069     }
10070     else
10071         o = listop;
10072
10073     if (!loop) {
10074         NewOp(1101,loop,1,LOOP);
10075         OpTYPE_set(loop, OP_ENTERLOOP);
10076         loop->op_private = 0;
10077         loop->op_next = (OP*)loop;
10078     }
10079
10080     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
10081
10082     loop->op_redoop = redo;
10083     loop->op_lastop = o;
10084     o->op_private |= loopflags;
10085
10086     if (next)
10087         loop->op_nextop = next;
10088     else
10089         loop->op_nextop = o;
10090
10091     o->op_flags |= flags;
10092     o->op_private |= (flags >> 8);
10093     return o;
10094 }
10095
10096 /*
10097 =for apidoc newFOROP
10098
10099 Constructs, checks, and returns an op tree expressing a C<foreach>
10100 loop (iteration through a list of values).  This is a heavyweight loop,
10101 with structure that allows exiting the loop by C<last> and suchlike.
10102
10103 C<sv> optionally supplies the variable that will be aliased to each
10104 item in turn; if null, it defaults to C<$_>.
10105 C<expr> supplies the list of values to iterate over.  C<block> supplies
10106 the main body of the loop, and C<cont> optionally supplies a C<continue>
10107 block that operates as a second half of the body.  All of these optree
10108 inputs are consumed by this function and become part of the constructed
10109 op tree.
10110
10111 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
10112 op and, shifted up eight bits, the eight bits of C<op_private> for
10113 the C<leaveloop> op, except that (in both cases) some bits will be set
10114 automatically.
10115
10116 =cut
10117 */
10118
10119 OP *
10120 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
10121 {
10122     dVAR;
10123     LOOP *loop;
10124     OP *wop;
10125     PADOFFSET padoff = 0;
10126     I32 iterflags = 0;
10127     I32 iterpflags = 0;
10128
10129     PERL_ARGS_ASSERT_NEWFOROP;
10130
10131     if (sv) {
10132         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
10133             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
10134             OpTYPE_set(sv, OP_RV2GV);
10135
10136             /* The op_type check is needed to prevent a possible segfault
10137              * if the loop variable is undeclared and 'strict vars' is in
10138              * effect. This is illegal but is nonetheless parsed, so we
10139              * may reach this point with an OP_CONST where we're expecting
10140              * an OP_GV.
10141              */
10142             if (cUNOPx(sv)->op_first->op_type == OP_GV
10143              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
10144                 iterpflags |= OPpITER_DEF;
10145         }
10146         else if (sv->op_type == OP_PADSV) { /* private variable */
10147             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
10148             padoff = sv->op_targ;
10149             sv->op_targ = 0;
10150             op_free(sv);
10151             sv = NULL;
10152             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
10153         }
10154         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
10155             NOOP;
10156         else
10157             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
10158         if (padoff) {
10159             PADNAME * const pn = PAD_COMPNAME(padoff);
10160             const char * const name = PadnamePV(pn);
10161
10162             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
10163                 iterpflags |= OPpITER_DEF;
10164         }
10165     }
10166     else {
10167         sv = newGVOP(OP_GV, 0, PL_defgv);
10168         iterpflags |= OPpITER_DEF;
10169     }
10170
10171     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
10172         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
10173         iterflags |= OPf_STACKED;
10174     }
10175     else if (expr->op_type == OP_NULL &&
10176              (expr->op_flags & OPf_KIDS) &&
10177              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
10178     {
10179         /* Basically turn for($x..$y) into the same as for($x,$y), but we
10180          * set the STACKED flag to indicate that these values are to be
10181          * treated as min/max values by 'pp_enteriter'.
10182          */
10183         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10184         LOGOP* const range = (LOGOP*) flip->op_first;
10185         OP* const left  = range->op_first;
10186         OP* const right = OpSIBLING(left);
10187         LISTOP* listop;
10188
10189         range->op_flags &= ~OPf_KIDS;
10190         /* detach range's children */
10191         op_sibling_splice((OP*)range, NULL, -1, NULL);
10192
10193         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10194         listop->op_first->op_next = range->op_next;
10195         left->op_next = range->op_other;
10196         right->op_next = (OP*)listop;
10197         listop->op_next = listop->op_first;
10198
10199         op_free(expr);
10200         expr = (OP*)(listop);
10201         op_null(expr);
10202         iterflags |= OPf_STACKED;
10203     }
10204     else {
10205         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10206     }
10207
10208     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10209                                   op_append_elem(OP_LIST, list(expr),
10210                                                  scalar(sv)));
10211     assert(!loop->op_next);
10212     /* for my  $x () sets OPpLVAL_INTRO;
10213      * for our $x () sets OPpOUR_INTRO */
10214     loop->op_private = (U8)iterpflags;
10215
10216     /* upgrade loop from a LISTOP to a LOOPOP;
10217      * keep it in-place if there's space */
10218     if (loop->op_slabbed
10219         &&    OpSLOT(loop)->opslot_size
10220             < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10221     {
10222         /* no space; allocate new op */
10223         LOOP *tmp;
10224         NewOp(1234,tmp,1,LOOP);
10225         Copy(loop,tmp,1,LISTOP);
10226         assert(loop->op_last->op_sibparent == (OP*)loop);
10227         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10228         S_op_destroy(aTHX_ (OP*)loop);
10229         loop = tmp;
10230     }
10231     else if (!loop->op_slabbed)
10232     {
10233         /* loop was malloc()ed */
10234         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10235         OpLASTSIB_set(loop->op_last, (OP*)loop);
10236     }
10237     loop->op_targ = padoff;
10238     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10239     return wop;
10240 }
10241
10242 /*
10243 =for apidoc newLOOPEX
10244
10245 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10246 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
10247 determining the target of the op; it is consumed by this function and
10248 becomes part of the constructed op tree.
10249
10250 =cut
10251 */
10252
10253 OP*
10254 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10255 {
10256     OP *o = NULL;
10257
10258     PERL_ARGS_ASSERT_NEWLOOPEX;
10259
10260     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10261         || type == OP_CUSTOM);
10262
10263     if (type != OP_GOTO) {
10264         /* "last()" means "last" */
10265         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10266             o = newOP(type, OPf_SPECIAL);
10267         }
10268     }
10269     else {
10270         /* Check whether it's going to be a goto &function */
10271         if (label->op_type == OP_ENTERSUB
10272                 && !(label->op_flags & OPf_STACKED))
10273             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10274     }
10275
10276     /* Check for a constant argument */
10277     if (label->op_type == OP_CONST) {
10278             SV * const sv = ((SVOP *)label)->op_sv;
10279             STRLEN l;
10280             const char *s = SvPV_const(sv,l);
10281             if (l == strlen(s)) {
10282                 o = newPVOP(type,
10283                             SvUTF8(((SVOP*)label)->op_sv),
10284                             savesharedpv(
10285                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10286             }
10287     }
10288
10289     /* If we have already created an op, we do not need the label. */
10290     if (o)
10291                 op_free(label);
10292     else o = newUNOP(type, OPf_STACKED, label);
10293
10294     PL_hints |= HINT_BLOCK_SCOPE;
10295     return o;
10296 }
10297
10298 /* if the condition is a literal array or hash
10299    (or @{ ... } etc), make a reference to it.
10300  */
10301 STATIC OP *
10302 S_ref_array_or_hash(pTHX_ OP *cond)
10303 {
10304     if (cond
10305     && (cond->op_type == OP_RV2AV
10306     ||  cond->op_type == OP_PADAV
10307     ||  cond->op_type == OP_RV2HV
10308     ||  cond->op_type == OP_PADHV))
10309
10310         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10311
10312     else if(cond
10313     && (cond->op_type == OP_ASLICE
10314     ||  cond->op_type == OP_KVASLICE
10315     ||  cond->op_type == OP_HSLICE
10316     ||  cond->op_type == OP_KVHSLICE)) {
10317
10318         /* anonlist now needs a list from this op, was previously used in
10319          * scalar context */
10320         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10321         cond->op_flags |= OPf_WANT_LIST;
10322
10323         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10324     }
10325
10326     else
10327         return cond;
10328 }
10329
10330 /* These construct the optree fragments representing given()
10331    and when() blocks.
10332
10333    entergiven and enterwhen are LOGOPs; the op_other pointer
10334    points up to the associated leave op. We need this so we
10335    can put it in the context and make break/continue work.
10336    (Also, of course, pp_enterwhen will jump straight to
10337    op_other if the match fails.)
10338  */
10339
10340 STATIC OP *
10341 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10342                    I32 enter_opcode, I32 leave_opcode,
10343                    PADOFFSET entertarg)
10344 {
10345     dVAR;
10346     LOGOP *enterop;
10347     OP *o;
10348
10349     PERL_ARGS_ASSERT_NEWGIVWHENOP;
10350     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10351
10352     enterop = alloc_LOGOP(enter_opcode, block, NULL);
10353     enterop->op_targ = 0;
10354     enterop->op_private = 0;
10355
10356     o = newUNOP(leave_opcode, 0, (OP *) enterop);
10357
10358     if (cond) {
10359         /* prepend cond if we have one */
10360         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10361
10362         o->op_next = LINKLIST(cond);
10363         cond->op_next = (OP *) enterop;
10364     }
10365     else {
10366         /* This is a default {} block */
10367         enterop->op_flags |= OPf_SPECIAL;
10368         o      ->op_flags |= OPf_SPECIAL;
10369
10370         o->op_next = (OP *) enterop;
10371     }
10372
10373     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10374                                        entergiven and enterwhen both
10375                                        use ck_null() */
10376
10377     enterop->op_next = LINKLIST(block);
10378     block->op_next = enterop->op_other = o;
10379
10380     return o;
10381 }
10382
10383
10384 /* For the purposes of 'when(implied_smartmatch)'
10385  *              versus 'when(boolean_expression)',
10386  * does this look like a boolean operation? For these purposes
10387    a boolean operation is:
10388      - a subroutine call [*]
10389      - a logical connective
10390      - a comparison operator
10391      - a filetest operator, with the exception of -s -M -A -C
10392      - defined(), exists() or eof()
10393      - /$re/ or $foo =~ /$re/
10394
10395    [*] possibly surprising
10396  */
10397 STATIC bool
10398 S_looks_like_bool(pTHX_ const OP *o)
10399 {
10400     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10401
10402     switch(o->op_type) {
10403         case OP_OR:
10404         case OP_DOR:
10405             return looks_like_bool(cLOGOPo->op_first);
10406
10407         case OP_AND:
10408         {
10409             OP* sibl = OpSIBLING(cLOGOPo->op_first);
10410             ASSUME(sibl);
10411             return (
10412                 looks_like_bool(cLOGOPo->op_first)
10413              && looks_like_bool(sibl));
10414         }
10415
10416         case OP_NULL:
10417         case OP_SCALAR:
10418             return (
10419                 o->op_flags & OPf_KIDS
10420             && looks_like_bool(cUNOPo->op_first));
10421
10422         case OP_ENTERSUB:
10423
10424         case OP_NOT:    case OP_XOR:
10425
10426         case OP_EQ:     case OP_NE:     case OP_LT:
10427         case OP_GT:     case OP_LE:     case OP_GE:
10428
10429         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
10430         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
10431
10432         case OP_SEQ:    case OP_SNE:    case OP_SLT:
10433         case OP_SGT:    case OP_SLE:    case OP_SGE:
10434
10435         case OP_SMARTMATCH:
10436
10437         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
10438         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
10439         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
10440         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
10441         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
10442         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
10443         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
10444         case OP_FTTEXT:   case OP_FTBINARY:
10445
10446         case OP_DEFINED: case OP_EXISTS:
10447         case OP_MATCH:   case OP_EOF:
10448
10449         case OP_FLOP:
10450
10451             return TRUE;
10452
10453         case OP_INDEX:
10454         case OP_RINDEX:
10455             /* optimised-away (index() != -1) or similar comparison */
10456             if (o->op_private & OPpTRUEBOOL)
10457                 return TRUE;
10458             return FALSE;
10459
10460         case OP_CONST:
10461             /* Detect comparisons that have been optimized away */
10462             if (cSVOPo->op_sv == &PL_sv_yes
10463             ||  cSVOPo->op_sv == &PL_sv_no)
10464
10465                 return TRUE;
10466             else
10467                 return FALSE;
10468         /* FALLTHROUGH */
10469         default:
10470             return FALSE;
10471     }
10472 }
10473
10474
10475 /*
10476 =for apidoc newGIVENOP
10477
10478 Constructs, checks, and returns an op tree expressing a C<given> block.
10479 C<cond> supplies the expression to whose value C<$_> will be locally
10480 aliased, and C<block> supplies the body of the C<given> construct; they
10481 are consumed by this function and become part of the constructed op tree.
10482 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10483
10484 =cut
10485 */
10486
10487 OP *
10488 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10489 {
10490     PERL_ARGS_ASSERT_NEWGIVENOP;
10491     PERL_UNUSED_ARG(defsv_off);
10492
10493     assert(!defsv_off);
10494     return newGIVWHENOP(
10495         ref_array_or_hash(cond),
10496         block,
10497         OP_ENTERGIVEN, OP_LEAVEGIVEN,
10498         0);
10499 }
10500
10501 /*
10502 =for apidoc newWHENOP
10503
10504 Constructs, checks, and returns an op tree expressing a C<when> block.
10505 C<cond> supplies the test expression, and C<block> supplies the block
10506 that will be executed if the test evaluates to true; they are consumed
10507 by this function and become part of the constructed op tree.  C<cond>
10508 will be interpreted DWIMically, often as a comparison against C<$_>,
10509 and may be null to generate a C<default> block.
10510
10511 =cut
10512 */
10513
10514 OP *
10515 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10516 {
10517     const bool cond_llb = (!cond || looks_like_bool(cond));
10518     OP *cond_op;
10519
10520     PERL_ARGS_ASSERT_NEWWHENOP;
10521
10522     if (cond_llb)
10523         cond_op = cond;
10524     else {
10525         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10526                 newDEFSVOP(),
10527                 scalar(ref_array_or_hash(cond)));
10528     }
10529
10530     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10531 }
10532
10533 /* must not conflict with SVf_UTF8 */
10534 #define CV_CKPROTO_CURSTASH     0x1
10535
10536 void
10537 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10538                     const STRLEN len, const U32 flags)
10539 {
10540     SV *name = NULL, *msg;
10541     const char * cvp = SvROK(cv)
10542                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10543                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10544                            : ""
10545                         : CvPROTO(cv);
10546     STRLEN clen = CvPROTOLEN(cv), plen = len;
10547
10548     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10549
10550     if (p == NULL && cvp == NULL)
10551         return;
10552
10553     if (!ckWARN_d(WARN_PROTOTYPE))
10554         return;
10555
10556     if (p && cvp) {
10557         p = S_strip_spaces(aTHX_ p, &plen);
10558         cvp = S_strip_spaces(aTHX_ cvp, &clen);
10559         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10560             if (plen == clen && memEQ(cvp, p, plen))
10561                 return;
10562         } else {
10563             if (flags & SVf_UTF8) {
10564                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10565                     return;
10566             }
10567             else {
10568                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10569                     return;
10570             }
10571         }
10572     }
10573
10574     msg = sv_newmortal();
10575
10576     if (gv)
10577     {
10578         if (isGV(gv))
10579             gv_efullname3(name = sv_newmortal(), gv, NULL);
10580         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10581             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10582         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10583             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10584             sv_catpvs(name, "::");
10585             if (SvROK(gv)) {
10586                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10587                 assert (CvNAMED(SvRV_const(gv)));
10588                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10589             }
10590             else sv_catsv(name, (SV *)gv);
10591         }
10592         else name = (SV *)gv;
10593     }
10594     sv_setpvs(msg, "Prototype mismatch:");
10595     if (name)
10596         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10597     if (cvp)
10598         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10599             UTF8fARG(SvUTF8(cv),clen,cvp)
10600         );
10601     else
10602         sv_catpvs(msg, ": none");
10603     sv_catpvs(msg, " vs ");
10604     if (p)
10605         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10606     else
10607         sv_catpvs(msg, "none");
10608     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10609 }
10610
10611 static void const_sv_xsub(pTHX_ CV* cv);
10612 static void const_av_xsub(pTHX_ CV* cv);
10613
10614 /*
10615
10616 =head1 Optree Manipulation Functions
10617
10618 =for apidoc cv_const_sv
10619
10620 If C<cv> is a constant sub eligible for inlining, returns the constant
10621 value returned by the sub.  Otherwise, returns C<NULL>.
10622
10623 Constant subs can be created with C<newCONSTSUB> or as described in
10624 L<perlsub/"Constant Functions">.
10625
10626 =cut
10627 */
10628 SV *
10629 Perl_cv_const_sv(const CV *const cv)
10630 {
10631     SV *sv;
10632     if (!cv)
10633         return NULL;
10634     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10635         return NULL;
10636     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10637     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10638     return sv;
10639 }
10640
10641 SV *
10642 Perl_cv_const_sv_or_av(const CV * const cv)
10643 {
10644     if (!cv)
10645         return NULL;
10646     if (SvROK(cv)) return SvRV((SV *)cv);
10647     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10648     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10649 }
10650
10651 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
10652  * Can be called in 2 ways:
10653  *
10654  * !allow_lex
10655  *      look for a single OP_CONST with attached value: return the value
10656  *
10657  * allow_lex && !CvCONST(cv);
10658  *
10659  *      examine the clone prototype, and if contains only a single
10660  *      OP_CONST, return the value; or if it contains a single PADSV ref-
10661  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
10662  *      a candidate for "constizing" at clone time, and return NULL.
10663  */
10664
10665 static SV *
10666 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10667 {
10668     SV *sv = NULL;
10669     bool padsv = FALSE;
10670
10671     assert(o);
10672     assert(cv);
10673
10674     for (; o; o = o->op_next) {
10675         const OPCODE type = o->op_type;
10676
10677         if (type == OP_NEXTSTATE || type == OP_LINESEQ
10678              || type == OP_NULL
10679              || type == OP_PUSHMARK)
10680                 continue;
10681         if (type == OP_DBSTATE)
10682                 continue;
10683         if (type == OP_LEAVESUB)
10684             break;
10685         if (sv)
10686             return NULL;
10687         if (type == OP_CONST && cSVOPo->op_sv)
10688             sv = cSVOPo->op_sv;
10689         else if (type == OP_UNDEF && !o->op_private) {
10690             sv = newSV(0);
10691             SAVEFREESV(sv);
10692         }
10693         else if (allow_lex && type == OP_PADSV) {
10694                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10695                 {
10696                     sv = &PL_sv_undef; /* an arbitrary non-null value */
10697                     padsv = TRUE;
10698                 }
10699                 else
10700                     return NULL;
10701         }
10702         else {
10703             return NULL;
10704         }
10705     }
10706     if (padsv) {
10707         CvCONST_on(cv);
10708         return NULL;
10709     }
10710     return sv;
10711 }
10712
10713 static void
10714 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10715                         PADNAME * const name, SV ** const const_svp)
10716 {
10717     assert (cv);
10718     assert (o || name);
10719     assert (const_svp);
10720     if (!block) {
10721         if (CvFLAGS(PL_compcv)) {
10722             /* might have had built-in attrs applied */
10723             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10724             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10725              && ckWARN(WARN_MISC))
10726             {
10727                 /* protect against fatal warnings leaking compcv */
10728                 SAVEFREESV(PL_compcv);
10729                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10730                 SvREFCNT_inc_simple_void_NN(PL_compcv);
10731             }
10732             CvFLAGS(cv) |=
10733                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10734                   & ~(CVf_LVALUE * pureperl));
10735         }
10736         return;
10737     }
10738
10739     /* redundant check for speed: */
10740     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10741         const line_t oldline = CopLINE(PL_curcop);
10742         SV *namesv = o
10743             ? cSVOPo->op_sv
10744             : sv_2mortal(newSVpvn_utf8(
10745                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10746               ));
10747         if (PL_parser && PL_parser->copline != NOLINE)
10748             /* This ensures that warnings are reported at the first
10749                line of a redefinition, not the last.  */
10750             CopLINE_set(PL_curcop, PL_parser->copline);
10751         /* protect against fatal warnings leaking compcv */
10752         SAVEFREESV(PL_compcv);
10753         report_redefined_cv(namesv, cv, const_svp);
10754         SvREFCNT_inc_simple_void_NN(PL_compcv);
10755         CopLINE_set(PL_curcop, oldline);
10756     }
10757     SAVEFREESV(cv);
10758     return;
10759 }
10760
10761 CV *
10762 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10763 {
10764     CV **spot;
10765     SV **svspot;
10766     const char *ps;
10767     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10768     U32 ps_utf8 = 0;
10769     CV *cv = NULL;
10770     CV *compcv = PL_compcv;
10771     SV *const_sv;
10772     PADNAME *name;
10773     PADOFFSET pax = o->op_targ;
10774     CV *outcv = CvOUTSIDE(PL_compcv);
10775     CV *clonee = NULL;
10776     HEK *hek = NULL;
10777     bool reusable = FALSE;
10778     OP *start = NULL;
10779 #ifdef PERL_DEBUG_READONLY_OPS
10780     OPSLAB *slab = NULL;
10781 #endif
10782
10783     PERL_ARGS_ASSERT_NEWMYSUB;
10784
10785     PL_hints |= HINT_BLOCK_SCOPE;
10786
10787     /* Find the pad slot for storing the new sub.
10788        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
10789        need to look in CvOUTSIDE and find the pad belonging to the enclos-
10790        ing sub.  And then we need to dig deeper if this is a lexical from
10791        outside, as in:
10792            my sub foo; sub { sub foo { } }
10793      */
10794   redo:
10795     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10796     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10797         pax = PARENT_PAD_INDEX(name);
10798         outcv = CvOUTSIDE(outcv);
10799         assert(outcv);
10800         goto redo;
10801     }
10802     svspot =
10803         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10804                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10805     spot = (CV **)svspot;
10806
10807     if (!(PL_parser && PL_parser->error_count))
10808         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10809
10810     if (proto) {
10811         assert(proto->op_type == OP_CONST);
10812         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10813         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10814     }
10815     else
10816         ps = NULL;
10817
10818     if (proto)
10819         SAVEFREEOP(proto);
10820     if (attrs)
10821         SAVEFREEOP(attrs);
10822
10823     if (PL_parser && PL_parser->error_count) {
10824         op_free(block);
10825         SvREFCNT_dec(PL_compcv);
10826         PL_compcv = 0;
10827         goto done;
10828     }
10829
10830     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10831         cv = *spot;
10832         svspot = (SV **)(spot = &clonee);
10833     }
10834     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10835         cv = *spot;
10836     else {
10837         assert (SvTYPE(*spot) == SVt_PVCV);
10838         if (CvNAMED(*spot))
10839             hek = CvNAME_HEK(*spot);
10840         else {
10841             dVAR;
10842             U32 hash;
10843             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10844             CvNAME_HEK_set(*spot, hek =
10845                 share_hek(
10846                     PadnamePV(name)+1,
10847                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10848                     hash
10849                 )
10850             );
10851             CvLEXICAL_on(*spot);
10852         }
10853         cv = PadnamePROTOCV(name);
10854         svspot = (SV **)(spot = &PadnamePROTOCV(name));
10855     }
10856
10857     if (block) {
10858         /* This makes sub {}; work as expected.  */
10859         if (block->op_type == OP_STUB) {
10860             const line_t l = PL_parser->copline;
10861             op_free(block);
10862             block = newSTATEOP(0, NULL, 0);
10863             PL_parser->copline = l;
10864         }
10865         block = CvLVALUE(compcv)
10866              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10867                    ? newUNOP(OP_LEAVESUBLV, 0,
10868                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10869                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10870         start = LINKLIST(block);
10871         block->op_next = 0;
10872         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10873             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10874         else
10875             const_sv = NULL;
10876     }
10877     else
10878         const_sv = NULL;
10879
10880     if (cv) {
10881         const bool exists = CvROOT(cv) || CvXSUB(cv);
10882
10883         /* if the subroutine doesn't exist and wasn't pre-declared
10884          * with a prototype, assume it will be AUTOLOADed,
10885          * skipping the prototype check
10886          */
10887         if (exists || SvPOK(cv))
10888             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10889                                  ps_utf8);
10890         /* already defined? */
10891         if (exists) {
10892             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10893             if (block)
10894                 cv = NULL;
10895             else {
10896                 if (attrs)
10897                     goto attrs;
10898                 /* just a "sub foo;" when &foo is already defined */
10899                 SAVEFREESV(compcv);
10900                 goto done;
10901             }
10902         }
10903         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10904             cv = NULL;
10905             reusable = TRUE;
10906         }
10907     }
10908
10909     if (const_sv) {
10910         SvREFCNT_inc_simple_void_NN(const_sv);
10911         SvFLAGS(const_sv) |= SVs_PADTMP;
10912         if (cv) {
10913             assert(!CvROOT(cv) && !CvCONST(cv));
10914             cv_forget_slab(cv);
10915         }
10916         else {
10917             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10918             CvFILE_set_from_cop(cv, PL_curcop);
10919             CvSTASH_set(cv, PL_curstash);
10920             *spot = cv;
10921         }
10922         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10923         CvXSUBANY(cv).any_ptr = const_sv;
10924         CvXSUB(cv) = const_sv_xsub;
10925         CvCONST_on(cv);
10926         CvISXSUB_on(cv);
10927         PoisonPADLIST(cv);
10928         CvFLAGS(cv) |= CvMETHOD(compcv);
10929         op_free(block);
10930         SvREFCNT_dec(compcv);
10931         PL_compcv = NULL;
10932         goto setname;
10933     }
10934
10935     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10936        determine whether this sub definition is in the same scope as its
10937        declaration.  If this sub definition is inside an inner named pack-
10938        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10939        the package sub.  So check PadnameOUTER(name) too.
10940      */
10941     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10942         assert(!CvWEAKOUTSIDE(compcv));
10943         SvREFCNT_dec(CvOUTSIDE(compcv));
10944         CvWEAKOUTSIDE_on(compcv);
10945     }
10946     /* XXX else do we have a circular reference? */
10947
10948     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
10949         /* transfer PL_compcv to cv */
10950         if (block) {
10951             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10952             cv_flags_t preserved_flags =
10953                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10954             PADLIST *const temp_padl = CvPADLIST(cv);
10955             CV *const temp_cv = CvOUTSIDE(cv);
10956             const cv_flags_t other_flags =
10957                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10958             OP * const cvstart = CvSTART(cv);
10959
10960             SvPOK_off(cv);
10961             CvFLAGS(cv) =
10962                 CvFLAGS(compcv) | preserved_flags;
10963             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10964             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10965             CvPADLIST_set(cv, CvPADLIST(compcv));
10966             CvOUTSIDE(compcv) = temp_cv;
10967             CvPADLIST_set(compcv, temp_padl);
10968             CvSTART(cv) = CvSTART(compcv);
10969             CvSTART(compcv) = cvstart;
10970             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10971             CvFLAGS(compcv) |= other_flags;
10972
10973             if (free_file) {
10974                 Safefree(CvFILE(cv));
10975                 CvFILE(cv) = NULL;
10976             }
10977
10978             /* inner references to compcv must be fixed up ... */
10979             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10980             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10981                 ++PL_sub_generation;
10982         }
10983         else {
10984             /* Might have had built-in attributes applied -- propagate them. */
10985             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10986         }
10987         /* ... before we throw it away */
10988         SvREFCNT_dec(compcv);
10989         PL_compcv = compcv = cv;
10990     }
10991     else {
10992         cv = compcv;
10993         *spot = cv;
10994     }
10995
10996   setname:
10997     CvLEXICAL_on(cv);
10998     if (!CvNAME_HEK(cv)) {
10999         if (hek) (void)share_hek_hek(hek);
11000         else {
11001             dVAR;
11002             U32 hash;
11003             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
11004             hek = share_hek(PadnamePV(name)+1,
11005                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
11006                       hash);
11007         }
11008         CvNAME_HEK_set(cv, hek);
11009     }
11010
11011     if (const_sv)
11012         goto clone;
11013
11014     if (CvFILE(cv) && CvDYNFILE(cv))
11015         Safefree(CvFILE(cv));
11016     CvFILE_set_from_cop(cv, PL_curcop);
11017     CvSTASH_set(cv, PL_curstash);
11018
11019     if (ps) {
11020         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11021         if (ps_utf8)
11022             SvUTF8_on(MUTABLE_SV(cv));
11023     }
11024
11025     if (block) {
11026         /* If we assign an optree to a PVCV, then we've defined a
11027          * subroutine that the debugger could be able to set a breakpoint
11028          * in, so signal to pp_entereval that it should not throw away any
11029          * saved lines at scope exit.  */
11030
11031         PL_breakable_sub_gen++;
11032         CvROOT(cv) = block;
11033         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11034            itself has a refcount. */
11035         CvSLABBED_off(cv);
11036         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11037 #ifdef PERL_DEBUG_READONLY_OPS
11038         slab = (OPSLAB *)CvSTART(cv);
11039 #endif
11040         S_process_optree(aTHX_ cv, block, start);
11041     }
11042
11043   attrs:
11044     if (attrs) {
11045         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11046         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
11047     }
11048
11049     if (block) {
11050         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11051             SV * const tmpstr = sv_newmortal();
11052             GV * const db_postponed = gv_fetchpvs("DB::postponed",
11053                                                   GV_ADDMULTI, SVt_PVHV);
11054             HV *hv;
11055             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11056                                           CopFILE(PL_curcop),
11057                                           (long)PL_subline,
11058                                           (long)CopLINE(PL_curcop));
11059             if (HvNAME_HEK(PL_curstash)) {
11060                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
11061                 sv_catpvs(tmpstr, "::");
11062             }
11063             else
11064                 sv_setpvs(tmpstr, "__ANON__::");
11065
11066             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
11067                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
11068             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11069                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11070             hv = GvHVn(db_postponed);
11071             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11072                 CV * const pcv = GvCV(db_postponed);
11073                 if (pcv) {
11074                     dSP;
11075                     PUSHMARK(SP);
11076                     XPUSHs(tmpstr);
11077                     PUTBACK;
11078                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
11079                 }
11080             }
11081         }
11082     }
11083
11084   clone:
11085     if (clonee) {
11086         assert(CvDEPTH(outcv));
11087         spot = (CV **)
11088             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
11089         if (reusable)
11090             cv_clone_into(clonee, *spot);
11091         else *spot = cv_clone(clonee);
11092         SvREFCNT_dec_NN(clonee);
11093         cv = *spot;
11094     }
11095
11096     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
11097         PADOFFSET depth = CvDEPTH(outcv);
11098         while (--depth) {
11099             SV *oldcv;
11100             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
11101             oldcv = *svspot;
11102             *svspot = SvREFCNT_inc_simple_NN(cv);
11103             SvREFCNT_dec(oldcv);
11104         }
11105     }
11106
11107   done:
11108     if (PL_parser)
11109         PL_parser->copline = NOLINE;
11110     LEAVE_SCOPE(floor);
11111 #ifdef PERL_DEBUG_READONLY_OPS
11112     if (slab)
11113         Slab_to_ro(slab);
11114 #endif
11115     op_free(o);
11116     return cv;
11117 }
11118
11119 /*
11120 =for apidoc newATTRSUB_x
11121
11122 Construct a Perl subroutine, also performing some surrounding jobs.
11123
11124 This function is expected to be called in a Perl compilation context,
11125 and some aspects of the subroutine are taken from global variables
11126 associated with compilation.  In particular, C<PL_compcv> represents
11127 the subroutine that is currently being compiled.  It must be non-null
11128 when this function is called, and some aspects of the subroutine being
11129 constructed are taken from it.  The constructed subroutine may actually
11130 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
11131
11132 If C<block> is null then the subroutine will have no body, and for the
11133 time being it will be an error to call it.  This represents a forward
11134 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
11135 non-null then it provides the Perl code of the subroutine body, which
11136 will be executed when the subroutine is called.  This body includes
11137 any argument unwrapping code resulting from a subroutine signature or
11138 similar.  The pad use of the code must correspond to the pad attached
11139 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
11140 C<leavesublv> op; this function will add such an op.  C<block> is consumed
11141 by this function and will become part of the constructed subroutine.
11142
11143 C<proto> specifies the subroutine's prototype, unless one is supplied
11144 as an attribute (see below).  If C<proto> is null, then the subroutine
11145 will not have a prototype.  If C<proto> is non-null, it must point to a
11146 C<const> op whose value is a string, and the subroutine will have that
11147 string as its prototype.  If a prototype is supplied as an attribute, the
11148 attribute takes precedence over C<proto>, but in that case C<proto> should
11149 preferably be null.  In any case, C<proto> is consumed by this function.
11150
11151 C<attrs> supplies attributes to be applied the subroutine.  A handful of
11152 attributes take effect by built-in means, being applied to C<PL_compcv>
11153 immediately when seen.  Other attributes are collected up and attached
11154 to the subroutine by this route.  C<attrs> may be null to supply no
11155 attributes, or point to a C<const> op for a single attribute, or point
11156 to a C<list> op whose children apart from the C<pushmark> are C<const>
11157 ops for one or more attributes.  Each C<const> op must be a string,
11158 giving the attribute name optionally followed by parenthesised arguments,
11159 in the manner in which attributes appear in Perl source.  The attributes
11160 will be applied to the sub by this function.  C<attrs> is consumed by
11161 this function.
11162
11163 If C<o_is_gv> is false and C<o> is null, then the subroutine will
11164 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
11165 must point to a C<const> op, which will be consumed by this function,
11166 and its string value supplies a name for the subroutine.  The name may
11167 be qualified or unqualified, and if it is unqualified then a default
11168 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
11169 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
11170 by which the subroutine will be named.
11171
11172 If there is already a subroutine of the specified name, then the new
11173 sub will either replace the existing one in the glob or be merged with
11174 the existing one.  A warning may be generated about redefinition.
11175
11176 If the subroutine has one of a few special names, such as C<BEGIN> or
11177 C<END>, then it will be claimed by the appropriate queue for automatic
11178 running of phase-related subroutines.  In this case the relevant glob will
11179 be left not containing any subroutine, even if it did contain one before.
11180 In the case of C<BEGIN>, the subroutine will be executed and the reference
11181 to it disposed of before this function returns.
11182
11183 The function returns a pointer to the constructed subroutine.  If the sub
11184 is anonymous then ownership of one counted reference to the subroutine
11185 is transferred to the caller.  If the sub is named then the caller does
11186 not get ownership of a reference.  In most such cases, where the sub
11187 has a non-phase name, the sub will be alive at the point it is returned
11188 by virtue of being contained in the glob that names it.  A phase-named
11189 subroutine will usually be alive by virtue of the reference owned by the
11190 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
11191 been executed, will quite likely have been destroyed already by the
11192 time this function returns, making it erroneous for the caller to make
11193 any use of the returned pointer.  It is the caller's responsibility to
11194 ensure that it knows which of these situations applies.
11195
11196 =cut
11197 */
11198
11199 /* _x = extended */
11200 CV *
11201 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11202                             OP *block, bool o_is_gv)
11203 {
11204     GV *gv;
11205     const char *ps;
11206     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11207     U32 ps_utf8 = 0;
11208     CV *cv = NULL;     /* the previous CV with this name, if any */
11209     SV *const_sv;
11210     const bool ec = PL_parser && PL_parser->error_count;
11211     /* If the subroutine has no body, no attributes, and no builtin attributes
11212        then it's just a sub declaration, and we may be able to get away with
11213        storing with a placeholder scalar in the symbol table, rather than a
11214        full CV.  If anything is present then it will take a full CV to
11215        store it.  */
11216     const I32 gv_fetch_flags
11217         = ec ? GV_NOADD_NOINIT :
11218         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11219         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11220     STRLEN namlen = 0;
11221     const char * const name =
11222          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11223     bool has_name;
11224     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11225     bool evanescent = FALSE;
11226     OP *start = NULL;
11227 #ifdef PERL_DEBUG_READONLY_OPS
11228     OPSLAB *slab = NULL;
11229 #endif
11230
11231     if (o_is_gv) {
11232         gv = (GV*)o;
11233         o = NULL;
11234         has_name = TRUE;
11235     } else if (name) {
11236         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
11237            hek and CvSTASH pointer together can imply the GV.  If the name
11238            contains a package name, then GvSTASH(CvGV(cv)) may differ from
11239            CvSTASH, so forego the optimisation if we find any.
11240            Also, we may be called from load_module at run time, so
11241            PL_curstash (which sets CvSTASH) may not point to the stash the
11242            sub is stored in.  */
11243         /* XXX This optimization is currently disabled for packages other
11244                than main, since there was too much CPAN breakage.  */
11245         const I32 flags =
11246            ec ? GV_NOADD_NOINIT
11247               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11248                || PL_curstash != PL_defstash
11249                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11250                     ? gv_fetch_flags
11251                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11252         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11253         has_name = TRUE;
11254     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11255         SV * const sv = sv_newmortal();
11256         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11257                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11258                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11259         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11260         has_name = TRUE;
11261     } else if (PL_curstash) {
11262         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11263         has_name = FALSE;
11264     } else {
11265         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11266         has_name = FALSE;
11267     }
11268
11269     if (!ec) {
11270         if (isGV(gv)) {
11271             move_proto_attr(&proto, &attrs, gv, 0);
11272         } else {
11273             assert(cSVOPo);
11274             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11275         }
11276     }
11277
11278     if (proto) {
11279         assert(proto->op_type == OP_CONST);
11280         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11281         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11282     }
11283     else
11284         ps = NULL;
11285
11286     if (o)
11287         SAVEFREEOP(o);
11288     if (proto)
11289         SAVEFREEOP(proto);
11290     if (attrs)
11291         SAVEFREEOP(attrs);
11292
11293     if (ec) {
11294         op_free(block);
11295
11296         if (name)
11297             SvREFCNT_dec(PL_compcv);
11298         else
11299             cv = PL_compcv;
11300
11301         PL_compcv = 0;
11302         if (name && block) {
11303             const char *s = (char *) my_memrchr(name, ':', namlen);
11304             s = s ? s+1 : name;
11305             if (strEQ(s, "BEGIN")) {
11306                 if (PL_in_eval & EVAL_KEEPERR)
11307                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11308                 else {
11309                     SV * const errsv = ERRSV;
11310                     /* force display of errors found but not reported */
11311                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11312                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11313                 }
11314             }
11315         }
11316         goto done;
11317     }
11318
11319     if (!block && SvTYPE(gv) != SVt_PVGV) {
11320         /* If we are not defining a new sub and the existing one is not a
11321            full GV + CV... */
11322         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11323             /* We are applying attributes to an existing sub, so we need it
11324                upgraded if it is a constant.  */
11325             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11326                 gv_init_pvn(gv, PL_curstash, name, namlen,
11327                             SVf_UTF8 * name_is_utf8);
11328         }
11329         else {                  /* Maybe prototype now, and had at maximum
11330                                    a prototype or const/sub ref before.  */
11331             if (SvTYPE(gv) > SVt_NULL) {
11332                 cv_ckproto_len_flags((const CV *)gv,
11333                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11334                                     ps_len, ps_utf8);
11335             }
11336
11337             if (!SvROK(gv)) {
11338                 if (ps) {
11339                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11340                     if (ps_utf8)
11341                         SvUTF8_on(MUTABLE_SV(gv));
11342                 }
11343                 else
11344                     sv_setiv(MUTABLE_SV(gv), -1);
11345             }
11346
11347             SvREFCNT_dec(PL_compcv);
11348             cv = PL_compcv = NULL;
11349             goto done;
11350         }
11351     }
11352
11353     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11354         ? NULL
11355         : isGV(gv)
11356             ? GvCV(gv)
11357             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11358                 ? (CV *)SvRV(gv)
11359                 : NULL;
11360
11361     if (block) {
11362         assert(PL_parser);
11363         /* This makes sub {}; work as expected.  */
11364         if (block->op_type == OP_STUB) {
11365             const line_t l = PL_parser->copline;
11366             op_free(block);
11367             block = newSTATEOP(0, NULL, 0);
11368             PL_parser->copline = l;
11369         }
11370         block = CvLVALUE(PL_compcv)
11371              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11372                     && (!isGV(gv) || !GvASSUMECV(gv)))
11373                    ? newUNOP(OP_LEAVESUBLV, 0,
11374                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11375                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11376         start = LINKLIST(block);
11377         block->op_next = 0;
11378         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11379             const_sv =
11380                 S_op_const_sv(aTHX_ start, PL_compcv,
11381                                         cBOOL(CvCLONE(PL_compcv)));
11382         else
11383             const_sv = NULL;
11384     }
11385     else
11386         const_sv = NULL;
11387
11388     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11389         cv_ckproto_len_flags((const CV *)gv,
11390                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11391                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11392         if (SvROK(gv)) {
11393             /* All the other code for sub redefinition warnings expects the
11394                clobbered sub to be a CV.  Instead of making all those code
11395                paths more complex, just inline the RV version here.  */
11396             const line_t oldline = CopLINE(PL_curcop);
11397             assert(IN_PERL_COMPILETIME);
11398             if (PL_parser && PL_parser->copline != NOLINE)
11399                 /* This ensures that warnings are reported at the first
11400                    line of a redefinition, not the last.  */
11401                 CopLINE_set(PL_curcop, PL_parser->copline);
11402             /* protect against fatal warnings leaking compcv */
11403             SAVEFREESV(PL_compcv);
11404
11405             if (ckWARN(WARN_REDEFINE)
11406              || (  ckWARN_d(WARN_REDEFINE)
11407                 && (  !const_sv || SvRV(gv) == const_sv
11408                    || sv_cmp(SvRV(gv), const_sv)  ))) {
11409                 assert(cSVOPo);
11410                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11411                           "Constant subroutine %" SVf " redefined",
11412                           SVfARG(cSVOPo->op_sv));
11413             }
11414
11415             SvREFCNT_inc_simple_void_NN(PL_compcv);
11416             CopLINE_set(PL_curcop, oldline);
11417             SvREFCNT_dec(SvRV(gv));
11418         }
11419     }
11420
11421     if (cv) {
11422         const bool exists = CvROOT(cv) || CvXSUB(cv);
11423
11424         /* if the subroutine doesn't exist and wasn't pre-declared
11425          * with a prototype, assume it will be AUTOLOADed,
11426          * skipping the prototype check
11427          */
11428         if (exists || SvPOK(cv))
11429             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11430         /* already defined (or promised)? */
11431         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11432             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11433             if (block)
11434                 cv = NULL;
11435             else {
11436                 if (attrs)
11437                     goto attrs;
11438                 /* just a "sub foo;" when &foo is already defined */
11439                 SAVEFREESV(PL_compcv);
11440                 goto done;
11441             }
11442         }
11443     }
11444
11445     if (const_sv) {
11446         SvREFCNT_inc_simple_void_NN(const_sv);
11447         SvFLAGS(const_sv) |= SVs_PADTMP;
11448         if (cv) {
11449             assert(!CvROOT(cv) && !CvCONST(cv));
11450             cv_forget_slab(cv);
11451             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
11452             CvXSUBANY(cv).any_ptr = const_sv;
11453             CvXSUB(cv) = const_sv_xsub;
11454             CvCONST_on(cv);
11455             CvISXSUB_on(cv);
11456             PoisonPADLIST(cv);
11457             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11458         }
11459         else {
11460             if (isGV(gv) || CvMETHOD(PL_compcv)) {
11461                 if (name && isGV(gv))
11462                     GvCV_set(gv, NULL);
11463                 cv = newCONSTSUB_flags(
11464                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11465                     const_sv
11466                 );
11467                 assert(cv);
11468                 assert(SvREFCNT((SV*)cv) != 0);
11469                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11470             }
11471             else {
11472                 if (!SvROK(gv)) {
11473                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11474                     prepare_SV_for_RV((SV *)gv);
11475                     SvOK_off((SV *)gv);
11476                     SvROK_on(gv);
11477                 }
11478                 SvRV_set(gv, const_sv);
11479             }
11480         }
11481         op_free(block);
11482         SvREFCNT_dec(PL_compcv);
11483         PL_compcv = NULL;
11484         goto done;
11485     }
11486
11487     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11488     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11489         cv = NULL;
11490
11491     if (cv) {                           /* must reuse cv if autoloaded */
11492         /* transfer PL_compcv to cv */
11493         if (block) {
11494             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11495             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11496             PADLIST *const temp_av = CvPADLIST(cv);
11497             CV *const temp_cv = CvOUTSIDE(cv);
11498             const cv_flags_t other_flags =
11499                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11500             OP * const cvstart = CvSTART(cv);
11501
11502             if (isGV(gv)) {
11503                 CvGV_set(cv,gv);
11504                 assert(!CvCVGV_RC(cv));
11505                 assert(CvGV(cv) == gv);
11506             }
11507             else {
11508                 dVAR;
11509                 U32 hash;
11510                 PERL_HASH(hash, name, namlen);
11511                 CvNAME_HEK_set(cv,
11512                                share_hek(name,
11513                                          name_is_utf8
11514                                             ? -(SSize_t)namlen
11515                                             :  (SSize_t)namlen,
11516                                          hash));
11517             }
11518
11519             SvPOK_off(cv);
11520             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11521                                              | CvNAMED(cv);
11522             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11523             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11524             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11525             CvOUTSIDE(PL_compcv) = temp_cv;
11526             CvPADLIST_set(PL_compcv, temp_av);
11527             CvSTART(cv) = CvSTART(PL_compcv);
11528             CvSTART(PL_compcv) = cvstart;
11529             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11530             CvFLAGS(PL_compcv) |= other_flags;
11531
11532             if (free_file) {
11533                 Safefree(CvFILE(cv));
11534             }
11535             CvFILE_set_from_cop(cv, PL_curcop);
11536             CvSTASH_set(cv, PL_curstash);
11537
11538             /* inner references to PL_compcv must be fixed up ... */
11539             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11540             if (PERLDB_INTER)/* Advice debugger on the new sub. */
11541                 ++PL_sub_generation;
11542         }
11543         else {
11544             /* Might have had built-in attributes applied -- propagate them. */
11545             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11546         }
11547         /* ... before we throw it away */
11548         SvREFCNT_dec(PL_compcv);
11549         PL_compcv = cv;
11550     }
11551     else {
11552         cv = PL_compcv;
11553         if (name && isGV(gv)) {
11554             GvCV_set(gv, cv);
11555             GvCVGEN(gv) = 0;
11556             if (HvENAME_HEK(GvSTASH(gv)))
11557                 /* sub Foo::bar { (shift)+1 } */
11558                 gv_method_changed(gv);
11559         }
11560         else if (name) {
11561             if (!SvROK(gv)) {
11562                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11563                 prepare_SV_for_RV((SV *)gv);
11564                 SvOK_off((SV *)gv);
11565                 SvROK_on(gv);
11566             }
11567             SvRV_set(gv, (SV *)cv);
11568             if (HvENAME_HEK(PL_curstash))
11569                 mro_method_changed_in(PL_curstash);
11570         }
11571     }
11572     assert(cv);
11573     assert(SvREFCNT((SV*)cv) != 0);
11574
11575     if (!CvHASGV(cv)) {
11576         if (isGV(gv))
11577             CvGV_set(cv, gv);
11578         else {
11579             dVAR;
11580             U32 hash;
11581             PERL_HASH(hash, name, namlen);
11582             CvNAME_HEK_set(cv, share_hek(name,
11583                                          name_is_utf8
11584                                             ? -(SSize_t)namlen
11585                                             :  (SSize_t)namlen,
11586                                          hash));
11587         }
11588         CvFILE_set_from_cop(cv, PL_curcop);
11589         CvSTASH_set(cv, PL_curstash);
11590     }
11591
11592     if (ps) {
11593         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11594         if ( ps_utf8 )
11595             SvUTF8_on(MUTABLE_SV(cv));
11596     }
11597
11598     if (block) {
11599         /* If we assign an optree to a PVCV, then we've defined a
11600          * subroutine that the debugger could be able to set a breakpoint
11601          * in, so signal to pp_entereval that it should not throw away any
11602          * saved lines at scope exit.  */
11603
11604         PL_breakable_sub_gen++;
11605         CvROOT(cv) = block;
11606         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11607            itself has a refcount. */
11608         CvSLABBED_off(cv);
11609         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11610 #ifdef PERL_DEBUG_READONLY_OPS
11611         slab = (OPSLAB *)CvSTART(cv);
11612 #endif
11613         S_process_optree(aTHX_ cv, block, start);
11614     }
11615
11616   attrs:
11617     if (attrs) {
11618         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11619         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11620                         ? GvSTASH(CvGV(cv))
11621                         : PL_curstash;
11622         if (!name)
11623             SAVEFREESV(cv);
11624         apply_attrs(stash, MUTABLE_SV(cv), attrs);
11625         if (!name)
11626             SvREFCNT_inc_simple_void_NN(cv);
11627     }
11628
11629     if (block && has_name) {
11630         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11631             SV * const tmpstr = cv_name(cv,NULL,0);
11632             GV * const db_postponed = gv_fetchpvs("DB::postponed",
11633                                                   GV_ADDMULTI, SVt_PVHV);
11634             HV *hv;
11635             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11636                                           CopFILE(PL_curcop),
11637                                           (long)PL_subline,
11638                                           (long)CopLINE(PL_curcop));
11639             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11640                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11641             hv = GvHVn(db_postponed);
11642             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11643                 CV * const pcv = GvCV(db_postponed);
11644                 if (pcv) {
11645                     dSP;
11646                     PUSHMARK(SP);
11647                     XPUSHs(tmpstr);
11648                     PUTBACK;
11649                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
11650                 }
11651             }
11652         }
11653
11654         if (name) {
11655             if (PL_parser && PL_parser->error_count)
11656                 clear_special_blocks(name, gv, cv);
11657             else
11658                 evanescent =
11659                     process_special_blocks(floor, name, gv, cv);
11660         }
11661     }
11662     assert(cv);
11663
11664   done:
11665     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11666     if (PL_parser)
11667         PL_parser->copline = NOLINE;
11668     LEAVE_SCOPE(floor);
11669
11670     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11671     if (!evanescent) {
11672 #ifdef PERL_DEBUG_READONLY_OPS
11673     if (slab)
11674         Slab_to_ro(slab);
11675 #endif
11676     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11677         pad_add_weakref(cv);
11678     }
11679     return cv;
11680 }
11681
11682 STATIC void
11683 S_clear_special_blocks(pTHX_ const char *const fullname,
11684                        GV *const gv, CV *const cv) {
11685     const char *colon;
11686     const char *name;
11687
11688     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11689
11690     colon = strrchr(fullname,':');
11691     name = colon ? colon + 1 : fullname;
11692
11693     if ((*name == 'B' && strEQ(name, "BEGIN"))
11694         || (*name == 'E' && strEQ(name, "END"))
11695         || (*name == 'U' && strEQ(name, "UNITCHECK"))
11696         || (*name == 'C' && strEQ(name, "CHECK"))
11697         || (*name == 'I' && strEQ(name, "INIT"))) {
11698         if (!isGV(gv)) {
11699             (void)CvGV(cv);
11700             assert(isGV(gv));
11701         }
11702         GvCV_set(gv, NULL);
11703         SvREFCNT_dec_NN(MUTABLE_SV(cv));
11704     }
11705 }
11706
11707 /* Returns true if the sub has been freed.  */
11708 STATIC bool
11709 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11710                          GV *const gv,
11711                          CV *const cv)
11712 {
11713     const char *const colon = strrchr(fullname,':');
11714     const char *const name = colon ? colon + 1 : fullname;
11715
11716     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11717
11718     if (*name == 'B') {
11719         if (strEQ(name, "BEGIN")) {
11720             const I32 oldscope = PL_scopestack_ix;
11721             dSP;
11722             (void)CvGV(cv);
11723             if (floor) LEAVE_SCOPE(floor);
11724             ENTER;
11725             PUSHSTACKi(PERLSI_REQUIRE);
11726             SAVECOPFILE(&PL_compiling);
11727             SAVECOPLINE(&PL_compiling);
11728             SAVEVPTR(PL_curcop);
11729
11730             DEBUG_x( dump_sub(gv) );
11731             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11732             GvCV_set(gv,0);             /* cv has been hijacked */
11733             call_list(oldscope, PL_beginav);
11734
11735             POPSTACK;
11736             LEAVE;
11737             return !PL_savebegin;
11738         }
11739         else
11740             return FALSE;
11741     } else {
11742         if (*name == 'E') {
11743             if (strEQ(name, "END")) {
11744                 DEBUG_x( dump_sub(gv) );
11745                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11746             } else
11747                 return FALSE;
11748         } else if (*name == 'U') {
11749             if (strEQ(name, "UNITCHECK")) {
11750                 /* It's never too late to run a unitcheck block */
11751                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11752             }
11753             else
11754                 return FALSE;
11755         } else if (*name == 'C') {
11756             if (strEQ(name, "CHECK")) {
11757                 if (PL_main_start)
11758                     /* diag_listed_as: Too late to run %s block */
11759                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11760                                    "Too late to run CHECK block");
11761                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11762             }
11763             else
11764                 return FALSE;
11765         } else if (*name == 'I') {
11766             if (strEQ(name, "INIT")) {
11767                 if (PL_main_start)
11768                     /* diag_listed_as: Too late to run %s block */
11769                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11770                                    "Too late to run INIT block");
11771                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11772             }
11773             else
11774                 return FALSE;
11775         } else
11776             return FALSE;
11777         DEBUG_x( dump_sub(gv) );
11778         (void)CvGV(cv);
11779         GvCV_set(gv,0);         /* cv has been hijacked */
11780         return FALSE;
11781     }
11782 }
11783
11784 /*
11785 =for apidoc newCONSTSUB
11786
11787 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11788 rather than of counted length, and no flags are set.  (This means that
11789 C<name> is always interpreted as Latin-1.)
11790
11791 =cut
11792 */
11793
11794 CV *
11795 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11796 {
11797     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11798 }
11799
11800 /*
11801 =for apidoc newCONSTSUB_flags
11802
11803 Construct a constant subroutine, also performing some surrounding
11804 jobs.  A scalar constant-valued subroutine is eligible for inlining
11805 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11806 123 }>>.  Other kinds of constant subroutine have other treatment.
11807
11808 The subroutine will have an empty prototype and will ignore any arguments
11809 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
11810 is null, the subroutine will yield an empty list.  If C<sv> points to a
11811 scalar, the subroutine will always yield that scalar.  If C<sv> points
11812 to an array, the subroutine will always yield a list of the elements of
11813 that array in list context, or the number of elements in the array in
11814 scalar context.  This function takes ownership of one counted reference
11815 to the scalar or array, and will arrange for the object to live as long
11816 as the subroutine does.  If C<sv> points to a scalar then the inlining
11817 assumes that the value of the scalar will never change, so the caller
11818 must ensure that the scalar is not subsequently written to.  If C<sv>
11819 points to an array then no such assumption is made, so it is ostensibly
11820 safe to mutate the array or its elements, but whether this is really
11821 supported has not been determined.
11822
11823 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11824 Other aspects of the subroutine will be left in their default state.
11825 The caller is free to mutate the subroutine beyond its initial state
11826 after this function has returned.
11827
11828 If C<name> is null then the subroutine will be anonymous, with its
11829 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11830 subroutine will be named accordingly, referenced by the appropriate glob.
11831 C<name> is a string of length C<len> bytes giving a sigilless symbol
11832 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11833 otherwise.  The name may be either qualified or unqualified.  If the
11834 name is unqualified then it defaults to being in the stash specified by
11835 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11836 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11837 semantics.
11838
11839 C<flags> should not have bits set other than C<SVf_UTF8>.
11840
11841 If there is already a subroutine of the specified name, then the new sub
11842 will replace the existing one in the glob.  A warning may be generated
11843 about the redefinition.
11844
11845 If the subroutine has one of a few special names, such as C<BEGIN> or
11846 C<END>, then it will be claimed by the appropriate queue for automatic
11847 running of phase-related subroutines.  In this case the relevant glob will
11848 be left not containing any subroutine, even if it did contain one before.
11849 Execution of the subroutine will likely be a no-op, unless C<sv> was
11850 a tied array or the caller modified the subroutine in some interesting
11851 way before it was executed.  In the case of C<BEGIN>, the treatment is
11852 buggy: the sub will be executed when only half built, and may be deleted
11853 prematurely, possibly causing a crash.
11854
11855 The function returns a pointer to the constructed subroutine.  If the sub
11856 is anonymous then ownership of one counted reference to the subroutine
11857 is transferred to the caller.  If the sub is named then the caller does
11858 not get ownership of a reference.  In most such cases, where the sub
11859 has a non-phase name, the sub will be alive at the point it is returned
11860 by virtue of being contained in the glob that names it.  A phase-named
11861 subroutine will usually be alive by virtue of the reference owned by
11862 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
11863 destroyed already by the time this function returns, but currently bugs
11864 occur in that case before the caller gets control.  It is the caller's
11865 responsibility to ensure that it knows which of these situations applies.
11866
11867 =cut
11868 */
11869
11870 CV *
11871 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11872                              U32 flags, SV *sv)
11873 {
11874     CV* cv;
11875     const char *const file = CopFILE(PL_curcop);
11876
11877     ENTER;
11878
11879     if (IN_PERL_RUNTIME) {
11880         /* at runtime, it's not safe to manipulate PL_curcop: it may be
11881          * an op shared between threads. Use a non-shared COP for our
11882          * dirty work */
11883          SAVEVPTR(PL_curcop);
11884          SAVECOMPILEWARNINGS();
11885          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11886          PL_curcop = &PL_compiling;
11887     }
11888     SAVECOPLINE(PL_curcop);
11889     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11890
11891     SAVEHINTS();
11892     PL_hints &= ~HINT_BLOCK_SCOPE;
11893
11894     if (stash) {
11895         SAVEGENERICSV(PL_curstash);
11896         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11897     }
11898
11899     /* Protect sv against leakage caused by fatal warnings. */
11900     if (sv) SAVEFREESV(sv);
11901
11902     /* file becomes the CvFILE. For an XS, it's usually static storage,
11903        and so doesn't get free()d.  (It's expected to be from the C pre-
11904        processor __FILE__ directive). But we need a dynamically allocated one,
11905        and we need it to get freed.  */
11906     cv = newXS_len_flags(name, len,
11907                          sv && SvTYPE(sv) == SVt_PVAV
11908                              ? const_av_xsub
11909                              : const_sv_xsub,
11910                          file ? file : "", "",
11911                          &sv, XS_DYNAMIC_FILENAME | flags);
11912     assert(cv);
11913     assert(SvREFCNT((SV*)cv) != 0);
11914     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11915     CvCONST_on(cv);
11916
11917     LEAVE;
11918
11919     return cv;
11920 }
11921
11922 /*
11923 =for apidoc newXS
11924
11925 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
11926 static storage, as it is used directly as CvFILE(), without a copy being made.
11927
11928 =cut
11929 */
11930
11931 CV *
11932 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11933 {
11934     PERL_ARGS_ASSERT_NEWXS;
11935     return newXS_len_flags(
11936         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11937     );
11938 }
11939
11940 CV *
11941 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11942                  const char *const filename, const char *const proto,
11943                  U32 flags)
11944 {
11945     PERL_ARGS_ASSERT_NEWXS_FLAGS;
11946     return newXS_len_flags(
11947        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11948     );
11949 }
11950
11951 CV *
11952 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11953 {
11954     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11955     return newXS_len_flags(
11956         name, strlen(name), subaddr, NULL, NULL, NULL, 0
11957     );
11958 }
11959
11960 /*
11961 =for apidoc newXS_len_flags
11962
11963 Construct an XS subroutine, also performing some surrounding jobs.
11964
11965 The subroutine will have the entry point C<subaddr>.  It will have
11966 the prototype specified by the nul-terminated string C<proto>, or
11967 no prototype if C<proto> is null.  The prototype string is copied;
11968 the caller can mutate the supplied string afterwards.  If C<filename>
11969 is non-null, it must be a nul-terminated filename, and the subroutine
11970 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
11971 point directly to the supplied string, which must be static.  If C<flags>
11972 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11973 be taken instead.
11974
11975 Other aspects of the subroutine will be left in their default state.
11976 If anything else needs to be done to the subroutine for it to function
11977 correctly, it is the caller's responsibility to do that after this
11978 function has constructed it.  However, beware of the subroutine
11979 potentially being destroyed before this function returns, as described
11980 below.
11981
11982 If C<name> is null then the subroutine will be anonymous, with its
11983 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11984 subroutine will be named accordingly, referenced by the appropriate glob.
11985 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11986 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11987 The name may be either qualified or unqualified, with the stash defaulting
11988 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
11989 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11990 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
11991 the stash if necessary, with C<GV_ADDMULTI> semantics.
11992
11993 If there is already a subroutine of the specified name, then the new sub
11994 will replace the existing one in the glob.  A warning may be generated
11995 about the redefinition.  If the old subroutine was C<CvCONST> then the
11996 decision about whether to warn is influenced by an expectation about
11997 whether the new subroutine will become a constant of similar value.
11998 That expectation is determined by C<const_svp>.  (Note that the call to
11999 this function doesn't make the new subroutine C<CvCONST> in any case;
12000 that is left to the caller.)  If C<const_svp> is null then it indicates
12001 that the new subroutine will not become a constant.  If C<const_svp>
12002 is non-null then it indicates that the new subroutine will become a
12003 constant, and it points to an C<SV*> that provides the constant value
12004 that the subroutine will have.
12005
12006 If the subroutine has one of a few special names, such as C<BEGIN> or
12007 C<END>, then it will be claimed by the appropriate queue for automatic
12008 running of phase-related subroutines.  In this case the relevant glob will
12009 be left not containing any subroutine, even if it did contain one before.
12010 In the case of C<BEGIN>, the subroutine will be executed and the reference
12011 to it disposed of before this function returns, and also before its
12012 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
12013 constructed by this function to be ready for execution then the caller
12014 must prevent this happening by giving the subroutine a different name.
12015
12016 The function returns a pointer to the constructed subroutine.  If the sub
12017 is anonymous then ownership of one counted reference to the subroutine
12018 is transferred to the caller.  If the sub is named then the caller does
12019 not get ownership of a reference.  In most such cases, where the sub
12020 has a non-phase name, the sub will be alive at the point it is returned
12021 by virtue of being contained in the glob that names it.  A phase-named
12022 subroutine will usually be alive by virtue of the reference owned by the
12023 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
12024 been executed, will quite likely have been destroyed already by the
12025 time this function returns, making it erroneous for the caller to make
12026 any use of the returned pointer.  It is the caller's responsibility to
12027 ensure that it knows which of these situations applies.
12028
12029 =cut
12030 */
12031
12032 CV *
12033 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12034                            XSUBADDR_t subaddr, const char *const filename,
12035                            const char *const proto, SV **const_svp,
12036                            U32 flags)
12037 {
12038     CV *cv;
12039     bool interleave = FALSE;
12040     bool evanescent = FALSE;
12041
12042     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12043
12044     {
12045         GV * const gv = gv_fetchpvn(
12046                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12047                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12048                                 sizeof("__ANON__::__ANON__") - 1,
12049                             GV_ADDMULTI | flags, SVt_PVCV);
12050
12051         if ((cv = (name ? GvCV(gv) : NULL))) {
12052             if (GvCVGEN(gv)) {
12053                 /* just a cached method */
12054                 SvREFCNT_dec(cv);
12055                 cv = NULL;
12056             }
12057             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12058                 /* already defined (or promised) */
12059                 /* Redundant check that allows us to avoid creating an SV
12060                    most of the time: */
12061                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12062                     report_redefined_cv(newSVpvn_flags(
12063                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
12064                                         ),
12065                                         cv, const_svp);
12066                 }
12067                 interleave = TRUE;
12068                 ENTER;
12069                 SAVEFREESV(cv);
12070                 cv = NULL;
12071             }
12072         }
12073
12074         if (cv)                         /* must reuse cv if autoloaded */
12075             cv_undef(cv);
12076         else {
12077             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12078             if (name) {
12079                 GvCV_set(gv,cv);
12080                 GvCVGEN(gv) = 0;
12081                 if (HvENAME_HEK(GvSTASH(gv)))
12082                     gv_method_changed(gv); /* newXS */
12083             }
12084         }
12085         assert(cv);
12086         assert(SvREFCNT((SV*)cv) != 0);
12087
12088         CvGV_set(cv, gv);
12089         if(filename) {
12090             /* XSUBs can't be perl lang/perl5db.pl debugged
12091             if (PERLDB_LINE_OR_SAVESRC)
12092                 (void)gv_fetchfile(filename); */
12093             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12094             if (flags & XS_DYNAMIC_FILENAME) {
12095                 CvDYNFILE_on(cv);
12096                 CvFILE(cv) = savepv(filename);
12097             } else {
12098             /* NOTE: not copied, as it is expected to be an external constant string */
12099                 CvFILE(cv) = (char *)filename;
12100             }
12101         } else {
12102             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12103             CvFILE(cv) = (char*)PL_xsubfilename;
12104         }
12105         CvISXSUB_on(cv);
12106         CvXSUB(cv) = subaddr;
12107 #ifndef PERL_IMPLICIT_CONTEXT
12108         CvHSCXT(cv) = &PL_stack_sp;
12109 #else
12110         PoisonPADLIST(cv);
12111 #endif
12112
12113         if (name)
12114             evanescent = process_special_blocks(0, name, gv, cv);
12115         else
12116             CvANON_on(cv);
12117     } /* <- not a conditional branch */
12118
12119     assert(cv);
12120     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12121
12122     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12123     if (interleave) LEAVE;
12124     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12125     return cv;
12126 }
12127
12128 /* Add a stub CV to a typeglob.
12129  * This is the implementation of a forward declaration, 'sub foo';'
12130  */
12131
12132 CV *
12133 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12134 {
12135     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12136     GV *cvgv;
12137     PERL_ARGS_ASSERT_NEWSTUB;
12138     assert(!GvCVu(gv));
12139     GvCV_set(gv, cv);
12140     GvCVGEN(gv) = 0;
12141     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12142         gv_method_changed(gv);
12143     if (SvFAKE(gv)) {
12144         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12145         SvFAKE_off(cvgv);
12146     }
12147     else cvgv = gv;
12148     CvGV_set(cv, cvgv);
12149     CvFILE_set_from_cop(cv, PL_curcop);
12150     CvSTASH_set(cv, PL_curstash);
12151     GvMULTI_on(gv);
12152     return cv;
12153 }
12154
12155 void
12156 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12157 {
12158     CV *cv;
12159     GV *gv;
12160     OP *root;
12161     OP *start;
12162
12163     if (PL_parser && PL_parser->error_count) {
12164         op_free(block);
12165         goto finish;
12166     }
12167
12168     gv = o
12169         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12170         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12171
12172     GvMULTI_on(gv);
12173     if ((cv = GvFORM(gv))) {
12174         if (ckWARN(WARN_REDEFINE)) {
12175             const line_t oldline = CopLINE(PL_curcop);
12176             if (PL_parser && PL_parser->copline != NOLINE)
12177                 CopLINE_set(PL_curcop, PL_parser->copline);
12178             if (o) {
12179                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12180                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12181             } else {
12182                 /* diag_listed_as: Format %s redefined */
12183                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12184                             "Format STDOUT redefined");
12185             }
12186             CopLINE_set(PL_curcop, oldline);
12187         }
12188         SvREFCNT_dec(cv);
12189     }
12190     cv = PL_compcv;
12191     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12192     CvGV_set(cv, gv);
12193     CvFILE_set_from_cop(cv, PL_curcop);
12194
12195
12196     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12197     CvROOT(cv) = root;
12198     start = LINKLIST(root);
12199     root->op_next = 0;
12200     S_process_optree(aTHX_ cv, root, start);
12201     cv_forget_slab(cv);
12202
12203   finish:
12204     op_free(o);
12205     if (PL_parser)
12206         PL_parser->copline = NOLINE;
12207     LEAVE_SCOPE(floor);
12208     PL_compiling.cop_seq = 0;
12209 }
12210
12211 OP *
12212 Perl_newANONLIST(pTHX_ OP *o)
12213 {
12214     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12215 }
12216
12217 OP *
12218 Perl_newANONHASH(pTHX_ OP *o)
12219 {
12220     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12221 }
12222
12223 OP *
12224 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12225 {
12226     return newANONATTRSUB(floor, proto, NULL, block);
12227 }
12228
12229 OP *
12230 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12231 {
12232     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12233     OP * anoncode =
12234         newSVOP(OP_ANONCODE, 0,
12235                 cv);
12236     if (CvANONCONST(cv))
12237         anoncode = newUNOP(OP_ANONCONST, 0,
12238                            op_convert_list(OP_ENTERSUB,
12239                                            OPf_STACKED|OPf_WANT_SCALAR,
12240                                            anoncode));
12241     return newUNOP(OP_REFGEN, 0, anoncode);
12242 }
12243
12244 OP *
12245 Perl_oopsAV(pTHX_ OP *o)
12246 {
12247     dVAR;
12248
12249     PERL_ARGS_ASSERT_OOPSAV;
12250
12251     switch (o->op_type) {
12252     case OP_PADSV:
12253     case OP_PADHV:
12254         OpTYPE_set(o, OP_PADAV);
12255         return ref(o, OP_RV2AV);
12256
12257     case OP_RV2SV:
12258     case OP_RV2HV:
12259         OpTYPE_set(o, OP_RV2AV);
12260         ref(o, OP_RV2AV);
12261         break;
12262
12263     default:
12264         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12265         break;
12266     }
12267     return o;
12268 }
12269
12270 OP *
12271 Perl_oopsHV(pTHX_ OP *o)
12272 {
12273     dVAR;
12274
12275     PERL_ARGS_ASSERT_OOPSHV;
12276
12277     switch (o->op_type) {
12278     case OP_PADSV:
12279     case OP_PADAV:
12280         OpTYPE_set(o, OP_PADHV);
12281         return ref(o, OP_RV2HV);
12282
12283     case OP_RV2SV:
12284     case OP_RV2AV:
12285         OpTYPE_set(o, OP_RV2HV);
12286         /* rv2hv steals the bottom bit for its own uses */
12287         o->op_private &= ~OPpARG1_MASK;
12288         ref(o, OP_RV2HV);
12289         break;
12290
12291     default:
12292         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12293         break;
12294     }
12295     return o;
12296 }
12297
12298 OP *
12299 Perl_newAVREF(pTHX_ OP *o)
12300 {
12301     dVAR;
12302
12303     PERL_ARGS_ASSERT_NEWAVREF;
12304
12305     if (o->op_type == OP_PADANY) {
12306         OpTYPE_set(o, OP_PADAV);
12307         return o;
12308     }
12309     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12310         Perl_croak(aTHX_ "Can't use an array as a reference");
12311     }
12312     return newUNOP(OP_RV2AV, 0, scalar(o));
12313 }
12314
12315 OP *
12316 Perl_newGVREF(pTHX_ I32 type, OP *o)
12317 {
12318     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12319         return newUNOP(OP_NULL, 0, o);
12320     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12321 }
12322
12323 OP *
12324 Perl_newHVREF(pTHX_ OP *o)
12325 {
12326     dVAR;
12327
12328     PERL_ARGS_ASSERT_NEWHVREF;
12329
12330     if (o->op_type == OP_PADANY) {
12331         OpTYPE_set(o, OP_PADHV);
12332         return o;
12333     }
12334     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12335         Perl_croak(aTHX_ "Can't use a hash as a reference");
12336     }
12337     return newUNOP(OP_RV2HV, 0, scalar(o));
12338 }
12339
12340 OP *
12341 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12342 {
12343     if (o->op_type == OP_PADANY) {
12344         dVAR;
12345         OpTYPE_set(o, OP_PADCV);
12346     }
12347     return newUNOP(OP_RV2CV, flags, scalar(o));
12348 }
12349
12350 OP *
12351 Perl_newSVREF(pTHX_ OP *o)
12352 {
12353     dVAR;
12354
12355     PERL_ARGS_ASSERT_NEWSVREF;
12356
12357     if (o->op_type == OP_PADANY) {
12358         OpTYPE_set(o, OP_PADSV);
12359         scalar(o);
12360         return o;
12361     }
12362     return newUNOP(OP_RV2SV, 0, scalar(o));
12363 }
12364
12365 /* Check routines. See the comments at the top of this file for details
12366  * on when these are called */
12367
12368 OP *
12369 Perl_ck_anoncode(pTHX_ OP *o)
12370 {
12371     PERL_ARGS_ASSERT_CK_ANONCODE;
12372
12373     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12374     cSVOPo->op_sv = NULL;
12375     return o;
12376 }
12377
12378 static void
12379 S_io_hints(pTHX_ OP *o)
12380 {
12381 #if O_BINARY != 0 || O_TEXT != 0
12382     HV * const table =
12383         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12384     if (table) {
12385         SV **svp = hv_fetchs(table, "open_IN", FALSE);
12386         if (svp && *svp) {
12387             STRLEN len = 0;
12388             const char *d = SvPV_const(*svp, len);
12389             const I32 mode = mode_from_discipline(d, len);
12390             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12391 #  if O_BINARY != 0
12392             if (mode & O_BINARY)
12393                 o->op_private |= OPpOPEN_IN_RAW;
12394 #  endif
12395 #  if O_TEXT != 0
12396             if (mode & O_TEXT)
12397                 o->op_private |= OPpOPEN_IN_CRLF;
12398 #  endif
12399         }
12400
12401         svp = hv_fetchs(table, "open_OUT", FALSE);
12402         if (svp && *svp) {
12403             STRLEN len = 0;
12404             const char *d = SvPV_const(*svp, len);
12405             const I32 mode = mode_from_discipline(d, len);
12406             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12407 #  if O_BINARY != 0
12408             if (mode & O_BINARY)
12409                 o->op_private |= OPpOPEN_OUT_RAW;
12410 #  endif
12411 #  if O_TEXT != 0
12412             if (mode & O_TEXT)
12413                 o->op_private |= OPpOPEN_OUT_CRLF;
12414 #  endif
12415         }
12416     }
12417 #else
12418     PERL_UNUSED_CONTEXT;
12419     PERL_UNUSED_ARG(o);
12420 #endif
12421 }
12422
12423 OP *
12424 Perl_ck_backtick(pTHX_ OP *o)
12425 {
12426     GV *gv;
12427     OP *newop = NULL;
12428     OP *sibl;
12429     PERL_ARGS_ASSERT_CK_BACKTICK;
12430     o = ck_fun(o);
12431     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12432     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12433      && (gv = gv_override("readpipe",8)))
12434     {
12435         /* detach rest of siblings from o and its first child */
12436         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12437         newop = S_new_entersubop(aTHX_ gv, sibl);
12438     }
12439     else if (!(o->op_flags & OPf_KIDS))
12440         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12441     if (newop) {
12442         op_free(o);
12443         return newop;
12444     }
12445     S_io_hints(aTHX_ o);
12446     return o;
12447 }
12448
12449 OP *
12450 Perl_ck_bitop(pTHX_ OP *o)
12451 {
12452     PERL_ARGS_ASSERT_CK_BITOP;
12453
12454     o->op_private = (U8)(PL_hints & HINT_INTEGER);
12455
12456     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12457             && OP_IS_INFIX_BIT(o->op_type))
12458     {
12459         const OP * const left = cBINOPo->op_first;
12460         const OP * const right = OpSIBLING(left);
12461         if ((OP_IS_NUMCOMPARE(left->op_type) &&
12462                 (left->op_flags & OPf_PARENS) == 0) ||
12463             (OP_IS_NUMCOMPARE(right->op_type) &&
12464                 (right->op_flags & OPf_PARENS) == 0))
12465             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12466                           "Possible precedence problem on bitwise %s operator",
12467                            o->op_type ==  OP_BIT_OR
12468                          ||o->op_type == OP_NBIT_OR  ? "|"
12469                         :  o->op_type ==  OP_BIT_AND
12470                          ||o->op_type == OP_NBIT_AND ? "&"
12471                         :  o->op_type ==  OP_BIT_XOR
12472                          ||o->op_type == OP_NBIT_XOR ? "^"
12473                         :  o->op_type == OP_SBIT_OR  ? "|."
12474                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
12475                            );
12476     }
12477     return o;
12478 }
12479
12480 PERL_STATIC_INLINE bool
12481 is_dollar_bracket(pTHX_ const OP * const o)
12482 {
12483     const OP *kid;
12484     PERL_UNUSED_CONTEXT;
12485     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12486         && (kid = cUNOPx(o)->op_first)
12487         && kid->op_type == OP_GV
12488         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12489 }
12490
12491 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12492
12493 OP *
12494 Perl_ck_cmp(pTHX_ OP *o)
12495 {
12496     bool is_eq;
12497     bool neg;
12498     bool reverse;
12499     bool iv0;
12500     OP *indexop, *constop, *start;
12501     SV *sv;
12502     IV iv;
12503
12504     PERL_ARGS_ASSERT_CK_CMP;
12505
12506     is_eq = (   o->op_type == OP_EQ
12507              || o->op_type == OP_NE
12508              || o->op_type == OP_I_EQ
12509              || o->op_type == OP_I_NE);
12510
12511     if (!is_eq && ckWARN(WARN_SYNTAX)) {
12512         const OP *kid = cUNOPo->op_first;
12513         if (kid &&
12514             (
12515                 (   is_dollar_bracket(aTHX_ kid)
12516                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12517                 )
12518              || (   kid->op_type == OP_CONST
12519                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12520                 )
12521            )
12522         )
12523             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12524                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12525     }
12526
12527     /* convert (index(...) == -1) and variations into
12528      *   (r)index/BOOL(,NEG)
12529      */
12530
12531     reverse = FALSE;
12532
12533     indexop = cUNOPo->op_first;
12534     constop = OpSIBLING(indexop);
12535     start = NULL;
12536     if (indexop->op_type == OP_CONST) {
12537         constop = indexop;
12538         indexop = OpSIBLING(constop);
12539         start = constop;
12540         reverse = TRUE;
12541     }
12542
12543     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12544         return o;
12545
12546     /* ($lex = index(....)) == -1 */
12547     if (indexop->op_private & OPpTARGET_MY)
12548         return o;
12549
12550     if (constop->op_type != OP_CONST)
12551         return o;
12552
12553     sv = cSVOPx_sv(constop);
12554     if (!(sv && SvIOK_notUV(sv)))
12555         return o;
12556
12557     iv = SvIVX(sv);
12558     if (iv != -1 && iv != 0)
12559         return o;
12560     iv0 = (iv == 0);
12561
12562     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12563         if (!(iv0 ^ reverse))
12564             return o;
12565         neg = iv0;
12566     }
12567     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12568         if (iv0 ^ reverse)
12569             return o;
12570         neg = !iv0;
12571     }
12572     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12573         if (!(iv0 ^ reverse))
12574             return o;
12575         neg = !iv0;
12576     }
12577     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12578         if (iv0 ^ reverse)
12579             return o;
12580         neg = iv0;
12581     }
12582     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12583         if (iv0)
12584             return o;
12585         neg = TRUE;
12586     }
12587     else {
12588         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12589         if (iv0)
12590             return o;
12591         neg = FALSE;
12592     }
12593
12594     indexop->op_flags &= ~OPf_PARENS;
12595     indexop->op_flags |= (o->op_flags & OPf_PARENS);
12596     indexop->op_private |= OPpTRUEBOOL;
12597     if (neg)
12598         indexop->op_private |= OPpINDEX_BOOLNEG;
12599     /* cut out the index op and free the eq,const ops */
12600     (void)op_sibling_splice(o, start, 1, NULL);
12601     op_free(o);
12602
12603     return indexop;
12604 }
12605
12606
12607 OP *
12608 Perl_ck_concat(pTHX_ OP *o)
12609 {
12610     const OP * const kid = cUNOPo->op_first;
12611
12612     PERL_ARGS_ASSERT_CK_CONCAT;
12613     PERL_UNUSED_CONTEXT;
12614
12615     /* reuse the padtmp returned by the concat child */
12616     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12617             !(kUNOP->op_first->op_flags & OPf_MOD))
12618     {
12619         o->op_flags |= OPf_STACKED;
12620         o->op_private |= OPpCONCAT_NESTED;
12621     }
12622     return o;
12623 }
12624
12625 OP *
12626 Perl_ck_spair(pTHX_ OP *o)
12627 {
12628     dVAR;
12629
12630     PERL_ARGS_ASSERT_CK_SPAIR;
12631
12632     if (o->op_flags & OPf_KIDS) {
12633         OP* newop;
12634         OP* kid;
12635         OP* kidkid;
12636         const OPCODE type = o->op_type;
12637         o = modkids(ck_fun(o), type);
12638         kid    = cUNOPo->op_first;
12639         kidkid = kUNOP->op_first;
12640         newop = OpSIBLING(kidkid);
12641         if (newop) {
12642             const OPCODE type = newop->op_type;
12643             if (OpHAS_SIBLING(newop))
12644                 return o;
12645             if (o->op_type == OP_REFGEN
12646              && (  type == OP_RV2CV
12647                 || (  !(newop->op_flags & OPf_PARENS)
12648                    && (  type == OP_RV2AV || type == OP_PADAV
12649                       || type == OP_RV2HV || type == OP_PADHV))))
12650                 NOOP; /* OK (allow srefgen for \@a and \%h) */
12651             else if (OP_GIMME(newop,0) != G_SCALAR)
12652                 return o;
12653         }
12654         /* excise first sibling */
12655         op_sibling_splice(kid, NULL, 1, NULL);
12656         op_free(kidkid);
12657     }
12658     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12659      * and OP_CHOMP into OP_SCHOMP */
12660     o->op_ppaddr = PL_ppaddr[++o->op_type];
12661     return ck_fun(o);
12662 }
12663
12664 OP *
12665 Perl_ck_delete(pTHX_ OP *o)
12666 {
12667     PERL_ARGS_ASSERT_CK_DELETE;
12668
12669     o = ck_fun(o);
12670     o->op_private = 0;
12671     if (o->op_flags & OPf_KIDS) {
12672         OP * const kid = cUNOPo->op_first;
12673         switch (kid->op_type) {
12674         case OP_ASLICE:
12675             o->op_flags |= OPf_SPECIAL;
12676             /* FALLTHROUGH */
12677         case OP_HSLICE:
12678             o->op_private |= OPpSLICE;
12679             break;
12680         case OP_AELEM:
12681             o->op_flags |= OPf_SPECIAL;
12682             /* FALLTHROUGH */
12683         case OP_HELEM:
12684             break;
12685         case OP_KVASLICE:
12686             o->op_flags |= OPf_SPECIAL;
12687             /* FALLTHROUGH */
12688         case OP_KVHSLICE:
12689             o->op_private |= OPpKVSLICE;
12690             break;
12691         default:
12692             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12693                              "element or slice");
12694         }
12695         if (kid->op_private & OPpLVAL_INTRO)
12696             o->op_private |= OPpLVAL_INTRO;
12697         op_null(kid);
12698     }
12699     return o;
12700 }
12701
12702 OP *
12703 Perl_ck_eof(pTHX_ OP *o)
12704 {
12705     PERL_ARGS_ASSERT_CK_EOF;
12706
12707     if (o->op_flags & OPf_KIDS) {
12708         OP *kid;
12709         if (cLISTOPo->op_first->op_type == OP_STUB) {
12710             OP * const newop
12711                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12712             op_free(o);
12713             o = newop;
12714         }
12715         o = ck_fun(o);
12716         kid = cLISTOPo->op_first;
12717         if (kid->op_type == OP_RV2GV)
12718             kid->op_private |= OPpALLOW_FAKE;
12719     }
12720     return o;
12721 }
12722
12723
12724 OP *
12725 Perl_ck_eval(pTHX_ OP *o)
12726 {
12727     dVAR;
12728
12729     PERL_ARGS_ASSERT_CK_EVAL;
12730
12731     PL_hints |= HINT_BLOCK_SCOPE;
12732     if (o->op_flags & OPf_KIDS) {
12733         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12734         assert(kid);
12735
12736         if (o->op_type == OP_ENTERTRY) {
12737             LOGOP *enter;
12738
12739             /* cut whole sibling chain free from o */
12740             op_sibling_splice(o, NULL, -1, NULL);
12741             op_free(o);
12742
12743             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12744
12745             /* establish postfix order */
12746             enter->op_next = (OP*)enter;
12747
12748             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12749             OpTYPE_set(o, OP_LEAVETRY);
12750             enter->op_other = o;
12751             return o;
12752         }
12753         else {
12754             scalar((OP*)kid);
12755             S_set_haseval(aTHX);
12756         }
12757     }
12758     else {
12759         const U8 priv = o->op_private;
12760         op_free(o);
12761         /* the newUNOP will recursively call ck_eval(), which will handle
12762          * all the stuff at the end of this function, like adding
12763          * OP_HINTSEVAL
12764          */
12765         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12766     }
12767     o->op_targ = (PADOFFSET)PL_hints;
12768     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12769     if ((PL_hints & HINT_LOCALIZE_HH) != 0
12770      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12771         /* Store a copy of %^H that pp_entereval can pick up. */
12772         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12773         OP *hhop;
12774         STOREFEATUREBITSHH(hh);
12775         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12776         /* append hhop to only child  */
12777         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12778
12779         o->op_private |= OPpEVAL_HAS_HH;
12780     }
12781     if (!(o->op_private & OPpEVAL_BYTES)
12782          && FEATURE_UNIEVAL_IS_ENABLED)
12783             o->op_private |= OPpEVAL_UNICODE;
12784     return o;
12785 }
12786
12787 OP *
12788 Perl_ck_exec(pTHX_ OP *o)
12789 {
12790     PERL_ARGS_ASSERT_CK_EXEC;
12791
12792     if (o->op_flags & OPf_STACKED) {
12793         OP *kid;
12794         o = ck_fun(o);
12795         kid = OpSIBLING(cUNOPo->op_first);
12796         if (kid->op_type == OP_RV2GV)
12797             op_null(kid);
12798     }
12799     else
12800         o = listkids(o);
12801     return o;
12802 }
12803
12804 OP *
12805 Perl_ck_exists(pTHX_ OP *o)
12806 {
12807     PERL_ARGS_ASSERT_CK_EXISTS;
12808
12809     o = ck_fun(o);
12810     if (o->op_flags & OPf_KIDS) {
12811         OP * const kid = cUNOPo->op_first;
12812         if (kid->op_type == OP_ENTERSUB) {
12813             (void) ref(kid, o->op_type);
12814             if (kid->op_type != OP_RV2CV
12815                         && !(PL_parser && PL_parser->error_count))
12816                 Perl_croak(aTHX_
12817                           "exists argument is not a subroutine name");
12818             o->op_private |= OPpEXISTS_SUB;
12819         }
12820         else if (kid->op_type == OP_AELEM)
12821             o->op_flags |= OPf_SPECIAL;
12822         else if (kid->op_type != OP_HELEM)
12823             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12824                              "element or a subroutine");
12825         op_null(kid);
12826     }
12827     return o;
12828 }
12829
12830 OP *
12831 Perl_ck_rvconst(pTHX_ OP *o)
12832 {
12833     dVAR;
12834     SVOP * const kid = (SVOP*)cUNOPo->op_first;
12835
12836     PERL_ARGS_ASSERT_CK_RVCONST;
12837
12838     if (o->op_type == OP_RV2HV)
12839         /* rv2hv steals the bottom bit for its own uses */
12840         o->op_private &= ~OPpARG1_MASK;
12841
12842     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12843
12844     if (kid->op_type == OP_CONST) {
12845         int iscv;
12846         GV *gv;
12847         SV * const kidsv = kid->op_sv;
12848
12849         /* Is it a constant from cv_const_sv()? */
12850         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12851             return o;
12852         }
12853         if (SvTYPE(kidsv) == SVt_PVAV) return o;
12854         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12855             const char *badthing;
12856             switch (o->op_type) {
12857             case OP_RV2SV:
12858                 badthing = "a SCALAR";
12859                 break;
12860             case OP_RV2AV:
12861                 badthing = "an ARRAY";
12862                 break;
12863             case OP_RV2HV:
12864                 badthing = "a HASH";
12865                 break;
12866             default:
12867                 badthing = NULL;
12868                 break;
12869             }
12870             if (badthing)
12871                 Perl_croak(aTHX_
12872                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12873                            SVfARG(kidsv), badthing);
12874         }
12875         /*
12876          * This is a little tricky.  We only want to add the symbol if we
12877          * didn't add it in the lexer.  Otherwise we get duplicate strict
12878          * warnings.  But if we didn't add it in the lexer, we must at
12879          * least pretend like we wanted to add it even if it existed before,
12880          * or we get possible typo warnings.  OPpCONST_ENTERED says
12881          * whether the lexer already added THIS instance of this symbol.
12882          */
12883         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12884         gv = gv_fetchsv(kidsv,
12885                 o->op_type == OP_RV2CV
12886                         && o->op_private & OPpMAY_RETURN_CONSTANT
12887                     ? GV_NOEXPAND
12888                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
12889                 iscv
12890                     ? SVt_PVCV
12891                     : o->op_type == OP_RV2SV
12892                         ? SVt_PV
12893                         : o->op_type == OP_RV2AV
12894                             ? SVt_PVAV
12895                             : o->op_type == OP_RV2HV
12896                                 ? SVt_PVHV
12897                                 : SVt_PVGV);
12898         if (gv) {
12899             if (!isGV(gv)) {
12900                 assert(iscv);
12901                 assert(SvROK(gv));
12902                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12903                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
12904                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12905             }
12906             OpTYPE_set(kid, OP_GV);
12907             SvREFCNT_dec(kid->op_sv);
12908 #ifdef USE_ITHREADS
12909             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12910             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12911             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12912             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12913             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12914 #else
12915             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12916 #endif
12917             kid->op_private = 0;
12918             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12919             SvFAKE_off(gv);
12920         }
12921     }
12922     return o;
12923 }
12924
12925 OP *
12926 Perl_ck_ftst(pTHX_ OP *o)
12927 {
12928     dVAR;
12929     const I32 type = o->op_type;
12930
12931     PERL_ARGS_ASSERT_CK_FTST;
12932
12933     if (o->op_flags & OPf_REF) {
12934         NOOP;
12935     }
12936     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12937         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12938         const OPCODE kidtype = kid->op_type;
12939
12940         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12941          && !kid->op_folded) {
12942             OP * const newop = newGVOP(type, OPf_REF,
12943                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12944             op_free(o);
12945             return newop;
12946         }
12947
12948         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12949             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12950             if (name) {
12951                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12952                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12953                             array_passed_to_stat, name);
12954             }
12955             else {
12956                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12957                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12958             }
12959        }
12960         scalar((OP *) kid);
12961         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12962             o->op_private |= OPpFT_ACCESS;
12963         if (OP_IS_FILETEST(type)
12964             && OP_IS_FILETEST(kidtype)
12965         ) {
12966             o->op_private |= OPpFT_STACKED;
12967             kid->op_private |= OPpFT_STACKING;
12968             if (kidtype == OP_FTTTY && (
12969                    !(kid->op_private & OPpFT_STACKED)
12970                 || kid->op_private & OPpFT_AFTER_t
12971                ))
12972                 o->op_private |= OPpFT_AFTER_t;
12973         }
12974     }
12975     else {
12976         op_free(o);
12977         if (type == OP_FTTTY)
12978             o = newGVOP(type, OPf_REF, PL_stdingv);
12979         else
12980             o = newUNOP(type, 0, newDEFSVOP());
12981     }
12982     return o;
12983 }
12984
12985 OP *
12986 Perl_ck_fun(pTHX_ OP *o)
12987 {
12988     const int type = o->op_type;
12989     I32 oa = PL_opargs[type] >> OASHIFT;
12990
12991     PERL_ARGS_ASSERT_CK_FUN;
12992
12993     if (o->op_flags & OPf_STACKED) {
12994         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12995             oa &= ~OA_OPTIONAL;
12996         else
12997             return no_fh_allowed(o);
12998     }
12999
13000     if (o->op_flags & OPf_KIDS) {
13001         OP *prev_kid = NULL;
13002         OP *kid = cLISTOPo->op_first;
13003         I32 numargs = 0;
13004         bool seen_optional = FALSE;
13005
13006         if (kid->op_type == OP_PUSHMARK ||
13007             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13008         {
13009             prev_kid = kid;
13010             kid = OpSIBLING(kid);
13011         }
13012         if (kid && kid->op_type == OP_COREARGS) {
13013             bool optional = FALSE;
13014             while (oa) {
13015                 numargs++;
13016                 if (oa & OA_OPTIONAL) optional = TRUE;
13017                 oa = oa >> 4;
13018             }
13019             if (optional) o->op_private |= numargs;
13020             return o;
13021         }
13022
13023         while (oa) {
13024             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13025                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13026                     kid = newDEFSVOP();
13027                     /* append kid to chain */
13028                     op_sibling_splice(o, prev_kid, 0, kid);
13029                 }
13030                 seen_optional = TRUE;
13031             }
13032             if (!kid) break;
13033
13034             numargs++;
13035             switch (oa & 7) {
13036             case OA_SCALAR:
13037                 /* list seen where single (scalar) arg expected? */
13038                 if (numargs == 1 && !(oa >> 4)
13039                     && kid->op_type == OP_LIST && type != OP_SCALAR)
13040                 {
13041                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13042                 }
13043                 if (type != OP_DELETE) scalar(kid);
13044                 break;
13045             case OA_LIST:
13046                 if (oa < 16) {
13047                     kid = 0;
13048                     continue;
13049                 }
13050                 else
13051                     list(kid);
13052                 break;
13053             case OA_AVREF:
13054                 if ((type == OP_PUSH || type == OP_UNSHIFT)
13055                     && !OpHAS_SIBLING(kid))
13056                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13057                                    "Useless use of %s with no values",
13058                                    PL_op_desc[type]);
13059
13060                 if (kid->op_type == OP_CONST
13061                       && (  !SvROK(cSVOPx_sv(kid))
13062                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
13063                         )
13064                     bad_type_pv(numargs, "array", o, kid);
13065                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13066                          || kid->op_type == OP_RV2GV) {
13067                     bad_type_pv(1, "array", o, kid);
13068                 }
13069                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13070                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13071                                          PL_op_desc[type]), 0);
13072                 }
13073                 else {
13074                     op_lvalue(kid, type);
13075                 }
13076                 break;
13077             case OA_HVREF:
13078                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13079                     bad_type_pv(numargs, "hash", o, kid);
13080                 op_lvalue(kid, type);
13081                 break;
13082             case OA_CVREF:
13083                 {
13084                     /* replace kid with newop in chain */
13085                     OP * const newop =
13086                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13087                     newop->op_next = newop;
13088                     kid = newop;
13089                 }
13090                 break;
13091             case OA_FILEREF:
13092                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13093                     if (kid->op_type == OP_CONST &&
13094                         (kid->op_private & OPpCONST_BARE))
13095                     {
13096                         OP * const newop = newGVOP(OP_GV, 0,
13097                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13098                         /* replace kid with newop in chain */
13099                         op_sibling_splice(o, prev_kid, 1, newop);
13100                         op_free(kid);
13101                         kid = newop;
13102                     }
13103                     else if (kid->op_type == OP_READLINE) {
13104                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13105                         bad_type_pv(numargs, "HANDLE", o, kid);
13106                     }
13107                     else {
13108                         I32 flags = OPf_SPECIAL;
13109                         I32 priv = 0;
13110                         PADOFFSET targ = 0;
13111
13112                         /* is this op a FH constructor? */
13113                         if (is_handle_constructor(o,numargs)) {
13114                             const char *name = NULL;
13115                             STRLEN len = 0;
13116                             U32 name_utf8 = 0;
13117                             bool want_dollar = TRUE;
13118
13119                             flags = 0;
13120                             /* Set a flag to tell rv2gv to vivify
13121                              * need to "prove" flag does not mean something
13122                              * else already - NI-S 1999/05/07
13123                              */
13124                             priv = OPpDEREF;
13125                             if (kid->op_type == OP_PADSV) {
13126                                 PADNAME * const pn
13127                                     = PAD_COMPNAME_SV(kid->op_targ);
13128                                 name = PadnamePV (pn);
13129                                 len  = PadnameLEN(pn);
13130                                 name_utf8 = PadnameUTF8(pn);
13131                             }
13132                             else if (kid->op_type == OP_RV2SV
13133                                      && kUNOP->op_first->op_type == OP_GV)
13134                             {
13135                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13136                                 name = GvNAME(gv);
13137                                 len = GvNAMELEN(gv);
13138                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13139                             }
13140                             else if (kid->op_type == OP_AELEM
13141                                      || kid->op_type == OP_HELEM)
13142                             {
13143                                  OP *firstop;
13144                                  OP *op = ((BINOP*)kid)->op_first;
13145                                  name = NULL;
13146                                  if (op) {
13147                                       SV *tmpstr = NULL;
13148                                       const char * const a =
13149                                            kid->op_type == OP_AELEM ?
13150                                            "[]" : "{}";
13151                                       if (((op->op_type == OP_RV2AV) ||
13152                                            (op->op_type == OP_RV2HV)) &&
13153                                           (firstop = ((UNOP*)op)->op_first) &&
13154                                           (firstop->op_type == OP_GV)) {
13155                                            /* packagevar $a[] or $h{} */
13156                                            GV * const gv = cGVOPx_gv(firstop);
13157                                            if (gv)
13158                                                 tmpstr =
13159                                                      Perl_newSVpvf(aTHX_
13160                                                                    "%s%c...%c",
13161                                                                    GvNAME(gv),
13162                                                                    a[0], a[1]);
13163                                       }
13164                                       else if (op->op_type == OP_PADAV
13165                                                || op->op_type == OP_PADHV) {
13166                                            /* lexicalvar $a[] or $h{} */
13167                                            const char * const padname =
13168                                                 PAD_COMPNAME_PV(op->op_targ);
13169                                            if (padname)
13170                                                 tmpstr =
13171                                                      Perl_newSVpvf(aTHX_
13172                                                                    "%s%c...%c",
13173                                                                    padname + 1,
13174                                                                    a[0], a[1]);
13175                                       }
13176                                       if (tmpstr) {
13177                                            name = SvPV_const(tmpstr, len);
13178                                            name_utf8 = SvUTF8(tmpstr);
13179                                            sv_2mortal(tmpstr);
13180                                       }
13181                                  }
13182                                  if (!name) {
13183                                       name = "__ANONIO__";
13184                                       len = 10;
13185                                       want_dollar = FALSE;
13186                                  }
13187                                  op_lvalue(kid, type);
13188                             }
13189                             if (name) {
13190                                 SV *namesv;
13191                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13192                                 namesv = PAD_SVl(targ);
13193                                 if (want_dollar && *name != '$')
13194                                     sv_setpvs(namesv, "$");
13195                                 else
13196                                     SvPVCLEAR(namesv);
13197                                 sv_catpvn(namesv, name, len);
13198                                 if ( name_utf8 ) SvUTF8_on(namesv);
13199                             }
13200                         }
13201                         scalar(kid);
13202                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13203                                     OP_RV2GV, flags);
13204                         kid->op_targ = targ;
13205                         kid->op_private |= priv;
13206                     }
13207                 }
13208                 scalar(kid);
13209                 break;
13210             case OA_SCALARREF:
13211                 if ((type == OP_UNDEF || type == OP_POS)
13212                     && numargs == 1 && !(oa >> 4)
13213                     && kid->op_type == OP_LIST)
13214                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13215                 op_lvalue(scalar(kid), type);
13216                 break;
13217             }
13218             oa >>= 4;
13219             prev_kid = kid;
13220             kid = OpSIBLING(kid);
13221         }
13222         /* FIXME - should the numargs or-ing move after the too many
13223          * arguments check? */
13224         o->op_private |= numargs;
13225         if (kid)
13226             return too_many_arguments_pv(o,OP_DESC(o), 0);
13227         listkids(o);
13228     }
13229     else if (PL_opargs[type] & OA_DEFGV) {
13230         /* Ordering of these two is important to keep f_map.t passing.  */
13231         op_free(o);
13232         return newUNOP(type, 0, newDEFSVOP());
13233     }
13234
13235     if (oa) {
13236         while (oa & OA_OPTIONAL)
13237             oa >>= 4;
13238         if (oa && oa != OA_LIST)
13239             return too_few_arguments_pv(o,OP_DESC(o), 0);
13240     }
13241     return o;
13242 }
13243
13244 OP *
13245 Perl_ck_glob(pTHX_ OP *o)
13246 {
13247     GV *gv;
13248
13249     PERL_ARGS_ASSERT_CK_GLOB;
13250
13251     o = ck_fun(o);
13252     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13253         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13254
13255     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13256     {
13257         /* convert
13258          *     glob
13259          *       \ null - const(wildcard)
13260          * into
13261          *     null
13262          *       \ enter
13263          *            \ list
13264          *                 \ mark - glob - rv2cv
13265          *                             |        \ gv(CORE::GLOBAL::glob)
13266          *                             |
13267          *                              \ null - const(wildcard)
13268          */
13269         o->op_flags |= OPf_SPECIAL;
13270         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13271         o = S_new_entersubop(aTHX_ gv, o);
13272         o = newUNOP(OP_NULL, 0, o);
13273         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13274         return o;
13275     }
13276     else o->op_flags &= ~OPf_SPECIAL;
13277 #if !defined(PERL_EXTERNAL_GLOB)
13278     if (!PL_globhook) {
13279         ENTER;
13280         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13281                                newSVpvs("File::Glob"), NULL, NULL, NULL);
13282         LEAVE;
13283     }
13284 #endif /* !PERL_EXTERNAL_GLOB */
13285     gv = (GV *)newSV(0);
13286     gv_init(gv, 0, "", 0, 0);
13287     gv_IOadd(gv);
13288     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13289     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13290     scalarkids(o);
13291     return o;
13292 }
13293
13294 OP *
13295 Perl_ck_grep(pTHX_ OP *o)
13296 {
13297     LOGOP *gwop;
13298     OP *kid;
13299     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13300
13301     PERL_ARGS_ASSERT_CK_GREP;
13302
13303     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13304
13305     if (o->op_flags & OPf_STACKED) {
13306         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13307         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13308             return no_fh_allowed(o);
13309         o->op_flags &= ~OPf_STACKED;
13310     }
13311     kid = OpSIBLING(cLISTOPo->op_first);
13312     if (type == OP_MAPWHILE)
13313         list(kid);
13314     else
13315         scalar(kid);
13316     o = ck_fun(o);
13317     if (PL_parser && PL_parser->error_count)
13318         return o;
13319     kid = OpSIBLING(cLISTOPo->op_first);
13320     if (kid->op_type != OP_NULL)
13321         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13322     kid = kUNOP->op_first;
13323
13324     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13325     kid->op_next = (OP*)gwop;
13326     o->op_private = gwop->op_private = 0;
13327     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13328
13329     kid = OpSIBLING(cLISTOPo->op_first);
13330     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13331         op_lvalue(kid, OP_GREPSTART);
13332
13333     return (OP*)gwop;
13334 }
13335
13336 OP *
13337 Perl_ck_index(pTHX_ OP *o)
13338 {
13339     PERL_ARGS_ASSERT_CK_INDEX;
13340
13341     if (o->op_flags & OPf_KIDS) {
13342         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
13343         if (kid)
13344             kid = OpSIBLING(kid);                       /* get past "big" */
13345         if (kid && kid->op_type == OP_CONST) {
13346             const bool save_taint = TAINT_get;
13347             SV *sv = kSVOP->op_sv;
13348             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13349                 && SvOK(sv) && !SvROK(sv))
13350             {
13351                 sv = newSV(0);
13352                 sv_copypv(sv, kSVOP->op_sv);
13353                 SvREFCNT_dec_NN(kSVOP->op_sv);
13354                 kSVOP->op_sv = sv;
13355             }
13356             if (SvOK(sv)) fbm_compile(sv, 0);
13357             TAINT_set(save_taint);
13358 #ifdef NO_TAINT_SUPPORT
13359             PERL_UNUSED_VAR(save_taint);
13360 #endif
13361         }
13362     }
13363     return ck_fun(o);
13364 }
13365
13366 OP *
13367 Perl_ck_lfun(pTHX_ OP *o)
13368 {
13369     const OPCODE type = o->op_type;
13370
13371     PERL_ARGS_ASSERT_CK_LFUN;
13372
13373     return modkids(ck_fun(o), type);
13374 }
13375
13376 OP *
13377 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
13378 {
13379     PERL_ARGS_ASSERT_CK_DEFINED;
13380
13381     if ((o->op_flags & OPf_KIDS)) {
13382         switch (cUNOPo->op_first->op_type) {
13383         case OP_RV2AV:
13384         case OP_PADAV:
13385             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13386                              " (Maybe you should just omit the defined()?)");
13387             NOT_REACHED; /* NOTREACHED */
13388             break;
13389         case OP_RV2HV:
13390         case OP_PADHV:
13391             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13392                              " (Maybe you should just omit the defined()?)");
13393             NOT_REACHED; /* NOTREACHED */
13394             break;
13395         default:
13396             /* no warning */
13397             break;
13398         }
13399     }
13400     return ck_rfun(o);
13401 }
13402
13403 OP *
13404 Perl_ck_readline(pTHX_ OP *o)
13405 {
13406     PERL_ARGS_ASSERT_CK_READLINE;
13407
13408     if (o->op_flags & OPf_KIDS) {
13409          OP *kid = cLISTOPo->op_first;
13410          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13411          scalar(kid);
13412     }
13413     else {
13414         OP * const newop
13415             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13416         op_free(o);
13417         return newop;
13418     }
13419     return o;
13420 }
13421
13422 OP *
13423 Perl_ck_rfun(pTHX_ OP *o)
13424 {
13425     const OPCODE type = o->op_type;
13426
13427     PERL_ARGS_ASSERT_CK_RFUN;
13428
13429     return refkids(ck_fun(o), type);
13430 }
13431
13432 OP *
13433 Perl_ck_listiob(pTHX_ OP *o)
13434 {
13435     OP *kid;
13436
13437     PERL_ARGS_ASSERT_CK_LISTIOB;
13438
13439     kid = cLISTOPo->op_first;
13440     if (!kid) {
13441         o = force_list(o, 1);
13442         kid = cLISTOPo->op_first;
13443     }
13444     if (kid->op_type == OP_PUSHMARK)
13445         kid = OpSIBLING(kid);
13446     if (kid && o->op_flags & OPf_STACKED)
13447         kid = OpSIBLING(kid);
13448     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
13449         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13450          && !kid->op_folded) {
13451             o->op_flags |= OPf_STACKED; /* make it a filehandle */
13452             scalar(kid);
13453             /* replace old const op with new OP_RV2GV parent */
13454             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13455                                         OP_RV2GV, OPf_REF);
13456             kid = OpSIBLING(kid);
13457         }
13458     }
13459
13460     if (!kid)
13461         op_append_elem(o->op_type, o, newDEFSVOP());
13462
13463     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13464     return listkids(o);
13465 }
13466
13467 OP *
13468 Perl_ck_smartmatch(pTHX_ OP *o)
13469 {
13470     dVAR;
13471     PERL_ARGS_ASSERT_CK_SMARTMATCH;
13472     if (0 == (o->op_flags & OPf_SPECIAL)) {
13473         OP *first  = cBINOPo->op_first;
13474         OP *second = OpSIBLING(first);
13475
13476         /* Implicitly take a reference to an array or hash */
13477
13478         /* remove the original two siblings, then add back the
13479          * (possibly different) first and second sibs.
13480          */
13481         op_sibling_splice(o, NULL, 1, NULL);
13482         op_sibling_splice(o, NULL, 1, NULL);
13483         first  = ref_array_or_hash(first);
13484         second = ref_array_or_hash(second);
13485         op_sibling_splice(o, NULL, 0, second);
13486         op_sibling_splice(o, NULL, 0, first);
13487
13488         /* Implicitly take a reference to a regular expression */
13489         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13490             OpTYPE_set(first, OP_QR);
13491         }
13492         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13493             OpTYPE_set(second, OP_QR);
13494         }
13495     }
13496
13497     return o;
13498 }
13499
13500
13501 static OP *
13502 S_maybe_targlex(pTHX_ OP *o)
13503 {
13504     OP * const kid = cLISTOPo->op_first;
13505     /* has a disposable target? */
13506     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13507         && !(kid->op_flags & OPf_STACKED)
13508         /* Cannot steal the second time! */
13509         && !(kid->op_private & OPpTARGET_MY)
13510         )
13511     {
13512         OP * const kkid = OpSIBLING(kid);
13513
13514         /* Can just relocate the target. */
13515         if (kkid && kkid->op_type == OP_PADSV
13516             && (!(kkid->op_private & OPpLVAL_INTRO)
13517                || kkid->op_private & OPpPAD_STATE))
13518         {
13519             kid->op_targ = kkid->op_targ;
13520             kkid->op_targ = 0;
13521             /* Now we do not need PADSV and SASSIGN.
13522              * Detach kid and free the rest. */
13523             op_sibling_splice(o, NULL, 1, NULL);
13524             op_free(o);
13525             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
13526             return kid;
13527         }
13528     }
13529     return o;
13530 }
13531
13532 OP *
13533 Perl_ck_sassign(pTHX_ OP *o)
13534 {
13535     dVAR;
13536     OP * const kid = cBINOPo->op_first;
13537
13538     PERL_ARGS_ASSERT_CK_SASSIGN;
13539
13540     if (OpHAS_SIBLING(kid)) {
13541         OP *kkid = OpSIBLING(kid);
13542         /* For state variable assignment with attributes, kkid is a list op
13543            whose op_last is a padsv. */
13544         if ((kkid->op_type == OP_PADSV ||
13545              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13546               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13547              )
13548             )
13549                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13550                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13551             return S_newONCEOP(aTHX_ o, kkid);
13552         }
13553     }
13554     return S_maybe_targlex(aTHX_ o);
13555 }
13556
13557
13558 OP *
13559 Perl_ck_match(pTHX_ OP *o)
13560 {
13561     PERL_UNUSED_CONTEXT;
13562     PERL_ARGS_ASSERT_CK_MATCH;
13563
13564     return o;
13565 }
13566
13567 OP *
13568 Perl_ck_method(pTHX_ OP *o)
13569 {
13570     SV *sv, *methsv, *rclass;
13571     const char* method;
13572     char* compatptr;
13573     int utf8;
13574     STRLEN len, nsplit = 0, i;
13575     OP* new_op;
13576     OP * const kid = cUNOPo->op_first;
13577
13578     PERL_ARGS_ASSERT_CK_METHOD;
13579     if (kid->op_type != OP_CONST) return o;
13580
13581     sv = kSVOP->op_sv;
13582
13583     /* replace ' with :: */
13584     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13585                                         SvEND(sv) - SvPVX(sv) )))
13586     {
13587         *compatptr = ':';
13588         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13589     }
13590
13591     method = SvPVX_const(sv);
13592     len = SvCUR(sv);
13593     utf8 = SvUTF8(sv) ? -1 : 1;
13594
13595     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13596         nsplit = i+1;
13597         break;
13598     }
13599
13600     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13601
13602     if (!nsplit) { /* $proto->method() */
13603         op_free(o);
13604         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13605     }
13606
13607     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13608         op_free(o);
13609         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13610     }
13611
13612     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13613     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13614         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13615         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13616     } else {
13617         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13618         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13619     }
13620 #ifdef USE_ITHREADS
13621     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13622 #else
13623     cMETHOPx(new_op)->op_rclass_sv = rclass;
13624 #endif
13625     op_free(o);
13626     return new_op;
13627 }
13628
13629 OP *
13630 Perl_ck_null(pTHX_ OP *o)
13631 {
13632     PERL_ARGS_ASSERT_CK_NULL;
13633     PERL_UNUSED_CONTEXT;
13634     return o;
13635 }
13636
13637 OP *
13638 Perl_ck_open(pTHX_ OP *o)
13639 {
13640     PERL_ARGS_ASSERT_CK_OPEN;
13641
13642     S_io_hints(aTHX_ o);
13643     {
13644          /* In case of three-arg dup open remove strictness
13645           * from the last arg if it is a bareword. */
13646          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13647          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
13648          OP *oa;
13649          const char *mode;
13650
13651          if ((last->op_type == OP_CONST) &&             /* The bareword. */
13652              (last->op_private & OPpCONST_BARE) &&
13653              (last->op_private & OPpCONST_STRICT) &&
13654              (oa = OpSIBLING(first)) &&         /* The fh. */
13655              (oa = OpSIBLING(oa)) &&                    /* The mode. */
13656              (oa->op_type == OP_CONST) &&
13657              SvPOK(((SVOP*)oa)->op_sv) &&
13658              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13659              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
13660              (last == OpSIBLING(oa)))                   /* The bareword. */
13661               last->op_private &= ~OPpCONST_STRICT;
13662     }
13663     return ck_fun(o);
13664 }
13665
13666 OP *
13667 Perl_ck_prototype(pTHX_ OP *o)
13668 {
13669     PERL_ARGS_ASSERT_CK_PROTOTYPE;
13670     if (!(o->op_flags & OPf_KIDS)) {
13671         op_free(o);
13672         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13673     }
13674     return o;
13675 }
13676
13677 OP *
13678 Perl_ck_refassign(pTHX_ OP *o)
13679 {
13680     OP * const right = cLISTOPo->op_first;
13681     OP * const left = OpSIBLING(right);
13682     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13683     bool stacked = 0;
13684
13685     PERL_ARGS_ASSERT_CK_REFASSIGN;
13686     assert (left);
13687     assert (left->op_type == OP_SREFGEN);
13688
13689     o->op_private = 0;
13690     /* we use OPpPAD_STATE in refassign to mean either of those things,
13691      * and the code assumes the two flags occupy the same bit position
13692      * in the various ops below */
13693     assert(OPpPAD_STATE == OPpOUR_INTRO);
13694
13695     switch (varop->op_type) {
13696     case OP_PADAV:
13697         o->op_private |= OPpLVREF_AV;
13698         goto settarg;
13699     case OP_PADHV:
13700         o->op_private |= OPpLVREF_HV;
13701         /* FALLTHROUGH */
13702     case OP_PADSV:
13703       settarg:
13704         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13705         o->op_targ = varop->op_targ;
13706         varop->op_targ = 0;
13707         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13708         break;
13709
13710     case OP_RV2AV:
13711         o->op_private |= OPpLVREF_AV;
13712         goto checkgv;
13713         NOT_REACHED; /* NOTREACHED */
13714     case OP_RV2HV:
13715         o->op_private |= OPpLVREF_HV;
13716         /* FALLTHROUGH */
13717     case OP_RV2SV:
13718       checkgv:
13719         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13720         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13721       detach_and_stack:
13722         /* Point varop to its GV kid, detached.  */
13723         varop = op_sibling_splice(varop, NULL, -1, NULL);
13724         stacked = TRUE;
13725         break;
13726     case OP_RV2CV: {
13727         OP * const kidparent =
13728             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13729         OP * const kid = cUNOPx(kidparent)->op_first;
13730         o->op_private |= OPpLVREF_CV;
13731         if (kid->op_type == OP_GV) {
13732             SV *sv = (SV*)cGVOPx_gv(kid);
13733             varop = kidparent;
13734             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13735                 /* a CVREF here confuses pp_refassign, so make sure
13736                    it gets a GV */
13737                 CV *const cv = (CV*)SvRV(sv);
13738                 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13739                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13740                 assert(SvTYPE(sv) == SVt_PVGV);
13741             }
13742             goto detach_and_stack;
13743         }
13744         if (kid->op_type != OP_PADCV)   goto bad;
13745         o->op_targ = kid->op_targ;
13746         kid->op_targ = 0;
13747         break;
13748     }
13749     case OP_AELEM:
13750     case OP_HELEM:
13751         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13752         o->op_private |= OPpLVREF_ELEM;
13753         op_null(varop);
13754         stacked = TRUE;
13755         /* Detach varop.  */
13756         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13757         break;
13758     default:
13759       bad:
13760         /* diag_listed_as: Can't modify reference to %s in %s assignment */
13761         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13762                                 "assignment",
13763                                  OP_DESC(varop)));
13764         return o;
13765     }
13766     if (!FEATURE_REFALIASING_IS_ENABLED)
13767         Perl_croak(aTHX_
13768                   "Experimental aliasing via reference not enabled");
13769     Perl_ck_warner_d(aTHX_
13770                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
13771                     "Aliasing via reference is experimental");
13772     if (stacked) {
13773         o->op_flags |= OPf_STACKED;
13774         op_sibling_splice(o, right, 1, varop);
13775     }
13776     else {
13777         o->op_flags &=~ OPf_STACKED;
13778         op_sibling_splice(o, right, 1, NULL);
13779     }
13780     op_free(left);
13781     return o;
13782 }
13783
13784 OP *
13785 Perl_ck_repeat(pTHX_ OP *o)
13786 {
13787     PERL_ARGS_ASSERT_CK_REPEAT;
13788
13789     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13790         OP* kids;
13791         o->op_private |= OPpREPEAT_DOLIST;
13792         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13793         kids = force_list(kids, 1); /* promote it to a list */
13794         op_sibling_splice(o, NULL, 0, kids); /* and add back */
13795     }
13796     else
13797         scalar(o);
13798     return o;
13799 }
13800
13801 OP *
13802 Perl_ck_require(pTHX_ OP *o)
13803 {
13804     GV* gv;
13805
13806     PERL_ARGS_ASSERT_CK_REQUIRE;
13807
13808     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
13809         SVOP * const kid = (SVOP*)cUNOPo->op_first;
13810         U32 hash;
13811         char *s;
13812         STRLEN len;
13813         if (kid->op_type == OP_CONST) {
13814           SV * const sv = kid->op_sv;
13815           U32 const was_readonly = SvREADONLY(sv);
13816           if (kid->op_private & OPpCONST_BARE) {
13817             dVAR;
13818             const char *end;
13819             HEK *hek;
13820
13821             if (was_readonly) {
13822                 SvREADONLY_off(sv);
13823             }
13824
13825             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13826
13827             s = SvPVX(sv);
13828             len = SvCUR(sv);
13829             end = s + len;
13830             /* treat ::foo::bar as foo::bar */
13831             if (len >= 2 && s[0] == ':' && s[1] == ':')
13832                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13833             if (s == end)
13834                 DIE(aTHX_ "Bareword in require maps to empty filename");
13835
13836             for (; s < end; s++) {
13837                 if (*s == ':' && s[1] == ':') {
13838                     *s = '/';
13839                     Move(s+2, s+1, end - s - 1, char);
13840                     --end;
13841                 }
13842             }
13843             SvEND_set(sv, end);
13844             sv_catpvs(sv, ".pm");
13845             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13846             hek = share_hek(SvPVX(sv),
13847                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13848                             hash);
13849             sv_sethek(sv, hek);
13850             unshare_hek(hek);
13851             SvFLAGS(sv) |= was_readonly;
13852           }
13853           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13854                 && !SvVOK(sv)) {
13855             s = SvPV(sv, len);
13856             if (SvREFCNT(sv) > 1) {
13857                 kid->op_sv = newSVpvn_share(
13858                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13859                 SvREFCNT_dec_NN(sv);
13860             }
13861             else {
13862                 dVAR;
13863                 HEK *hek;
13864                 if (was_readonly) SvREADONLY_off(sv);
13865                 PERL_HASH(hash, s, len);
13866                 hek = share_hek(s,
13867                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13868                                 hash);
13869                 sv_sethek(sv, hek);
13870                 unshare_hek(hek);
13871                 SvFLAGS(sv) |= was_readonly;
13872             }
13873           }
13874         }
13875     }
13876
13877     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13878         /* handle override, if any */
13879      && (gv = gv_override("require", 7))) {
13880         OP *kid, *newop;
13881         if (o->op_flags & OPf_KIDS) {
13882             kid = cUNOPo->op_first;
13883             op_sibling_splice(o, NULL, -1, NULL);
13884         }
13885         else {
13886             kid = newDEFSVOP();
13887         }
13888         op_free(o);
13889         newop = S_new_entersubop(aTHX_ gv, kid);
13890         return newop;
13891     }
13892
13893     return ck_fun(o);
13894 }
13895
13896 OP *
13897 Perl_ck_return(pTHX_ OP *o)
13898 {
13899     OP *kid;
13900
13901     PERL_ARGS_ASSERT_CK_RETURN;
13902
13903     kid = OpSIBLING(cLISTOPo->op_first);
13904     if (PL_compcv && CvLVALUE(PL_compcv)) {
13905         for (; kid; kid = OpSIBLING(kid))
13906             op_lvalue(kid, OP_LEAVESUBLV);
13907     }
13908
13909     return o;
13910 }
13911
13912 OP *
13913 Perl_ck_select(pTHX_ OP *o)
13914 {
13915     dVAR;
13916     OP* kid;
13917
13918     PERL_ARGS_ASSERT_CK_SELECT;
13919
13920     if (o->op_flags & OPf_KIDS) {
13921         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13922         if (kid && OpHAS_SIBLING(kid)) {
13923             OpTYPE_set(o, OP_SSELECT);
13924             o = ck_fun(o);
13925             return fold_constants(op_integerize(op_std_init(o)));
13926         }
13927     }
13928     o = ck_fun(o);
13929     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13930     if (kid && kid->op_type == OP_RV2GV)
13931         kid->op_private &= ~HINT_STRICT_REFS;
13932     return o;
13933 }
13934
13935 OP *
13936 Perl_ck_shift(pTHX_ OP *o)
13937 {
13938     const I32 type = o->op_type;
13939
13940     PERL_ARGS_ASSERT_CK_SHIFT;
13941
13942     if (!(o->op_flags & OPf_KIDS)) {
13943         OP *argop;
13944
13945         if (!CvUNIQUE(PL_compcv)) {
13946             o->op_flags |= OPf_SPECIAL;
13947             return o;
13948         }
13949
13950         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13951         op_free(o);
13952         return newUNOP(type, 0, scalar(argop));
13953     }
13954     return scalar(ck_fun(o));
13955 }
13956
13957 OP *
13958 Perl_ck_sort(pTHX_ OP *o)
13959 {
13960     OP *firstkid;
13961     OP *kid;
13962     HV * const hinthv =
13963         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13964     U8 stacked;
13965
13966     PERL_ARGS_ASSERT_CK_SORT;
13967
13968     if (hinthv) {
13969             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13970             if (svp) {
13971                 const I32 sorthints = (I32)SvIV(*svp);
13972                 if ((sorthints & HINT_SORT_STABLE) != 0)
13973                     o->op_private |= OPpSORT_STABLE;
13974                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13975                     o->op_private |= OPpSORT_UNSTABLE;
13976             }
13977     }
13978
13979     if (o->op_flags & OPf_STACKED)
13980         simplify_sort(o);
13981     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
13982
13983     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
13984         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
13985
13986         /* if the first arg is a code block, process it and mark sort as
13987          * OPf_SPECIAL */
13988         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13989             LINKLIST(kid);
13990             if (kid->op_type == OP_LEAVE)
13991                     op_null(kid);                       /* wipe out leave */
13992             /* Prevent execution from escaping out of the sort block. */
13993             kid->op_next = 0;
13994
13995             /* provide scalar context for comparison function/block */
13996             kid = scalar(firstkid);
13997             kid->op_next = kid;
13998             o->op_flags |= OPf_SPECIAL;
13999         }
14000         else if (kid->op_type == OP_CONST
14001               && kid->op_private & OPpCONST_BARE) {
14002             char tmpbuf[256];
14003             STRLEN len;
14004             PADOFFSET off;
14005             const char * const name = SvPV(kSVOP_sv, len);
14006             *tmpbuf = '&';
14007             assert (len < 256);
14008             Copy(name, tmpbuf+1, len, char);
14009             off = pad_findmy_pvn(tmpbuf, len+1, 0);
14010             if (off != NOT_IN_PAD) {
14011                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14012                     SV * const fq =
14013                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14014                     sv_catpvs(fq, "::");
14015                     sv_catsv(fq, kSVOP_sv);
14016                     SvREFCNT_dec_NN(kSVOP_sv);
14017                     kSVOP->op_sv = fq;
14018                 }
14019                 else {
14020                     OP * const padop = newOP(OP_PADCV, 0);
14021                     padop->op_targ = off;
14022                     /* replace the const op with the pad op */
14023                     op_sibling_splice(firstkid, NULL, 1, padop);
14024                     op_free(kid);
14025                 }
14026             }
14027         }
14028
14029         firstkid = OpSIBLING(firstkid);
14030     }
14031
14032     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14033         /* provide list context for arguments */
14034         list(kid);
14035         if (stacked)
14036             op_lvalue(kid, OP_GREPSTART);
14037     }
14038
14039     return o;
14040 }
14041
14042 /* for sort { X } ..., where X is one of
14043  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14044  * elide the second child of the sort (the one containing X),
14045  * and set these flags as appropriate
14046         OPpSORT_NUMERIC;
14047         OPpSORT_INTEGER;
14048         OPpSORT_DESCEND;
14049  * Also, check and warn on lexical $a, $b.
14050  */
14051
14052 STATIC void
14053 S_simplify_sort(pTHX_ OP *o)
14054 {
14055     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
14056     OP *k;
14057     int descending;
14058     GV *gv;
14059     const char *gvname;
14060     bool have_scopeop;
14061
14062     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14063
14064     kid = kUNOP->op_first;                              /* get past null */
14065     if (!(have_scopeop = kid->op_type == OP_SCOPE)
14066      && kid->op_type != OP_LEAVE)
14067         return;
14068     kid = kLISTOP->op_last;                             /* get past scope */
14069     switch(kid->op_type) {
14070         case OP_NCMP:
14071         case OP_I_NCMP:
14072         case OP_SCMP:
14073             if (!have_scopeop) goto padkids;
14074             break;
14075         default:
14076             return;
14077     }
14078     k = kid;                                            /* remember this node*/
14079     if (kBINOP->op_first->op_type != OP_RV2SV
14080      || kBINOP->op_last ->op_type != OP_RV2SV)
14081     {
14082         /*
14083            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14084            then used in a comparison.  This catches most, but not
14085            all cases.  For instance, it catches
14086                sort { my($a); $a <=> $b }
14087            but not
14088                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14089            (although why you'd do that is anyone's guess).
14090         */
14091
14092        padkids:
14093         if (!ckWARN(WARN_SYNTAX)) return;
14094         kid = kBINOP->op_first;
14095         do {
14096             if (kid->op_type == OP_PADSV) {
14097                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14098                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14099                  && (  PadnamePV(name)[1] == 'a'
14100                     || PadnamePV(name)[1] == 'b'  ))
14101                     /* diag_listed_as: "my %s" used in sort comparison */
14102                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14103                                      "\"%s %s\" used in sort comparison",
14104                                       PadnameIsSTATE(name)
14105                                         ? "state"
14106                                         : "my",
14107                                       PadnamePV(name));
14108             }
14109         } while ((kid = OpSIBLING(kid)));
14110         return;
14111     }
14112     kid = kBINOP->op_first;                             /* get past cmp */
14113     if (kUNOP->op_first->op_type != OP_GV)
14114         return;
14115     kid = kUNOP->op_first;                              /* get past rv2sv */
14116     gv = kGVOP_gv;
14117     if (GvSTASH(gv) != PL_curstash)
14118         return;
14119     gvname = GvNAME(gv);
14120     if (*gvname == 'a' && gvname[1] == '\0')
14121         descending = 0;
14122     else if (*gvname == 'b' && gvname[1] == '\0')
14123         descending = 1;
14124     else
14125         return;
14126
14127     kid = k;                                            /* back to cmp */
14128     /* already checked above that it is rv2sv */
14129     kid = kBINOP->op_last;                              /* down to 2nd arg */
14130     if (kUNOP->op_first->op_type != OP_GV)
14131         return;
14132     kid = kUNOP->op_first;                              /* get past rv2sv */
14133     gv = kGVOP_gv;
14134     if (GvSTASH(gv) != PL_curstash)
14135         return;
14136     gvname = GvNAME(gv);
14137     if ( descending
14138          ? !(*gvname == 'a' && gvname[1] == '\0')
14139          : !(*gvname == 'b' && gvname[1] == '\0'))
14140         return;
14141     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14142     if (descending)
14143         o->op_private |= OPpSORT_DESCEND;
14144     if (k->op_type == OP_NCMP)
14145         o->op_private |= OPpSORT_NUMERIC;
14146     if (k->op_type == OP_I_NCMP)
14147         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14148     kid = OpSIBLING(cLISTOPo->op_first);
14149     /* cut out and delete old block (second sibling) */
14150     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14151     op_free(kid);
14152 }
14153
14154 OP *
14155 Perl_ck_split(pTHX_ OP *o)
14156 {
14157     dVAR;
14158     OP *kid;
14159     OP *sibs;
14160
14161     PERL_ARGS_ASSERT_CK_SPLIT;
14162
14163     assert(o->op_type == OP_LIST);
14164
14165     if (o->op_flags & OPf_STACKED)
14166         return no_fh_allowed(o);
14167
14168     kid = cLISTOPo->op_first;
14169     /* delete leading NULL node, then add a CONST if no other nodes */
14170     assert(kid->op_type == OP_NULL);
14171     op_sibling_splice(o, NULL, 1,
14172         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14173     op_free(kid);
14174     kid = cLISTOPo->op_first;
14175
14176     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14177         /* remove match expression, and replace with new optree with
14178          * a match op at its head */
14179         op_sibling_splice(o, NULL, 1, NULL);
14180         /* pmruntime will handle split " " behavior with flag==2 */
14181         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14182         op_sibling_splice(o, NULL, 0, kid);
14183     }
14184
14185     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14186
14187     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14188       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14189                      "Use of /g modifier is meaningless in split");
14190     }
14191
14192     /* eliminate the split op, and move the match op (plus any children)
14193      * into its place, then convert the match op into a split op. i.e.
14194      *
14195      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
14196      *    |                        |                     |
14197      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
14198      *    |                        |                     |
14199      *    R                        X - Y                 X - Y
14200      *    |
14201      *    X - Y
14202      *
14203      * (R, if it exists, will be a regcomp op)
14204      */
14205
14206     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14207     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14208     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14209     OpTYPE_set(kid, OP_SPLIT);
14210     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
14211     kid->op_private = o->op_private;
14212     op_free(o);
14213     o = kid;
14214     kid = sibs; /* kid is now the string arg of the split */
14215
14216     if (!kid) {
14217         kid = newDEFSVOP();
14218         op_append_elem(OP_SPLIT, o, kid);
14219     }
14220     scalar(kid);
14221
14222     kid = OpSIBLING(kid);
14223     if (!kid) {
14224         kid = newSVOP(OP_CONST, 0, newSViv(0));
14225         op_append_elem(OP_SPLIT, o, kid);
14226         o->op_private |= OPpSPLIT_IMPLIM;
14227     }
14228     scalar(kid);
14229
14230     if (OpHAS_SIBLING(kid))
14231         return too_many_arguments_pv(o,OP_DESC(o), 0);
14232
14233     return o;
14234 }
14235
14236 OP *
14237 Perl_ck_stringify(pTHX_ OP *o)
14238 {
14239     OP * const kid = OpSIBLING(cUNOPo->op_first);
14240     PERL_ARGS_ASSERT_CK_STRINGIFY;
14241     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14242          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
14243          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
14244         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14245     {
14246         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14247         op_free(o);
14248         return kid;
14249     }
14250     return ck_fun(o);
14251 }
14252
14253 OP *
14254 Perl_ck_join(pTHX_ OP *o)
14255 {
14256     OP * const kid = OpSIBLING(cLISTOPo->op_first);
14257
14258     PERL_ARGS_ASSERT_CK_JOIN;
14259
14260     if (kid && kid->op_type == OP_MATCH) {
14261         if (ckWARN(WARN_SYNTAX)) {
14262             const REGEXP *re = PM_GETRE(kPMOP);
14263             const SV *msg = re
14264                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14265                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14266                     : newSVpvs_flags( "STRING", SVs_TEMP );
14267             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14268                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
14269                         SVfARG(msg), SVfARG(msg));
14270         }
14271     }
14272     if (kid
14273      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14274         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14275         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14276            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14277     {
14278         const OP * const bairn = OpSIBLING(kid); /* the list */
14279         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14280          && OP_GIMME(bairn,0) == G_SCALAR)
14281         {
14282             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14283                                      op_sibling_splice(o, kid, 1, NULL));
14284             op_free(o);
14285             return ret;
14286         }
14287     }
14288
14289     return ck_fun(o);
14290 }
14291
14292 /*
14293 =for apidoc rv2cv_op_cv
14294
14295 Examines an op, which is expected to identify a subroutine at runtime,
14296 and attempts to determine at compile time which subroutine it identifies.
14297 This is normally used during Perl compilation to determine whether
14298 a prototype can be applied to a function call.  C<cvop> is the op
14299 being considered, normally an C<rv2cv> op.  A pointer to the identified
14300 subroutine is returned, if it could be determined statically, and a null
14301 pointer is returned if it was not possible to determine statically.
14302
14303 Currently, the subroutine can be identified statically if the RV that the
14304 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14305 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
14306 suitable if the constant value must be an RV pointing to a CV.  Details of
14307 this process may change in future versions of Perl.  If the C<rv2cv> op
14308 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14309 the subroutine statically: this flag is used to suppress compile-time
14310 magic on a subroutine call, forcing it to use default runtime behaviour.
14311
14312 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14313 of a GV reference is modified.  If a GV was examined and its CV slot was
14314 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14315 If the op is not optimised away, and the CV slot is later populated with
14316 a subroutine having a prototype, that flag eventually triggers the warning
14317 "called too early to check prototype".
14318
14319 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14320 of returning a pointer to the subroutine it returns a pointer to the
14321 GV giving the most appropriate name for the subroutine in this context.
14322 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14323 (C<CvANON>) subroutine that is referenced through a GV it will be the
14324 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
14325 A null pointer is returned as usual if there is no statically-determinable
14326 subroutine.
14327
14328 =for apidoc Amnh||OPpEARLY_CV
14329 =for apidoc Amnh||OPpENTERSUB_AMPER
14330 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14331 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14332
14333 =cut
14334 */
14335
14336 /* shared by toke.c:yylex */
14337 CV *
14338 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14339 {
14340     PADNAME *name = PAD_COMPNAME(off);
14341     CV *compcv = PL_compcv;
14342     while (PadnameOUTER(name)) {
14343         assert(PARENT_PAD_INDEX(name));
14344         compcv = CvOUTSIDE(compcv);
14345         name = PadlistNAMESARRAY(CvPADLIST(compcv))
14346                 [off = PARENT_PAD_INDEX(name)];
14347     }
14348     assert(!PadnameIsOUR(name));
14349     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14350         return PadnamePROTOCV(name);
14351     }
14352     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14353 }
14354
14355 CV *
14356 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14357 {
14358     OP *rvop;
14359     CV *cv;
14360     GV *gv;
14361     PERL_ARGS_ASSERT_RV2CV_OP_CV;
14362     if (flags & ~RV2CVOPCV_FLAG_MASK)
14363         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14364     if (cvop->op_type != OP_RV2CV)
14365         return NULL;
14366     if (cvop->op_private & OPpENTERSUB_AMPER)
14367         return NULL;
14368     if (!(cvop->op_flags & OPf_KIDS))
14369         return NULL;
14370     rvop = cUNOPx(cvop)->op_first;
14371     switch (rvop->op_type) {
14372         case OP_GV: {
14373             gv = cGVOPx_gv(rvop);
14374             if (!isGV(gv)) {
14375                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14376                     cv = MUTABLE_CV(SvRV(gv));
14377                     gv = NULL;
14378                     break;
14379                 }
14380                 if (flags & RV2CVOPCV_RETURN_STUB)
14381                     return (CV *)gv;
14382                 else return NULL;
14383             }
14384             cv = GvCVu(gv);
14385             if (!cv) {
14386                 if (flags & RV2CVOPCV_MARK_EARLY)
14387                     rvop->op_private |= OPpEARLY_CV;
14388                 return NULL;
14389             }
14390         } break;
14391         case OP_CONST: {
14392             SV *rv = cSVOPx_sv(rvop);
14393             if (!SvROK(rv))
14394                 return NULL;
14395             cv = (CV*)SvRV(rv);
14396             gv = NULL;
14397         } break;
14398         case OP_PADCV: {
14399             cv = find_lexical_cv(rvop->op_targ);
14400             gv = NULL;
14401         } break;
14402         default: {
14403             return NULL;
14404         } NOT_REACHED; /* NOTREACHED */
14405     }
14406     if (SvTYPE((SV*)cv) != SVt_PVCV)
14407         return NULL;
14408     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14409         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14410             gv = CvGV(cv);
14411         return (CV*)gv;
14412     }
14413     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14414         if (CvLEXICAL(cv) || CvNAMED(cv))
14415             return NULL;
14416         if (!CvANON(cv) || !gv)
14417             gv = CvGV(cv);
14418         return (CV*)gv;
14419
14420     } else {
14421         return cv;
14422     }
14423 }
14424
14425 /*
14426 =for apidoc ck_entersub_args_list
14427
14428 Performs the default fixup of the arguments part of an C<entersub>
14429 op tree.  This consists of applying list context to each of the
14430 argument ops.  This is the standard treatment used on a call marked
14431 with C<&>, or a method call, or a call through a subroutine reference,
14432 or any other call where the callee can't be identified at compile time,
14433 or a call where the callee has no prototype.
14434
14435 =cut
14436 */
14437
14438 OP *
14439 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14440 {
14441     OP *aop;
14442
14443     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14444
14445     aop = cUNOPx(entersubop)->op_first;
14446     if (!OpHAS_SIBLING(aop))
14447         aop = cUNOPx(aop)->op_first;
14448     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14449         /* skip the extra attributes->import() call implicitly added in
14450          * something like foo(my $x : bar)
14451          */
14452         if (   aop->op_type == OP_ENTERSUB
14453             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14454         )
14455             continue;
14456         list(aop);
14457         op_lvalue(aop, OP_ENTERSUB);
14458     }
14459     return entersubop;
14460 }
14461
14462 /*
14463 =for apidoc ck_entersub_args_proto
14464
14465 Performs the fixup of the arguments part of an C<entersub> op tree
14466 based on a subroutine prototype.  This makes various modifications to
14467 the argument ops, from applying context up to inserting C<refgen> ops,
14468 and checking the number and syntactic types of arguments, as directed by
14469 the prototype.  This is the standard treatment used on a subroutine call,
14470 not marked with C<&>, where the callee can be identified at compile time
14471 and has a prototype.
14472
14473 C<protosv> supplies the subroutine prototype to be applied to the call.
14474 It may be a normal defined scalar, of which the string value will be used.
14475 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14476 that has been cast to C<SV*>) which has a prototype.  The prototype
14477 supplied, in whichever form, does not need to match the actual callee
14478 referenced by the op tree.
14479
14480 If the argument ops disagree with the prototype, for example by having
14481 an unacceptable number of arguments, a valid op tree is returned anyway.
14482 The error is reflected in the parser state, normally resulting in a single
14483 exception at the top level of parsing which covers all the compilation
14484 errors that occurred.  In the error message, the callee is referred to
14485 by the name defined by the C<namegv> parameter.
14486
14487 =cut
14488 */
14489
14490 OP *
14491 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14492 {
14493     STRLEN proto_len;
14494     const char *proto, *proto_end;
14495     OP *aop, *prev, *cvop, *parent;
14496     int optional = 0;
14497     I32 arg = 0;
14498     I32 contextclass = 0;
14499     const char *e = NULL;
14500     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14501     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14502         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14503                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
14504     if (SvTYPE(protosv) == SVt_PVCV)
14505          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14506     else proto = SvPV(protosv, proto_len);
14507     proto = S_strip_spaces(aTHX_ proto, &proto_len);
14508     proto_end = proto + proto_len;
14509     parent = entersubop;
14510     aop = cUNOPx(entersubop)->op_first;
14511     if (!OpHAS_SIBLING(aop)) {
14512         parent = aop;
14513         aop = cUNOPx(aop)->op_first;
14514     }
14515     prev = aop;
14516     aop = OpSIBLING(aop);
14517     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14518     while (aop != cvop) {
14519         OP* o3 = aop;
14520
14521         if (proto >= proto_end)
14522         {
14523             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14524             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14525                                         SVfARG(namesv)), SvUTF8(namesv));
14526             return entersubop;
14527         }
14528
14529         switch (*proto) {
14530             case ';':
14531                 optional = 1;
14532                 proto++;
14533                 continue;
14534             case '_':
14535                 /* _ must be at the end */
14536                 if (proto[1] && !memCHRs(";@%", proto[1]))
14537                     goto oops;
14538                 /* FALLTHROUGH */
14539             case '$':
14540                 proto++;
14541                 arg++;
14542                 scalar(aop);
14543                 break;
14544             case '%':
14545             case '@':
14546                 list(aop);
14547                 arg++;
14548                 break;
14549             case '&':
14550                 proto++;
14551                 arg++;
14552                 if (    o3->op_type != OP_UNDEF
14553                     && (o3->op_type != OP_SREFGEN
14554                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14555                                 != OP_ANONCODE
14556                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14557                                 != OP_RV2CV)))
14558                     bad_type_gv(arg, namegv, o3,
14559                             arg == 1 ? "block or sub {}" : "sub {}");
14560                 break;
14561             case '*':
14562                 /* '*' allows any scalar type, including bareword */
14563                 proto++;
14564                 arg++;
14565                 if (o3->op_type == OP_RV2GV)
14566                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
14567                 else if (o3->op_type == OP_CONST)
14568                     o3->op_private &= ~OPpCONST_STRICT;
14569                 scalar(aop);
14570                 break;
14571             case '+':
14572                 proto++;
14573                 arg++;
14574                 if (o3->op_type == OP_RV2AV ||
14575                     o3->op_type == OP_PADAV ||
14576                     o3->op_type == OP_RV2HV ||
14577                     o3->op_type == OP_PADHV
14578                 ) {
14579                     goto wrapref;
14580                 }
14581                 scalar(aop);
14582                 break;
14583             case '[': case ']':
14584                 goto oops;
14585
14586             case '\\':
14587                 proto++;
14588                 arg++;
14589             again:
14590                 switch (*proto++) {
14591                     case '[':
14592                         if (contextclass++ == 0) {
14593                             e = (char *) memchr(proto, ']', proto_end - proto);
14594                             if (!e || e == proto)
14595                                 goto oops;
14596                         }
14597                         else
14598                             goto oops;
14599                         goto again;
14600
14601                     case ']':
14602                         if (contextclass) {
14603                             const char *p = proto;
14604                             const char *const end = proto;
14605                             contextclass = 0;
14606                             while (*--p != '[')
14607                                 /* \[$] accepts any scalar lvalue */
14608                                 if (*p == '$'
14609                                  && Perl_op_lvalue_flags(aTHX_
14610                                      scalar(o3),
14611                                      OP_READ, /* not entersub */
14612                                      OP_LVALUE_NO_CROAK
14613                                     )) goto wrapref;
14614                             bad_type_gv(arg, namegv, o3,
14615                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14616                         } else
14617                             goto oops;
14618                         break;
14619                     case '*':
14620                         if (o3->op_type == OP_RV2GV)
14621                             goto wrapref;
14622                         if (!contextclass)
14623                             bad_type_gv(arg, namegv, o3, "symbol");
14624                         break;
14625                     case '&':
14626                         if (o3->op_type == OP_ENTERSUB
14627                          && !(o3->op_flags & OPf_STACKED))
14628                             goto wrapref;
14629                         if (!contextclass)
14630                             bad_type_gv(arg, namegv, o3, "subroutine");
14631                         break;
14632                     case '$':
14633                         if (o3->op_type == OP_RV2SV ||
14634                                 o3->op_type == OP_PADSV ||
14635                                 o3->op_type == OP_HELEM ||
14636                                 o3->op_type == OP_AELEM)
14637                             goto wrapref;
14638                         if (!contextclass) {
14639                             /* \$ accepts any scalar lvalue */
14640                             if (Perl_op_lvalue_flags(aTHX_
14641                                     scalar(o3),
14642                                     OP_READ,  /* not entersub */
14643                                     OP_LVALUE_NO_CROAK
14644                                )) goto wrapref;
14645                             bad_type_gv(arg, namegv, o3, "scalar");
14646                         }
14647                         break;
14648                     case '@':
14649                         if (o3->op_type == OP_RV2AV ||
14650                                 o3->op_type == OP_PADAV)
14651                         {
14652                             o3->op_flags &=~ OPf_PARENS;
14653                             goto wrapref;
14654                         }
14655                         if (!contextclass)
14656                             bad_type_gv(arg, namegv, o3, "array");
14657                         break;
14658                     case '%':
14659                         if (o3->op_type == OP_RV2HV ||
14660                                 o3->op_type == OP_PADHV)
14661                         {
14662                             o3->op_flags &=~ OPf_PARENS;
14663                             goto wrapref;
14664                         }
14665                         if (!contextclass)
14666                             bad_type_gv(arg, namegv, o3, "hash");
14667                         break;
14668                     wrapref:
14669                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14670                                                 OP_REFGEN, 0);
14671                         if (contextclass && e) {
14672                             proto = e + 1;
14673                             contextclass = 0;
14674                         }
14675                         break;
14676                     default: goto oops;
14677                 }
14678                 if (contextclass)
14679                     goto again;
14680                 break;
14681             case ' ':
14682                 proto++;
14683                 continue;
14684             default:
14685             oops: {
14686                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14687                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
14688                                   SVfARG(protosv));
14689             }
14690         }
14691
14692         op_lvalue(aop, OP_ENTERSUB);
14693         prev = aop;
14694         aop = OpSIBLING(aop);
14695     }
14696     if (aop == cvop && *proto == '_') {
14697         /* generate an access to $_ */
14698         op_sibling_splice(parent, prev, 0, newDEFSVOP());
14699     }
14700     if (!optional && proto_end > proto &&
14701         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14702     {
14703         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14704         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14705                                     SVfARG(namesv)), SvUTF8(namesv));
14706     }
14707     return entersubop;
14708 }
14709
14710 /*
14711 =for apidoc ck_entersub_args_proto_or_list
14712
14713 Performs the fixup of the arguments part of an C<entersub> op tree either
14714 based on a subroutine prototype or using default list-context processing.
14715 This is the standard treatment used on a subroutine call, not marked
14716 with C<&>, where the callee can be identified at compile time.
14717
14718 C<protosv> supplies the subroutine prototype to be applied to the call,
14719 or indicates that there is no prototype.  It may be a normal scalar,
14720 in which case if it is defined then the string value will be used
14721 as a prototype, and if it is undefined then there is no prototype.
14722 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14723 that has been cast to C<SV*>), of which the prototype will be used if it
14724 has one.  The prototype (or lack thereof) supplied, in whichever form,
14725 does not need to match the actual callee referenced by the op tree.
14726
14727 If the argument ops disagree with the prototype, for example by having
14728 an unacceptable number of arguments, a valid op tree is returned anyway.
14729 The error is reflected in the parser state, normally resulting in a single
14730 exception at the top level of parsing which covers all the compilation
14731 errors that occurred.  In the error message, the callee is referred to
14732 by the name defined by the C<namegv> parameter.
14733
14734 =cut
14735 */
14736
14737 OP *
14738 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14739         GV *namegv, SV *protosv)
14740 {
14741     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14742     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14743         return ck_entersub_args_proto(entersubop, namegv, protosv);
14744     else
14745         return ck_entersub_args_list(entersubop);
14746 }
14747
14748 OP *
14749 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14750 {
14751     IV cvflags = SvIVX(protosv);
14752     int opnum = cvflags & 0xffff;
14753     OP *aop = cUNOPx(entersubop)->op_first;
14754
14755     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14756
14757     if (!opnum) {
14758         OP *cvop;
14759         if (!OpHAS_SIBLING(aop))
14760             aop = cUNOPx(aop)->op_first;
14761         aop = OpSIBLING(aop);
14762         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14763         if (aop != cvop) {
14764             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14765             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14766                 SVfARG(namesv)), SvUTF8(namesv));
14767         }
14768
14769         op_free(entersubop);
14770         switch(cvflags >> 16) {
14771         case 'F': return newSVOP(OP_CONST, 0,
14772                                         newSVpv(CopFILE(PL_curcop),0));
14773         case 'L': return newSVOP(
14774                            OP_CONST, 0,
14775                            Perl_newSVpvf(aTHX_
14776                              "%" IVdf, (IV)CopLINE(PL_curcop)
14777                            )
14778                          );
14779         case 'P': return newSVOP(OP_CONST, 0,
14780                                    (PL_curstash
14781                                      ? newSVhek(HvNAME_HEK(PL_curstash))
14782                                      : &PL_sv_undef
14783                                    )
14784                                 );
14785         }
14786         NOT_REACHED; /* NOTREACHED */
14787     }
14788     else {
14789         OP *prev, *cvop, *first, *parent;
14790         U32 flags = 0;
14791
14792         parent = entersubop;
14793         if (!OpHAS_SIBLING(aop)) {
14794             parent = aop;
14795             aop = cUNOPx(aop)->op_first;
14796         }
14797
14798         first = prev = aop;
14799         aop = OpSIBLING(aop);
14800         /* find last sibling */
14801         for (cvop = aop;
14802              OpHAS_SIBLING(cvop);
14803              prev = cvop, cvop = OpSIBLING(cvop))
14804             ;
14805         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14806             /* Usually, OPf_SPECIAL on an op with no args means that it had
14807              * parens, but these have their own meaning for that flag: */
14808             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14809             && opnum != OP_DELETE && opnum != OP_EXISTS)
14810                 flags |= OPf_SPECIAL;
14811         /* excise cvop from end of sibling chain */
14812         op_sibling_splice(parent, prev, 1, NULL);
14813         op_free(cvop);
14814         if (aop == cvop) aop = NULL;
14815
14816         /* detach remaining siblings from the first sibling, then
14817          * dispose of original optree */
14818
14819         if (aop)
14820             op_sibling_splice(parent, first, -1, NULL);
14821         op_free(entersubop);
14822
14823         if (cvflags == (OP_ENTEREVAL | (1<<16)))
14824             flags |= OPpEVAL_BYTES <<8;
14825
14826         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14827         case OA_UNOP:
14828         case OA_BASEOP_OR_UNOP:
14829         case OA_FILESTATOP:
14830             if (!aop)
14831                 return newOP(opnum,flags);       /* zero args */
14832             if (aop == prev)
14833                 return newUNOP(opnum,flags,aop); /* one arg */
14834             /* too many args */
14835             /* FALLTHROUGH */
14836         case OA_BASEOP:
14837             if (aop) {
14838                 SV *namesv;
14839                 OP *nextop;
14840
14841                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14842                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14843                     SVfARG(namesv)), SvUTF8(namesv));
14844                 while (aop) {
14845                     nextop = OpSIBLING(aop);
14846                     op_free(aop);
14847                     aop = nextop;
14848                 }
14849
14850             }
14851             return opnum == OP_RUNCV
14852                 ? newPVOP(OP_RUNCV,0,NULL)
14853                 : newOP(opnum,0);
14854         default:
14855             return op_convert_list(opnum,0,aop);
14856         }
14857     }
14858     NOT_REACHED; /* NOTREACHED */
14859     return entersubop;
14860 }
14861
14862 /*
14863 =for apidoc cv_get_call_checker_flags
14864
14865 Retrieves the function that will be used to fix up a call to C<cv>.
14866 Specifically, the function is applied to an C<entersub> op tree for a
14867 subroutine call, not marked with C<&>, where the callee can be identified
14868 at compile time as C<cv>.
14869
14870 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14871 for it is returned in C<*ckobj_p>, and control flags are returned in
14872 C<*ckflags_p>.  The function is intended to be called in this manner:
14873
14874  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14875
14876 In this call, C<entersubop> is a pointer to the C<entersub> op,
14877 which may be replaced by the check function, and C<namegv> supplies
14878 the name that should be used by the check function to refer
14879 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14880 It is permitted to apply the check function in non-standard situations,
14881 such as to a call to a different subroutine or to a method call.
14882
14883 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
14884 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14885 instead, anything that can be used as the first argument to L</cv_name>.
14886 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14887 check function requires C<namegv> to be a genuine GV.
14888
14889 By default, the check function is
14890 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14891 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14892 flag is clear.  This implements standard prototype processing.  It can
14893 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14894
14895 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14896 indicates that the caller only knows about the genuine GV version of
14897 C<namegv>, and accordingly the corresponding bit will always be set in
14898 C<*ckflags_p>, regardless of the check function's recorded requirements.
14899 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14900 indicates the caller knows about the possibility of passing something
14901 other than a GV as C<namegv>, and accordingly the corresponding bit may
14902 be either set or clear in C<*ckflags_p>, indicating the check function's
14903 recorded requirements.
14904
14905 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14906 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14907 (for which see above).  All other bits should be clear.
14908
14909 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14910
14911 =for apidoc cv_get_call_checker
14912
14913 The original form of L</cv_get_call_checker_flags>, which does not return
14914 checker flags.  When using a checker function returned by this function,
14915 it is only safe to call it with a genuine GV as its C<namegv> argument.
14916
14917 =cut
14918 */
14919
14920 void
14921 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14922         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14923 {
14924     MAGIC *callmg;
14925     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14926     PERL_UNUSED_CONTEXT;
14927     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14928     if (callmg) {
14929         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14930         *ckobj_p = callmg->mg_obj;
14931         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14932     } else {
14933         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14934         *ckobj_p = (SV*)cv;
14935         *ckflags_p = gflags & MGf_REQUIRE_GV;
14936     }
14937 }
14938
14939 void
14940 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14941 {
14942     U32 ckflags;
14943     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14944     PERL_UNUSED_CONTEXT;
14945     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14946         &ckflags);
14947 }
14948
14949 /*
14950 =for apidoc cv_set_call_checker_flags
14951
14952 Sets the function that will be used to fix up a call to C<cv>.
14953 Specifically, the function is applied to an C<entersub> op tree for a
14954 subroutine call, not marked with C<&>, where the callee can be identified
14955 at compile time as C<cv>.
14956
14957 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14958 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14959 The function should be defined like this:
14960
14961     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14962
14963 It is intended to be called in this manner:
14964
14965     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14966
14967 In this call, C<entersubop> is a pointer to the C<entersub> op,
14968 which may be replaced by the check function, and C<namegv> supplies
14969 the name that should be used by the check function to refer
14970 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14971 It is permitted to apply the check function in non-standard situations,
14972 such as to a call to a different subroutine or to a method call.
14973
14974 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14975 CV or other SV instead.  Whatever is passed can be used as the first
14976 argument to L</cv_name>.  You can force perl to pass a GV by including
14977 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14978
14979 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14980 bit currently has a defined meaning (for which see above).  All other
14981 bits should be clear.
14982
14983 The current setting for a particular CV can be retrieved by
14984 L</cv_get_call_checker_flags>.
14985
14986 =for apidoc cv_set_call_checker
14987
14988 The original form of L</cv_set_call_checker_flags>, which passes it the
14989 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
14990 of that flag setting is that the check function is guaranteed to get a
14991 genuine GV as its C<namegv> argument.
14992
14993 =cut
14994 */
14995
14996 void
14997 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14998 {
14999     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15000     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15001 }
15002
15003 void
15004 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15005                                      SV *ckobj, U32 ckflags)
15006 {
15007     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15008     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15009         if (SvMAGICAL((SV*)cv))
15010             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15011     } else {
15012         MAGIC *callmg;
15013         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15014         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15015         assert(callmg);
15016         if (callmg->mg_flags & MGf_REFCOUNTED) {
15017             SvREFCNT_dec(callmg->mg_obj);
15018             callmg->mg_flags &= ~MGf_REFCOUNTED;
15019         }
15020         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15021         callmg->mg_obj = ckobj;
15022         if (ckobj != (SV*)cv) {
15023             SvREFCNT_inc_simple_void_NN(ckobj);
15024             callmg->mg_flags |= MGf_REFCOUNTED;
15025         }
15026         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15027                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15028     }
15029 }
15030
15031 static void
15032 S_entersub_alloc_targ(pTHX_ OP * const o)
15033 {
15034     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15035     o->op_private |= OPpENTERSUB_HASTARG;
15036 }
15037
15038 OP *
15039 Perl_ck_subr(pTHX_ OP *o)
15040 {
15041     OP *aop, *cvop;
15042     CV *cv;
15043     GV *namegv;
15044     SV **const_class = NULL;
15045
15046     PERL_ARGS_ASSERT_CK_SUBR;
15047
15048     aop = cUNOPx(o)->op_first;
15049     if (!OpHAS_SIBLING(aop))
15050         aop = cUNOPx(aop)->op_first;
15051     aop = OpSIBLING(aop);
15052     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15053     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15054     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15055
15056     o->op_private &= ~1;
15057     o->op_private |= (PL_hints & HINT_STRICT_REFS);
15058     if (PERLDB_SUB && PL_curstash != PL_debstash)
15059         o->op_private |= OPpENTERSUB_DB;
15060     switch (cvop->op_type) {
15061         case OP_RV2CV:
15062             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15063             op_null(cvop);
15064             break;
15065         case OP_METHOD:
15066         case OP_METHOD_NAMED:
15067         case OP_METHOD_SUPER:
15068         case OP_METHOD_REDIR:
15069         case OP_METHOD_REDIR_SUPER:
15070             o->op_flags |= OPf_REF;
15071             if (aop->op_type == OP_CONST) {
15072                 aop->op_private &= ~OPpCONST_STRICT;
15073                 const_class = &cSVOPx(aop)->op_sv;
15074             }
15075             else if (aop->op_type == OP_LIST) {
15076                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15077                 if (sib && sib->op_type == OP_CONST) {
15078                     sib->op_private &= ~OPpCONST_STRICT;
15079                     const_class = &cSVOPx(sib)->op_sv;
15080                 }
15081             }
15082             /* make class name a shared cow string to speedup method calls */
15083             /* constant string might be replaced with object, f.e. bigint */
15084             if (const_class && SvPOK(*const_class)) {
15085                 STRLEN len;
15086                 const char* str = SvPV(*const_class, len);
15087                 if (len) {
15088                     SV* const shared = newSVpvn_share(
15089                         str, SvUTF8(*const_class)
15090                                     ? -(SSize_t)len : (SSize_t)len,
15091                         0
15092                     );
15093                     if (SvREADONLY(*const_class))
15094                         SvREADONLY_on(shared);
15095                     SvREFCNT_dec(*const_class);
15096                     *const_class = shared;
15097                 }
15098             }
15099             break;
15100     }
15101
15102     if (!cv) {
15103         S_entersub_alloc_targ(aTHX_ o);
15104         return ck_entersub_args_list(o);
15105     } else {
15106         Perl_call_checker ckfun;
15107         SV *ckobj;
15108         U32 ckflags;
15109         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15110         if (CvISXSUB(cv) || !CvROOT(cv))
15111             S_entersub_alloc_targ(aTHX_ o);
15112         if (!namegv) {
15113             /* The original call checker API guarantees that a GV will be
15114                be provided with the right name.  So, if the old API was
15115                used (or the REQUIRE_GV flag was passed), we have to reify
15116                the CV’s GV, unless this is an anonymous sub.  This is not
15117                ideal for lexical subs, as its stringification will include
15118                the package.  But it is the best we can do.  */
15119             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15120                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15121                     namegv = CvGV(cv);
15122             }
15123             else namegv = MUTABLE_GV(cv);
15124             /* After a syntax error in a lexical sub, the cv that
15125                rv2cv_op_cv returns may be a nameless stub. */
15126             if (!namegv) return ck_entersub_args_list(o);
15127
15128         }
15129         return ckfun(aTHX_ o, namegv, ckobj);
15130     }
15131 }
15132
15133 OP *
15134 Perl_ck_svconst(pTHX_ OP *o)
15135 {
15136     SV * const sv = cSVOPo->op_sv;
15137     PERL_ARGS_ASSERT_CK_SVCONST;
15138     PERL_UNUSED_CONTEXT;
15139 #ifdef PERL_COPY_ON_WRITE
15140     /* Since the read-only flag may be used to protect a string buffer, we
15141        cannot do copy-on-write with existing read-only scalars that are not
15142        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
15143        that constant, mark the constant as COWable here, if it is not
15144        already read-only. */
15145     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15146         SvIsCOW_on(sv);
15147         CowREFCNT(sv) = 0;
15148 # ifdef PERL_DEBUG_READONLY_COW
15149         sv_buf_to_ro(sv);
15150 # endif
15151     }
15152 #endif
15153     SvREADONLY_on(sv);
15154     return o;
15155 }
15156
15157 OP *
15158 Perl_ck_trunc(pTHX_ OP *o)
15159 {
15160     PERL_ARGS_ASSERT_CK_TRUNC;
15161
15162     if (o->op_flags & OPf_KIDS) {
15163         SVOP *kid = (SVOP*)cUNOPo->op_first;
15164
15165         if (kid->op_type == OP_NULL)
15166             kid = (SVOP*)OpSIBLING(kid);
15167         if (kid && kid->op_type == OP_CONST &&
15168             (kid->op_private & OPpCONST_BARE) &&
15169             !kid->op_folded)
15170         {
15171             o->op_flags |= OPf_SPECIAL;
15172             kid->op_private &= ~OPpCONST_STRICT;
15173         }
15174     }
15175     return ck_fun(o);
15176 }
15177
15178 OP *
15179 Perl_ck_substr(pTHX_ OP *o)
15180 {
15181     PERL_ARGS_ASSERT_CK_SUBSTR;
15182
15183     o = ck_fun(o);
15184     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15185         OP *kid = cLISTOPo->op_first;
15186
15187         if (kid->op_type == OP_NULL)
15188             kid = OpSIBLING(kid);
15189         if (kid)
15190             /* Historically, substr(delete $foo{bar},...) has been allowed
15191                with 4-arg substr.  Keep it working by applying entersub
15192                lvalue context.  */
15193             op_lvalue(kid, OP_ENTERSUB);
15194
15195     }
15196     return o;
15197 }
15198
15199 OP *
15200 Perl_ck_tell(pTHX_ OP *o)
15201 {
15202     PERL_ARGS_ASSERT_CK_TELL;
15203     o = ck_fun(o);
15204     if (o->op_flags & OPf_KIDS) {
15205      OP *kid = cLISTOPo->op_first;
15206      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15207      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15208     }
15209     return o;
15210 }
15211
15212 OP *
15213 Perl_ck_each(pTHX_ OP *o)
15214 {
15215     dVAR;
15216     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15217     const unsigned orig_type  = o->op_type;
15218
15219     PERL_ARGS_ASSERT_CK_EACH;
15220
15221     if (kid) {
15222         switch (kid->op_type) {
15223             case OP_PADHV:
15224             case OP_RV2HV:
15225                 break;
15226             case OP_PADAV:
15227             case OP_RV2AV:
15228                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15229                             : orig_type == OP_KEYS ? OP_AKEYS
15230                             :                        OP_AVALUES);
15231                 break;
15232             case OP_CONST:
15233                 if (kid->op_private == OPpCONST_BARE
15234                  || !SvROK(cSVOPx_sv(kid))
15235                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15236                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
15237                    )
15238                     goto bad;
15239                 /* FALLTHROUGH */
15240             default:
15241                 qerror(Perl_mess(aTHX_
15242                     "Experimental %s on scalar is now forbidden",
15243                      PL_op_desc[orig_type]));
15244                bad:
15245                 bad_type_pv(1, "hash or array", o, kid);
15246                 return o;
15247         }
15248     }
15249     return ck_fun(o);
15250 }
15251
15252 OP *
15253 Perl_ck_length(pTHX_ OP *o)
15254 {
15255     PERL_ARGS_ASSERT_CK_LENGTH;
15256
15257     o = ck_fun(o);
15258
15259     if (ckWARN(WARN_SYNTAX)) {
15260         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15261
15262         if (kid) {
15263             SV *name = NULL;
15264             const bool hash = kid->op_type == OP_PADHV
15265                            || kid->op_type == OP_RV2HV;
15266             switch (kid->op_type) {
15267                 case OP_PADHV:
15268                 case OP_PADAV:
15269                 case OP_RV2HV:
15270                 case OP_RV2AV:
15271                     name = S_op_varname(aTHX_ kid);
15272                     break;
15273                 default:
15274                     return o;
15275             }
15276             if (name)
15277                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15278                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15279                     ")\"?)",
15280                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
15281                 );
15282             else if (hash)
15283      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15284                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15285                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15286             else
15287      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15288                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15289                     "length() used on @array (did you mean \"scalar(@array)\"?)");
15290         }
15291     }
15292
15293     return o;
15294 }
15295
15296
15297 OP *
15298 Perl_ck_isa(pTHX_ OP *o)
15299 {
15300     OP *classop = cBINOPo->op_last;
15301
15302     PERL_ARGS_ASSERT_CK_ISA;
15303
15304     /* Convert barename into PV */
15305     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15306         /* TODO: Optionally convert package to raw HV here */
15307         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15308     }
15309
15310     return o;
15311 }
15312
15313
15314 /*
15315    ---------------------------------------------------------
15316
15317    Common vars in list assignment
15318
15319    There now follows some enums and static functions for detecting
15320    common variables in list assignments. Here is a little essay I wrote
15321    for myself when trying to get my head around this. DAPM.
15322
15323    ----
15324
15325    First some random observations:
15326
15327    * If a lexical var is an alias of something else, e.g.
15328        for my $x ($lex, $pkg, $a[0]) {...}
15329      then the act of aliasing will increase the reference count of the SV
15330
15331    * If a package var is an alias of something else, it may still have a
15332      reference count of 1, depending on how the alias was created, e.g.
15333      in *a = *b, $a may have a refcount of 1 since the GP is shared
15334      with a single GvSV pointer to the SV. So If it's an alias of another
15335      package var, then RC may be 1; if it's an alias of another scalar, e.g.
15336      a lexical var or an array element, then it will have RC > 1.
15337
15338    * There are many ways to create a package alias; ultimately, XS code
15339      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15340      run-time tracing mechanisms are unlikely to be able to catch all cases.
15341
15342    * When the LHS is all my declarations, the same vars can't appear directly
15343      on the RHS, but they can indirectly via closures, aliasing and lvalue
15344      subs. But those techniques all involve an increase in the lexical
15345      scalar's ref count.
15346
15347    * When the LHS is all lexical vars (but not necessarily my declarations),
15348      it is possible for the same lexicals to appear directly on the RHS, and
15349      without an increased ref count, since the stack isn't refcounted.
15350      This case can be detected at compile time by scanning for common lex
15351      vars with PL_generation.
15352
15353    * lvalue subs defeat common var detection, but they do at least
15354      return vars with a temporary ref count increment. Also, you can't
15355      tell at compile time whether a sub call is lvalue.
15356
15357
15358    So...
15359
15360    A: There are a few circumstances where there definitely can't be any
15361      commonality:
15362
15363        LHS empty:  () = (...);
15364        RHS empty:  (....) = ();
15365        RHS contains only constants or other 'can't possibly be shared'
15366            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
15367            i.e. they only contain ops not marked as dangerous, whose children
15368            are also not dangerous;
15369        LHS ditto;
15370        LHS contains a single scalar element: e.g. ($x) = (....); because
15371            after $x has been modified, it won't be used again on the RHS;
15372        RHS contains a single element with no aggregate on LHS: e.g.
15373            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
15374            won't be used again.
15375
15376    B: If LHS are all 'my' lexical var declarations (or safe ops, which
15377      we can ignore):
15378
15379        my ($a, $b, @c) = ...;
15380
15381        Due to closure and goto tricks, these vars may already have content.
15382        For the same reason, an element on the RHS may be a lexical or package
15383        alias of one of the vars on the left, or share common elements, for
15384        example:
15385
15386            my ($x,$y) = f(); # $x and $y on both sides
15387            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15388
15389        and
15390
15391            my $ra = f();
15392            my @a = @$ra;  # elements of @a on both sides
15393            sub f { @a = 1..4; \@a }
15394
15395
15396        First, just consider scalar vars on LHS:
15397
15398            RHS is safe only if (A), or in addition,
15399                * contains only lexical *scalar* vars, where neither side's
15400                  lexicals have been flagged as aliases
15401
15402            If RHS is not safe, then it's always legal to check LHS vars for
15403            RC==1, since the only RHS aliases will always be associated
15404            with an RC bump.
15405
15406            Note that in particular, RHS is not safe if:
15407
15408                * it contains package scalar vars; e.g.:
15409
15410                    f();
15411                    my ($x, $y) = (2, $x_alias);
15412                    sub f { $x = 1; *x_alias = \$x; }
15413
15414                * It contains other general elements, such as flattened or
15415                * spliced or single array or hash elements, e.g.
15416
15417                    f();
15418                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15419
15420                    sub f {
15421                        ($x, $y) = (1,2);
15422                        use feature 'refaliasing';
15423                        \($a[0], $a[1]) = \($y,$x);
15424                    }
15425
15426                  It doesn't matter if the array/hash is lexical or package.
15427
15428                * it contains a function call that happens to be an lvalue
15429                  sub which returns one or more of the above, e.g.
15430
15431                    f();
15432                    my ($x,$y) = f();
15433
15434                    sub f : lvalue {
15435                        ($x, $y) = (1,2);
15436                        *x1 = \$x;
15437                        $y, $x1;
15438                    }
15439
15440                    (so a sub call on the RHS should be treated the same
15441                    as having a package var on the RHS).
15442
15443                * any other "dangerous" thing, such an op or built-in that
15444                  returns one of the above, e.g. pp_preinc
15445
15446
15447            If RHS is not safe, what we can do however is at compile time flag
15448            that the LHS are all my declarations, and at run time check whether
15449            all the LHS have RC == 1, and if so skip the full scan.
15450
15451        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15452
15453            Here the issue is whether there can be elements of @a on the RHS
15454            which will get prematurely freed when @a is cleared prior to
15455            assignment. This is only a problem if the aliasing mechanism
15456            is one which doesn't increase the refcount - only if RC == 1
15457            will the RHS element be prematurely freed.
15458
15459            Because the array/hash is being INTROed, it or its elements
15460            can't directly appear on the RHS:
15461
15462                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15463
15464            but can indirectly, e.g.:
15465
15466                my $r = f();
15467                my (@a) = @$r;
15468                sub f { @a = 1..3; \@a }
15469
15470            So if the RHS isn't safe as defined by (A), we must always
15471            mortalise and bump the ref count of any remaining RHS elements
15472            when assigning to a non-empty LHS aggregate.
15473
15474            Lexical scalars on the RHS aren't safe if they've been involved in
15475            aliasing, e.g.
15476
15477                use feature 'refaliasing';
15478
15479                f();
15480                \(my $lex) = \$pkg;
15481                my @a = ($lex,3); # equivalent to ($a[0],3)
15482
15483                sub f {
15484                    @a = (1,2);
15485                    \$pkg = \$a[0];
15486                }
15487
15488            Similarly with lexical arrays and hashes on the RHS:
15489
15490                f();
15491                my @b;
15492                my @a = (@b);
15493
15494                sub f {
15495                    @a = (1,2);
15496                    \$b[0] = \$a[1];
15497                    \$b[1] = \$a[0];
15498                }
15499
15500
15501
15502    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15503        my $a; ($a, my $b) = (....);
15504
15505        The difference between (B) and (C) is that it is now physically
15506        possible for the LHS vars to appear on the RHS too, where they
15507        are not reference counted; but in this case, the compile-time
15508        PL_generation sweep will detect such common vars.
15509
15510        So the rules for (C) differ from (B) in that if common vars are
15511        detected, the runtime "test RC==1" optimisation can no longer be used,
15512        and a full mark and sweep is required
15513
15514    D: As (C), but in addition the LHS may contain package vars.
15515
15516        Since package vars can be aliased without a corresponding refcount
15517        increase, all bets are off. It's only safe if (A). E.g.
15518
15519            my ($x, $y) = (1,2);
15520
15521            for $x_alias ($x) {
15522                ($x_alias, $y) = (3, $x); # whoops
15523            }
15524
15525        Ditto for LHS aggregate package vars.
15526
15527    E: Any other dangerous ops on LHS, e.g.
15528            (f(), $a[0], @$r) = (...);
15529
15530        this is similar to (E) in that all bets are off. In addition, it's
15531        impossible to determine at compile time whether the LHS
15532        contains a scalar or an aggregate, e.g.
15533
15534            sub f : lvalue { @a }
15535            (f()) = 1..3;
15536
15537 * ---------------------------------------------------------
15538 */
15539
15540
15541 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15542  * that at least one of the things flagged was seen.
15543  */
15544
15545 enum {
15546     AAS_MY_SCALAR       = 0x001, /* my $scalar */
15547     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
15548     AAS_LEX_SCALAR      = 0x004, /* $lexical */
15549     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
15550     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15551     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
15552     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
15553     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
15554                                          that's flagged OA_DANGEROUS */
15555     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
15556                                         not in any of the categories above */
15557     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
15558 };
15559
15560
15561
15562 /* helper function for S_aassign_scan().
15563  * check a PAD-related op for commonality and/or set its generation number.
15564  * Returns a boolean indicating whether its shared */
15565
15566 static bool
15567 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15568 {
15569     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15570         /* lexical used in aliasing */
15571         return TRUE;
15572
15573     if (rhs)
15574         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15575     else
15576         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15577
15578     return FALSE;
15579 }
15580
15581
15582 /*
15583   Helper function for OPpASSIGN_COMMON* detection in rpeep().
15584   It scans the left or right hand subtree of the aassign op, and returns a
15585   set of flags indicating what sorts of things it found there.
15586   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15587   set PL_generation on lexical vars; if the latter, we see if
15588   PL_generation matches.
15589   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15590   This fn will increment it by the number seen. It's not intended to
15591   be an accurate count (especially as many ops can push a variable
15592   number of SVs onto the stack); rather it's used as to test whether there
15593   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15594 */
15595
15596 static int
15597 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15598 {
15599     OP *top_op           = o;
15600     OP *effective_top_op = o;
15601     int all_flags = 0;
15602
15603     while (1) {
15604     bool top = o == effective_top_op;
15605     int flags = 0;
15606     OP* next_kid = NULL;
15607
15608     /* first, look for a solitary @_ on the RHS */
15609     if (   rhs
15610         && top
15611         && (o->op_flags & OPf_KIDS)
15612         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15613     ) {
15614         OP *kid = cUNOPo->op_first;
15615         if (   (   kid->op_type == OP_PUSHMARK
15616                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15617             && ((kid = OpSIBLING(kid)))
15618             && !OpHAS_SIBLING(kid)
15619             && kid->op_type == OP_RV2AV
15620             && !(kid->op_flags & OPf_REF)
15621             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15622             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15623             && ((kid = cUNOPx(kid)->op_first))
15624             && kid->op_type == OP_GV
15625             && cGVOPx_gv(kid) == PL_defgv
15626         )
15627             flags = AAS_DEFAV;
15628     }
15629
15630     switch (o->op_type) {
15631     case OP_GVSV:
15632         (*scalars_p)++;
15633         all_flags |= AAS_PKG_SCALAR;
15634         goto do_next;
15635
15636     case OP_PADAV:
15637     case OP_PADHV:
15638         (*scalars_p) += 2;
15639         /* if !top, could be e.g. @a[0,1] */
15640         all_flags |=  (top && (o->op_flags & OPf_REF))
15641                         ? ((o->op_private & OPpLVAL_INTRO)
15642                             ? AAS_MY_AGG : AAS_LEX_AGG)
15643                         : AAS_DANGEROUS;
15644         goto do_next;
15645
15646     case OP_PADSV:
15647         {
15648             int comm = S_aassign_padcheck(aTHX_ o, rhs)
15649                         ?  AAS_LEX_SCALAR_COMM : 0;
15650             (*scalars_p)++;
15651             all_flags |= (o->op_private & OPpLVAL_INTRO)
15652                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15653             goto do_next;
15654
15655         }
15656
15657     case OP_RV2AV:
15658     case OP_RV2HV:
15659         (*scalars_p) += 2;
15660         if (cUNOPx(o)->op_first->op_type != OP_GV)
15661             all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15662         /* @pkg, %pkg */
15663         /* if !top, could be e.g. @a[0,1] */
15664         else if (top && (o->op_flags & OPf_REF))
15665             all_flags |= AAS_PKG_AGG;
15666         else
15667             all_flags |= AAS_DANGEROUS;
15668         goto do_next;
15669
15670     case OP_RV2SV:
15671         (*scalars_p)++;
15672         if (cUNOPx(o)->op_first->op_type != OP_GV) {
15673             (*scalars_p) += 2;
15674             all_flags |= AAS_DANGEROUS; /* ${expr} */
15675         }
15676         else
15677             all_flags |= AAS_PKG_SCALAR; /* $pkg */
15678         goto do_next;
15679
15680     case OP_SPLIT:
15681         if (o->op_private & OPpSPLIT_ASSIGN) {
15682             /* the assign in @a = split() has been optimised away
15683              * and the @a attached directly to the split op
15684              * Treat the array as appearing on the RHS, i.e.
15685              *    ... = (@a = split)
15686              * is treated like
15687              *    ... = @a;
15688              */
15689
15690             if (o->op_flags & OPf_STACKED) {
15691                 /* @{expr} = split() - the array expression is tacked
15692                  * on as an extra child to split - process kid */
15693                 next_kid = cLISTOPo->op_last;
15694                 goto do_next;
15695             }
15696
15697             /* ... else array is directly attached to split op */
15698             (*scalars_p) += 2;
15699             all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15700                             ? ((o->op_private & OPpLVAL_INTRO)
15701                                 ? AAS_MY_AGG : AAS_LEX_AGG)
15702                             : AAS_PKG_AGG;
15703             goto do_next;
15704         }
15705         (*scalars_p)++;
15706         /* other args of split can't be returned */
15707         all_flags |= AAS_SAFE_SCALAR;
15708         goto do_next;
15709
15710     case OP_UNDEF:
15711         /* undef counts as a scalar on the RHS:
15712          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
15713          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
15714          */
15715         if (rhs)
15716             (*scalars_p)++;
15717         flags = AAS_SAFE_SCALAR;
15718         break;
15719
15720     case OP_PUSHMARK:
15721     case OP_STUB:
15722         /* these are all no-ops; they don't push a potentially common SV
15723          * onto the stack, so they are neither AAS_DANGEROUS nor
15724          * AAS_SAFE_SCALAR */
15725         goto do_next;
15726
15727     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15728         break;
15729
15730     case OP_NULL:
15731     case OP_LIST:
15732         /* these do nothing, but may have children */
15733         break;
15734
15735     default:
15736         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15737             (*scalars_p) += 2;
15738             flags = AAS_DANGEROUS;
15739             break;
15740         }
15741
15742         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
15743             && (o->op_private & OPpTARGET_MY))
15744         {
15745             (*scalars_p)++;
15746             all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15747                             ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15748             goto do_next;
15749         }
15750
15751         /* if its an unrecognised, non-dangerous op, assume that it
15752          * it the cause of at least one safe scalar */
15753         (*scalars_p)++;
15754         flags = AAS_SAFE_SCALAR;
15755         break;
15756     }
15757
15758     all_flags |= flags;
15759
15760     /* by default, process all kids next
15761      * XXX this assumes that all other ops are "transparent" - i.e. that
15762      * they can return some of their children. While this true for e.g.
15763      * sort and grep, it's not true for e.g. map. We really need a
15764      * 'transparent' flag added to regen/opcodes
15765      */
15766     if (o->op_flags & OPf_KIDS) {
15767         next_kid = cUNOPo->op_first;
15768         /* these ops do nothing but may have children; but their
15769          * children should also be treated as top-level */
15770         if (   o == effective_top_op
15771             && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15772         )
15773             effective_top_op = next_kid;
15774     }
15775
15776
15777     /* If next_kid is set, someone in the code above wanted us to process
15778      * that kid and all its remaining siblings.  Otherwise, work our way
15779      * back up the tree */
15780   do_next:
15781     while (!next_kid) {
15782         if (o == top_op)
15783             return all_flags; /* at top; no parents/siblings to try */
15784         if (OpHAS_SIBLING(o)) {
15785             next_kid = o->op_sibparent;
15786             if (o == effective_top_op)
15787                 effective_top_op = next_kid;
15788         }
15789         else
15790             if (o == effective_top_op)
15791                 effective_top_op = o->op_sibparent;
15792             o = o->op_sibparent; /* try parent's next sibling */
15793
15794     }
15795     o = next_kid;
15796     } /* while */
15797
15798 }
15799
15800
15801 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15802    and modify the optree to make them work inplace */
15803
15804 STATIC void
15805 S_inplace_aassign(pTHX_ OP *o) {
15806
15807     OP *modop, *modop_pushmark;
15808     OP *oright;
15809     OP *oleft, *oleft_pushmark;
15810
15811     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15812
15813     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15814
15815     assert(cUNOPo->op_first->op_type == OP_NULL);
15816     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15817     assert(modop_pushmark->op_type == OP_PUSHMARK);
15818     modop = OpSIBLING(modop_pushmark);
15819
15820     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15821         return;
15822
15823     /* no other operation except sort/reverse */
15824     if (OpHAS_SIBLING(modop))
15825         return;
15826
15827     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15828     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15829
15830     if (modop->op_flags & OPf_STACKED) {
15831         /* skip sort subroutine/block */
15832         assert(oright->op_type == OP_NULL);
15833         oright = OpSIBLING(oright);
15834     }
15835
15836     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15837     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15838     assert(oleft_pushmark->op_type == OP_PUSHMARK);
15839     oleft = OpSIBLING(oleft_pushmark);
15840
15841     /* Check the lhs is an array */
15842     if (!oleft ||
15843         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15844         || OpHAS_SIBLING(oleft)
15845         || (oleft->op_private & OPpLVAL_INTRO)
15846     )
15847         return;
15848
15849     /* Only one thing on the rhs */
15850     if (OpHAS_SIBLING(oright))
15851         return;
15852
15853     /* check the array is the same on both sides */
15854     if (oleft->op_type == OP_RV2AV) {
15855         if (oright->op_type != OP_RV2AV
15856             || !cUNOPx(oright)->op_first
15857             || cUNOPx(oright)->op_first->op_type != OP_GV
15858             || cUNOPx(oleft )->op_first->op_type != OP_GV
15859             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15860                cGVOPx_gv(cUNOPx(oright)->op_first)
15861         )
15862             return;
15863     }
15864     else if (oright->op_type != OP_PADAV
15865         || oright->op_targ != oleft->op_targ
15866     )
15867         return;
15868
15869     /* This actually is an inplace assignment */
15870
15871     modop->op_private |= OPpSORT_INPLACE;
15872
15873     /* transfer MODishness etc from LHS arg to RHS arg */
15874     oright->op_flags = oleft->op_flags;
15875
15876     /* remove the aassign op and the lhs */
15877     op_null(o);
15878     op_null(oleft_pushmark);
15879     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15880         op_null(cUNOPx(oleft)->op_first);
15881     op_null(oleft);
15882 }
15883
15884
15885
15886 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15887  * that potentially represent a series of one or more aggregate derefs
15888  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15889  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15890  * additional ops left in too).
15891  *
15892  * The caller will have already verified that the first few ops in the
15893  * chain following 'start' indicate a multideref candidate, and will have
15894  * set 'orig_o' to the point further on in the chain where the first index
15895  * expression (if any) begins.  'orig_action' specifies what type of
15896  * beginning has already been determined by the ops between start..orig_o
15897  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
15898  *
15899  * 'hints' contains any hints flags that need adding (currently just
15900  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15901  */
15902
15903 STATIC void
15904 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15905 {
15906     dVAR;
15907     int pass;
15908     UNOP_AUX_item *arg_buf = NULL;
15909     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
15910     int index_skip         = -1;    /* don't output index arg on this action */
15911
15912     /* similar to regex compiling, do two passes; the first pass
15913      * determines whether the op chain is convertible and calculates the
15914      * buffer size; the second pass populates the buffer and makes any
15915      * changes necessary to ops (such as moving consts to the pad on
15916      * threaded builds).
15917      *
15918      * NB: for things like Coverity, note that both passes take the same
15919      * path through the logic tree (except for 'if (pass)' bits), since
15920      * both passes are following the same op_next chain; and in
15921      * particular, if it would return early on the second pass, it would
15922      * already have returned early on the first pass.
15923      */
15924     for (pass = 0; pass < 2; pass++) {
15925         OP *o                = orig_o;
15926         UV action            = orig_action;
15927         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
15928         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
15929         int action_count     = 0;     /* number of actions seen so far */
15930         int action_ix        = 0;     /* action_count % (actions per IV) */
15931         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
15932         bool is_last         = FALSE; /* no more derefs to follow */
15933         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15934         UV action_word       = 0;     /* all actions so far */
15935         UNOP_AUX_item *arg     = arg_buf;
15936         UNOP_AUX_item *action_ptr = arg_buf;
15937
15938         arg++; /* reserve slot for first action word */
15939
15940         switch (action) {
15941         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15942         case MDEREF_HV_gvhv_helem:
15943             next_is_hash = TRUE;
15944             /* FALLTHROUGH */
15945         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15946         case MDEREF_AV_gvav_aelem:
15947             if (pass) {
15948 #ifdef USE_ITHREADS
15949                 arg->pad_offset = cPADOPx(start)->op_padix;
15950                 /* stop it being swiped when nulled */
15951                 cPADOPx(start)->op_padix = 0;
15952 #else
15953                 arg->sv = cSVOPx(start)->op_sv;
15954                 cSVOPx(start)->op_sv = NULL;
15955 #endif
15956             }
15957             arg++;
15958             break;
15959
15960         case MDEREF_HV_padhv_helem:
15961         case MDEREF_HV_padsv_vivify_rv2hv_helem:
15962             next_is_hash = TRUE;
15963             /* FALLTHROUGH */
15964         case MDEREF_AV_padav_aelem:
15965         case MDEREF_AV_padsv_vivify_rv2av_aelem:
15966             if (pass) {
15967                 arg->pad_offset = start->op_targ;
15968                 /* we skip setting op_targ = 0 for now, since the intact
15969                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15970                 reset_start_targ = TRUE;
15971             }
15972             arg++;
15973             break;
15974
15975         case MDEREF_HV_pop_rv2hv_helem:
15976             next_is_hash = TRUE;
15977             /* FALLTHROUGH */
15978         case MDEREF_AV_pop_rv2av_aelem:
15979             break;
15980
15981         default:
15982             NOT_REACHED; /* NOTREACHED */
15983             return;
15984         }
15985
15986         while (!is_last) {
15987             /* look for another (rv2av/hv; get index;
15988              * aelem/helem/exists/delele) sequence */
15989
15990             OP *kid;
15991             bool is_deref;
15992             bool ok;
15993             UV index_type = MDEREF_INDEX_none;
15994
15995             if (action_count) {
15996                 /* if this is not the first lookup, consume the rv2av/hv  */
15997
15998                 /* for N levels of aggregate lookup, we normally expect
15999                  * that the first N-1 [ah]elem ops will be flagged as
16000                  * /DEREF (so they autovivifiy if necessary), and the last
16001                  * lookup op not to be.
16002                  * For other things (like @{$h{k1}{k2}}) extra scope or
16003                  * leave ops can appear, so abandon the effort in that
16004                  * case */
16005                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16006                     return;
16007
16008                 /* rv2av or rv2hv sKR/1 */
16009
16010                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16011                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16012                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16013                     return;
16014
16015                 /* at this point, we wouldn't expect any of these
16016                  * possible private flags:
16017                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16018                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16019                  */
16020                 ASSUME(!(o->op_private &
16021                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16022
16023                 hints = (o->op_private & OPpHINT_STRICT_REFS);
16024
16025                 /* make sure the type of the previous /DEREF matches the
16026                  * type of the next lookup */
16027                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16028                 top_op = o;
16029
16030                 action = next_is_hash
16031                             ? MDEREF_HV_vivify_rv2hv_helem
16032                             : MDEREF_AV_vivify_rv2av_aelem;
16033                 o = o->op_next;
16034             }
16035
16036             /* if this is the second pass, and we're at the depth where
16037              * previously we encountered a non-simple index expression,
16038              * stop processing the index at this point */
16039             if (action_count != index_skip) {
16040
16041                 /* look for one or more simple ops that return an array
16042                  * index or hash key */
16043
16044                 switch (o->op_type) {
16045                 case OP_PADSV:
16046                     /* it may be a lexical var index */
16047                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16048                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16049                     ASSUME(!(o->op_private &
16050                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16051
16052                     if (   OP_GIMME(o,0) == G_SCALAR
16053                         && !(o->op_flags & (OPf_REF|OPf_MOD))
16054                         && o->op_private == 0)
16055                     {
16056                         if (pass)
16057                             arg->pad_offset = o->op_targ;
16058                         arg++;
16059                         index_type = MDEREF_INDEX_padsv;
16060                         o = o->op_next;
16061                     }
16062                     break;
16063
16064                 case OP_CONST:
16065                     if (next_is_hash) {
16066                         /* it's a constant hash index */
16067                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16068                             /* "use constant foo => FOO; $h{+foo}" for
16069                              * some weird FOO, can leave you with constants
16070                              * that aren't simple strings. It's not worth
16071                              * the extra hassle for those edge cases */
16072                             break;
16073
16074                         {
16075                             UNOP *rop = NULL;
16076                             OP * helem_op = o->op_next;
16077
16078                             ASSUME(   helem_op->op_type == OP_HELEM
16079                                    || helem_op->op_type == OP_NULL
16080                                    || pass == 0);
16081                             if (helem_op->op_type == OP_HELEM) {
16082                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16083                                 if (   helem_op->op_private & OPpLVAL_INTRO
16084                                     || rop->op_type != OP_RV2HV
16085                                 )
16086                                     rop = NULL;
16087                             }
16088                             /* on first pass just check; on second pass
16089                              * hekify */
16090                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16091                                                             pass);
16092                         }
16093
16094                         if (pass) {
16095 #ifdef USE_ITHREADS
16096                             /* Relocate sv to the pad for thread safety */
16097                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16098                             arg->pad_offset = o->op_targ;
16099                             o->op_targ = 0;
16100 #else
16101                             arg->sv = cSVOPx_sv(o);
16102 #endif
16103                         }
16104                     }
16105                     else {
16106                         /* it's a constant array index */
16107                         IV iv;
16108                         SV *ix_sv = cSVOPo->op_sv;
16109                         if (!SvIOK(ix_sv))
16110                             break;
16111                         iv = SvIV(ix_sv);
16112
16113                         if (   action_count == 0
16114                             && iv >= -128
16115                             && iv <= 127
16116                             && (   action == MDEREF_AV_padav_aelem
16117                                 || action == MDEREF_AV_gvav_aelem)
16118                         )
16119                             maybe_aelemfast = TRUE;
16120
16121                         if (pass) {
16122                             arg->iv = iv;
16123                             SvREFCNT_dec_NN(cSVOPo->op_sv);
16124                         }
16125                     }
16126                     if (pass)
16127                         /* we've taken ownership of the SV */
16128                         cSVOPo->op_sv = NULL;
16129                     arg++;
16130                     index_type = MDEREF_INDEX_const;
16131                     o = o->op_next;
16132                     break;
16133
16134                 case OP_GV:
16135                     /* it may be a package var index */
16136
16137                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16138                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16139                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16140                         || o->op_private != 0
16141                     )
16142                         break;
16143
16144                     kid = o->op_next;
16145                     if (kid->op_type != OP_RV2SV)
16146                         break;
16147
16148                     ASSUME(!(kid->op_flags &
16149                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16150                              |OPf_SPECIAL|OPf_PARENS)));
16151                     ASSUME(!(kid->op_private &
16152                                     ~(OPpARG1_MASK
16153                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16154                                      |OPpDEREF|OPpLVAL_INTRO)));
16155                     if(   (kid->op_flags &~ OPf_PARENS)
16156                             != (OPf_WANT_SCALAR|OPf_KIDS)
16157                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16158                     )
16159                         break;
16160
16161                     if (pass) {
16162 #ifdef USE_ITHREADS
16163                         arg->pad_offset = cPADOPx(o)->op_padix;
16164                         /* stop it being swiped when nulled */
16165                         cPADOPx(o)->op_padix = 0;
16166 #else
16167                         arg->sv = cSVOPx(o)->op_sv;
16168                         cSVOPo->op_sv = NULL;
16169 #endif
16170                     }
16171                     arg++;
16172                     index_type = MDEREF_INDEX_gvsv;
16173                     o = kid->op_next;
16174                     break;
16175
16176                 } /* switch */
16177             } /* action_count != index_skip */
16178
16179             action |= index_type;
16180
16181
16182             /* at this point we have either:
16183              *   * detected what looks like a simple index expression,
16184              *     and expect the next op to be an [ah]elem, or
16185              *     an nulled  [ah]elem followed by a delete or exists;
16186              *  * found a more complex expression, so something other
16187              *    than the above follows.
16188              */
16189
16190             /* possibly an optimised away [ah]elem (where op_next is
16191              * exists or delete) */
16192             if (o->op_type == OP_NULL)
16193                 o = o->op_next;
16194
16195             /* at this point we're looking for an OP_AELEM, OP_HELEM,
16196              * OP_EXISTS or OP_DELETE */
16197
16198             /* if a custom array/hash access checker is in scope,
16199              * abandon optimisation attempt */
16200             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16201                && PL_check[o->op_type] != Perl_ck_null)
16202                 return;
16203             /* similarly for customised exists and delete */
16204             if (  (o->op_type == OP_EXISTS)
16205                && PL_check[o->op_type] != Perl_ck_exists)
16206                 return;
16207             if (  (o->op_type == OP_DELETE)
16208                && PL_check[o->op_type] != Perl_ck_delete)
16209                 return;
16210
16211             if (   o->op_type != OP_AELEM
16212                 || (o->op_private &
16213                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16214                 )
16215                 maybe_aelemfast = FALSE;
16216
16217             /* look for aelem/helem/exists/delete. If it's not the last elem
16218              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16219              * flags; if it's the last, then it mustn't have
16220              * OPpDEREF_AV/HV, but may have lots of other flags, like
16221              * OPpLVAL_INTRO etc
16222              */
16223
16224             if (   index_type == MDEREF_INDEX_none
16225                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
16226                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16227             )
16228                 ok = FALSE;
16229             else {
16230                 /* we have aelem/helem/exists/delete with valid simple index */
16231
16232                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16233                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
16234                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16235
16236                 /* This doesn't make much sense but is legal:
16237                  *    @{ local $x[0][0] } = 1
16238                  * Since scope exit will undo the autovivification,
16239                  * don't bother in the first place. The OP_LEAVE
16240                  * assertion is in case there are other cases of both
16241                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16242                  * exit that would undo the local - in which case this
16243                  * block of code would need rethinking.
16244                  */
16245                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16246 #ifdef DEBUGGING
16247                     OP *n = o->op_next;
16248                     while (n && (  n->op_type == OP_NULL
16249                                 || n->op_type == OP_LIST
16250                                 || n->op_type == OP_SCALAR))
16251                         n = n->op_next;
16252                     assert(n && n->op_type == OP_LEAVE);
16253 #endif
16254                     o->op_private &= ~OPpDEREF;
16255                     is_deref = FALSE;
16256                 }
16257
16258                 if (is_deref) {
16259                     ASSUME(!(o->op_flags &
16260                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16261                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16262
16263                     ok =    (o->op_flags &~ OPf_PARENS)
16264                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16265                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16266                 }
16267                 else if (o->op_type == OP_EXISTS) {
16268                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16269                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16270                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16271                     ok =  !(o->op_private & ~OPpARG1_MASK);
16272                 }
16273                 else if (o->op_type == OP_DELETE) {
16274                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16275                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16276                     ASSUME(!(o->op_private &
16277                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16278                     /* don't handle slices or 'local delete'; the latter
16279                      * is fairly rare, and has a complex runtime */
16280                     ok =  !(o->op_private & ~OPpARG1_MASK);
16281                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16282                         /* skip handling run-tome error */
16283                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16284                 }
16285                 else {
16286                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16287                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16288                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16289                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16290                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16291                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16292                 }
16293             }
16294
16295             if (ok) {
16296                 if (!first_elem_op)
16297                     first_elem_op = o;
16298                 top_op = o;
16299                 if (is_deref) {
16300                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16301                     o = o->op_next;
16302                 }
16303                 else {
16304                     is_last = TRUE;
16305                     action |= MDEREF_FLAG_last;
16306                 }
16307             }
16308             else {
16309                 /* at this point we have something that started
16310                  * promisingly enough (with rv2av or whatever), but failed
16311                  * to find a simple index followed by an
16312                  * aelem/helem/exists/delete. If this is the first action,
16313                  * give up; but if we've already seen at least one
16314                  * aelem/helem, then keep them and add a new action with
16315                  * MDEREF_INDEX_none, which causes it to do the vivify
16316                  * from the end of the previous lookup, and do the deref,
16317                  * but stop at that point. So $a[0][expr] will do one
16318                  * av_fetch, vivify and deref, then continue executing at
16319                  * expr */
16320                 if (!action_count)
16321                     return;
16322                 is_last = TRUE;
16323                 index_skip = action_count;
16324                 action |= MDEREF_FLAG_last;
16325                 if (index_type != MDEREF_INDEX_none)
16326                     arg--;
16327             }
16328
16329             action_word |= (action << (action_ix * MDEREF_SHIFT));
16330             action_ix++;
16331             action_count++;
16332             /* if there's no space for the next action, reserve a new slot
16333              * for it *before* we start adding args for that action */
16334             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16335                 if (pass)
16336                     action_ptr->uv = action_word;
16337                 action_word = 0;
16338                 action_ptr = arg;
16339                 arg++;
16340                 action_ix = 0;
16341             }
16342         } /* while !is_last */
16343
16344         /* success! */
16345
16346         if (!action_ix)
16347             /* slot reserved for next action word not now needed */
16348             arg--;
16349         else if (pass)
16350             action_ptr->uv = action_word;
16351
16352         if (pass) {
16353             OP *mderef;
16354             OP *p, *q;
16355
16356             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16357             if (index_skip == -1) {
16358                 mderef->op_flags = o->op_flags
16359                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16360                 if (o->op_type == OP_EXISTS)
16361                     mderef->op_private = OPpMULTIDEREF_EXISTS;
16362                 else if (o->op_type == OP_DELETE)
16363                     mderef->op_private = OPpMULTIDEREF_DELETE;
16364                 else
16365                     mderef->op_private = o->op_private
16366                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16367             }
16368             /* accumulate strictness from every level (although I don't think
16369              * they can actually vary) */
16370             mderef->op_private |= hints;
16371
16372             /* integrate the new multideref op into the optree and the
16373              * op_next chain.
16374              *
16375              * In general an op like aelem or helem has two child
16376              * sub-trees: the aggregate expression (a_expr) and the
16377              * index expression (i_expr):
16378              *
16379              *     aelem
16380              *       |
16381              *     a_expr - i_expr
16382              *
16383              * The a_expr returns an AV or HV, while the i-expr returns an
16384              * index. In general a multideref replaces most or all of a
16385              * multi-level tree, e.g.
16386              *
16387              *     exists
16388              *       |
16389              *     ex-aelem
16390              *       |
16391              *     rv2av  - i_expr1
16392              *       |
16393              *     helem
16394              *       |
16395              *     rv2hv  - i_expr2
16396              *       |
16397              *     aelem
16398              *       |
16399              *     a_expr - i_expr3
16400              *
16401              * With multideref, all the i_exprs will be simple vars or
16402              * constants, except that i_expr1 may be arbitrary in the case
16403              * of MDEREF_INDEX_none.
16404              *
16405              * The bottom-most a_expr will be either:
16406              *   1) a simple var (so padXv or gv+rv2Xv);
16407              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
16408              *      so a simple var with an extra rv2Xv;
16409              *   3) or an arbitrary expression.
16410              *
16411              * 'start', the first op in the execution chain, will point to
16412              *   1),2): the padXv or gv op;
16413              *   3):    the rv2Xv which forms the last op in the a_expr
16414              *          execution chain, and the top-most op in the a_expr
16415              *          subtree.
16416              *
16417              * For all cases, the 'start' node is no longer required,
16418              * but we can't free it since one or more external nodes
16419              * may point to it. E.g. consider
16420              *     $h{foo} = $a ? $b : $c
16421              * Here, both the op_next and op_other branches of the
16422              * cond_expr point to the gv[*h] of the hash expression, so
16423              * we can't free the 'start' op.
16424              *
16425              * For expr->[...], we need to save the subtree containing the
16426              * expression; for the other cases, we just need to save the
16427              * start node.
16428              * So in all cases, we null the start op and keep it around by
16429              * making it the child of the multideref op; for the expr->
16430              * case, the expr will be a subtree of the start node.
16431              *
16432              * So in the simple 1,2 case the  optree above changes to
16433              *
16434              *     ex-exists
16435              *       |
16436              *     multideref
16437              *       |
16438              *     ex-gv (or ex-padxv)
16439              *
16440              *  with the op_next chain being
16441              *
16442              *  -> ex-gv -> multideref -> op-following-ex-exists ->
16443              *
16444              *  In the 3 case, we have
16445              *
16446              *     ex-exists
16447              *       |
16448              *     multideref
16449              *       |
16450              *     ex-rv2xv
16451              *       |
16452              *    rest-of-a_expr
16453              *      subtree
16454              *
16455              *  and
16456              *
16457              *  -> rest-of-a_expr subtree ->
16458              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
16459              *
16460              *
16461              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16462              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16463              * multideref attached as the child, e.g.
16464              *
16465              *     exists
16466              *       |
16467              *     ex-aelem
16468              *       |
16469              *     ex-rv2av  - i_expr1
16470              *       |
16471              *     multideref
16472              *       |
16473              *     ex-whatever
16474              *
16475              */
16476
16477             /* if we free this op, don't free the pad entry */
16478             if (reset_start_targ)
16479                 start->op_targ = 0;
16480
16481
16482             /* Cut the bit we need to save out of the tree and attach to
16483              * the multideref op, then free the rest of the tree */
16484
16485             /* find parent of node to be detached (for use by splice) */
16486             p = first_elem_op;
16487             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
16488                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16489             {
16490                 /* there is an arbitrary expression preceding us, e.g.
16491                  * expr->[..]? so we need to save the 'expr' subtree */
16492                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16493                     p = cUNOPx(p)->op_first;
16494                 ASSUME(   start->op_type == OP_RV2AV
16495                        || start->op_type == OP_RV2HV);
16496             }
16497             else {
16498                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16499                  * above for exists/delete. */
16500                 while (   (p->op_flags & OPf_KIDS)
16501                        && cUNOPx(p)->op_first != start
16502                 )
16503                     p = cUNOPx(p)->op_first;
16504             }
16505             ASSUME(cUNOPx(p)->op_first == start);
16506
16507             /* detach from main tree, and re-attach under the multideref */
16508             op_sibling_splice(mderef, NULL, 0,
16509                     op_sibling_splice(p, NULL, 1, NULL));
16510             op_null(start);
16511
16512             start->op_next = mderef;
16513
16514             mderef->op_next = index_skip == -1 ? o->op_next : o;
16515
16516             /* excise and free the original tree, and replace with
16517              * the multideref op */
16518             p = op_sibling_splice(top_op, NULL, -1, mderef);
16519             while (p) {
16520                 q = OpSIBLING(p);
16521                 op_free(p);
16522                 p = q;
16523             }
16524             op_null(top_op);
16525         }
16526         else {
16527             Size_t size = arg - arg_buf;
16528
16529             if (maybe_aelemfast && action_count == 1)
16530                 return;
16531
16532             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16533                                 sizeof(UNOP_AUX_item) * (size + 1));
16534             /* for dumping etc: store the length in a hidden first slot;
16535              * we set the op_aux pointer to the second slot */
16536             arg_buf->uv = size;
16537             arg_buf++;
16538         }
16539     } /* for (pass = ...) */
16540 }
16541
16542 /* See if the ops following o are such that o will always be executed in
16543  * boolean context: that is, the SV which o pushes onto the stack will
16544  * only ever be consumed by later ops via SvTRUE(sv) or similar.
16545  * If so, set a suitable private flag on o. Normally this will be
16546  * bool_flag; but see below why maybe_flag is needed too.
16547  *
16548  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16549  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16550  * already be taken, so you'll have to give that op two different flags.
16551  *
16552  * More explanation of 'maybe_flag' and 'safe_and' parameters.
16553  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16554  * those underlying ops) short-circuit, which means that rather than
16555  * necessarily returning a truth value, they may return the LH argument,
16556  * which may not be boolean. For example in $x = (keys %h || -1), keys
16557  * should return a key count rather than a boolean, even though its
16558  * sort-of being used in boolean context.
16559  *
16560  * So we only consider such logical ops to provide boolean context to
16561  * their LH argument if they themselves are in void or boolean context.
16562  * However, sometimes the context isn't known until run-time. In this
16563  * case the op is marked with the maybe_flag flag it.
16564  *
16565  * Consider the following.
16566  *
16567  *     sub f { ....;  if (%h) { .... } }
16568  *
16569  * This is actually compiled as
16570  *
16571  *     sub f { ....;  %h && do { .... } }
16572  *
16573  * Here we won't know until runtime whether the final statement (and hence
16574  * the &&) is in void context and so is safe to return a boolean value.
16575  * So mark o with maybe_flag rather than the bool_flag.
16576  * Note that there is cost associated with determining context at runtime
16577  * (e.g. a call to block_gimme()), so it may not be worth setting (at
16578  * compile time) and testing (at runtime) maybe_flag if the scalar verses
16579  * boolean costs savings are marginal.
16580  *
16581  * However, we can do slightly better with && (compared to || and //):
16582  * this op only returns its LH argument when that argument is false. In
16583  * this case, as long as the op promises to return a false value which is
16584  * valid in both boolean and scalar contexts, we can mark an op consumed
16585  * by && with bool_flag rather than maybe_flag.
16586  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16587  * than &PL_sv_no for a false result in boolean context, then it's safe. An
16588  * op which promises to handle this case is indicated by setting safe_and
16589  * to true.
16590  */
16591
16592 static void
16593 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16594 {
16595     OP *lop;
16596     U8 flag = 0;
16597
16598     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16599
16600     /* OPpTARGET_MY and boolean context probably don't mix well.
16601      * If someone finds a valid use case, maybe add an extra flag to this
16602      * function which indicates its safe to do so for this op? */
16603     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
16604              && (o->op_private & OPpTARGET_MY)));
16605
16606     lop = o->op_next;
16607
16608     while (lop) {
16609         switch (lop->op_type) {
16610         case OP_NULL:
16611         case OP_SCALAR:
16612             break;
16613
16614         /* these two consume the stack argument in the scalar case,
16615          * and treat it as a boolean in the non linenumber case */
16616         case OP_FLIP:
16617         case OP_FLOP:
16618             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16619                 || (lop->op_private & OPpFLIP_LINENUM))
16620             {
16621                 lop = NULL;
16622                 break;
16623             }
16624             /* FALLTHROUGH */
16625         /* these never leave the original value on the stack */
16626         case OP_NOT:
16627         case OP_XOR:
16628         case OP_COND_EXPR:
16629         case OP_GREPWHILE:
16630             flag = bool_flag;
16631             lop = NULL;
16632             break;
16633
16634         /* OR DOR and AND evaluate their arg as a boolean, but then may
16635          * leave the original scalar value on the stack when following the
16636          * op_next route. If not in void context, we need to ensure
16637          * that whatever follows consumes the arg only in boolean context
16638          * too.
16639          */
16640         case OP_AND:
16641             if (safe_and) {
16642                 flag = bool_flag;
16643                 lop = NULL;
16644                 break;
16645             }
16646             /* FALLTHROUGH */
16647         case OP_OR:
16648         case OP_DOR:
16649             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16650                 flag = bool_flag;
16651                 lop = NULL;
16652             }
16653             else if (!(lop->op_flags & OPf_WANT)) {
16654                 /* unknown context - decide at runtime */
16655                 flag = maybe_flag;
16656                 lop = NULL;
16657             }
16658             break;
16659
16660         default:
16661             lop = NULL;
16662             break;
16663         }
16664
16665         if (lop)
16666             lop = lop->op_next;
16667     }
16668
16669     o->op_private |= flag;
16670 }
16671
16672
16673
16674 /* mechanism for deferring recursion in rpeep() */
16675
16676 #define MAX_DEFERRED 4
16677
16678 #define DEFER(o) \
16679   STMT_START { \
16680     if (defer_ix == (MAX_DEFERRED-1)) { \
16681         OP **defer = defer_queue[defer_base]; \
16682         CALL_RPEEP(*defer); \
16683         S_prune_chain_head(defer); \
16684         defer_base = (defer_base + 1) % MAX_DEFERRED; \
16685         defer_ix--; \
16686     } \
16687     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16688   } STMT_END
16689
16690 #define IS_AND_OP(o)   (o->op_type == OP_AND)
16691 #define IS_OR_OP(o)    (o->op_type == OP_OR)
16692
16693
16694 /* A peephole optimizer.  We visit the ops in the order they're to execute.
16695  * See the comments at the top of this file for more details about when
16696  * peep() is called */
16697
16698 void
16699 Perl_rpeep(pTHX_ OP *o)
16700 {
16701     dVAR;
16702     OP* oldop = NULL;
16703     OP* oldoldop = NULL;
16704     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16705     int defer_base = 0;
16706     int defer_ix = -1;
16707
16708     if (!o || o->op_opt)
16709         return;
16710
16711     assert(o->op_type != OP_FREED);
16712
16713     ENTER;
16714     SAVEOP();
16715     SAVEVPTR(PL_curcop);
16716     for (;; o = o->op_next) {
16717         if (o && o->op_opt)
16718             o = NULL;
16719         if (!o) {
16720             while (defer_ix >= 0) {
16721                 OP **defer =
16722                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16723                 CALL_RPEEP(*defer);
16724                 S_prune_chain_head(defer);
16725             }
16726             break;
16727         }
16728
16729       redo:
16730
16731         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16732         assert(!oldoldop || oldoldop->op_next == oldop);
16733         assert(!oldop    || oldop->op_next    == o);
16734
16735         /* By default, this op has now been optimised. A couple of cases below
16736            clear this again.  */
16737         o->op_opt = 1;
16738         PL_op = o;
16739
16740         /* look for a series of 1 or more aggregate derefs, e.g.
16741          *   $a[1]{foo}[$i]{$k}
16742          * and replace with a single OP_MULTIDEREF op.
16743          * Each index must be either a const, or a simple variable,
16744          *
16745          * First, look for likely combinations of starting ops,
16746          * corresponding to (global and lexical variants of)
16747          *     $a[...]   $h{...}
16748          *     $r->[...] $r->{...}
16749          *     (preceding expression)->[...]
16750          *     (preceding expression)->{...}
16751          * and if so, call maybe_multideref() to do a full inspection
16752          * of the op chain and if appropriate, replace with an
16753          * OP_MULTIDEREF
16754          */
16755         {
16756             UV action;
16757             OP *o2 = o;
16758             U8 hints = 0;
16759
16760             switch (o2->op_type) {
16761             case OP_GV:
16762                 /* $pkg[..]   :   gv[*pkg]
16763                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
16764
16765                 /* Fail if there are new op flag combinations that we're
16766                  * not aware of, rather than:
16767                  *  * silently failing to optimise, or
16768                  *  * silently optimising the flag away.
16769                  * If this ASSUME starts failing, examine what new flag
16770                  * has been added to the op, and decide whether the
16771                  * optimisation should still occur with that flag, then
16772                  * update the code accordingly. This applies to all the
16773                  * other ASSUMEs in the block of code too.
16774                  */
16775                 ASSUME(!(o2->op_flags &
16776                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16777                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16778
16779                 o2 = o2->op_next;
16780
16781                 if (o2->op_type == OP_RV2AV) {
16782                     action = MDEREF_AV_gvav_aelem;
16783                     goto do_deref;
16784                 }
16785
16786                 if (o2->op_type == OP_RV2HV) {
16787                     action = MDEREF_HV_gvhv_helem;
16788                     goto do_deref;
16789                 }
16790
16791                 if (o2->op_type != OP_RV2SV)
16792                     break;
16793
16794                 /* at this point we've seen gv,rv2sv, so the only valid
16795                  * construct left is $pkg->[] or $pkg->{} */
16796
16797                 ASSUME(!(o2->op_flags & OPf_STACKED));
16798                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16799                             != (OPf_WANT_SCALAR|OPf_MOD))
16800                     break;
16801
16802                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16803                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16804                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16805                     break;
16806                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
16807                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16808                     break;
16809
16810                 o2 = o2->op_next;
16811                 if (o2->op_type == OP_RV2AV) {
16812                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16813                     goto do_deref;
16814                 }
16815                 if (o2->op_type == OP_RV2HV) {
16816                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16817                     goto do_deref;
16818                 }
16819                 break;
16820
16821             case OP_PADSV:
16822                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16823
16824                 ASSUME(!(o2->op_flags &
16825                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16826                 if ((o2->op_flags &
16827                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16828                      != (OPf_WANT_SCALAR|OPf_MOD))
16829                     break;
16830
16831                 ASSUME(!(o2->op_private &
16832                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16833                 /* skip if state or intro, or not a deref */
16834                 if (      o2->op_private != OPpDEREF_AV
16835                        && o2->op_private != OPpDEREF_HV)
16836                     break;
16837
16838                 o2 = o2->op_next;
16839                 if (o2->op_type == OP_RV2AV) {
16840                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16841                     goto do_deref;
16842                 }
16843                 if (o2->op_type == OP_RV2HV) {
16844                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16845                     goto do_deref;
16846                 }
16847                 break;
16848
16849             case OP_PADAV:
16850             case OP_PADHV:
16851                 /*    $lex[..]:  padav[@lex:1,2] sR *
16852                  * or $lex{..}:  padhv[%lex:1,2] sR */
16853                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16854                                             OPf_REF|OPf_SPECIAL)));
16855                 if ((o2->op_flags &
16856                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16857                      != (OPf_WANT_SCALAR|OPf_REF))
16858                     break;
16859                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16860                     break;
16861                 /* OPf_PARENS isn't currently used in this case;
16862                  * if that changes, let us know! */
16863                 ASSUME(!(o2->op_flags & OPf_PARENS));
16864
16865                 /* at this point, we wouldn't expect any of the remaining
16866                  * possible private flags:
16867                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16868                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16869                  *
16870                  * OPpSLICEWARNING shouldn't affect runtime
16871                  */
16872                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16873
16874                 action = o2->op_type == OP_PADAV
16875                             ? MDEREF_AV_padav_aelem
16876                             : MDEREF_HV_padhv_helem;
16877                 o2 = o2->op_next;
16878                 S_maybe_multideref(aTHX_ o, o2, action, 0);
16879                 break;
16880
16881
16882             case OP_RV2AV:
16883             case OP_RV2HV:
16884                 action = o2->op_type == OP_RV2AV
16885                             ? MDEREF_AV_pop_rv2av_aelem
16886                             : MDEREF_HV_pop_rv2hv_helem;
16887                 /* FALLTHROUGH */
16888             do_deref:
16889                 /* (expr)->[...]:  rv2av sKR/1;
16890                  * (expr)->{...}:  rv2hv sKR/1; */
16891
16892                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16893
16894                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16895                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16896                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16897                     break;
16898
16899                 /* at this point, we wouldn't expect any of these
16900                  * possible private flags:
16901                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16902                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16903                  */
16904                 ASSUME(!(o2->op_private &
16905                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16906                      |OPpOUR_INTRO)));
16907                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16908
16909                 o2 = o2->op_next;
16910
16911                 S_maybe_multideref(aTHX_ o, o2, action, hints);
16912                 break;
16913
16914             default:
16915                 break;
16916             }
16917         }
16918
16919
16920         switch (o->op_type) {
16921         case OP_DBSTATE:
16922             PL_curcop = ((COP*)o);              /* for warnings */
16923             break;
16924         case OP_NEXTSTATE:
16925             PL_curcop = ((COP*)o);              /* for warnings */
16926
16927             /* Optimise a "return ..." at the end of a sub to just be "...".
16928              * This saves 2 ops. Before:
16929              * 1  <;> nextstate(main 1 -e:1) v ->2
16930              * 4  <@> return K ->5
16931              * 2    <0> pushmark s ->3
16932              * -    <1> ex-rv2sv sK/1 ->4
16933              * 3      <#> gvsv[*cat] s ->4
16934              *
16935              * After:
16936              * -  <@> return K ->-
16937              * -    <0> pushmark s ->2
16938              * -    <1> ex-rv2sv sK/1 ->-
16939              * 2      <$> gvsv(*cat) s ->3
16940              */
16941             {
16942                 OP *next = o->op_next;
16943                 OP *sibling = OpSIBLING(o);
16944                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
16945                     && OP_TYPE_IS(sibling, OP_RETURN)
16946                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16947                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16948                        ||OP_TYPE_IS(sibling->op_next->op_next,
16949                                     OP_LEAVESUBLV))
16950                     && cUNOPx(sibling)->op_first == next
16951                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16952                     && next->op_next
16953                 ) {
16954                     /* Look through the PUSHMARK's siblings for one that
16955                      * points to the RETURN */
16956                     OP *top = OpSIBLING(next);
16957                     while (top && top->op_next) {
16958                         if (top->op_next == sibling) {
16959                             top->op_next = sibling->op_next;
16960                             o->op_next = next->op_next;
16961                             break;
16962                         }
16963                         top = OpSIBLING(top);
16964                     }
16965                 }
16966             }
16967
16968             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16969              *
16970              * This latter form is then suitable for conversion into padrange
16971              * later on. Convert:
16972              *
16973              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16974              *
16975              * into:
16976              *
16977              *   nextstate1 ->     listop     -> nextstate3
16978              *                 /            \
16979              *         pushmark -> padop1 -> padop2
16980              */
16981             if (o->op_next && (
16982                     o->op_next->op_type == OP_PADSV
16983                  || o->op_next->op_type == OP_PADAV
16984                  || o->op_next->op_type == OP_PADHV
16985                 )
16986                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16987                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16988                 && o->op_next->op_next->op_next && (
16989                     o->op_next->op_next->op_next->op_type == OP_PADSV
16990                  || o->op_next->op_next->op_next->op_type == OP_PADAV
16991                  || o->op_next->op_next->op_next->op_type == OP_PADHV
16992                 )
16993                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16994                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16995                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16996                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16997             ) {
16998                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16999
17000                 pad1 =    o->op_next;
17001                 ns2  = pad1->op_next;
17002                 pad2 =  ns2->op_next;
17003                 ns3  = pad2->op_next;
17004
17005                 /* we assume here that the op_next chain is the same as
17006                  * the op_sibling chain */
17007                 assert(OpSIBLING(o)    == pad1);
17008                 assert(OpSIBLING(pad1) == ns2);
17009                 assert(OpSIBLING(ns2)  == pad2);
17010                 assert(OpSIBLING(pad2) == ns3);
17011
17012                 /* excise and delete ns2 */
17013                 op_sibling_splice(NULL, pad1, 1, NULL);
17014                 op_free(ns2);
17015
17016                 /* excise pad1 and pad2 */
17017                 op_sibling_splice(NULL, o, 2, NULL);
17018
17019                 /* create new listop, with children consisting of:
17020                  * a new pushmark, pad1, pad2. */
17021                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17022                 newop->op_flags |= OPf_PARENS;
17023                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17024
17025                 /* insert newop between o and ns3 */
17026                 op_sibling_splice(NULL, o, 0, newop);
17027
17028                 /*fixup op_next chain */
17029                 newpm = cUNOPx(newop)->op_first; /* pushmark */
17030                 o    ->op_next = newpm;
17031                 newpm->op_next = pad1;
17032                 pad1 ->op_next = pad2;
17033                 pad2 ->op_next = newop; /* listop */
17034                 newop->op_next = ns3;
17035
17036                 /* Ensure pushmark has this flag if padops do */
17037                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17038                     newpm->op_flags |= OPf_MOD;
17039                 }
17040
17041                 break;
17042             }
17043
17044             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17045                to carry two labels. For now, take the easier option, and skip
17046                this optimisation if the first NEXTSTATE has a label.  */
17047             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17048                 OP *nextop = o->op_next;
17049                 while (nextop) {
17050                     switch (nextop->op_type) {
17051                         case OP_NULL:
17052                         case OP_SCALAR:
17053                         case OP_LINESEQ:
17054                         case OP_SCOPE:
17055                             nextop = nextop->op_next;
17056                             continue;
17057                     }
17058                     break;
17059                 }
17060
17061                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17062                     op_null(o);
17063                     if (oldop)
17064                         oldop->op_next = nextop;
17065                     o = nextop;
17066                     /* Skip (old)oldop assignment since the current oldop's
17067                        op_next already points to the next op.  */
17068                     goto redo;
17069                 }
17070             }
17071             break;
17072
17073         case OP_CONCAT:
17074             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17075                 if (o->op_next->op_private & OPpTARGET_MY) {
17076                     if (o->op_flags & OPf_STACKED) /* chained concats */
17077                         break; /* ignore_optimization */
17078                     else {
17079                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17080                         o->op_targ = o->op_next->op_targ;
17081                         o->op_next->op_targ = 0;
17082                         o->op_private |= OPpTARGET_MY;
17083                     }
17084                 }
17085                 op_null(o->op_next);
17086             }
17087             break;
17088         case OP_STUB:
17089             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17090                 break; /* Scalar stub must produce undef.  List stub is noop */
17091             }
17092             goto nothin;
17093         case OP_NULL:
17094             if (o->op_targ == OP_NEXTSTATE
17095                 || o->op_targ == OP_DBSTATE)
17096             {
17097                 PL_curcop = ((COP*)o);
17098             }
17099             /* XXX: We avoid setting op_seq here to prevent later calls
17100                to rpeep() from mistakenly concluding that optimisation
17101                has already occurred. This doesn't fix the real problem,
17102                though (See 20010220.007 (#5874)). AMS 20010719 */
17103             /* op_seq functionality is now replaced by op_opt */
17104             o->op_opt = 0;
17105             /* FALLTHROUGH */
17106         case OP_SCALAR:
17107         case OP_LINESEQ:
17108         case OP_SCOPE:
17109         nothin:
17110             if (oldop) {
17111                 oldop->op_next = o->op_next;
17112                 o->op_opt = 0;
17113                 continue;
17114             }
17115             break;
17116
17117         case OP_PUSHMARK:
17118
17119             /* Given
17120                  5 repeat/DOLIST
17121                  3   ex-list
17122                  1     pushmark
17123                  2     scalar or const
17124                  4   const[0]
17125                convert repeat into a stub with no kids.
17126              */
17127             if (o->op_next->op_type == OP_CONST
17128              || (  o->op_next->op_type == OP_PADSV
17129                 && !(o->op_next->op_private & OPpLVAL_INTRO))
17130              || (  o->op_next->op_type == OP_GV
17131                 && o->op_next->op_next->op_type == OP_RV2SV
17132                 && !(o->op_next->op_next->op_private
17133                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17134             {
17135                 const OP *kid = o->op_next->op_next;
17136                 if (o->op_next->op_type == OP_GV)
17137                    kid = kid->op_next;
17138                 /* kid is now the ex-list.  */
17139                 if (kid->op_type == OP_NULL
17140                  && (kid = kid->op_next)->op_type == OP_CONST
17141                     /* kid is now the repeat count.  */
17142                  && kid->op_next->op_type == OP_REPEAT
17143                  && kid->op_next->op_private & OPpREPEAT_DOLIST
17144                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17145                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17146                  && oldop)
17147                 {
17148                     o = kid->op_next; /* repeat */
17149                     oldop->op_next = o;
17150                     op_free(cBINOPo->op_first);
17151                     op_free(cBINOPo->op_last );
17152                     o->op_flags &=~ OPf_KIDS;
17153                     /* stub is a baseop; repeat is a binop */
17154                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17155                     OpTYPE_set(o, OP_STUB);
17156                     o->op_private = 0;
17157                     break;
17158                 }
17159             }
17160
17161             /* Convert a series of PAD ops for my vars plus support into a
17162              * single padrange op. Basically
17163              *
17164              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17165              *
17166              * becomes, depending on circumstances, one of
17167              *
17168              *    padrange  ----------------------------------> (list) -> rest
17169              *    padrange  --------------------------------------------> rest
17170              *
17171              * where all the pad indexes are sequential and of the same type
17172              * (INTRO or not).
17173              * We convert the pushmark into a padrange op, then skip
17174              * any other pad ops, and possibly some trailing ops.
17175              * Note that we don't null() the skipped ops, to make it
17176              * easier for Deparse to undo this optimisation (and none of
17177              * the skipped ops are holding any resourses). It also makes
17178              * it easier for find_uninit_var(), as it can just ignore
17179              * padrange, and examine the original pad ops.
17180              */
17181         {
17182             OP *p;
17183             OP *followop = NULL; /* the op that will follow the padrange op */
17184             U8 count = 0;
17185             U8 intro = 0;
17186             PADOFFSET base = 0; /* init only to stop compiler whining */
17187             bool gvoid = 0;     /* init only to stop compiler whining */
17188             bool defav = 0;  /* seen (...) = @_ */
17189             bool reuse = 0;  /* reuse an existing padrange op */
17190
17191             /* look for a pushmark -> gv[_] -> rv2av */
17192
17193             {
17194                 OP *rv2av, *q;
17195                 p = o->op_next;
17196                 if (   p->op_type == OP_GV
17197                     && cGVOPx_gv(p) == PL_defgv
17198                     && (rv2av = p->op_next)
17199                     && rv2av->op_type == OP_RV2AV
17200                     && !(rv2av->op_flags & OPf_REF)
17201                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17202                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17203                 ) {
17204                     q = rv2av->op_next;
17205                     if (q->op_type == OP_NULL)
17206                         q = q->op_next;
17207                     if (q->op_type == OP_PUSHMARK) {
17208                         defav = 1;
17209                         p = q;
17210                     }
17211                 }
17212             }
17213             if (!defav) {
17214                 p = o;
17215             }
17216
17217             /* scan for PAD ops */
17218
17219             for (p = p->op_next; p; p = p->op_next) {
17220                 if (p->op_type == OP_NULL)
17221                     continue;
17222
17223                 if ((     p->op_type != OP_PADSV
17224                        && p->op_type != OP_PADAV
17225                        && p->op_type != OP_PADHV
17226                     )
17227                       /* any private flag other than INTRO? e.g. STATE */
17228                    || (p->op_private & ~OPpLVAL_INTRO)
17229                 )
17230                     break;
17231
17232                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17233                  * instead */
17234                 if (   p->op_type == OP_PADAV
17235                     && p->op_next
17236                     && p->op_next->op_type == OP_CONST
17237                     && p->op_next->op_next
17238                     && p->op_next->op_next->op_type == OP_AELEM
17239                 )
17240                     break;
17241
17242                 /* for 1st padop, note what type it is and the range
17243                  * start; for the others, check that it's the same type
17244                  * and that the targs are contiguous */
17245                 if (count == 0) {
17246                     intro = (p->op_private & OPpLVAL_INTRO);
17247                     base = p->op_targ;
17248                     gvoid = OP_GIMME(p,0) == G_VOID;
17249                 }
17250                 else {
17251                     if ((p->op_private & OPpLVAL_INTRO) != intro)
17252                         break;
17253                     /* Note that you'd normally  expect targs to be
17254                      * contiguous in my($a,$b,$c), but that's not the case
17255                      * when external modules start doing things, e.g.
17256                      * Function::Parameters */
17257                     if (p->op_targ != base + count)
17258                         break;
17259                     assert(p->op_targ == base + count);
17260                     /* Either all the padops or none of the padops should
17261                        be in void context.  Since we only do the optimisa-
17262                        tion for av/hv when the aggregate itself is pushed
17263                        on to the stack (one item), there is no need to dis-
17264                        tinguish list from scalar context.  */
17265                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
17266                         break;
17267                 }
17268
17269                 /* for AV, HV, only when we're not flattening */
17270                 if (   p->op_type != OP_PADSV
17271                     && !gvoid
17272                     && !(p->op_flags & OPf_REF)
17273                 )
17274                     break;
17275
17276                 if (count >= OPpPADRANGE_COUNTMASK)
17277                     break;
17278
17279                 /* there's a biggest base we can fit into a
17280                  * SAVEt_CLEARPADRANGE in pp_padrange.
17281                  * (The sizeof() stuff will be constant-folded, and is
17282                  * intended to avoid getting "comparison is always false"
17283                  * compiler warnings. See the comments above
17284                  * MEM_WRAP_CHECK for more explanation on why we do this
17285                  * in a weird way to avoid compiler warnings.)
17286                  */
17287                 if (   intro
17288                     && (8*sizeof(base) >
17289                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17290                         ? (Size_t)base
17291                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17292                         ) >
17293                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17294                 )
17295                     break;
17296
17297                 /* Success! We've got another valid pad op to optimise away */
17298                 count++;
17299                 followop = p->op_next;
17300             }
17301
17302             if (count < 1 || (count == 1 && !defav))
17303                 break;
17304
17305             /* pp_padrange in specifically compile-time void context
17306              * skips pushing a mark and lexicals; in all other contexts
17307              * (including unknown till runtime) it pushes a mark and the
17308              * lexicals. We must be very careful then, that the ops we
17309              * optimise away would have exactly the same effect as the
17310              * padrange.
17311              * In particular in void context, we can only optimise to
17312              * a padrange if we see the complete sequence
17313              *     pushmark, pad*v, ...., list
17314              * which has the net effect of leaving the markstack as it
17315              * was.  Not pushing onto the stack (whereas padsv does touch
17316              * the stack) makes no difference in void context.
17317              */
17318             assert(followop);
17319             if (gvoid) {
17320                 if (followop->op_type == OP_LIST
17321                         && OP_GIMME(followop,0) == G_VOID
17322                    )
17323                 {
17324                     followop = followop->op_next; /* skip OP_LIST */
17325
17326                     /* consolidate two successive my(...);'s */
17327
17328                     if (   oldoldop
17329                         && oldoldop->op_type == OP_PADRANGE
17330                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17331                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17332                         && !(oldoldop->op_flags & OPf_SPECIAL)
17333                     ) {
17334                         U8 old_count;
17335                         assert(oldoldop->op_next == oldop);
17336                         assert(   oldop->op_type == OP_NEXTSTATE
17337                                || oldop->op_type == OP_DBSTATE);
17338                         assert(oldop->op_next == o);
17339
17340                         old_count
17341                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17342
17343                        /* Do not assume pad offsets for $c and $d are con-
17344                           tiguous in
17345                             my ($a,$b,$c);
17346                             my ($d,$e,$f);
17347                         */
17348                         if (  oldoldop->op_targ + old_count == base
17349                            && old_count < OPpPADRANGE_COUNTMASK - count) {
17350                             base = oldoldop->op_targ;
17351                             count += old_count;
17352                             reuse = 1;
17353                         }
17354                     }
17355
17356                     /* if there's any immediately following singleton
17357                      * my var's; then swallow them and the associated
17358                      * nextstates; i.e.
17359                      *    my ($a,$b); my $c; my $d;
17360                      * is treated as
17361                      *    my ($a,$b,$c,$d);
17362                      */
17363
17364                     while (    ((p = followop->op_next))
17365                             && (  p->op_type == OP_PADSV
17366                                || p->op_type == OP_PADAV
17367                                || p->op_type == OP_PADHV)
17368                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17369                             && (p->op_private & OPpLVAL_INTRO) == intro
17370                             && !(p->op_private & ~OPpLVAL_INTRO)
17371                             && p->op_next
17372                             && (   p->op_next->op_type == OP_NEXTSTATE
17373                                 || p->op_next->op_type == OP_DBSTATE)
17374                             && count < OPpPADRANGE_COUNTMASK
17375                             && base + count == p->op_targ
17376                     ) {
17377                         count++;
17378                         followop = p->op_next;
17379                     }
17380                 }
17381                 else
17382                     break;
17383             }
17384
17385             if (reuse) {
17386                 assert(oldoldop->op_type == OP_PADRANGE);
17387                 oldoldop->op_next = followop;
17388                 oldoldop->op_private = (intro | count);
17389                 o = oldoldop;
17390                 oldop = NULL;
17391                 oldoldop = NULL;
17392             }
17393             else {
17394                 /* Convert the pushmark into a padrange.
17395                  * To make Deparse easier, we guarantee that a padrange was
17396                  * *always* formerly a pushmark */
17397                 assert(o->op_type == OP_PUSHMARK);
17398                 o->op_next = followop;
17399                 OpTYPE_set(o, OP_PADRANGE);
17400                 o->op_targ = base;
17401                 /* bit 7: INTRO; bit 6..0: count */
17402                 o->op_private = (intro | count);
17403                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17404                               | gvoid * OPf_WANT_VOID
17405                               | (defav ? OPf_SPECIAL : 0));
17406             }
17407             break;
17408         }
17409
17410         case OP_RV2AV:
17411             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17412                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17413             break;
17414
17415         case OP_RV2HV:
17416         case OP_PADHV:
17417             /*'keys %h' in void or scalar context: skip the OP_KEYS
17418              * and perform the functionality directly in the RV2HV/PADHV
17419              * op
17420              */
17421             if (o->op_flags & OPf_REF) {
17422                 OP *k = o->op_next;
17423                 U8 want = (k->op_flags & OPf_WANT);
17424                 if (   k
17425                     && k->op_type == OP_KEYS
17426                     && (   want == OPf_WANT_VOID
17427                         || want == OPf_WANT_SCALAR)
17428                     && !(k->op_private & OPpMAYBE_LVSUB)
17429                     && !(k->op_flags & OPf_MOD)
17430                 ) {
17431                     o->op_next     = k->op_next;
17432                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
17433                     o->op_flags   |= want;
17434                     o->op_private |= (o->op_type == OP_PADHV ?
17435                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17436                     /* for keys(%lex), hold onto the OP_KEYS's targ
17437                      * since padhv doesn't have its own targ to return
17438                      * an int with */
17439                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17440                         op_null(k);
17441                 }
17442             }
17443
17444             /* see if %h is used in boolean context */
17445             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17446                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17447
17448
17449             if (o->op_type != OP_PADHV)
17450                 break;
17451             /* FALLTHROUGH */
17452         case OP_PADAV:
17453             if (   o->op_type == OP_PADAV
17454                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17455             )
17456                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17457             /* FALLTHROUGH */
17458         case OP_PADSV:
17459             /* Skip over state($x) in void context.  */
17460             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17461              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17462             {
17463                 oldop->op_next = o->op_next;
17464                 goto redo_nextstate;
17465             }
17466             if (o->op_type != OP_PADAV)
17467                 break;
17468             /* FALLTHROUGH */
17469         case OP_GV:
17470             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17471                 OP* const pop = (o->op_type == OP_PADAV) ?
17472                             o->op_next : o->op_next->op_next;
17473                 IV i;
17474                 if (pop && pop->op_type == OP_CONST &&
17475                     ((PL_op = pop->op_next)) &&
17476                     pop->op_next->op_type == OP_AELEM &&
17477                     !(pop->op_next->op_private &
17478                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17479                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17480                 {
17481                     GV *gv;
17482                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17483                         no_bareword_allowed(pop);
17484                     if (o->op_type == OP_GV)
17485                         op_null(o->op_next);
17486                     op_null(pop->op_next);
17487                     op_null(pop);
17488                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17489                     o->op_next = pop->op_next->op_next;
17490                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17491                     o->op_private = (U8)i;
17492                     if (o->op_type == OP_GV) {
17493                         gv = cGVOPo_gv;
17494                         GvAVn(gv);
17495                         o->op_type = OP_AELEMFAST;
17496                     }
17497                     else
17498                         o->op_type = OP_AELEMFAST_LEX;
17499                 }
17500                 if (o->op_type != OP_GV)
17501                     break;
17502             }
17503
17504             /* Remove $foo from the op_next chain in void context.  */
17505             if (oldop
17506              && (  o->op_next->op_type == OP_RV2SV
17507                 || o->op_next->op_type == OP_RV2AV
17508                 || o->op_next->op_type == OP_RV2HV  )
17509              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17510              && !(o->op_next->op_private & OPpLVAL_INTRO))
17511             {
17512                 oldop->op_next = o->op_next->op_next;
17513                 /* Reprocess the previous op if it is a nextstate, to
17514                    allow double-nextstate optimisation.  */
17515               redo_nextstate:
17516                 if (oldop->op_type == OP_NEXTSTATE) {
17517                     oldop->op_opt = 0;
17518                     o = oldop;
17519                     oldop = oldoldop;
17520                     oldoldop = NULL;
17521                     goto redo;
17522                 }
17523                 o = oldop->op_next;
17524                 goto redo;
17525             }
17526             else if (o->op_next->op_type == OP_RV2SV) {
17527                 if (!(o->op_next->op_private & OPpDEREF)) {
17528                     op_null(o->op_next);
17529                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17530                                                                | OPpOUR_INTRO);
17531                     o->op_next = o->op_next->op_next;
17532                     OpTYPE_set(o, OP_GVSV);
17533                 }
17534             }
17535             else if (o->op_next->op_type == OP_READLINE
17536                     && o->op_next->op_next->op_type == OP_CONCAT
17537                     && (o->op_next->op_next->op_flags & OPf_STACKED))
17538             {
17539                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17540                 OpTYPE_set(o, OP_RCATLINE);
17541                 o->op_flags |= OPf_STACKED;
17542                 op_null(o->op_next->op_next);
17543                 op_null(o->op_next);
17544             }
17545
17546             break;
17547
17548         case OP_NOT:
17549             break;
17550
17551         case OP_AND:
17552         case OP_OR:
17553         case OP_DOR:
17554         case OP_CMPCHAIN_AND:
17555             while (cLOGOP->op_other->op_type == OP_NULL)
17556                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17557             while (o->op_next && (   o->op_type == o->op_next->op_type
17558                                   || o->op_next->op_type == OP_NULL))
17559                 o->op_next = o->op_next->op_next;
17560
17561             /* If we're an OR and our next is an AND in void context, we'll
17562                follow its op_other on short circuit, same for reverse.
17563                We can't do this with OP_DOR since if it's true, its return
17564                value is the underlying value which must be evaluated
17565                by the next op. */
17566             if (o->op_next &&
17567                 (
17568                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17569                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17570                 )
17571                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17572             ) {
17573                 o->op_next = ((LOGOP*)o->op_next)->op_other;
17574             }
17575             DEFER(cLOGOP->op_other);
17576             o->op_opt = 1;
17577             break;
17578
17579         case OP_GREPWHILE:
17580             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17581                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17582             /* FALLTHROUGH */
17583         case OP_COND_EXPR:
17584         case OP_MAPWHILE:
17585         case OP_ANDASSIGN:
17586         case OP_ORASSIGN:
17587         case OP_DORASSIGN:
17588         case OP_RANGE:
17589         case OP_ONCE:
17590         case OP_ARGDEFELEM:
17591             while (cLOGOP->op_other->op_type == OP_NULL)
17592                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17593             DEFER(cLOGOP->op_other);
17594             break;
17595
17596         case OP_ENTERLOOP:
17597         case OP_ENTERITER:
17598             while (cLOOP->op_redoop->op_type == OP_NULL)
17599                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17600             while (cLOOP->op_nextop->op_type == OP_NULL)
17601                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17602             while (cLOOP->op_lastop->op_type == OP_NULL)
17603                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17604             /* a while(1) loop doesn't have an op_next that escapes the
17605              * loop, so we have to explicitly follow the op_lastop to
17606              * process the rest of the code */
17607             DEFER(cLOOP->op_lastop);
17608             break;
17609
17610         case OP_ENTERTRY:
17611             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17612             DEFER(cLOGOPo->op_other);
17613             break;
17614
17615         case OP_SUBST:
17616             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17617                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17618             assert(!(cPMOP->op_pmflags & PMf_ONCE));
17619             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17620                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17621                 cPMOP->op_pmstashstartu.op_pmreplstart
17622                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17623             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17624             break;
17625
17626         case OP_SORT: {
17627             OP *oright;
17628
17629             if (o->op_flags & OPf_SPECIAL) {
17630                 /* first arg is a code block */
17631                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17632                 OP * kid          = cUNOPx(nullop)->op_first;
17633
17634                 assert(nullop->op_type == OP_NULL);
17635                 assert(kid->op_type == OP_SCOPE
17636                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17637                 /* since OP_SORT doesn't have a handy op_other-style
17638                  * field that can point directly to the start of the code
17639                  * block, store it in the otherwise-unused op_next field
17640                  * of the top-level OP_NULL. This will be quicker at
17641                  * run-time, and it will also allow us to remove leading
17642                  * OP_NULLs by just messing with op_nexts without
17643                  * altering the basic op_first/op_sibling layout. */
17644                 kid = kLISTOP->op_first;
17645                 assert(
17646                       (kid->op_type == OP_NULL
17647                       && (  kid->op_targ == OP_NEXTSTATE
17648                          || kid->op_targ == OP_DBSTATE  ))
17649                     || kid->op_type == OP_STUB
17650                     || kid->op_type == OP_ENTER
17651                     || (PL_parser && PL_parser->error_count));
17652                 nullop->op_next = kid->op_next;
17653                 DEFER(nullop->op_next);
17654             }
17655
17656             /* check that RHS of sort is a single plain array */
17657             oright = cUNOPo->op_first;
17658             if (!oright || oright->op_type != OP_PUSHMARK)
17659                 break;
17660
17661             if (o->op_private & OPpSORT_INPLACE)
17662                 break;
17663
17664             /* reverse sort ... can be optimised.  */
17665             if (!OpHAS_SIBLING(cUNOPo)) {
17666                 /* Nothing follows us on the list. */
17667                 OP * const reverse = o->op_next;
17668
17669                 if (reverse->op_type == OP_REVERSE &&
17670                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17671                     OP * const pushmark = cUNOPx(reverse)->op_first;
17672                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17673                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17674                         /* reverse -> pushmark -> sort */
17675                         o->op_private |= OPpSORT_REVERSE;
17676                         op_null(reverse);
17677                         pushmark->op_next = oright->op_next;
17678                         op_null(oright);
17679                     }
17680                 }
17681             }
17682
17683             break;
17684         }
17685
17686         case OP_REVERSE: {
17687             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17688             OP *gvop = NULL;
17689             LISTOP *enter, *exlist;
17690
17691             if (o->op_private & OPpSORT_INPLACE)
17692                 break;
17693
17694             enter = (LISTOP *) o->op_next;
17695             if (!enter)
17696                 break;
17697             if (enter->op_type == OP_NULL) {
17698                 enter = (LISTOP *) enter->op_next;
17699                 if (!enter)
17700                     break;
17701             }
17702             /* for $a (...) will have OP_GV then OP_RV2GV here.
17703                for (...) just has an OP_GV.  */
17704             if (enter->op_type == OP_GV) {
17705                 gvop = (OP *) enter;
17706                 enter = (LISTOP *) enter->op_next;
17707                 if (!enter)
17708                     break;
17709                 if (enter->op_type == OP_RV2GV) {
17710                   enter = (LISTOP *) enter->op_next;
17711                   if (!enter)
17712                     break;
17713                 }
17714             }
17715
17716             if (enter->op_type != OP_ENTERITER)
17717                 break;
17718
17719             iter = enter->op_next;
17720             if (!iter || iter->op_type != OP_ITER)
17721                 break;
17722
17723             expushmark = enter->op_first;
17724             if (!expushmark || expushmark->op_type != OP_NULL
17725                 || expushmark->op_targ != OP_PUSHMARK)
17726                 break;
17727
17728             exlist = (LISTOP *) OpSIBLING(expushmark);
17729             if (!exlist || exlist->op_type != OP_NULL
17730                 || exlist->op_targ != OP_LIST)
17731                 break;
17732
17733             if (exlist->op_last != o) {
17734                 /* Mmm. Was expecting to point back to this op.  */
17735                 break;
17736             }
17737             theirmark = exlist->op_first;
17738             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17739                 break;
17740
17741             if (OpSIBLING(theirmark) != o) {
17742                 /* There's something between the mark and the reverse, eg
17743                    for (1, reverse (...))
17744                    so no go.  */
17745                 break;
17746             }
17747
17748             ourmark = ((LISTOP *)o)->op_first;
17749             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17750                 break;
17751
17752             ourlast = ((LISTOP *)o)->op_last;
17753             if (!ourlast || ourlast->op_next != o)
17754                 break;
17755
17756             rv2av = OpSIBLING(ourmark);
17757             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17758                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17759                 /* We're just reversing a single array.  */
17760                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17761                 enter->op_flags |= OPf_STACKED;
17762             }
17763
17764             /* We don't have control over who points to theirmark, so sacrifice
17765                ours.  */
17766             theirmark->op_next = ourmark->op_next;
17767             theirmark->op_flags = ourmark->op_flags;
17768             ourlast->op_next = gvop ? gvop : (OP *) enter;
17769             op_null(ourmark);
17770             op_null(o);
17771             enter->op_private |= OPpITER_REVERSED;
17772             iter->op_private |= OPpITER_REVERSED;
17773
17774             oldoldop = NULL;
17775             oldop    = ourlast;
17776             o        = oldop->op_next;
17777             goto redo;
17778             NOT_REACHED; /* NOTREACHED */
17779             break;
17780         }
17781
17782         case OP_QR:
17783         case OP_MATCH:
17784             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17785                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17786             }
17787             break;
17788
17789         case OP_RUNCV:
17790             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17791              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17792             {
17793                 SV *sv;
17794                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17795                 else {
17796                     sv = newRV((SV *)PL_compcv);
17797                     sv_rvweaken(sv);
17798                     SvREADONLY_on(sv);
17799                 }
17800                 OpTYPE_set(o, OP_CONST);
17801                 o->op_flags |= OPf_SPECIAL;
17802                 cSVOPo->op_sv = sv;
17803             }
17804             break;
17805
17806         case OP_SASSIGN:
17807             if (OP_GIMME(o,0) == G_VOID
17808              || (  o->op_next->op_type == OP_LINESEQ
17809                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
17810                    || (  o->op_next->op_next->op_type == OP_RETURN
17811                       && !CvLVALUE(PL_compcv)))))
17812             {
17813                 OP *right = cBINOP->op_first;
17814                 if (right) {
17815                     /*   sassign
17816                     *      RIGHT
17817                     *      substr
17818                     *         pushmark
17819                     *         arg1
17820                     *         arg2
17821                     *         ...
17822                     * becomes
17823                     *
17824                     *  ex-sassign
17825                     *     substr
17826                     *        pushmark
17827                     *        RIGHT
17828                     *        arg1
17829                     *        arg2
17830                     *        ...
17831                     */
17832                     OP *left = OpSIBLING(right);
17833                     if (left->op_type == OP_SUBSTR
17834                          && (left->op_private & 7) < 4) {
17835                         op_null(o);
17836                         /* cut out right */
17837                         op_sibling_splice(o, NULL, 1, NULL);
17838                         /* and insert it as second child of OP_SUBSTR */
17839                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17840                                     right);
17841                         left->op_private |= OPpSUBSTR_REPL_FIRST;
17842                         left->op_flags =
17843                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17844                     }
17845                 }
17846             }
17847             break;
17848
17849         case OP_AASSIGN: {
17850             int l, r, lr, lscalars, rscalars;
17851
17852             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17853                Note that we do this now rather than in newASSIGNOP(),
17854                since only by now are aliased lexicals flagged as such
17855
17856                See the essay "Common vars in list assignment" above for
17857                the full details of the rationale behind all the conditions
17858                below.
17859
17860                PL_generation sorcery:
17861                To detect whether there are common vars, the global var
17862                PL_generation is incremented for each assign op we scan.
17863                Then we run through all the lexical variables on the LHS,
17864                of the assignment, setting a spare slot in each of them to
17865                PL_generation.  Then we scan the RHS, and if any lexicals
17866                already have that value, we know we've got commonality.
17867                Also, if the generation number is already set to
17868                PERL_INT_MAX, then the variable is involved in aliasing, so
17869                we also have potential commonality in that case.
17870              */
17871
17872             PL_generation++;
17873             /* scan LHS */
17874             lscalars = 0;
17875             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, &lscalars);
17876             /* scan RHS */
17877             rscalars = 0;
17878             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17879             lr = (l|r);
17880
17881
17882             /* After looking for things which are *always* safe, this main
17883              * if/else chain selects primarily based on the type of the
17884              * LHS, gradually working its way down from the more dangerous
17885              * to the more restrictive and thus safer cases */
17886
17887             if (   !l                      /* () = ....; */
17888                 || !r                      /* .... = (); */
17889                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17890                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17891                 || (lscalars < 2)          /* ($x, undef) = ... */
17892             ) {
17893                 NOOP; /* always safe */
17894             }
17895             else if (l & AAS_DANGEROUS) {
17896                 /* always dangerous */
17897                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17898                 o->op_private |= OPpASSIGN_COMMON_AGG;
17899             }
17900             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17901                 /* package vars are always dangerous - too many
17902                  * aliasing possibilities */
17903                 if (l & AAS_PKG_SCALAR)
17904                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
17905                 if (l & AAS_PKG_AGG)
17906                     o->op_private |= OPpASSIGN_COMMON_AGG;
17907             }
17908             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17909                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
17910             {
17911                 /* LHS contains only lexicals and safe ops */
17912
17913                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17914                     o->op_private |= OPpASSIGN_COMMON_AGG;
17915
17916                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17917                     if (lr & AAS_LEX_SCALAR_COMM)
17918                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
17919                     else if (   !(l & AAS_LEX_SCALAR)
17920                              && (r & AAS_DEFAV))
17921                     {
17922                         /* falsely mark
17923                          *    my (...) = @_
17924                          * as scalar-safe for performance reasons.
17925                          * (it will still have been marked _AGG if necessary */
17926                         NOOP;
17927                     }
17928                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17929                         /* if there are only lexicals on the LHS and no
17930                          * common ones on the RHS, then we assume that the
17931                          * only way those lexicals could also get
17932                          * on the RHS is via some sort of dereffing or
17933                          * closure, e.g.
17934                          *    $r = \$lex;
17935                          *    ($lex, $x) = (1, $$r)
17936                          * and in this case we assume the var must have
17937                          *  a bumped ref count. So if its ref count is 1,
17938                          *  it must only be on the LHS.
17939                          */
17940                         o->op_private |= OPpASSIGN_COMMON_RC1;
17941                 }
17942             }
17943
17944             /* ... = ($x)
17945              * may have to handle aggregate on LHS, but we can't
17946              * have common scalars. */
17947             if (rscalars < 2)
17948                 o->op_private &=
17949                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17950
17951             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17952                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17953             break;
17954         }
17955
17956         case OP_REF:
17957             /* see if ref() is used in boolean context */
17958             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17959                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17960             break;
17961
17962         case OP_LENGTH:
17963             /* see if the op is used in known boolean context,
17964              * but not if OA_TARGLEX optimisation is enabled */
17965             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17966                 && !(o->op_private & OPpTARGET_MY)
17967             )
17968                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17969             break;
17970
17971         case OP_POS:
17972             /* see if the op is used in known boolean context */
17973             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17974                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17975             break;
17976
17977         case OP_CUSTOM: {
17978             Perl_cpeep_t cpeep =
17979                 XopENTRYCUSTOM(o, xop_peep);
17980             if (cpeep)
17981                 cpeep(aTHX_ o, oldop);
17982             break;
17983         }
17984
17985         }
17986         /* did we just null the current op? If so, re-process it to handle
17987          * eliding "empty" ops from the chain */
17988         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17989             o->op_opt = 0;
17990             o = oldop;
17991         }
17992         else {
17993             oldoldop = oldop;
17994             oldop = o;
17995         }
17996     }
17997     LEAVE;
17998 }
17999
18000 void
18001 Perl_peep(pTHX_ OP *o)
18002 {
18003     CALL_RPEEP(o);
18004 }
18005
18006 /*
18007 =head1 Custom Operators
18008
18009 =for apidoc Perl_custom_op_xop
18010 Return the XOP structure for a given custom op.  This macro should be
18011 considered internal to C<OP_NAME> and the other access macros: use them instead.
18012 This macro does call a function.  Prior
18013 to 5.19.6, this was implemented as a
18014 function.
18015
18016 =cut
18017 */
18018
18019
18020 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18021  * freeing PL_custom_ops */
18022
18023 static int
18024 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18025 {
18026     XOP *xop;
18027
18028     PERL_UNUSED_ARG(mg);
18029     xop = INT2PTR(XOP *, SvIV(sv));
18030     Safefree(xop->xop_name);
18031     Safefree(xop->xop_desc);
18032     Safefree(xop);
18033     return 0;
18034 }
18035
18036
18037 static const MGVTBL custom_op_register_vtbl = {
18038     0,                          /* get */
18039     0,                          /* set */
18040     0,                          /* len */
18041     0,                          /* clear */
18042     custom_op_register_free,     /* free */
18043     0,                          /* copy */
18044     0,                          /* dup */
18045 #ifdef MGf_LOCAL
18046     0,                          /* local */
18047 #endif
18048 };
18049
18050
18051 XOPRETANY
18052 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18053 {
18054     SV *keysv;
18055     HE *he = NULL;
18056     XOP *xop;
18057
18058     static const XOP xop_null = { 0, 0, 0, 0, 0 };
18059
18060     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18061     assert(o->op_type == OP_CUSTOM);
18062
18063     /* This is wrong. It assumes a function pointer can be cast to IV,
18064      * which isn't guaranteed, but this is what the old custom OP code
18065      * did. In principle it should be safer to Copy the bytes of the
18066      * pointer into a PV: since the new interface is hidden behind
18067      * functions, this can be changed later if necessary.  */
18068     /* Change custom_op_xop if this ever happens */
18069     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18070
18071     if (PL_custom_ops)
18072         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18073
18074     /* See if the op isn't registered, but its name *is* registered.
18075      * That implies someone is using the pre-5.14 API,where only name and
18076      * description could be registered. If so, fake up a real
18077      * registration.
18078      * We only check for an existing name, and assume no one will have
18079      * just registered a desc */
18080     if (!he && PL_custom_op_names &&
18081         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18082     ) {
18083         const char *pv;
18084         STRLEN l;
18085
18086         /* XXX does all this need to be shared mem? */
18087         Newxz(xop, 1, XOP);
18088         pv = SvPV(HeVAL(he), l);
18089         XopENTRY_set(xop, xop_name, savepvn(pv, l));
18090         if (PL_custom_op_descs &&
18091             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18092         ) {
18093             pv = SvPV(HeVAL(he), l);
18094             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18095         }
18096         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18097         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18098         /* add magic to the SV so that the xop struct (pointed to by
18099          * SvIV(sv)) is freed. Normally a static xop is registered, but
18100          * for this backcompat hack, we've alloced one */
18101         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18102                 &custom_op_register_vtbl, NULL, 0);
18103
18104     }
18105     else {
18106         if (!he)
18107             xop = (XOP *)&xop_null;
18108         else
18109             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18110     }
18111     {
18112         XOPRETANY any;
18113         if(field == XOPe_xop_ptr) {
18114             any.xop_ptr = xop;
18115         } else {
18116             const U32 flags = XopFLAGS(xop);
18117             if(flags & field) {
18118                 switch(field) {
18119                 case XOPe_xop_name:
18120                     any.xop_name = xop->xop_name;
18121                     break;
18122                 case XOPe_xop_desc:
18123                     any.xop_desc = xop->xop_desc;
18124                     break;
18125                 case XOPe_xop_class:
18126                     any.xop_class = xop->xop_class;
18127                     break;
18128                 case XOPe_xop_peep:
18129                     any.xop_peep = xop->xop_peep;
18130                     break;
18131                 default:
18132                     NOT_REACHED; /* NOTREACHED */
18133                     break;
18134                 }
18135             } else {
18136                 switch(field) {
18137                 case XOPe_xop_name:
18138                     any.xop_name = XOPd_xop_name;
18139                     break;
18140                 case XOPe_xop_desc:
18141                     any.xop_desc = XOPd_xop_desc;
18142                     break;
18143                 case XOPe_xop_class:
18144                     any.xop_class = XOPd_xop_class;
18145                     break;
18146                 case XOPe_xop_peep:
18147                     any.xop_peep = XOPd_xop_peep;
18148                     break;
18149                 default:
18150                     NOT_REACHED; /* NOTREACHED */
18151                     break;
18152                 }
18153             }
18154         }
18155         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18156          * op.c: In function 'Perl_custom_op_get_field':
18157          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18158          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18159          * expands to assert(0), which expands to ((0) ? (void)0 :
18160          * __assert(...)), and gcc doesn't know that __assert can never return. */
18161         return any;
18162     }
18163 }
18164
18165 /*
18166 =for apidoc custom_op_register
18167 Register a custom op.  See L<perlguts/"Custom Operators">.
18168
18169 =cut
18170 */
18171
18172 void
18173 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18174 {
18175     SV *keysv;
18176
18177     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18178
18179     /* see the comment in custom_op_xop */
18180     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18181
18182     if (!PL_custom_ops)
18183         PL_custom_ops = newHV();
18184
18185     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18186         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18187 }
18188
18189 /*
18190
18191 =for apidoc core_prototype
18192
18193 This function assigns the prototype of the named core function to C<sv>, or
18194 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
18195 C<NULL> if the core function has no prototype.  C<code> is a code as returned
18196 by C<keyword()>.  It must not be equal to 0.
18197
18198 =cut
18199 */
18200
18201 SV *
18202 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18203                           int * const opnum)
18204 {
18205     int i = 0, n = 0, seen_question = 0, defgv = 0;
18206     I32 oa;
18207 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18208     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18209     bool nullret = FALSE;
18210
18211     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18212
18213     assert (code);
18214
18215     if (!sv) sv = sv_newmortal();
18216
18217 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18218
18219     switch (code < 0 ? -code : code) {
18220     case KEY_and   : case KEY_chop: case KEY_chomp:
18221     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
18222     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
18223     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
18224     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
18225     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
18226     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
18227     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
18228     case KEY_x     : case KEY_xor    :
18229         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18230     case KEY_glob:    retsetpvs("_;", OP_GLOB);
18231     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
18232     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
18233     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
18234     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
18235     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18236         retsetpvs("", 0);
18237     case KEY_evalbytes:
18238         name = "entereval"; break;
18239     case KEY_readpipe:
18240         name = "backtick";
18241     }
18242
18243 #undef retsetpvs
18244
18245   findopnum:
18246     while (i < MAXO) {  /* The slow way. */
18247         if (strEQ(name, PL_op_name[i])
18248             || strEQ(name, PL_op_desc[i]))
18249         {
18250             if (nullret) { assert(opnum); *opnum = i; return NULL; }
18251             goto found;
18252         }
18253         i++;
18254     }
18255     return NULL;
18256   found:
18257     defgv = PL_opargs[i] & OA_DEFGV;
18258     oa = PL_opargs[i] >> OASHIFT;
18259     while (oa) {
18260         if (oa & OA_OPTIONAL && !seen_question && (
18261               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18262         )) {
18263             seen_question = 1;
18264             str[n++] = ';';
18265         }
18266         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18267             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18268             /* But globs are already references (kinda) */
18269             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18270         ) {
18271             str[n++] = '\\';
18272         }
18273         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18274          && !scalar_mod_type(NULL, i)) {
18275             str[n++] = '[';
18276             str[n++] = '$';
18277             str[n++] = '@';
18278             str[n++] = '%';
18279             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18280             str[n++] = '*';
18281             str[n++] = ']';
18282         }
18283         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18284         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18285             str[n-1] = '_'; defgv = 0;
18286         }
18287         oa = oa >> 4;
18288     }
18289     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18290     str[n++] = '\0';
18291     sv_setpvn(sv, str, n - 1);
18292     if (opnum) *opnum = i;
18293     return sv;
18294 }
18295
18296 OP *
18297 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18298                       const int opnum)
18299 {
18300     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18301                                         newSVOP(OP_COREARGS,0,coreargssv);
18302     OP *o;
18303
18304     PERL_ARGS_ASSERT_CORESUB_OP;
18305
18306     switch(opnum) {
18307     case 0:
18308         return op_append_elem(OP_LINESEQ,
18309                        argop,
18310                        newSLICEOP(0,
18311                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18312                                   newOP(OP_CALLER,0)
18313                        )
18314                );
18315     case OP_EACH:
18316     case OP_KEYS:
18317     case OP_VALUES:
18318         o = newUNOP(OP_AVHVSWITCH,0,argop);
18319         o->op_private = opnum-OP_EACH;
18320         return o;
18321     case OP_SELECT: /* which represents OP_SSELECT as well */
18322         if (code)
18323             return newCONDOP(
18324                          0,
18325                          newBINOP(OP_GT, 0,
18326                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18327                                   newSVOP(OP_CONST, 0, newSVuv(1))
18328                                  ),
18329                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
18330                                     OP_SSELECT),
18331                          coresub_op(coreargssv, 0, OP_SELECT)
18332                    );
18333         /* FALLTHROUGH */
18334     default:
18335         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18336         case OA_BASEOP:
18337             return op_append_elem(
18338                         OP_LINESEQ, argop,
18339                         newOP(opnum,
18340                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
18341                                 ? OPpOFFBYONE << 8 : 0)
18342                    );
18343         case OA_BASEOP_OR_UNOP:
18344             if (opnum == OP_ENTEREVAL) {
18345                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18346                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18347             }
18348             else o = newUNOP(opnum,0,argop);
18349             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18350             else {
18351           onearg:
18352               if (is_handle_constructor(o, 1))
18353                 argop->op_private |= OPpCOREARGS_DEREF1;
18354               if (scalar_mod_type(NULL, opnum))
18355                 argop->op_private |= OPpCOREARGS_SCALARMOD;
18356             }
18357             return o;
18358         default:
18359             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18360             if (is_handle_constructor(o, 2))
18361                 argop->op_private |= OPpCOREARGS_DEREF2;
18362             if (opnum == OP_SUBSTR) {
18363                 o->op_private |= OPpMAYBE_LVSUB;
18364                 return o;
18365             }
18366             else goto onearg;
18367         }
18368     }
18369 }
18370
18371 void
18372 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18373                                SV * const *new_const_svp)
18374 {
18375     const char *hvname;
18376     bool is_const = !!CvCONST(old_cv);
18377     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18378
18379     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18380
18381     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18382         return;
18383         /* They are 2 constant subroutines generated from
18384            the same constant. This probably means that
18385            they are really the "same" proxy subroutine
18386            instantiated in 2 places. Most likely this is
18387            when a constant is exported twice.  Don't warn.
18388         */
18389     if (
18390         (ckWARN(WARN_REDEFINE)
18391          && !(
18392                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18393              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18394              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18395                  strEQ(hvname, "autouse"))
18396              )
18397         )
18398      || (is_const
18399          && ckWARN_d(WARN_REDEFINE)
18400          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18401         )
18402     )
18403         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18404                           is_const
18405                             ? "Constant subroutine %" SVf " redefined"
18406                             : "Subroutine %" SVf " redefined",
18407                           SVfARG(name));
18408 }
18409
18410 /*
18411 =head1 Hook manipulation
18412
18413 These functions provide convenient and thread-safe means of manipulating
18414 hook variables.
18415
18416 =cut
18417 */
18418
18419 /*
18420 =for apidoc wrap_op_checker
18421
18422 Puts a C function into the chain of check functions for a specified op
18423 type.  This is the preferred way to manipulate the L</PL_check> array.
18424 C<opcode> specifies which type of op is to be affected.  C<new_checker>
18425 is a pointer to the C function that is to be added to that opcode's
18426 check chain, and C<old_checker_p> points to the storage location where a
18427 pointer to the next function in the chain will be stored.  The value of
18428 C<new_checker> is written into the L</PL_check> array, while the value
18429 previously stored there is written to C<*old_checker_p>.
18430
18431 L</PL_check> is global to an entire process, and a module wishing to
18432 hook op checking may find itself invoked more than once per process,
18433 typically in different threads.  To handle that situation, this function
18434 is idempotent.  The location C<*old_checker_p> must initially (once
18435 per process) contain a null pointer.  A C variable of static duration
18436 (declared at file scope, typically also marked C<static> to give
18437 it internal linkage) will be implicitly initialised appropriately,
18438 if it does not have an explicit initialiser.  This function will only
18439 actually modify the check chain if it finds C<*old_checker_p> to be null.
18440 This function is also thread safe on the small scale.  It uses appropriate
18441 locking to avoid race conditions in accessing L</PL_check>.
18442
18443 When this function is called, the function referenced by C<new_checker>
18444 must be ready to be called, except for C<*old_checker_p> being unfilled.
18445 In a threading situation, C<new_checker> may be called immediately,
18446 even before this function has returned.  C<*old_checker_p> will always
18447 be appropriately set before C<new_checker> is called.  If C<new_checker>
18448 decides not to do anything special with an op that it is given (which
18449 is the usual case for most uses of op check hooking), it must chain the
18450 check function referenced by C<*old_checker_p>.
18451
18452 Taken all together, XS code to hook an op checker should typically look
18453 something like this:
18454
18455     static Perl_check_t nxck_frob;
18456     static OP *myck_frob(pTHX_ OP *op) {
18457         ...
18458         op = nxck_frob(aTHX_ op);
18459         ...
18460         return op;
18461     }
18462     BOOT:
18463         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18464
18465 If you want to influence compilation of calls to a specific subroutine,
18466 then use L</cv_set_call_checker_flags> rather than hooking checking of
18467 all C<entersub> ops.
18468
18469 =cut
18470 */
18471
18472 void
18473 Perl_wrap_op_checker(pTHX_ Optype opcode,
18474     Perl_check_t new_checker, Perl_check_t *old_checker_p)
18475 {
18476     dVAR;
18477
18478     PERL_UNUSED_CONTEXT;
18479     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18480     if (*old_checker_p) return;
18481     OP_CHECK_MUTEX_LOCK;
18482     if (!*old_checker_p) {
18483         *old_checker_p = PL_check[opcode];
18484         PL_check[opcode] = new_checker;
18485     }
18486     OP_CHECK_MUTEX_UNLOCK;
18487 }
18488
18489 #include "XSUB.h"
18490
18491 /* Efficient sub that returns a constant scalar value. */
18492 static void
18493 const_sv_xsub(pTHX_ CV* cv)
18494 {
18495     dXSARGS;
18496     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18497     PERL_UNUSED_ARG(items);
18498     if (!sv) {
18499         XSRETURN(0);
18500     }
18501     EXTEND(sp, 1);
18502     ST(0) = sv;
18503     XSRETURN(1);
18504 }
18505
18506 static void
18507 const_av_xsub(pTHX_ CV* cv)
18508 {
18509     dXSARGS;
18510     AV * const av = MUTABLE_AV(XSANY.any_ptr);
18511     SP -= items;
18512     assert(av);
18513 #ifndef DEBUGGING
18514     if (!av) {
18515         XSRETURN(0);
18516     }
18517 #endif
18518     if (SvRMAGICAL(av))
18519         Perl_croak(aTHX_ "Magical list constants are not supported");
18520     if (GIMME_V != G_ARRAY) {
18521         EXTEND(SP, 1);
18522         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18523         XSRETURN(1);
18524     }
18525     EXTEND(SP, AvFILLp(av)+1);
18526     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18527     XSRETURN(AvFILLp(av)+1);
18528 }
18529
18530 /* Copy an existing cop->cop_warnings field.
18531  * If it's one of the standard addresses, just re-use the address.
18532  * This is the e implementation for the DUP_WARNINGS() macro
18533  */
18534
18535 STRLEN*
18536 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18537 {
18538     Size_t size;
18539     STRLEN *new_warnings;
18540
18541     if (warnings == NULL || specialWARN(warnings))
18542         return warnings;
18543
18544     size = sizeof(*warnings) + *warnings;
18545
18546     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18547     Copy(warnings, new_warnings, size, char);
18548     return new_warnings;
18549 }
18550
18551 /*
18552  * ex: set ts=8 sts=4 sw=4 et:
18553  */