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
11726             SAVEVPTR(PL_curcop);
11727             if (PL_curcop == &PL_compiling) {
11728                 /* Avoid pushing the "global" &PL_compiling onto the
11729                  * context stack. For example, a stack trace inside
11730                  * nested use's would show all calls coming from whoever
11731                  * most recently updated PL_compiling.cop_file and
11732                  * cop_line.  So instead, temporarily set PL_curcop to a
11733                  * private copy of &PL_compiling. PL_curcop will soon be
11734                  * set to point back to &PL_compiling anyway but only
11735                  * after the temp value has been pushed onto the context
11736                  * stack as blk_oldcop.
11737                  * This is slightly hacky, but necessary. Note also
11738                  * that in the brief window before PL_curcop is set back
11739                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11740                  * will give the wrong answer.
11741                  */
11742                 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
11743                 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
11744                 SAVEFREEOP(PL_curcop);
11745             }
11746
11747             PUSHSTACKi(PERLSI_REQUIRE);
11748             SAVECOPFILE(&PL_compiling);
11749             SAVECOPLINE(&PL_compiling);
11750
11751             DEBUG_x( dump_sub(gv) );
11752             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11753             GvCV_set(gv,0);             /* cv has been hijacked */
11754             call_list(oldscope, PL_beginav);
11755
11756             POPSTACK;
11757             LEAVE;
11758             return !PL_savebegin;
11759         }
11760         else
11761             return FALSE;
11762     } else {
11763         if (*name == 'E') {
11764             if (strEQ(name, "END")) {
11765                 DEBUG_x( dump_sub(gv) );
11766                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11767             } else
11768                 return FALSE;
11769         } else if (*name == 'U') {
11770             if (strEQ(name, "UNITCHECK")) {
11771                 /* It's never too late to run a unitcheck block */
11772                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11773             }
11774             else
11775                 return FALSE;
11776         } else if (*name == 'C') {
11777             if (strEQ(name, "CHECK")) {
11778                 if (PL_main_start)
11779                     /* diag_listed_as: Too late to run %s block */
11780                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11781                                    "Too late to run CHECK block");
11782                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11783             }
11784             else
11785                 return FALSE;
11786         } else if (*name == 'I') {
11787             if (strEQ(name, "INIT")) {
11788                 if (PL_main_start)
11789                     /* diag_listed_as: Too late to run %s block */
11790                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11791                                    "Too late to run INIT block");
11792                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11793             }
11794             else
11795                 return FALSE;
11796         } else
11797             return FALSE;
11798         DEBUG_x( dump_sub(gv) );
11799         (void)CvGV(cv);
11800         GvCV_set(gv,0);         /* cv has been hijacked */
11801         return FALSE;
11802     }
11803 }
11804
11805 /*
11806 =for apidoc newCONSTSUB
11807
11808 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11809 rather than of counted length, and no flags are set.  (This means that
11810 C<name> is always interpreted as Latin-1.)
11811
11812 =cut
11813 */
11814
11815 CV *
11816 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11817 {
11818     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11819 }
11820
11821 /*
11822 =for apidoc newCONSTSUB_flags
11823
11824 Construct a constant subroutine, also performing some surrounding
11825 jobs.  A scalar constant-valued subroutine is eligible for inlining
11826 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11827 123 }>>.  Other kinds of constant subroutine have other treatment.
11828
11829 The subroutine will have an empty prototype and will ignore any arguments
11830 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
11831 is null, the subroutine will yield an empty list.  If C<sv> points to a
11832 scalar, the subroutine will always yield that scalar.  If C<sv> points
11833 to an array, the subroutine will always yield a list of the elements of
11834 that array in list context, or the number of elements in the array in
11835 scalar context.  This function takes ownership of one counted reference
11836 to the scalar or array, and will arrange for the object to live as long
11837 as the subroutine does.  If C<sv> points to a scalar then the inlining
11838 assumes that the value of the scalar will never change, so the caller
11839 must ensure that the scalar is not subsequently written to.  If C<sv>
11840 points to an array then no such assumption is made, so it is ostensibly
11841 safe to mutate the array or its elements, but whether this is really
11842 supported has not been determined.
11843
11844 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11845 Other aspects of the subroutine will be left in their default state.
11846 The caller is free to mutate the subroutine beyond its initial state
11847 after this function has returned.
11848
11849 If C<name> is null then the subroutine will be anonymous, with its
11850 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11851 subroutine will be named accordingly, referenced by the appropriate glob.
11852 C<name> is a string of length C<len> bytes giving a sigilless symbol
11853 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11854 otherwise.  The name may be either qualified or unqualified.  If the
11855 name is unqualified then it defaults to being in the stash specified by
11856 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11857 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11858 semantics.
11859
11860 C<flags> should not have bits set other than C<SVf_UTF8>.
11861
11862 If there is already a subroutine of the specified name, then the new sub
11863 will replace the existing one in the glob.  A warning may be generated
11864 about the redefinition.
11865
11866 If the subroutine has one of a few special names, such as C<BEGIN> or
11867 C<END>, then it will be claimed by the appropriate queue for automatic
11868 running of phase-related subroutines.  In this case the relevant glob will
11869 be left not containing any subroutine, even if it did contain one before.
11870 Execution of the subroutine will likely be a no-op, unless C<sv> was
11871 a tied array or the caller modified the subroutine in some interesting
11872 way before it was executed.  In the case of C<BEGIN>, the treatment is
11873 buggy: the sub will be executed when only half built, and may be deleted
11874 prematurely, possibly causing a crash.
11875
11876 The function returns a pointer to the constructed subroutine.  If the sub
11877 is anonymous then ownership of one counted reference to the subroutine
11878 is transferred to the caller.  If the sub is named then the caller does
11879 not get ownership of a reference.  In most such cases, where the sub
11880 has a non-phase name, the sub will be alive at the point it is returned
11881 by virtue of being contained in the glob that names it.  A phase-named
11882 subroutine will usually be alive by virtue of the reference owned by
11883 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
11884 destroyed already by the time this function returns, but currently bugs
11885 occur in that case before the caller gets control.  It is the caller's
11886 responsibility to ensure that it knows which of these situations applies.
11887
11888 =cut
11889 */
11890
11891 CV *
11892 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11893                              U32 flags, SV *sv)
11894 {
11895     CV* cv;
11896     const char *const file = CopFILE(PL_curcop);
11897
11898     ENTER;
11899
11900     if (IN_PERL_RUNTIME) {
11901         /* at runtime, it's not safe to manipulate PL_curcop: it may be
11902          * an op shared between threads. Use a non-shared COP for our
11903          * dirty work */
11904          SAVEVPTR(PL_curcop);
11905          SAVECOMPILEWARNINGS();
11906          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11907          PL_curcop = &PL_compiling;
11908     }
11909     SAVECOPLINE(PL_curcop);
11910     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11911
11912     SAVEHINTS();
11913     PL_hints &= ~HINT_BLOCK_SCOPE;
11914
11915     if (stash) {
11916         SAVEGENERICSV(PL_curstash);
11917         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11918     }
11919
11920     /* Protect sv against leakage caused by fatal warnings. */
11921     if (sv) SAVEFREESV(sv);
11922
11923     /* file becomes the CvFILE. For an XS, it's usually static storage,
11924        and so doesn't get free()d.  (It's expected to be from the C pre-
11925        processor __FILE__ directive). But we need a dynamically allocated one,
11926        and we need it to get freed.  */
11927     cv = newXS_len_flags(name, len,
11928                          sv && SvTYPE(sv) == SVt_PVAV
11929                              ? const_av_xsub
11930                              : const_sv_xsub,
11931                          file ? file : "", "",
11932                          &sv, XS_DYNAMIC_FILENAME | flags);
11933     assert(cv);
11934     assert(SvREFCNT((SV*)cv) != 0);
11935     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11936     CvCONST_on(cv);
11937
11938     LEAVE;
11939
11940     return cv;
11941 }
11942
11943 /*
11944 =for apidoc newXS
11945
11946 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
11947 static storage, as it is used directly as CvFILE(), without a copy being made.
11948
11949 =cut
11950 */
11951
11952 CV *
11953 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11954 {
11955     PERL_ARGS_ASSERT_NEWXS;
11956     return newXS_len_flags(
11957         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11958     );
11959 }
11960
11961 CV *
11962 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11963                  const char *const filename, const char *const proto,
11964                  U32 flags)
11965 {
11966     PERL_ARGS_ASSERT_NEWXS_FLAGS;
11967     return newXS_len_flags(
11968        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11969     );
11970 }
11971
11972 CV *
11973 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11974 {
11975     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11976     return newXS_len_flags(
11977         name, strlen(name), subaddr, NULL, NULL, NULL, 0
11978     );
11979 }
11980
11981 /*
11982 =for apidoc newXS_len_flags
11983
11984 Construct an XS subroutine, also performing some surrounding jobs.
11985
11986 The subroutine will have the entry point C<subaddr>.  It will have
11987 the prototype specified by the nul-terminated string C<proto>, or
11988 no prototype if C<proto> is null.  The prototype string is copied;
11989 the caller can mutate the supplied string afterwards.  If C<filename>
11990 is non-null, it must be a nul-terminated filename, and the subroutine
11991 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
11992 point directly to the supplied string, which must be static.  If C<flags>
11993 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11994 be taken instead.
11995
11996 Other aspects of the subroutine will be left in their default state.
11997 If anything else needs to be done to the subroutine for it to function
11998 correctly, it is the caller's responsibility to do that after this
11999 function has constructed it.  However, beware of the subroutine
12000 potentially being destroyed before this function returns, as described
12001 below.
12002
12003 If C<name> is null then the subroutine will be anonymous, with its
12004 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
12005 subroutine will be named accordingly, referenced by the appropriate glob.
12006 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
12007 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
12008 The name may be either qualified or unqualified, with the stash defaulting
12009 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
12010 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
12011 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
12012 the stash if necessary, with C<GV_ADDMULTI> semantics.
12013
12014 If there is already a subroutine of the specified name, then the new sub
12015 will replace the existing one in the glob.  A warning may be generated
12016 about the redefinition.  If the old subroutine was C<CvCONST> then the
12017 decision about whether to warn is influenced by an expectation about
12018 whether the new subroutine will become a constant of similar value.
12019 That expectation is determined by C<const_svp>.  (Note that the call to
12020 this function doesn't make the new subroutine C<CvCONST> in any case;
12021 that is left to the caller.)  If C<const_svp> is null then it indicates
12022 that the new subroutine will not become a constant.  If C<const_svp>
12023 is non-null then it indicates that the new subroutine will become a
12024 constant, and it points to an C<SV*> that provides the constant value
12025 that the subroutine will have.
12026
12027 If the subroutine has one of a few special names, such as C<BEGIN> or
12028 C<END>, then it will be claimed by the appropriate queue for automatic
12029 running of phase-related subroutines.  In this case the relevant glob will
12030 be left not containing any subroutine, even if it did contain one before.
12031 In the case of C<BEGIN>, the subroutine will be executed and the reference
12032 to it disposed of before this function returns, and also before its
12033 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
12034 constructed by this function to be ready for execution then the caller
12035 must prevent this happening by giving the subroutine a different name.
12036
12037 The function returns a pointer to the constructed subroutine.  If the sub
12038 is anonymous then ownership of one counted reference to the subroutine
12039 is transferred to the caller.  If the sub is named then the caller does
12040 not get ownership of a reference.  In most such cases, where the sub
12041 has a non-phase name, the sub will be alive at the point it is returned
12042 by virtue of being contained in the glob that names it.  A phase-named
12043 subroutine will usually be alive by virtue of the reference owned by the
12044 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
12045 been executed, will quite likely have been destroyed already by the
12046 time this function returns, making it erroneous for the caller to make
12047 any use of the returned pointer.  It is the caller's responsibility to
12048 ensure that it knows which of these situations applies.
12049
12050 =cut
12051 */
12052
12053 CV *
12054 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
12055                            XSUBADDR_t subaddr, const char *const filename,
12056                            const char *const proto, SV **const_svp,
12057                            U32 flags)
12058 {
12059     CV *cv;
12060     bool interleave = FALSE;
12061     bool evanescent = FALSE;
12062
12063     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
12064
12065     {
12066         GV * const gv = gv_fetchpvn(
12067                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
12068                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
12069                                 sizeof("__ANON__::__ANON__") - 1,
12070                             GV_ADDMULTI | flags, SVt_PVCV);
12071
12072         if ((cv = (name ? GvCV(gv) : NULL))) {
12073             if (GvCVGEN(gv)) {
12074                 /* just a cached method */
12075                 SvREFCNT_dec(cv);
12076                 cv = NULL;
12077             }
12078             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
12079                 /* already defined (or promised) */
12080                 /* Redundant check that allows us to avoid creating an SV
12081                    most of the time: */
12082                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
12083                     report_redefined_cv(newSVpvn_flags(
12084                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
12085                                         ),
12086                                         cv, const_svp);
12087                 }
12088                 interleave = TRUE;
12089                 ENTER;
12090                 SAVEFREESV(cv);
12091                 cv = NULL;
12092             }
12093         }
12094
12095         if (cv)                         /* must reuse cv if autoloaded */
12096             cv_undef(cv);
12097         else {
12098             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12099             if (name) {
12100                 GvCV_set(gv,cv);
12101                 GvCVGEN(gv) = 0;
12102                 if (HvENAME_HEK(GvSTASH(gv)))
12103                     gv_method_changed(gv); /* newXS */
12104             }
12105         }
12106         assert(cv);
12107         assert(SvREFCNT((SV*)cv) != 0);
12108
12109         CvGV_set(cv, gv);
12110         if(filename) {
12111             /* XSUBs can't be perl lang/perl5db.pl debugged
12112             if (PERLDB_LINE_OR_SAVESRC)
12113                 (void)gv_fetchfile(filename); */
12114             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
12115             if (flags & XS_DYNAMIC_FILENAME) {
12116                 CvDYNFILE_on(cv);
12117                 CvFILE(cv) = savepv(filename);
12118             } else {
12119             /* NOTE: not copied, as it is expected to be an external constant string */
12120                 CvFILE(cv) = (char *)filename;
12121             }
12122         } else {
12123             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
12124             CvFILE(cv) = (char*)PL_xsubfilename;
12125         }
12126         CvISXSUB_on(cv);
12127         CvXSUB(cv) = subaddr;
12128 #ifndef PERL_IMPLICIT_CONTEXT
12129         CvHSCXT(cv) = &PL_stack_sp;
12130 #else
12131         PoisonPADLIST(cv);
12132 #endif
12133
12134         if (name)
12135             evanescent = process_special_blocks(0, name, gv, cv);
12136         else
12137             CvANON_on(cv);
12138     } /* <- not a conditional branch */
12139
12140     assert(cv);
12141     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12142
12143     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
12144     if (interleave) LEAVE;
12145     assert(evanescent || SvREFCNT((SV*)cv) != 0);
12146     return cv;
12147 }
12148
12149 /* Add a stub CV to a typeglob.
12150  * This is the implementation of a forward declaration, 'sub foo';'
12151  */
12152
12153 CV *
12154 Perl_newSTUB(pTHX_ GV *gv, bool fake)
12155 {
12156     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
12157     GV *cvgv;
12158     PERL_ARGS_ASSERT_NEWSTUB;
12159     assert(!GvCVu(gv));
12160     GvCV_set(gv, cv);
12161     GvCVGEN(gv) = 0;
12162     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
12163         gv_method_changed(gv);
12164     if (SvFAKE(gv)) {
12165         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
12166         SvFAKE_off(cvgv);
12167     }
12168     else cvgv = gv;
12169     CvGV_set(cv, cvgv);
12170     CvFILE_set_from_cop(cv, PL_curcop);
12171     CvSTASH_set(cv, PL_curstash);
12172     GvMULTI_on(gv);
12173     return cv;
12174 }
12175
12176 void
12177 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12178 {
12179     CV *cv;
12180     GV *gv;
12181     OP *root;
12182     OP *start;
12183
12184     if (PL_parser && PL_parser->error_count) {
12185         op_free(block);
12186         goto finish;
12187     }
12188
12189     gv = o
12190         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12191         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12192
12193     GvMULTI_on(gv);
12194     if ((cv = GvFORM(gv))) {
12195         if (ckWARN(WARN_REDEFINE)) {
12196             const line_t oldline = CopLINE(PL_curcop);
12197             if (PL_parser && PL_parser->copline != NOLINE)
12198                 CopLINE_set(PL_curcop, PL_parser->copline);
12199             if (o) {
12200                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12201                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12202             } else {
12203                 /* diag_listed_as: Format %s redefined */
12204                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12205                             "Format STDOUT redefined");
12206             }
12207             CopLINE_set(PL_curcop, oldline);
12208         }
12209         SvREFCNT_dec(cv);
12210     }
12211     cv = PL_compcv;
12212     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12213     CvGV_set(cv, gv);
12214     CvFILE_set_from_cop(cv, PL_curcop);
12215
12216
12217     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12218     CvROOT(cv) = root;
12219     start = LINKLIST(root);
12220     root->op_next = 0;
12221     S_process_optree(aTHX_ cv, root, start);
12222     cv_forget_slab(cv);
12223
12224   finish:
12225     op_free(o);
12226     if (PL_parser)
12227         PL_parser->copline = NOLINE;
12228     LEAVE_SCOPE(floor);
12229     PL_compiling.cop_seq = 0;
12230 }
12231
12232 OP *
12233 Perl_newANONLIST(pTHX_ OP *o)
12234 {
12235     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12236 }
12237
12238 OP *
12239 Perl_newANONHASH(pTHX_ OP *o)
12240 {
12241     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12242 }
12243
12244 OP *
12245 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12246 {
12247     return newANONATTRSUB(floor, proto, NULL, block);
12248 }
12249
12250 OP *
12251 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12252 {
12253     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12254     OP * anoncode =
12255         newSVOP(OP_ANONCODE, 0,
12256                 cv);
12257     if (CvANONCONST(cv))
12258         anoncode = newUNOP(OP_ANONCONST, 0,
12259                            op_convert_list(OP_ENTERSUB,
12260                                            OPf_STACKED|OPf_WANT_SCALAR,
12261                                            anoncode));
12262     return newUNOP(OP_REFGEN, 0, anoncode);
12263 }
12264
12265 OP *
12266 Perl_oopsAV(pTHX_ OP *o)
12267 {
12268     dVAR;
12269
12270     PERL_ARGS_ASSERT_OOPSAV;
12271
12272     switch (o->op_type) {
12273     case OP_PADSV:
12274     case OP_PADHV:
12275         OpTYPE_set(o, OP_PADAV);
12276         return ref(o, OP_RV2AV);
12277
12278     case OP_RV2SV:
12279     case OP_RV2HV:
12280         OpTYPE_set(o, OP_RV2AV);
12281         ref(o, OP_RV2AV);
12282         break;
12283
12284     default:
12285         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12286         break;
12287     }
12288     return o;
12289 }
12290
12291 OP *
12292 Perl_oopsHV(pTHX_ OP *o)
12293 {
12294     dVAR;
12295
12296     PERL_ARGS_ASSERT_OOPSHV;
12297
12298     switch (o->op_type) {
12299     case OP_PADSV:
12300     case OP_PADAV:
12301         OpTYPE_set(o, OP_PADHV);
12302         return ref(o, OP_RV2HV);
12303
12304     case OP_RV2SV:
12305     case OP_RV2AV:
12306         OpTYPE_set(o, OP_RV2HV);
12307         /* rv2hv steals the bottom bit for its own uses */
12308         o->op_private &= ~OPpARG1_MASK;
12309         ref(o, OP_RV2HV);
12310         break;
12311
12312     default:
12313         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12314         break;
12315     }
12316     return o;
12317 }
12318
12319 OP *
12320 Perl_newAVREF(pTHX_ OP *o)
12321 {
12322     dVAR;
12323
12324     PERL_ARGS_ASSERT_NEWAVREF;
12325
12326     if (o->op_type == OP_PADANY) {
12327         OpTYPE_set(o, OP_PADAV);
12328         return o;
12329     }
12330     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12331         Perl_croak(aTHX_ "Can't use an array as a reference");
12332     }
12333     return newUNOP(OP_RV2AV, 0, scalar(o));
12334 }
12335
12336 OP *
12337 Perl_newGVREF(pTHX_ I32 type, OP *o)
12338 {
12339     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12340         return newUNOP(OP_NULL, 0, o);
12341     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12342 }
12343
12344 OP *
12345 Perl_newHVREF(pTHX_ OP *o)
12346 {
12347     dVAR;
12348
12349     PERL_ARGS_ASSERT_NEWHVREF;
12350
12351     if (o->op_type == OP_PADANY) {
12352         OpTYPE_set(o, OP_PADHV);
12353         return o;
12354     }
12355     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12356         Perl_croak(aTHX_ "Can't use a hash as a reference");
12357     }
12358     return newUNOP(OP_RV2HV, 0, scalar(o));
12359 }
12360
12361 OP *
12362 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12363 {
12364     if (o->op_type == OP_PADANY) {
12365         dVAR;
12366         OpTYPE_set(o, OP_PADCV);
12367     }
12368     return newUNOP(OP_RV2CV, flags, scalar(o));
12369 }
12370
12371 OP *
12372 Perl_newSVREF(pTHX_ OP *o)
12373 {
12374     dVAR;
12375
12376     PERL_ARGS_ASSERT_NEWSVREF;
12377
12378     if (o->op_type == OP_PADANY) {
12379         OpTYPE_set(o, OP_PADSV);
12380         scalar(o);
12381         return o;
12382     }
12383     return newUNOP(OP_RV2SV, 0, scalar(o));
12384 }
12385
12386 /* Check routines. See the comments at the top of this file for details
12387  * on when these are called */
12388
12389 OP *
12390 Perl_ck_anoncode(pTHX_ OP *o)
12391 {
12392     PERL_ARGS_ASSERT_CK_ANONCODE;
12393
12394     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12395     cSVOPo->op_sv = NULL;
12396     return o;
12397 }
12398
12399 static void
12400 S_io_hints(pTHX_ OP *o)
12401 {
12402 #if O_BINARY != 0 || O_TEXT != 0
12403     HV * const table =
12404         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12405     if (table) {
12406         SV **svp = hv_fetchs(table, "open_IN", FALSE);
12407         if (svp && *svp) {
12408             STRLEN len = 0;
12409             const char *d = SvPV_const(*svp, len);
12410             const I32 mode = mode_from_discipline(d, len);
12411             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12412 #  if O_BINARY != 0
12413             if (mode & O_BINARY)
12414                 o->op_private |= OPpOPEN_IN_RAW;
12415 #  endif
12416 #  if O_TEXT != 0
12417             if (mode & O_TEXT)
12418                 o->op_private |= OPpOPEN_IN_CRLF;
12419 #  endif
12420         }
12421
12422         svp = hv_fetchs(table, "open_OUT", FALSE);
12423         if (svp && *svp) {
12424             STRLEN len = 0;
12425             const char *d = SvPV_const(*svp, len);
12426             const I32 mode = mode_from_discipline(d, len);
12427             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12428 #  if O_BINARY != 0
12429             if (mode & O_BINARY)
12430                 o->op_private |= OPpOPEN_OUT_RAW;
12431 #  endif
12432 #  if O_TEXT != 0
12433             if (mode & O_TEXT)
12434                 o->op_private |= OPpOPEN_OUT_CRLF;
12435 #  endif
12436         }
12437     }
12438 #else
12439     PERL_UNUSED_CONTEXT;
12440     PERL_UNUSED_ARG(o);
12441 #endif
12442 }
12443
12444 OP *
12445 Perl_ck_backtick(pTHX_ OP *o)
12446 {
12447     GV *gv;
12448     OP *newop = NULL;
12449     OP *sibl;
12450     PERL_ARGS_ASSERT_CK_BACKTICK;
12451     o = ck_fun(o);
12452     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12453     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12454      && (gv = gv_override("readpipe",8)))
12455     {
12456         /* detach rest of siblings from o and its first child */
12457         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12458         newop = S_new_entersubop(aTHX_ gv, sibl);
12459     }
12460     else if (!(o->op_flags & OPf_KIDS))
12461         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12462     if (newop) {
12463         op_free(o);
12464         return newop;
12465     }
12466     S_io_hints(aTHX_ o);
12467     return o;
12468 }
12469
12470 OP *
12471 Perl_ck_bitop(pTHX_ OP *o)
12472 {
12473     PERL_ARGS_ASSERT_CK_BITOP;
12474
12475     o->op_private = (U8)(PL_hints & HINT_INTEGER);
12476
12477     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12478             && OP_IS_INFIX_BIT(o->op_type))
12479     {
12480         const OP * const left = cBINOPo->op_first;
12481         const OP * const right = OpSIBLING(left);
12482         if ((OP_IS_NUMCOMPARE(left->op_type) &&
12483                 (left->op_flags & OPf_PARENS) == 0) ||
12484             (OP_IS_NUMCOMPARE(right->op_type) &&
12485                 (right->op_flags & OPf_PARENS) == 0))
12486             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12487                           "Possible precedence problem on bitwise %s operator",
12488                            o->op_type ==  OP_BIT_OR
12489                          ||o->op_type == OP_NBIT_OR  ? "|"
12490                         :  o->op_type ==  OP_BIT_AND
12491                          ||o->op_type == OP_NBIT_AND ? "&"
12492                         :  o->op_type ==  OP_BIT_XOR
12493                          ||o->op_type == OP_NBIT_XOR ? "^"
12494                         :  o->op_type == OP_SBIT_OR  ? "|."
12495                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
12496                            );
12497     }
12498     return o;
12499 }
12500
12501 PERL_STATIC_INLINE bool
12502 is_dollar_bracket(pTHX_ const OP * const o)
12503 {
12504     const OP *kid;
12505     PERL_UNUSED_CONTEXT;
12506     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12507         && (kid = cUNOPx(o)->op_first)
12508         && kid->op_type == OP_GV
12509         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12510 }
12511
12512 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12513
12514 OP *
12515 Perl_ck_cmp(pTHX_ OP *o)
12516 {
12517     bool is_eq;
12518     bool neg;
12519     bool reverse;
12520     bool iv0;
12521     OP *indexop, *constop, *start;
12522     SV *sv;
12523     IV iv;
12524
12525     PERL_ARGS_ASSERT_CK_CMP;
12526
12527     is_eq = (   o->op_type == OP_EQ
12528              || o->op_type == OP_NE
12529              || o->op_type == OP_I_EQ
12530              || o->op_type == OP_I_NE);
12531
12532     if (!is_eq && ckWARN(WARN_SYNTAX)) {
12533         const OP *kid = cUNOPo->op_first;
12534         if (kid &&
12535             (
12536                 (   is_dollar_bracket(aTHX_ kid)
12537                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12538                 )
12539              || (   kid->op_type == OP_CONST
12540                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12541                 )
12542            )
12543         )
12544             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12545                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12546     }
12547
12548     /* convert (index(...) == -1) and variations into
12549      *   (r)index/BOOL(,NEG)
12550      */
12551
12552     reverse = FALSE;
12553
12554     indexop = cUNOPo->op_first;
12555     constop = OpSIBLING(indexop);
12556     start = NULL;
12557     if (indexop->op_type == OP_CONST) {
12558         constop = indexop;
12559         indexop = OpSIBLING(constop);
12560         start = constop;
12561         reverse = TRUE;
12562     }
12563
12564     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12565         return o;
12566
12567     /* ($lex = index(....)) == -1 */
12568     if (indexop->op_private & OPpTARGET_MY)
12569         return o;
12570
12571     if (constop->op_type != OP_CONST)
12572         return o;
12573
12574     sv = cSVOPx_sv(constop);
12575     if (!(sv && SvIOK_notUV(sv)))
12576         return o;
12577
12578     iv = SvIVX(sv);
12579     if (iv != -1 && iv != 0)
12580         return o;
12581     iv0 = (iv == 0);
12582
12583     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12584         if (!(iv0 ^ reverse))
12585             return o;
12586         neg = iv0;
12587     }
12588     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12589         if (iv0 ^ reverse)
12590             return o;
12591         neg = !iv0;
12592     }
12593     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12594         if (!(iv0 ^ reverse))
12595             return o;
12596         neg = !iv0;
12597     }
12598     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12599         if (iv0 ^ reverse)
12600             return o;
12601         neg = iv0;
12602     }
12603     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12604         if (iv0)
12605             return o;
12606         neg = TRUE;
12607     }
12608     else {
12609         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12610         if (iv0)
12611             return o;
12612         neg = FALSE;
12613     }
12614
12615     indexop->op_flags &= ~OPf_PARENS;
12616     indexop->op_flags |= (o->op_flags & OPf_PARENS);
12617     indexop->op_private |= OPpTRUEBOOL;
12618     if (neg)
12619         indexop->op_private |= OPpINDEX_BOOLNEG;
12620     /* cut out the index op and free the eq,const ops */
12621     (void)op_sibling_splice(o, start, 1, NULL);
12622     op_free(o);
12623
12624     return indexop;
12625 }
12626
12627
12628 OP *
12629 Perl_ck_concat(pTHX_ OP *o)
12630 {
12631     const OP * const kid = cUNOPo->op_first;
12632
12633     PERL_ARGS_ASSERT_CK_CONCAT;
12634     PERL_UNUSED_CONTEXT;
12635
12636     /* reuse the padtmp returned by the concat child */
12637     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12638             !(kUNOP->op_first->op_flags & OPf_MOD))
12639     {
12640         o->op_flags |= OPf_STACKED;
12641         o->op_private |= OPpCONCAT_NESTED;
12642     }
12643     return o;
12644 }
12645
12646 OP *
12647 Perl_ck_spair(pTHX_ OP *o)
12648 {
12649     dVAR;
12650
12651     PERL_ARGS_ASSERT_CK_SPAIR;
12652
12653     if (o->op_flags & OPf_KIDS) {
12654         OP* newop;
12655         OP* kid;
12656         OP* kidkid;
12657         const OPCODE type = o->op_type;
12658         o = modkids(ck_fun(o), type);
12659         kid    = cUNOPo->op_first;
12660         kidkid = kUNOP->op_first;
12661         newop = OpSIBLING(kidkid);
12662         if (newop) {
12663             const OPCODE type = newop->op_type;
12664             if (OpHAS_SIBLING(newop))
12665                 return o;
12666             if (o->op_type == OP_REFGEN
12667              && (  type == OP_RV2CV
12668                 || (  !(newop->op_flags & OPf_PARENS)
12669                    && (  type == OP_RV2AV || type == OP_PADAV
12670                       || type == OP_RV2HV || type == OP_PADHV))))
12671                 NOOP; /* OK (allow srefgen for \@a and \%h) */
12672             else if (OP_GIMME(newop,0) != G_SCALAR)
12673                 return o;
12674         }
12675         /* excise first sibling */
12676         op_sibling_splice(kid, NULL, 1, NULL);
12677         op_free(kidkid);
12678     }
12679     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12680      * and OP_CHOMP into OP_SCHOMP */
12681     o->op_ppaddr = PL_ppaddr[++o->op_type];
12682     return ck_fun(o);
12683 }
12684
12685 OP *
12686 Perl_ck_delete(pTHX_ OP *o)
12687 {
12688     PERL_ARGS_ASSERT_CK_DELETE;
12689
12690     o = ck_fun(o);
12691     o->op_private = 0;
12692     if (o->op_flags & OPf_KIDS) {
12693         OP * const kid = cUNOPo->op_first;
12694         switch (kid->op_type) {
12695         case OP_ASLICE:
12696             o->op_flags |= OPf_SPECIAL;
12697             /* FALLTHROUGH */
12698         case OP_HSLICE:
12699             o->op_private |= OPpSLICE;
12700             break;
12701         case OP_AELEM:
12702             o->op_flags |= OPf_SPECIAL;
12703             /* FALLTHROUGH */
12704         case OP_HELEM:
12705             break;
12706         case OP_KVASLICE:
12707             o->op_flags |= OPf_SPECIAL;
12708             /* FALLTHROUGH */
12709         case OP_KVHSLICE:
12710             o->op_private |= OPpKVSLICE;
12711             break;
12712         default:
12713             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12714                              "element or slice");
12715         }
12716         if (kid->op_private & OPpLVAL_INTRO)
12717             o->op_private |= OPpLVAL_INTRO;
12718         op_null(kid);
12719     }
12720     return o;
12721 }
12722
12723 OP *
12724 Perl_ck_eof(pTHX_ OP *o)
12725 {
12726     PERL_ARGS_ASSERT_CK_EOF;
12727
12728     if (o->op_flags & OPf_KIDS) {
12729         OP *kid;
12730         if (cLISTOPo->op_first->op_type == OP_STUB) {
12731             OP * const newop
12732                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12733             op_free(o);
12734             o = newop;
12735         }
12736         o = ck_fun(o);
12737         kid = cLISTOPo->op_first;
12738         if (kid->op_type == OP_RV2GV)
12739             kid->op_private |= OPpALLOW_FAKE;
12740     }
12741     return o;
12742 }
12743
12744
12745 OP *
12746 Perl_ck_eval(pTHX_ OP *o)
12747 {
12748     dVAR;
12749
12750     PERL_ARGS_ASSERT_CK_EVAL;
12751
12752     PL_hints |= HINT_BLOCK_SCOPE;
12753     if (o->op_flags & OPf_KIDS) {
12754         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12755         assert(kid);
12756
12757         if (o->op_type == OP_ENTERTRY) {
12758             LOGOP *enter;
12759
12760             /* cut whole sibling chain free from o */
12761             op_sibling_splice(o, NULL, -1, NULL);
12762             op_free(o);
12763
12764             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12765
12766             /* establish postfix order */
12767             enter->op_next = (OP*)enter;
12768
12769             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12770             OpTYPE_set(o, OP_LEAVETRY);
12771             enter->op_other = o;
12772             return o;
12773         }
12774         else {
12775             scalar((OP*)kid);
12776             S_set_haseval(aTHX);
12777         }
12778     }
12779     else {
12780         const U8 priv = o->op_private;
12781         op_free(o);
12782         /* the newUNOP will recursively call ck_eval(), which will handle
12783          * all the stuff at the end of this function, like adding
12784          * OP_HINTSEVAL
12785          */
12786         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12787     }
12788     o->op_targ = (PADOFFSET)PL_hints;
12789     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12790     if ((PL_hints & HINT_LOCALIZE_HH) != 0
12791      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12792         /* Store a copy of %^H that pp_entereval can pick up. */
12793         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12794         OP *hhop;
12795         STOREFEATUREBITSHH(hh);
12796         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12797         /* append hhop to only child  */
12798         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12799
12800         o->op_private |= OPpEVAL_HAS_HH;
12801     }
12802     if (!(o->op_private & OPpEVAL_BYTES)
12803          && FEATURE_UNIEVAL_IS_ENABLED)
12804             o->op_private |= OPpEVAL_UNICODE;
12805     return o;
12806 }
12807
12808 OP *
12809 Perl_ck_exec(pTHX_ OP *o)
12810 {
12811     PERL_ARGS_ASSERT_CK_EXEC;
12812
12813     if (o->op_flags & OPf_STACKED) {
12814         OP *kid;
12815         o = ck_fun(o);
12816         kid = OpSIBLING(cUNOPo->op_first);
12817         if (kid->op_type == OP_RV2GV)
12818             op_null(kid);
12819     }
12820     else
12821         o = listkids(o);
12822     return o;
12823 }
12824
12825 OP *
12826 Perl_ck_exists(pTHX_ OP *o)
12827 {
12828     PERL_ARGS_ASSERT_CK_EXISTS;
12829
12830     o = ck_fun(o);
12831     if (o->op_flags & OPf_KIDS) {
12832         OP * const kid = cUNOPo->op_first;
12833         if (kid->op_type == OP_ENTERSUB) {
12834             (void) ref(kid, o->op_type);
12835             if (kid->op_type != OP_RV2CV
12836                         && !(PL_parser && PL_parser->error_count))
12837                 Perl_croak(aTHX_
12838                           "exists argument is not a subroutine name");
12839             o->op_private |= OPpEXISTS_SUB;
12840         }
12841         else if (kid->op_type == OP_AELEM)
12842             o->op_flags |= OPf_SPECIAL;
12843         else if (kid->op_type != OP_HELEM)
12844             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12845                              "element or a subroutine");
12846         op_null(kid);
12847     }
12848     return o;
12849 }
12850
12851 OP *
12852 Perl_ck_rvconst(pTHX_ OP *o)
12853 {
12854     dVAR;
12855     SVOP * const kid = (SVOP*)cUNOPo->op_first;
12856
12857     PERL_ARGS_ASSERT_CK_RVCONST;
12858
12859     if (o->op_type == OP_RV2HV)
12860         /* rv2hv steals the bottom bit for its own uses */
12861         o->op_private &= ~OPpARG1_MASK;
12862
12863     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12864
12865     if (kid->op_type == OP_CONST) {
12866         int iscv;
12867         GV *gv;
12868         SV * const kidsv = kid->op_sv;
12869
12870         /* Is it a constant from cv_const_sv()? */
12871         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12872             return o;
12873         }
12874         if (SvTYPE(kidsv) == SVt_PVAV) return o;
12875         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12876             const char *badthing;
12877             switch (o->op_type) {
12878             case OP_RV2SV:
12879                 badthing = "a SCALAR";
12880                 break;
12881             case OP_RV2AV:
12882                 badthing = "an ARRAY";
12883                 break;
12884             case OP_RV2HV:
12885                 badthing = "a HASH";
12886                 break;
12887             default:
12888                 badthing = NULL;
12889                 break;
12890             }
12891             if (badthing)
12892                 Perl_croak(aTHX_
12893                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12894                            SVfARG(kidsv), badthing);
12895         }
12896         /*
12897          * This is a little tricky.  We only want to add the symbol if we
12898          * didn't add it in the lexer.  Otherwise we get duplicate strict
12899          * warnings.  But if we didn't add it in the lexer, we must at
12900          * least pretend like we wanted to add it even if it existed before,
12901          * or we get possible typo warnings.  OPpCONST_ENTERED says
12902          * whether the lexer already added THIS instance of this symbol.
12903          */
12904         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12905         gv = gv_fetchsv(kidsv,
12906                 o->op_type == OP_RV2CV
12907                         && o->op_private & OPpMAY_RETURN_CONSTANT
12908                     ? GV_NOEXPAND
12909                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
12910                 iscv
12911                     ? SVt_PVCV
12912                     : o->op_type == OP_RV2SV
12913                         ? SVt_PV
12914                         : o->op_type == OP_RV2AV
12915                             ? SVt_PVAV
12916                             : o->op_type == OP_RV2HV
12917                                 ? SVt_PVHV
12918                                 : SVt_PVGV);
12919         if (gv) {
12920             if (!isGV(gv)) {
12921                 assert(iscv);
12922                 assert(SvROK(gv));
12923                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12924                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
12925                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12926             }
12927             OpTYPE_set(kid, OP_GV);
12928             SvREFCNT_dec(kid->op_sv);
12929 #ifdef USE_ITHREADS
12930             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12931             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12932             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12933             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12934             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12935 #else
12936             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12937 #endif
12938             kid->op_private = 0;
12939             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12940             SvFAKE_off(gv);
12941         }
12942     }
12943     return o;
12944 }
12945
12946 OP *
12947 Perl_ck_ftst(pTHX_ OP *o)
12948 {
12949     dVAR;
12950     const I32 type = o->op_type;
12951
12952     PERL_ARGS_ASSERT_CK_FTST;
12953
12954     if (o->op_flags & OPf_REF) {
12955         NOOP;
12956     }
12957     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12958         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12959         const OPCODE kidtype = kid->op_type;
12960
12961         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12962          && !kid->op_folded) {
12963             OP * const newop = newGVOP(type, OPf_REF,
12964                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12965             op_free(o);
12966             return newop;
12967         }
12968
12969         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12970             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12971             if (name) {
12972                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12973                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12974                             array_passed_to_stat, name);
12975             }
12976             else {
12977                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12978                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12979             }
12980        }
12981         scalar((OP *) kid);
12982         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12983             o->op_private |= OPpFT_ACCESS;
12984         if (OP_IS_FILETEST(type)
12985             && OP_IS_FILETEST(kidtype)
12986         ) {
12987             o->op_private |= OPpFT_STACKED;
12988             kid->op_private |= OPpFT_STACKING;
12989             if (kidtype == OP_FTTTY && (
12990                    !(kid->op_private & OPpFT_STACKED)
12991                 || kid->op_private & OPpFT_AFTER_t
12992                ))
12993                 o->op_private |= OPpFT_AFTER_t;
12994         }
12995     }
12996     else {
12997         op_free(o);
12998         if (type == OP_FTTTY)
12999             o = newGVOP(type, OPf_REF, PL_stdingv);
13000         else
13001             o = newUNOP(type, 0, newDEFSVOP());
13002     }
13003     return o;
13004 }
13005
13006 OP *
13007 Perl_ck_fun(pTHX_ OP *o)
13008 {
13009     const int type = o->op_type;
13010     I32 oa = PL_opargs[type] >> OASHIFT;
13011
13012     PERL_ARGS_ASSERT_CK_FUN;
13013
13014     if (o->op_flags & OPf_STACKED) {
13015         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
13016             oa &= ~OA_OPTIONAL;
13017         else
13018             return no_fh_allowed(o);
13019     }
13020
13021     if (o->op_flags & OPf_KIDS) {
13022         OP *prev_kid = NULL;
13023         OP *kid = cLISTOPo->op_first;
13024         I32 numargs = 0;
13025         bool seen_optional = FALSE;
13026
13027         if (kid->op_type == OP_PUSHMARK ||
13028             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
13029         {
13030             prev_kid = kid;
13031             kid = OpSIBLING(kid);
13032         }
13033         if (kid && kid->op_type == OP_COREARGS) {
13034             bool optional = FALSE;
13035             while (oa) {
13036                 numargs++;
13037                 if (oa & OA_OPTIONAL) optional = TRUE;
13038                 oa = oa >> 4;
13039             }
13040             if (optional) o->op_private |= numargs;
13041             return o;
13042         }
13043
13044         while (oa) {
13045             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
13046                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
13047                     kid = newDEFSVOP();
13048                     /* append kid to chain */
13049                     op_sibling_splice(o, prev_kid, 0, kid);
13050                 }
13051                 seen_optional = TRUE;
13052             }
13053             if (!kid) break;
13054
13055             numargs++;
13056             switch (oa & 7) {
13057             case OA_SCALAR:
13058                 /* list seen where single (scalar) arg expected? */
13059                 if (numargs == 1 && !(oa >> 4)
13060                     && kid->op_type == OP_LIST && type != OP_SCALAR)
13061                 {
13062                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13063                 }
13064                 if (type != OP_DELETE) scalar(kid);
13065                 break;
13066             case OA_LIST:
13067                 if (oa < 16) {
13068                     kid = 0;
13069                     continue;
13070                 }
13071                 else
13072                     list(kid);
13073                 break;
13074             case OA_AVREF:
13075                 if ((type == OP_PUSH || type == OP_UNSHIFT)
13076                     && !OpHAS_SIBLING(kid))
13077                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
13078                                    "Useless use of %s with no values",
13079                                    PL_op_desc[type]);
13080
13081                 if (kid->op_type == OP_CONST
13082                       && (  !SvROK(cSVOPx_sv(kid))
13083                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
13084                         )
13085                     bad_type_pv(numargs, "array", o, kid);
13086                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
13087                          || kid->op_type == OP_RV2GV) {
13088                     bad_type_pv(1, "array", o, kid);
13089                 }
13090                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
13091                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
13092                                          PL_op_desc[type]), 0);
13093                 }
13094                 else {
13095                     op_lvalue(kid, type);
13096                 }
13097                 break;
13098             case OA_HVREF:
13099                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
13100                     bad_type_pv(numargs, "hash", o, kid);
13101                 op_lvalue(kid, type);
13102                 break;
13103             case OA_CVREF:
13104                 {
13105                     /* replace kid with newop in chain */
13106                     OP * const newop =
13107                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
13108                     newop->op_next = newop;
13109                     kid = newop;
13110                 }
13111                 break;
13112             case OA_FILEREF:
13113                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
13114                     if (kid->op_type == OP_CONST &&
13115                         (kid->op_private & OPpCONST_BARE))
13116                     {
13117                         OP * const newop = newGVOP(OP_GV, 0,
13118                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
13119                         /* replace kid with newop in chain */
13120                         op_sibling_splice(o, prev_kid, 1, newop);
13121                         op_free(kid);
13122                         kid = newop;
13123                     }
13124                     else if (kid->op_type == OP_READLINE) {
13125                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
13126                         bad_type_pv(numargs, "HANDLE", o, kid);
13127                     }
13128                     else {
13129                         I32 flags = OPf_SPECIAL;
13130                         I32 priv = 0;
13131                         PADOFFSET targ = 0;
13132
13133                         /* is this op a FH constructor? */
13134                         if (is_handle_constructor(o,numargs)) {
13135                             const char *name = NULL;
13136                             STRLEN len = 0;
13137                             U32 name_utf8 = 0;
13138                             bool want_dollar = TRUE;
13139
13140                             flags = 0;
13141                             /* Set a flag to tell rv2gv to vivify
13142                              * need to "prove" flag does not mean something
13143                              * else already - NI-S 1999/05/07
13144                              */
13145                             priv = OPpDEREF;
13146                             if (kid->op_type == OP_PADSV) {
13147                                 PADNAME * const pn
13148                                     = PAD_COMPNAME_SV(kid->op_targ);
13149                                 name = PadnamePV (pn);
13150                                 len  = PadnameLEN(pn);
13151                                 name_utf8 = PadnameUTF8(pn);
13152                             }
13153                             else if (kid->op_type == OP_RV2SV
13154                                      && kUNOP->op_first->op_type == OP_GV)
13155                             {
13156                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
13157                                 name = GvNAME(gv);
13158                                 len = GvNAMELEN(gv);
13159                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
13160                             }
13161                             else if (kid->op_type == OP_AELEM
13162                                      || kid->op_type == OP_HELEM)
13163                             {
13164                                  OP *firstop;
13165                                  OP *op = ((BINOP*)kid)->op_first;
13166                                  name = NULL;
13167                                  if (op) {
13168                                       SV *tmpstr = NULL;
13169                                       const char * const a =
13170                                            kid->op_type == OP_AELEM ?
13171                                            "[]" : "{}";
13172                                       if (((op->op_type == OP_RV2AV) ||
13173                                            (op->op_type == OP_RV2HV)) &&
13174                                           (firstop = ((UNOP*)op)->op_first) &&
13175                                           (firstop->op_type == OP_GV)) {
13176                                            /* packagevar $a[] or $h{} */
13177                                            GV * const gv = cGVOPx_gv(firstop);
13178                                            if (gv)
13179                                                 tmpstr =
13180                                                      Perl_newSVpvf(aTHX_
13181                                                                    "%s%c...%c",
13182                                                                    GvNAME(gv),
13183                                                                    a[0], a[1]);
13184                                       }
13185                                       else if (op->op_type == OP_PADAV
13186                                                || op->op_type == OP_PADHV) {
13187                                            /* lexicalvar $a[] or $h{} */
13188                                            const char * const padname =
13189                                                 PAD_COMPNAME_PV(op->op_targ);
13190                                            if (padname)
13191                                                 tmpstr =
13192                                                      Perl_newSVpvf(aTHX_
13193                                                                    "%s%c...%c",
13194                                                                    padname + 1,
13195                                                                    a[0], a[1]);
13196                                       }
13197                                       if (tmpstr) {
13198                                            name = SvPV_const(tmpstr, len);
13199                                            name_utf8 = SvUTF8(tmpstr);
13200                                            sv_2mortal(tmpstr);
13201                                       }
13202                                  }
13203                                  if (!name) {
13204                                       name = "__ANONIO__";
13205                                       len = 10;
13206                                       want_dollar = FALSE;
13207                                  }
13208                                  op_lvalue(kid, type);
13209                             }
13210                             if (name) {
13211                                 SV *namesv;
13212                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13213                                 namesv = PAD_SVl(targ);
13214                                 if (want_dollar && *name != '$')
13215                                     sv_setpvs(namesv, "$");
13216                                 else
13217                                     SvPVCLEAR(namesv);
13218                                 sv_catpvn(namesv, name, len);
13219                                 if ( name_utf8 ) SvUTF8_on(namesv);
13220                             }
13221                         }
13222                         scalar(kid);
13223                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13224                                     OP_RV2GV, flags);
13225                         kid->op_targ = targ;
13226                         kid->op_private |= priv;
13227                     }
13228                 }
13229                 scalar(kid);
13230                 break;
13231             case OA_SCALARREF:
13232                 if ((type == OP_UNDEF || type == OP_POS)
13233                     && numargs == 1 && !(oa >> 4)
13234                     && kid->op_type == OP_LIST)
13235                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
13236                 op_lvalue(scalar(kid), type);
13237                 break;
13238             }
13239             oa >>= 4;
13240             prev_kid = kid;
13241             kid = OpSIBLING(kid);
13242         }
13243         /* FIXME - should the numargs or-ing move after the too many
13244          * arguments check? */
13245         o->op_private |= numargs;
13246         if (kid)
13247             return too_many_arguments_pv(o,OP_DESC(o), 0);
13248         listkids(o);
13249     }
13250     else if (PL_opargs[type] & OA_DEFGV) {
13251         /* Ordering of these two is important to keep f_map.t passing.  */
13252         op_free(o);
13253         return newUNOP(type, 0, newDEFSVOP());
13254     }
13255
13256     if (oa) {
13257         while (oa & OA_OPTIONAL)
13258             oa >>= 4;
13259         if (oa && oa != OA_LIST)
13260             return too_few_arguments_pv(o,OP_DESC(o), 0);
13261     }
13262     return o;
13263 }
13264
13265 OP *
13266 Perl_ck_glob(pTHX_ OP *o)
13267 {
13268     GV *gv;
13269
13270     PERL_ARGS_ASSERT_CK_GLOB;
13271
13272     o = ck_fun(o);
13273     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13274         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13275
13276     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13277     {
13278         /* convert
13279          *     glob
13280          *       \ null - const(wildcard)
13281          * into
13282          *     null
13283          *       \ enter
13284          *            \ list
13285          *                 \ mark - glob - rv2cv
13286          *                             |        \ gv(CORE::GLOBAL::glob)
13287          *                             |
13288          *                              \ null - const(wildcard)
13289          */
13290         o->op_flags |= OPf_SPECIAL;
13291         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13292         o = S_new_entersubop(aTHX_ gv, o);
13293         o = newUNOP(OP_NULL, 0, o);
13294         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13295         return o;
13296     }
13297     else o->op_flags &= ~OPf_SPECIAL;
13298 #if !defined(PERL_EXTERNAL_GLOB)
13299     if (!PL_globhook) {
13300         ENTER;
13301         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13302                                newSVpvs("File::Glob"), NULL, NULL, NULL);
13303         LEAVE;
13304     }
13305 #endif /* !PERL_EXTERNAL_GLOB */
13306     gv = (GV *)newSV(0);
13307     gv_init(gv, 0, "", 0, 0);
13308     gv_IOadd(gv);
13309     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13310     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13311     scalarkids(o);
13312     return o;
13313 }
13314
13315 OP *
13316 Perl_ck_grep(pTHX_ OP *o)
13317 {
13318     LOGOP *gwop;
13319     OP *kid;
13320     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13321
13322     PERL_ARGS_ASSERT_CK_GREP;
13323
13324     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13325
13326     if (o->op_flags & OPf_STACKED) {
13327         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13328         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13329             return no_fh_allowed(o);
13330         o->op_flags &= ~OPf_STACKED;
13331     }
13332     kid = OpSIBLING(cLISTOPo->op_first);
13333     if (type == OP_MAPWHILE)
13334         list(kid);
13335     else
13336         scalar(kid);
13337     o = ck_fun(o);
13338     if (PL_parser && PL_parser->error_count)
13339         return o;
13340     kid = OpSIBLING(cLISTOPo->op_first);
13341     if (kid->op_type != OP_NULL)
13342         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13343     kid = kUNOP->op_first;
13344
13345     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13346     kid->op_next = (OP*)gwop;
13347     o->op_private = gwop->op_private = 0;
13348     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13349
13350     kid = OpSIBLING(cLISTOPo->op_first);
13351     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13352         op_lvalue(kid, OP_GREPSTART);
13353
13354     return (OP*)gwop;
13355 }
13356
13357 OP *
13358 Perl_ck_index(pTHX_ OP *o)
13359 {
13360     PERL_ARGS_ASSERT_CK_INDEX;
13361
13362     if (o->op_flags & OPf_KIDS) {
13363         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
13364         if (kid)
13365             kid = OpSIBLING(kid);                       /* get past "big" */
13366         if (kid && kid->op_type == OP_CONST) {
13367             const bool save_taint = TAINT_get;
13368             SV *sv = kSVOP->op_sv;
13369             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13370                 && SvOK(sv) && !SvROK(sv))
13371             {
13372                 sv = newSV(0);
13373                 sv_copypv(sv, kSVOP->op_sv);
13374                 SvREFCNT_dec_NN(kSVOP->op_sv);
13375                 kSVOP->op_sv = sv;
13376             }
13377             if (SvOK(sv)) fbm_compile(sv, 0);
13378             TAINT_set(save_taint);
13379 #ifdef NO_TAINT_SUPPORT
13380             PERL_UNUSED_VAR(save_taint);
13381 #endif
13382         }
13383     }
13384     return ck_fun(o);
13385 }
13386
13387 OP *
13388 Perl_ck_lfun(pTHX_ OP *o)
13389 {
13390     const OPCODE type = o->op_type;
13391
13392     PERL_ARGS_ASSERT_CK_LFUN;
13393
13394     return modkids(ck_fun(o), type);
13395 }
13396
13397 OP *
13398 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
13399 {
13400     PERL_ARGS_ASSERT_CK_DEFINED;
13401
13402     if ((o->op_flags & OPf_KIDS)) {
13403         switch (cUNOPo->op_first->op_type) {
13404         case OP_RV2AV:
13405         case OP_PADAV:
13406             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13407                              " (Maybe you should just omit the defined()?)");
13408             NOT_REACHED; /* NOTREACHED */
13409             break;
13410         case OP_RV2HV:
13411         case OP_PADHV:
13412             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13413                              " (Maybe you should just omit the defined()?)");
13414             NOT_REACHED; /* NOTREACHED */
13415             break;
13416         default:
13417             /* no warning */
13418             break;
13419         }
13420     }
13421     return ck_rfun(o);
13422 }
13423
13424 OP *
13425 Perl_ck_readline(pTHX_ OP *o)
13426 {
13427     PERL_ARGS_ASSERT_CK_READLINE;
13428
13429     if (o->op_flags & OPf_KIDS) {
13430          OP *kid = cLISTOPo->op_first;
13431          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13432          scalar(kid);
13433     }
13434     else {
13435         OP * const newop
13436             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13437         op_free(o);
13438         return newop;
13439     }
13440     return o;
13441 }
13442
13443 OP *
13444 Perl_ck_rfun(pTHX_ OP *o)
13445 {
13446     const OPCODE type = o->op_type;
13447
13448     PERL_ARGS_ASSERT_CK_RFUN;
13449
13450     return refkids(ck_fun(o), type);
13451 }
13452
13453 OP *
13454 Perl_ck_listiob(pTHX_ OP *o)
13455 {
13456     OP *kid;
13457
13458     PERL_ARGS_ASSERT_CK_LISTIOB;
13459
13460     kid = cLISTOPo->op_first;
13461     if (!kid) {
13462         o = force_list(o, 1);
13463         kid = cLISTOPo->op_first;
13464     }
13465     if (kid->op_type == OP_PUSHMARK)
13466         kid = OpSIBLING(kid);
13467     if (kid && o->op_flags & OPf_STACKED)
13468         kid = OpSIBLING(kid);
13469     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
13470         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13471          && !kid->op_folded) {
13472             o->op_flags |= OPf_STACKED; /* make it a filehandle */
13473             scalar(kid);
13474             /* replace old const op with new OP_RV2GV parent */
13475             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13476                                         OP_RV2GV, OPf_REF);
13477             kid = OpSIBLING(kid);
13478         }
13479     }
13480
13481     if (!kid)
13482         op_append_elem(o->op_type, o, newDEFSVOP());
13483
13484     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13485     return listkids(o);
13486 }
13487
13488 OP *
13489 Perl_ck_smartmatch(pTHX_ OP *o)
13490 {
13491     dVAR;
13492     PERL_ARGS_ASSERT_CK_SMARTMATCH;
13493     if (0 == (o->op_flags & OPf_SPECIAL)) {
13494         OP *first  = cBINOPo->op_first;
13495         OP *second = OpSIBLING(first);
13496
13497         /* Implicitly take a reference to an array or hash */
13498
13499         /* remove the original two siblings, then add back the
13500          * (possibly different) first and second sibs.
13501          */
13502         op_sibling_splice(o, NULL, 1, NULL);
13503         op_sibling_splice(o, NULL, 1, NULL);
13504         first  = ref_array_or_hash(first);
13505         second = ref_array_or_hash(second);
13506         op_sibling_splice(o, NULL, 0, second);
13507         op_sibling_splice(o, NULL, 0, first);
13508
13509         /* Implicitly take a reference to a regular expression */
13510         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13511             OpTYPE_set(first, OP_QR);
13512         }
13513         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13514             OpTYPE_set(second, OP_QR);
13515         }
13516     }
13517
13518     return o;
13519 }
13520
13521
13522 static OP *
13523 S_maybe_targlex(pTHX_ OP *o)
13524 {
13525     OP * const kid = cLISTOPo->op_first;
13526     /* has a disposable target? */
13527     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13528         && !(kid->op_flags & OPf_STACKED)
13529         /* Cannot steal the second time! */
13530         && !(kid->op_private & OPpTARGET_MY)
13531         )
13532     {
13533         OP * const kkid = OpSIBLING(kid);
13534
13535         /* Can just relocate the target. */
13536         if (kkid && kkid->op_type == OP_PADSV
13537             && (!(kkid->op_private & OPpLVAL_INTRO)
13538                || kkid->op_private & OPpPAD_STATE))
13539         {
13540             kid->op_targ = kkid->op_targ;
13541             kkid->op_targ = 0;
13542             /* Now we do not need PADSV and SASSIGN.
13543              * Detach kid and free the rest. */
13544             op_sibling_splice(o, NULL, 1, NULL);
13545             op_free(o);
13546             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
13547             return kid;
13548         }
13549     }
13550     return o;
13551 }
13552
13553 OP *
13554 Perl_ck_sassign(pTHX_ OP *o)
13555 {
13556     dVAR;
13557     OP * const kid = cBINOPo->op_first;
13558
13559     PERL_ARGS_ASSERT_CK_SASSIGN;
13560
13561     if (OpHAS_SIBLING(kid)) {
13562         OP *kkid = OpSIBLING(kid);
13563         /* For state variable assignment with attributes, kkid is a list op
13564            whose op_last is a padsv. */
13565         if ((kkid->op_type == OP_PADSV ||
13566              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13567               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13568              )
13569             )
13570                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13571                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13572             return S_newONCEOP(aTHX_ o, kkid);
13573         }
13574     }
13575     return S_maybe_targlex(aTHX_ o);
13576 }
13577
13578
13579 OP *
13580 Perl_ck_match(pTHX_ OP *o)
13581 {
13582     PERL_UNUSED_CONTEXT;
13583     PERL_ARGS_ASSERT_CK_MATCH;
13584
13585     return o;
13586 }
13587
13588 OP *
13589 Perl_ck_method(pTHX_ OP *o)
13590 {
13591     SV *sv, *methsv, *rclass;
13592     const char* method;
13593     char* compatptr;
13594     int utf8;
13595     STRLEN len, nsplit = 0, i;
13596     OP* new_op;
13597     OP * const kid = cUNOPo->op_first;
13598
13599     PERL_ARGS_ASSERT_CK_METHOD;
13600     if (kid->op_type != OP_CONST) return o;
13601
13602     sv = kSVOP->op_sv;
13603
13604     /* replace ' with :: */
13605     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13606                                         SvEND(sv) - SvPVX(sv) )))
13607     {
13608         *compatptr = ':';
13609         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13610     }
13611
13612     method = SvPVX_const(sv);
13613     len = SvCUR(sv);
13614     utf8 = SvUTF8(sv) ? -1 : 1;
13615
13616     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13617         nsplit = i+1;
13618         break;
13619     }
13620
13621     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13622
13623     if (!nsplit) { /* $proto->method() */
13624         op_free(o);
13625         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13626     }
13627
13628     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13629         op_free(o);
13630         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13631     }
13632
13633     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13634     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13635         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13636         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13637     } else {
13638         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13639         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13640     }
13641 #ifdef USE_ITHREADS
13642     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13643 #else
13644     cMETHOPx(new_op)->op_rclass_sv = rclass;
13645 #endif
13646     op_free(o);
13647     return new_op;
13648 }
13649
13650 OP *
13651 Perl_ck_null(pTHX_ OP *o)
13652 {
13653     PERL_ARGS_ASSERT_CK_NULL;
13654     PERL_UNUSED_CONTEXT;
13655     return o;
13656 }
13657
13658 OP *
13659 Perl_ck_open(pTHX_ OP *o)
13660 {
13661     PERL_ARGS_ASSERT_CK_OPEN;
13662
13663     S_io_hints(aTHX_ o);
13664     {
13665          /* In case of three-arg dup open remove strictness
13666           * from the last arg if it is a bareword. */
13667          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13668          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
13669          OP *oa;
13670          const char *mode;
13671
13672          if ((last->op_type == OP_CONST) &&             /* The bareword. */
13673              (last->op_private & OPpCONST_BARE) &&
13674              (last->op_private & OPpCONST_STRICT) &&
13675              (oa = OpSIBLING(first)) &&         /* The fh. */
13676              (oa = OpSIBLING(oa)) &&                    /* The mode. */
13677              (oa->op_type == OP_CONST) &&
13678              SvPOK(((SVOP*)oa)->op_sv) &&
13679              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13680              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
13681              (last == OpSIBLING(oa)))                   /* The bareword. */
13682               last->op_private &= ~OPpCONST_STRICT;
13683     }
13684     return ck_fun(o);
13685 }
13686
13687 OP *
13688 Perl_ck_prototype(pTHX_ OP *o)
13689 {
13690     PERL_ARGS_ASSERT_CK_PROTOTYPE;
13691     if (!(o->op_flags & OPf_KIDS)) {
13692         op_free(o);
13693         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13694     }
13695     return o;
13696 }
13697
13698 OP *
13699 Perl_ck_refassign(pTHX_ OP *o)
13700 {
13701     OP * const right = cLISTOPo->op_first;
13702     OP * const left = OpSIBLING(right);
13703     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13704     bool stacked = 0;
13705
13706     PERL_ARGS_ASSERT_CK_REFASSIGN;
13707     assert (left);
13708     assert (left->op_type == OP_SREFGEN);
13709
13710     o->op_private = 0;
13711     /* we use OPpPAD_STATE in refassign to mean either of those things,
13712      * and the code assumes the two flags occupy the same bit position
13713      * in the various ops below */
13714     assert(OPpPAD_STATE == OPpOUR_INTRO);
13715
13716     switch (varop->op_type) {
13717     case OP_PADAV:
13718         o->op_private |= OPpLVREF_AV;
13719         goto settarg;
13720     case OP_PADHV:
13721         o->op_private |= OPpLVREF_HV;
13722         /* FALLTHROUGH */
13723     case OP_PADSV:
13724       settarg:
13725         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13726         o->op_targ = varop->op_targ;
13727         varop->op_targ = 0;
13728         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13729         break;
13730
13731     case OP_RV2AV:
13732         o->op_private |= OPpLVREF_AV;
13733         goto checkgv;
13734         NOT_REACHED; /* NOTREACHED */
13735     case OP_RV2HV:
13736         o->op_private |= OPpLVREF_HV;
13737         /* FALLTHROUGH */
13738     case OP_RV2SV:
13739       checkgv:
13740         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13741         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13742       detach_and_stack:
13743         /* Point varop to its GV kid, detached.  */
13744         varop = op_sibling_splice(varop, NULL, -1, NULL);
13745         stacked = TRUE;
13746         break;
13747     case OP_RV2CV: {
13748         OP * const kidparent =
13749             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13750         OP * const kid = cUNOPx(kidparent)->op_first;
13751         o->op_private |= OPpLVREF_CV;
13752         if (kid->op_type == OP_GV) {
13753             SV *sv = (SV*)cGVOPx_gv(kid);
13754             varop = kidparent;
13755             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13756                 /* a CVREF here confuses pp_refassign, so make sure
13757                    it gets a GV */
13758                 CV *const cv = (CV*)SvRV(sv);
13759                 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13760                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13761                 assert(SvTYPE(sv) == SVt_PVGV);
13762             }
13763             goto detach_and_stack;
13764         }
13765         if (kid->op_type != OP_PADCV)   goto bad;
13766         o->op_targ = kid->op_targ;
13767         kid->op_targ = 0;
13768         break;
13769     }
13770     case OP_AELEM:
13771     case OP_HELEM:
13772         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13773         o->op_private |= OPpLVREF_ELEM;
13774         op_null(varop);
13775         stacked = TRUE;
13776         /* Detach varop.  */
13777         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13778         break;
13779     default:
13780       bad:
13781         /* diag_listed_as: Can't modify reference to %s in %s assignment */
13782         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13783                                 "assignment",
13784                                  OP_DESC(varop)));
13785         return o;
13786     }
13787     if (!FEATURE_REFALIASING_IS_ENABLED)
13788         Perl_croak(aTHX_
13789                   "Experimental aliasing via reference not enabled");
13790     Perl_ck_warner_d(aTHX_
13791                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
13792                     "Aliasing via reference is experimental");
13793     if (stacked) {
13794         o->op_flags |= OPf_STACKED;
13795         op_sibling_splice(o, right, 1, varop);
13796     }
13797     else {
13798         o->op_flags &=~ OPf_STACKED;
13799         op_sibling_splice(o, right, 1, NULL);
13800     }
13801     op_free(left);
13802     return o;
13803 }
13804
13805 OP *
13806 Perl_ck_repeat(pTHX_ OP *o)
13807 {
13808     PERL_ARGS_ASSERT_CK_REPEAT;
13809
13810     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13811         OP* kids;
13812         o->op_private |= OPpREPEAT_DOLIST;
13813         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13814         kids = force_list(kids, 1); /* promote it to a list */
13815         op_sibling_splice(o, NULL, 0, kids); /* and add back */
13816     }
13817     else
13818         scalar(o);
13819     return o;
13820 }
13821
13822 OP *
13823 Perl_ck_require(pTHX_ OP *o)
13824 {
13825     GV* gv;
13826
13827     PERL_ARGS_ASSERT_CK_REQUIRE;
13828
13829     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
13830         SVOP * const kid = (SVOP*)cUNOPo->op_first;
13831         U32 hash;
13832         char *s;
13833         STRLEN len;
13834         if (kid->op_type == OP_CONST) {
13835           SV * const sv = kid->op_sv;
13836           U32 const was_readonly = SvREADONLY(sv);
13837           if (kid->op_private & OPpCONST_BARE) {
13838             dVAR;
13839             const char *end;
13840             HEK *hek;
13841
13842             if (was_readonly) {
13843                 SvREADONLY_off(sv);
13844             }
13845
13846             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13847
13848             s = SvPVX(sv);
13849             len = SvCUR(sv);
13850             end = s + len;
13851             /* treat ::foo::bar as foo::bar */
13852             if (len >= 2 && s[0] == ':' && s[1] == ':')
13853                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13854             if (s == end)
13855                 DIE(aTHX_ "Bareword in require maps to empty filename");
13856
13857             for (; s < end; s++) {
13858                 if (*s == ':' && s[1] == ':') {
13859                     *s = '/';
13860                     Move(s+2, s+1, end - s - 1, char);
13861                     --end;
13862                 }
13863             }
13864             SvEND_set(sv, end);
13865             sv_catpvs(sv, ".pm");
13866             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13867             hek = share_hek(SvPVX(sv),
13868                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13869                             hash);
13870             sv_sethek(sv, hek);
13871             unshare_hek(hek);
13872             SvFLAGS(sv) |= was_readonly;
13873           }
13874           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13875                 && !SvVOK(sv)) {
13876             s = SvPV(sv, len);
13877             if (SvREFCNT(sv) > 1) {
13878                 kid->op_sv = newSVpvn_share(
13879                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13880                 SvREFCNT_dec_NN(sv);
13881             }
13882             else {
13883                 dVAR;
13884                 HEK *hek;
13885                 if (was_readonly) SvREADONLY_off(sv);
13886                 PERL_HASH(hash, s, len);
13887                 hek = share_hek(s,
13888                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13889                                 hash);
13890                 sv_sethek(sv, hek);
13891                 unshare_hek(hek);
13892                 SvFLAGS(sv) |= was_readonly;
13893             }
13894           }
13895         }
13896     }
13897
13898     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13899         /* handle override, if any */
13900      && (gv = gv_override("require", 7))) {
13901         OP *kid, *newop;
13902         if (o->op_flags & OPf_KIDS) {
13903             kid = cUNOPo->op_first;
13904             op_sibling_splice(o, NULL, -1, NULL);
13905         }
13906         else {
13907             kid = newDEFSVOP();
13908         }
13909         op_free(o);
13910         newop = S_new_entersubop(aTHX_ gv, kid);
13911         return newop;
13912     }
13913
13914     return ck_fun(o);
13915 }
13916
13917 OP *
13918 Perl_ck_return(pTHX_ OP *o)
13919 {
13920     OP *kid;
13921
13922     PERL_ARGS_ASSERT_CK_RETURN;
13923
13924     kid = OpSIBLING(cLISTOPo->op_first);
13925     if (PL_compcv && CvLVALUE(PL_compcv)) {
13926         for (; kid; kid = OpSIBLING(kid))
13927             op_lvalue(kid, OP_LEAVESUBLV);
13928     }
13929
13930     return o;
13931 }
13932
13933 OP *
13934 Perl_ck_select(pTHX_ OP *o)
13935 {
13936     dVAR;
13937     OP* kid;
13938
13939     PERL_ARGS_ASSERT_CK_SELECT;
13940
13941     if (o->op_flags & OPf_KIDS) {
13942         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13943         if (kid && OpHAS_SIBLING(kid)) {
13944             OpTYPE_set(o, OP_SSELECT);
13945             o = ck_fun(o);
13946             return fold_constants(op_integerize(op_std_init(o)));
13947         }
13948     }
13949     o = ck_fun(o);
13950     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13951     if (kid && kid->op_type == OP_RV2GV)
13952         kid->op_private &= ~HINT_STRICT_REFS;
13953     return o;
13954 }
13955
13956 OP *
13957 Perl_ck_shift(pTHX_ OP *o)
13958 {
13959     const I32 type = o->op_type;
13960
13961     PERL_ARGS_ASSERT_CK_SHIFT;
13962
13963     if (!(o->op_flags & OPf_KIDS)) {
13964         OP *argop;
13965
13966         if (!CvUNIQUE(PL_compcv)) {
13967             o->op_flags |= OPf_SPECIAL;
13968             return o;
13969         }
13970
13971         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13972         op_free(o);
13973         return newUNOP(type, 0, scalar(argop));
13974     }
13975     return scalar(ck_fun(o));
13976 }
13977
13978 OP *
13979 Perl_ck_sort(pTHX_ OP *o)
13980 {
13981     OP *firstkid;
13982     OP *kid;
13983     HV * const hinthv =
13984         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13985     U8 stacked;
13986
13987     PERL_ARGS_ASSERT_CK_SORT;
13988
13989     if (hinthv) {
13990             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13991             if (svp) {
13992                 const I32 sorthints = (I32)SvIV(*svp);
13993                 if ((sorthints & HINT_SORT_STABLE) != 0)
13994                     o->op_private |= OPpSORT_STABLE;
13995                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13996                     o->op_private |= OPpSORT_UNSTABLE;
13997             }
13998     }
13999
14000     if (o->op_flags & OPf_STACKED)
14001         simplify_sort(o);
14002     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
14003
14004     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
14005         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
14006
14007         /* if the first arg is a code block, process it and mark sort as
14008          * OPf_SPECIAL */
14009         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
14010             LINKLIST(kid);
14011             if (kid->op_type == OP_LEAVE)
14012                     op_null(kid);                       /* wipe out leave */
14013             /* Prevent execution from escaping out of the sort block. */
14014             kid->op_next = 0;
14015
14016             /* provide scalar context for comparison function/block */
14017             kid = scalar(firstkid);
14018             kid->op_next = kid;
14019             o->op_flags |= OPf_SPECIAL;
14020         }
14021         else if (kid->op_type == OP_CONST
14022               && kid->op_private & OPpCONST_BARE) {
14023             char tmpbuf[256];
14024             STRLEN len;
14025             PADOFFSET off;
14026             const char * const name = SvPV(kSVOP_sv, len);
14027             *tmpbuf = '&';
14028             assert (len < 256);
14029             Copy(name, tmpbuf+1, len, char);
14030             off = pad_findmy_pvn(tmpbuf, len+1, 0);
14031             if (off != NOT_IN_PAD) {
14032                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
14033                     SV * const fq =
14034                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
14035                     sv_catpvs(fq, "::");
14036                     sv_catsv(fq, kSVOP_sv);
14037                     SvREFCNT_dec_NN(kSVOP_sv);
14038                     kSVOP->op_sv = fq;
14039                 }
14040                 else {
14041                     OP * const padop = newOP(OP_PADCV, 0);
14042                     padop->op_targ = off;
14043                     /* replace the const op with the pad op */
14044                     op_sibling_splice(firstkid, NULL, 1, padop);
14045                     op_free(kid);
14046                 }
14047             }
14048         }
14049
14050         firstkid = OpSIBLING(firstkid);
14051     }
14052
14053     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
14054         /* provide list context for arguments */
14055         list(kid);
14056         if (stacked)
14057             op_lvalue(kid, OP_GREPSTART);
14058     }
14059
14060     return o;
14061 }
14062
14063 /* for sort { X } ..., where X is one of
14064  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
14065  * elide the second child of the sort (the one containing X),
14066  * and set these flags as appropriate
14067         OPpSORT_NUMERIC;
14068         OPpSORT_INTEGER;
14069         OPpSORT_DESCEND;
14070  * Also, check and warn on lexical $a, $b.
14071  */
14072
14073 STATIC void
14074 S_simplify_sort(pTHX_ OP *o)
14075 {
14076     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
14077     OP *k;
14078     int descending;
14079     GV *gv;
14080     const char *gvname;
14081     bool have_scopeop;
14082
14083     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
14084
14085     kid = kUNOP->op_first;                              /* get past null */
14086     if (!(have_scopeop = kid->op_type == OP_SCOPE)
14087      && kid->op_type != OP_LEAVE)
14088         return;
14089     kid = kLISTOP->op_last;                             /* get past scope */
14090     switch(kid->op_type) {
14091         case OP_NCMP:
14092         case OP_I_NCMP:
14093         case OP_SCMP:
14094             if (!have_scopeop) goto padkids;
14095             break;
14096         default:
14097             return;
14098     }
14099     k = kid;                                            /* remember this node*/
14100     if (kBINOP->op_first->op_type != OP_RV2SV
14101      || kBINOP->op_last ->op_type != OP_RV2SV)
14102     {
14103         /*
14104            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
14105            then used in a comparison.  This catches most, but not
14106            all cases.  For instance, it catches
14107                sort { my($a); $a <=> $b }
14108            but not
14109                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
14110            (although why you'd do that is anyone's guess).
14111         */
14112
14113        padkids:
14114         if (!ckWARN(WARN_SYNTAX)) return;
14115         kid = kBINOP->op_first;
14116         do {
14117             if (kid->op_type == OP_PADSV) {
14118                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
14119                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
14120                  && (  PadnamePV(name)[1] == 'a'
14121                     || PadnamePV(name)[1] == 'b'  ))
14122                     /* diag_listed_as: "my %s" used in sort comparison */
14123                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14124                                      "\"%s %s\" used in sort comparison",
14125                                       PadnameIsSTATE(name)
14126                                         ? "state"
14127                                         : "my",
14128                                       PadnamePV(name));
14129             }
14130         } while ((kid = OpSIBLING(kid)));
14131         return;
14132     }
14133     kid = kBINOP->op_first;                             /* get past cmp */
14134     if (kUNOP->op_first->op_type != OP_GV)
14135         return;
14136     kid = kUNOP->op_first;                              /* get past rv2sv */
14137     gv = kGVOP_gv;
14138     if (GvSTASH(gv) != PL_curstash)
14139         return;
14140     gvname = GvNAME(gv);
14141     if (*gvname == 'a' && gvname[1] == '\0')
14142         descending = 0;
14143     else if (*gvname == 'b' && gvname[1] == '\0')
14144         descending = 1;
14145     else
14146         return;
14147
14148     kid = k;                                            /* back to cmp */
14149     /* already checked above that it is rv2sv */
14150     kid = kBINOP->op_last;                              /* down to 2nd arg */
14151     if (kUNOP->op_first->op_type != OP_GV)
14152         return;
14153     kid = kUNOP->op_first;                              /* get past rv2sv */
14154     gv = kGVOP_gv;
14155     if (GvSTASH(gv) != PL_curstash)
14156         return;
14157     gvname = GvNAME(gv);
14158     if ( descending
14159          ? !(*gvname == 'a' && gvname[1] == '\0')
14160          : !(*gvname == 'b' && gvname[1] == '\0'))
14161         return;
14162     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
14163     if (descending)
14164         o->op_private |= OPpSORT_DESCEND;
14165     if (k->op_type == OP_NCMP)
14166         o->op_private |= OPpSORT_NUMERIC;
14167     if (k->op_type == OP_I_NCMP)
14168         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
14169     kid = OpSIBLING(cLISTOPo->op_first);
14170     /* cut out and delete old block (second sibling) */
14171     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
14172     op_free(kid);
14173 }
14174
14175 OP *
14176 Perl_ck_split(pTHX_ OP *o)
14177 {
14178     dVAR;
14179     OP *kid;
14180     OP *sibs;
14181
14182     PERL_ARGS_ASSERT_CK_SPLIT;
14183
14184     assert(o->op_type == OP_LIST);
14185
14186     if (o->op_flags & OPf_STACKED)
14187         return no_fh_allowed(o);
14188
14189     kid = cLISTOPo->op_first;
14190     /* delete leading NULL node, then add a CONST if no other nodes */
14191     assert(kid->op_type == OP_NULL);
14192     op_sibling_splice(o, NULL, 1,
14193         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14194     op_free(kid);
14195     kid = cLISTOPo->op_first;
14196
14197     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14198         /* remove match expression, and replace with new optree with
14199          * a match op at its head */
14200         op_sibling_splice(o, NULL, 1, NULL);
14201         /* pmruntime will handle split " " behavior with flag==2 */
14202         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14203         op_sibling_splice(o, NULL, 0, kid);
14204     }
14205
14206     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14207
14208     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14209       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14210                      "Use of /g modifier is meaningless in split");
14211     }
14212
14213     /* eliminate the split op, and move the match op (plus any children)
14214      * into its place, then convert the match op into a split op. i.e.
14215      *
14216      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
14217      *    |                        |                     |
14218      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
14219      *    |                        |                     |
14220      *    R                        X - Y                 X - Y
14221      *    |
14222      *    X - Y
14223      *
14224      * (R, if it exists, will be a regcomp op)
14225      */
14226
14227     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14228     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14229     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14230     OpTYPE_set(kid, OP_SPLIT);
14231     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
14232     kid->op_private = o->op_private;
14233     op_free(o);
14234     o = kid;
14235     kid = sibs; /* kid is now the string arg of the split */
14236
14237     if (!kid) {
14238         kid = newDEFSVOP();
14239         op_append_elem(OP_SPLIT, o, kid);
14240     }
14241     scalar(kid);
14242
14243     kid = OpSIBLING(kid);
14244     if (!kid) {
14245         kid = newSVOP(OP_CONST, 0, newSViv(0));
14246         op_append_elem(OP_SPLIT, o, kid);
14247         o->op_private |= OPpSPLIT_IMPLIM;
14248     }
14249     scalar(kid);
14250
14251     if (OpHAS_SIBLING(kid))
14252         return too_many_arguments_pv(o,OP_DESC(o), 0);
14253
14254     return o;
14255 }
14256
14257 OP *
14258 Perl_ck_stringify(pTHX_ OP *o)
14259 {
14260     OP * const kid = OpSIBLING(cUNOPo->op_first);
14261     PERL_ARGS_ASSERT_CK_STRINGIFY;
14262     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14263          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
14264          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
14265         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14266     {
14267         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14268         op_free(o);
14269         return kid;
14270     }
14271     return ck_fun(o);
14272 }
14273
14274 OP *
14275 Perl_ck_join(pTHX_ OP *o)
14276 {
14277     OP * const kid = OpSIBLING(cLISTOPo->op_first);
14278
14279     PERL_ARGS_ASSERT_CK_JOIN;
14280
14281     if (kid && kid->op_type == OP_MATCH) {
14282         if (ckWARN(WARN_SYNTAX)) {
14283             const REGEXP *re = PM_GETRE(kPMOP);
14284             const SV *msg = re
14285                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14286                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14287                     : newSVpvs_flags( "STRING", SVs_TEMP );
14288             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14289                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
14290                         SVfARG(msg), SVfARG(msg));
14291         }
14292     }
14293     if (kid
14294      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14295         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14296         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14297            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14298     {
14299         const OP * const bairn = OpSIBLING(kid); /* the list */
14300         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14301          && OP_GIMME(bairn,0) == G_SCALAR)
14302         {
14303             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14304                                      op_sibling_splice(o, kid, 1, NULL));
14305             op_free(o);
14306             return ret;
14307         }
14308     }
14309
14310     return ck_fun(o);
14311 }
14312
14313 /*
14314 =for apidoc rv2cv_op_cv
14315
14316 Examines an op, which is expected to identify a subroutine at runtime,
14317 and attempts to determine at compile time which subroutine it identifies.
14318 This is normally used during Perl compilation to determine whether
14319 a prototype can be applied to a function call.  C<cvop> is the op
14320 being considered, normally an C<rv2cv> op.  A pointer to the identified
14321 subroutine is returned, if it could be determined statically, and a null
14322 pointer is returned if it was not possible to determine statically.
14323
14324 Currently, the subroutine can be identified statically if the RV that the
14325 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14326 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
14327 suitable if the constant value must be an RV pointing to a CV.  Details of
14328 this process may change in future versions of Perl.  If the C<rv2cv> op
14329 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14330 the subroutine statically: this flag is used to suppress compile-time
14331 magic on a subroutine call, forcing it to use default runtime behaviour.
14332
14333 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14334 of a GV reference is modified.  If a GV was examined and its CV slot was
14335 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14336 If the op is not optimised away, and the CV slot is later populated with
14337 a subroutine having a prototype, that flag eventually triggers the warning
14338 "called too early to check prototype".
14339
14340 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14341 of returning a pointer to the subroutine it returns a pointer to the
14342 GV giving the most appropriate name for the subroutine in this context.
14343 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14344 (C<CvANON>) subroutine that is referenced through a GV it will be the
14345 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
14346 A null pointer is returned as usual if there is no statically-determinable
14347 subroutine.
14348
14349 =for apidoc Amnh||OPpEARLY_CV
14350 =for apidoc Amnh||OPpENTERSUB_AMPER
14351 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14352 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14353
14354 =cut
14355 */
14356
14357 /* shared by toke.c:yylex */
14358 CV *
14359 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14360 {
14361     PADNAME *name = PAD_COMPNAME(off);
14362     CV *compcv = PL_compcv;
14363     while (PadnameOUTER(name)) {
14364         assert(PARENT_PAD_INDEX(name));
14365         compcv = CvOUTSIDE(compcv);
14366         name = PadlistNAMESARRAY(CvPADLIST(compcv))
14367                 [off = PARENT_PAD_INDEX(name)];
14368     }
14369     assert(!PadnameIsOUR(name));
14370     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14371         return PadnamePROTOCV(name);
14372     }
14373     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14374 }
14375
14376 CV *
14377 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14378 {
14379     OP *rvop;
14380     CV *cv;
14381     GV *gv;
14382     PERL_ARGS_ASSERT_RV2CV_OP_CV;
14383     if (flags & ~RV2CVOPCV_FLAG_MASK)
14384         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14385     if (cvop->op_type != OP_RV2CV)
14386         return NULL;
14387     if (cvop->op_private & OPpENTERSUB_AMPER)
14388         return NULL;
14389     if (!(cvop->op_flags & OPf_KIDS))
14390         return NULL;
14391     rvop = cUNOPx(cvop)->op_first;
14392     switch (rvop->op_type) {
14393         case OP_GV: {
14394             gv = cGVOPx_gv(rvop);
14395             if (!isGV(gv)) {
14396                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14397                     cv = MUTABLE_CV(SvRV(gv));
14398                     gv = NULL;
14399                     break;
14400                 }
14401                 if (flags & RV2CVOPCV_RETURN_STUB)
14402                     return (CV *)gv;
14403                 else return NULL;
14404             }
14405             cv = GvCVu(gv);
14406             if (!cv) {
14407                 if (flags & RV2CVOPCV_MARK_EARLY)
14408                     rvop->op_private |= OPpEARLY_CV;
14409                 return NULL;
14410             }
14411         } break;
14412         case OP_CONST: {
14413             SV *rv = cSVOPx_sv(rvop);
14414             if (!SvROK(rv))
14415                 return NULL;
14416             cv = (CV*)SvRV(rv);
14417             gv = NULL;
14418         } break;
14419         case OP_PADCV: {
14420             cv = find_lexical_cv(rvop->op_targ);
14421             gv = NULL;
14422         } break;
14423         default: {
14424             return NULL;
14425         } NOT_REACHED; /* NOTREACHED */
14426     }
14427     if (SvTYPE((SV*)cv) != SVt_PVCV)
14428         return NULL;
14429     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14430         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14431             gv = CvGV(cv);
14432         return (CV*)gv;
14433     }
14434     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14435         if (CvLEXICAL(cv) || CvNAMED(cv))
14436             return NULL;
14437         if (!CvANON(cv) || !gv)
14438             gv = CvGV(cv);
14439         return (CV*)gv;
14440
14441     } else {
14442         return cv;
14443     }
14444 }
14445
14446 /*
14447 =for apidoc ck_entersub_args_list
14448
14449 Performs the default fixup of the arguments part of an C<entersub>
14450 op tree.  This consists of applying list context to each of the
14451 argument ops.  This is the standard treatment used on a call marked
14452 with C<&>, or a method call, or a call through a subroutine reference,
14453 or any other call where the callee can't be identified at compile time,
14454 or a call where the callee has no prototype.
14455
14456 =cut
14457 */
14458
14459 OP *
14460 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14461 {
14462     OP *aop;
14463
14464     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14465
14466     aop = cUNOPx(entersubop)->op_first;
14467     if (!OpHAS_SIBLING(aop))
14468         aop = cUNOPx(aop)->op_first;
14469     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14470         /* skip the extra attributes->import() call implicitly added in
14471          * something like foo(my $x : bar)
14472          */
14473         if (   aop->op_type == OP_ENTERSUB
14474             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14475         )
14476             continue;
14477         list(aop);
14478         op_lvalue(aop, OP_ENTERSUB);
14479     }
14480     return entersubop;
14481 }
14482
14483 /*
14484 =for apidoc ck_entersub_args_proto
14485
14486 Performs the fixup of the arguments part of an C<entersub> op tree
14487 based on a subroutine prototype.  This makes various modifications to
14488 the argument ops, from applying context up to inserting C<refgen> ops,
14489 and checking the number and syntactic types of arguments, as directed by
14490 the prototype.  This is the standard treatment used on a subroutine call,
14491 not marked with C<&>, where the callee can be identified at compile time
14492 and has a prototype.
14493
14494 C<protosv> supplies the subroutine prototype to be applied to the call.
14495 It may be a normal defined scalar, of which the string value will be used.
14496 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14497 that has been cast to C<SV*>) which has a prototype.  The prototype
14498 supplied, in whichever form, does not need to match the actual callee
14499 referenced by the op tree.
14500
14501 If the argument ops disagree with the prototype, for example by having
14502 an unacceptable number of arguments, a valid op tree is returned anyway.
14503 The error is reflected in the parser state, normally resulting in a single
14504 exception at the top level of parsing which covers all the compilation
14505 errors that occurred.  In the error message, the callee is referred to
14506 by the name defined by the C<namegv> parameter.
14507
14508 =cut
14509 */
14510
14511 OP *
14512 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14513 {
14514     STRLEN proto_len;
14515     const char *proto, *proto_end;
14516     OP *aop, *prev, *cvop, *parent;
14517     int optional = 0;
14518     I32 arg = 0;
14519     I32 contextclass = 0;
14520     const char *e = NULL;
14521     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14522     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14523         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14524                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
14525     if (SvTYPE(protosv) == SVt_PVCV)
14526          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14527     else proto = SvPV(protosv, proto_len);
14528     proto = S_strip_spaces(aTHX_ proto, &proto_len);
14529     proto_end = proto + proto_len;
14530     parent = entersubop;
14531     aop = cUNOPx(entersubop)->op_first;
14532     if (!OpHAS_SIBLING(aop)) {
14533         parent = aop;
14534         aop = cUNOPx(aop)->op_first;
14535     }
14536     prev = aop;
14537     aop = OpSIBLING(aop);
14538     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14539     while (aop != cvop) {
14540         OP* o3 = aop;
14541
14542         if (proto >= proto_end)
14543         {
14544             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14545             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14546                                         SVfARG(namesv)), SvUTF8(namesv));
14547             return entersubop;
14548         }
14549
14550         switch (*proto) {
14551             case ';':
14552                 optional = 1;
14553                 proto++;
14554                 continue;
14555             case '_':
14556                 /* _ must be at the end */
14557                 if (proto[1] && !memCHRs(";@%", proto[1]))
14558                     goto oops;
14559                 /* FALLTHROUGH */
14560             case '$':
14561                 proto++;
14562                 arg++;
14563                 scalar(aop);
14564                 break;
14565             case '%':
14566             case '@':
14567                 list(aop);
14568                 arg++;
14569                 break;
14570             case '&':
14571                 proto++;
14572                 arg++;
14573                 if (    o3->op_type != OP_UNDEF
14574                     && (o3->op_type != OP_SREFGEN
14575                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14576                                 != OP_ANONCODE
14577                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14578                                 != OP_RV2CV)))
14579                     bad_type_gv(arg, namegv, o3,
14580                             arg == 1 ? "block or sub {}" : "sub {}");
14581                 break;
14582             case '*':
14583                 /* '*' allows any scalar type, including bareword */
14584                 proto++;
14585                 arg++;
14586                 if (o3->op_type == OP_RV2GV)
14587                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
14588                 else if (o3->op_type == OP_CONST)
14589                     o3->op_private &= ~OPpCONST_STRICT;
14590                 scalar(aop);
14591                 break;
14592             case '+':
14593                 proto++;
14594                 arg++;
14595                 if (o3->op_type == OP_RV2AV ||
14596                     o3->op_type == OP_PADAV ||
14597                     o3->op_type == OP_RV2HV ||
14598                     o3->op_type == OP_PADHV
14599                 ) {
14600                     goto wrapref;
14601                 }
14602                 scalar(aop);
14603                 break;
14604             case '[': case ']':
14605                 goto oops;
14606
14607             case '\\':
14608                 proto++;
14609                 arg++;
14610             again:
14611                 switch (*proto++) {
14612                     case '[':
14613                         if (contextclass++ == 0) {
14614                             e = (char *) memchr(proto, ']', proto_end - proto);
14615                             if (!e || e == proto)
14616                                 goto oops;
14617                         }
14618                         else
14619                             goto oops;
14620                         goto again;
14621
14622                     case ']':
14623                         if (contextclass) {
14624                             const char *p = proto;
14625                             const char *const end = proto;
14626                             contextclass = 0;
14627                             while (*--p != '[')
14628                                 /* \[$] accepts any scalar lvalue */
14629                                 if (*p == '$'
14630                                  && Perl_op_lvalue_flags(aTHX_
14631                                      scalar(o3),
14632                                      OP_READ, /* not entersub */
14633                                      OP_LVALUE_NO_CROAK
14634                                     )) goto wrapref;
14635                             bad_type_gv(arg, namegv, o3,
14636                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14637                         } else
14638                             goto oops;
14639                         break;
14640                     case '*':
14641                         if (o3->op_type == OP_RV2GV)
14642                             goto wrapref;
14643                         if (!contextclass)
14644                             bad_type_gv(arg, namegv, o3, "symbol");
14645                         break;
14646                     case '&':
14647                         if (o3->op_type == OP_ENTERSUB
14648                          && !(o3->op_flags & OPf_STACKED))
14649                             goto wrapref;
14650                         if (!contextclass)
14651                             bad_type_gv(arg, namegv, o3, "subroutine");
14652                         break;
14653                     case '$':
14654                         if (o3->op_type == OP_RV2SV ||
14655                                 o3->op_type == OP_PADSV ||
14656                                 o3->op_type == OP_HELEM ||
14657                                 o3->op_type == OP_AELEM)
14658                             goto wrapref;
14659                         if (!contextclass) {
14660                             /* \$ accepts any scalar lvalue */
14661                             if (Perl_op_lvalue_flags(aTHX_
14662                                     scalar(o3),
14663                                     OP_READ,  /* not entersub */
14664                                     OP_LVALUE_NO_CROAK
14665                                )) goto wrapref;
14666                             bad_type_gv(arg, namegv, o3, "scalar");
14667                         }
14668                         break;
14669                     case '@':
14670                         if (o3->op_type == OP_RV2AV ||
14671                                 o3->op_type == OP_PADAV)
14672                         {
14673                             o3->op_flags &=~ OPf_PARENS;
14674                             goto wrapref;
14675                         }
14676                         if (!contextclass)
14677                             bad_type_gv(arg, namegv, o3, "array");
14678                         break;
14679                     case '%':
14680                         if (o3->op_type == OP_RV2HV ||
14681                                 o3->op_type == OP_PADHV)
14682                         {
14683                             o3->op_flags &=~ OPf_PARENS;
14684                             goto wrapref;
14685                         }
14686                         if (!contextclass)
14687                             bad_type_gv(arg, namegv, o3, "hash");
14688                         break;
14689                     wrapref:
14690                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14691                                                 OP_REFGEN, 0);
14692                         if (contextclass && e) {
14693                             proto = e + 1;
14694                             contextclass = 0;
14695                         }
14696                         break;
14697                     default: goto oops;
14698                 }
14699                 if (contextclass)
14700                     goto again;
14701                 break;
14702             case ' ':
14703                 proto++;
14704                 continue;
14705             default:
14706             oops: {
14707                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14708                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
14709                                   SVfARG(protosv));
14710             }
14711         }
14712
14713         op_lvalue(aop, OP_ENTERSUB);
14714         prev = aop;
14715         aop = OpSIBLING(aop);
14716     }
14717     if (aop == cvop && *proto == '_') {
14718         /* generate an access to $_ */
14719         op_sibling_splice(parent, prev, 0, newDEFSVOP());
14720     }
14721     if (!optional && proto_end > proto &&
14722         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14723     {
14724         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14725         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14726                                     SVfARG(namesv)), SvUTF8(namesv));
14727     }
14728     return entersubop;
14729 }
14730
14731 /*
14732 =for apidoc ck_entersub_args_proto_or_list
14733
14734 Performs the fixup of the arguments part of an C<entersub> op tree either
14735 based on a subroutine prototype or using default list-context processing.
14736 This is the standard treatment used on a subroutine call, not marked
14737 with C<&>, where the callee can be identified at compile time.
14738
14739 C<protosv> supplies the subroutine prototype to be applied to the call,
14740 or indicates that there is no prototype.  It may be a normal scalar,
14741 in which case if it is defined then the string value will be used
14742 as a prototype, and if it is undefined then there is no prototype.
14743 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14744 that has been cast to C<SV*>), of which the prototype will be used if it
14745 has one.  The prototype (or lack thereof) supplied, in whichever form,
14746 does not need to match the actual callee referenced by the op tree.
14747
14748 If the argument ops disagree with the prototype, for example by having
14749 an unacceptable number of arguments, a valid op tree is returned anyway.
14750 The error is reflected in the parser state, normally resulting in a single
14751 exception at the top level of parsing which covers all the compilation
14752 errors that occurred.  In the error message, the callee is referred to
14753 by the name defined by the C<namegv> parameter.
14754
14755 =cut
14756 */
14757
14758 OP *
14759 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14760         GV *namegv, SV *protosv)
14761 {
14762     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14763     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14764         return ck_entersub_args_proto(entersubop, namegv, protosv);
14765     else
14766         return ck_entersub_args_list(entersubop);
14767 }
14768
14769 OP *
14770 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14771 {
14772     IV cvflags = SvIVX(protosv);
14773     int opnum = cvflags & 0xffff;
14774     OP *aop = cUNOPx(entersubop)->op_first;
14775
14776     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14777
14778     if (!opnum) {
14779         OP *cvop;
14780         if (!OpHAS_SIBLING(aop))
14781             aop = cUNOPx(aop)->op_first;
14782         aop = OpSIBLING(aop);
14783         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14784         if (aop != cvop) {
14785             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14786             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14787                 SVfARG(namesv)), SvUTF8(namesv));
14788         }
14789
14790         op_free(entersubop);
14791         switch(cvflags >> 16) {
14792         case 'F': return newSVOP(OP_CONST, 0,
14793                                         newSVpv(CopFILE(PL_curcop),0));
14794         case 'L': return newSVOP(
14795                            OP_CONST, 0,
14796                            Perl_newSVpvf(aTHX_
14797                              "%" IVdf, (IV)CopLINE(PL_curcop)
14798                            )
14799                          );
14800         case 'P': return newSVOP(OP_CONST, 0,
14801                                    (PL_curstash
14802                                      ? newSVhek(HvNAME_HEK(PL_curstash))
14803                                      : &PL_sv_undef
14804                                    )
14805                                 );
14806         }
14807         NOT_REACHED; /* NOTREACHED */
14808     }
14809     else {
14810         OP *prev, *cvop, *first, *parent;
14811         U32 flags = 0;
14812
14813         parent = entersubop;
14814         if (!OpHAS_SIBLING(aop)) {
14815             parent = aop;
14816             aop = cUNOPx(aop)->op_first;
14817         }
14818
14819         first = prev = aop;
14820         aop = OpSIBLING(aop);
14821         /* find last sibling */
14822         for (cvop = aop;
14823              OpHAS_SIBLING(cvop);
14824              prev = cvop, cvop = OpSIBLING(cvop))
14825             ;
14826         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14827             /* Usually, OPf_SPECIAL on an op with no args means that it had
14828              * parens, but these have their own meaning for that flag: */
14829             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14830             && opnum != OP_DELETE && opnum != OP_EXISTS)
14831                 flags |= OPf_SPECIAL;
14832         /* excise cvop from end of sibling chain */
14833         op_sibling_splice(parent, prev, 1, NULL);
14834         op_free(cvop);
14835         if (aop == cvop) aop = NULL;
14836
14837         /* detach remaining siblings from the first sibling, then
14838          * dispose of original optree */
14839
14840         if (aop)
14841             op_sibling_splice(parent, first, -1, NULL);
14842         op_free(entersubop);
14843
14844         if (cvflags == (OP_ENTEREVAL | (1<<16)))
14845             flags |= OPpEVAL_BYTES <<8;
14846
14847         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14848         case OA_UNOP:
14849         case OA_BASEOP_OR_UNOP:
14850         case OA_FILESTATOP:
14851             if (!aop)
14852                 return newOP(opnum,flags);       /* zero args */
14853             if (aop == prev)
14854                 return newUNOP(opnum,flags,aop); /* one arg */
14855             /* too many args */
14856             /* FALLTHROUGH */
14857         case OA_BASEOP:
14858             if (aop) {
14859                 SV *namesv;
14860                 OP *nextop;
14861
14862                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14863                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14864                     SVfARG(namesv)), SvUTF8(namesv));
14865                 while (aop) {
14866                     nextop = OpSIBLING(aop);
14867                     op_free(aop);
14868                     aop = nextop;
14869                 }
14870
14871             }
14872             return opnum == OP_RUNCV
14873                 ? newPVOP(OP_RUNCV,0,NULL)
14874                 : newOP(opnum,0);
14875         default:
14876             return op_convert_list(opnum,0,aop);
14877         }
14878     }
14879     NOT_REACHED; /* NOTREACHED */
14880     return entersubop;
14881 }
14882
14883 /*
14884 =for apidoc cv_get_call_checker_flags
14885
14886 Retrieves the function that will be used to fix up a call to C<cv>.
14887 Specifically, the function is applied to an C<entersub> op tree for a
14888 subroutine call, not marked with C<&>, where the callee can be identified
14889 at compile time as C<cv>.
14890
14891 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14892 for it is returned in C<*ckobj_p>, and control flags are returned in
14893 C<*ckflags_p>.  The function is intended to be called in this manner:
14894
14895  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14896
14897 In this call, C<entersubop> is a pointer to the C<entersub> op,
14898 which may be replaced by the check function, and C<namegv> supplies
14899 the name that should be used by the check function to refer
14900 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14901 It is permitted to apply the check function in non-standard situations,
14902 such as to a call to a different subroutine or to a method call.
14903
14904 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
14905 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14906 instead, anything that can be used as the first argument to L</cv_name>.
14907 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14908 check function requires C<namegv> to be a genuine GV.
14909
14910 By default, the check function is
14911 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14912 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14913 flag is clear.  This implements standard prototype processing.  It can
14914 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14915
14916 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14917 indicates that the caller only knows about the genuine GV version of
14918 C<namegv>, and accordingly the corresponding bit will always be set in
14919 C<*ckflags_p>, regardless of the check function's recorded requirements.
14920 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14921 indicates the caller knows about the possibility of passing something
14922 other than a GV as C<namegv>, and accordingly the corresponding bit may
14923 be either set or clear in C<*ckflags_p>, indicating the check function's
14924 recorded requirements.
14925
14926 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14927 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14928 (for which see above).  All other bits should be clear.
14929
14930 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14931
14932 =for apidoc cv_get_call_checker
14933
14934 The original form of L</cv_get_call_checker_flags>, which does not return
14935 checker flags.  When using a checker function returned by this function,
14936 it is only safe to call it with a genuine GV as its C<namegv> argument.
14937
14938 =cut
14939 */
14940
14941 void
14942 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14943         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14944 {
14945     MAGIC *callmg;
14946     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14947     PERL_UNUSED_CONTEXT;
14948     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14949     if (callmg) {
14950         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14951         *ckobj_p = callmg->mg_obj;
14952         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14953     } else {
14954         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14955         *ckobj_p = (SV*)cv;
14956         *ckflags_p = gflags & MGf_REQUIRE_GV;
14957     }
14958 }
14959
14960 void
14961 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14962 {
14963     U32 ckflags;
14964     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14965     PERL_UNUSED_CONTEXT;
14966     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14967         &ckflags);
14968 }
14969
14970 /*
14971 =for apidoc cv_set_call_checker_flags
14972
14973 Sets the function that will be used to fix up a call to C<cv>.
14974 Specifically, the function is applied to an C<entersub> op tree for a
14975 subroutine call, not marked with C<&>, where the callee can be identified
14976 at compile time as C<cv>.
14977
14978 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14979 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14980 The function should be defined like this:
14981
14982     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14983
14984 It is intended to be called in this manner:
14985
14986     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14987
14988 In this call, C<entersubop> is a pointer to the C<entersub> op,
14989 which may be replaced by the check function, and C<namegv> supplies
14990 the name that should be used by the check function to refer
14991 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14992 It is permitted to apply the check function in non-standard situations,
14993 such as to a call to a different subroutine or to a method call.
14994
14995 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14996 CV or other SV instead.  Whatever is passed can be used as the first
14997 argument to L</cv_name>.  You can force perl to pass a GV by including
14998 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14999
15000 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
15001 bit currently has a defined meaning (for which see above).  All other
15002 bits should be clear.
15003
15004 The current setting for a particular CV can be retrieved by
15005 L</cv_get_call_checker_flags>.
15006
15007 =for apidoc cv_set_call_checker
15008
15009 The original form of L</cv_set_call_checker_flags>, which passes it the
15010 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
15011 of that flag setting is that the check function is guaranteed to get a
15012 genuine GV as its C<namegv> argument.
15013
15014 =cut
15015 */
15016
15017 void
15018 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
15019 {
15020     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
15021     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
15022 }
15023
15024 void
15025 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
15026                                      SV *ckobj, U32 ckflags)
15027 {
15028     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
15029     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
15030         if (SvMAGICAL((SV*)cv))
15031             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
15032     } else {
15033         MAGIC *callmg;
15034         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
15035         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
15036         assert(callmg);
15037         if (callmg->mg_flags & MGf_REFCOUNTED) {
15038             SvREFCNT_dec(callmg->mg_obj);
15039             callmg->mg_flags &= ~MGf_REFCOUNTED;
15040         }
15041         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
15042         callmg->mg_obj = ckobj;
15043         if (ckobj != (SV*)cv) {
15044             SvREFCNT_inc_simple_void_NN(ckobj);
15045             callmg->mg_flags |= MGf_REFCOUNTED;
15046         }
15047         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
15048                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
15049     }
15050 }
15051
15052 static void
15053 S_entersub_alloc_targ(pTHX_ OP * const o)
15054 {
15055     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
15056     o->op_private |= OPpENTERSUB_HASTARG;
15057 }
15058
15059 OP *
15060 Perl_ck_subr(pTHX_ OP *o)
15061 {
15062     OP *aop, *cvop;
15063     CV *cv;
15064     GV *namegv;
15065     SV **const_class = NULL;
15066
15067     PERL_ARGS_ASSERT_CK_SUBR;
15068
15069     aop = cUNOPx(o)->op_first;
15070     if (!OpHAS_SIBLING(aop))
15071         aop = cUNOPx(aop)->op_first;
15072     aop = OpSIBLING(aop);
15073     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
15074     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
15075     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
15076
15077     o->op_private &= ~1;
15078     o->op_private |= (PL_hints & HINT_STRICT_REFS);
15079     if (PERLDB_SUB && PL_curstash != PL_debstash)
15080         o->op_private |= OPpENTERSUB_DB;
15081     switch (cvop->op_type) {
15082         case OP_RV2CV:
15083             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
15084             op_null(cvop);
15085             break;
15086         case OP_METHOD:
15087         case OP_METHOD_NAMED:
15088         case OP_METHOD_SUPER:
15089         case OP_METHOD_REDIR:
15090         case OP_METHOD_REDIR_SUPER:
15091             o->op_flags |= OPf_REF;
15092             if (aop->op_type == OP_CONST) {
15093                 aop->op_private &= ~OPpCONST_STRICT;
15094                 const_class = &cSVOPx(aop)->op_sv;
15095             }
15096             else if (aop->op_type == OP_LIST) {
15097                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
15098                 if (sib && sib->op_type == OP_CONST) {
15099                     sib->op_private &= ~OPpCONST_STRICT;
15100                     const_class = &cSVOPx(sib)->op_sv;
15101                 }
15102             }
15103             /* make class name a shared cow string to speedup method calls */
15104             /* constant string might be replaced with object, f.e. bigint */
15105             if (const_class && SvPOK(*const_class)) {
15106                 STRLEN len;
15107                 const char* str = SvPV(*const_class, len);
15108                 if (len) {
15109                     SV* const shared = newSVpvn_share(
15110                         str, SvUTF8(*const_class)
15111                                     ? -(SSize_t)len : (SSize_t)len,
15112                         0
15113                     );
15114                     if (SvREADONLY(*const_class))
15115                         SvREADONLY_on(shared);
15116                     SvREFCNT_dec(*const_class);
15117                     *const_class = shared;
15118                 }
15119             }
15120             break;
15121     }
15122
15123     if (!cv) {
15124         S_entersub_alloc_targ(aTHX_ o);
15125         return ck_entersub_args_list(o);
15126     } else {
15127         Perl_call_checker ckfun;
15128         SV *ckobj;
15129         U32 ckflags;
15130         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
15131         if (CvISXSUB(cv) || !CvROOT(cv))
15132             S_entersub_alloc_targ(aTHX_ o);
15133         if (!namegv) {
15134             /* The original call checker API guarantees that a GV will be
15135                be provided with the right name.  So, if the old API was
15136                used (or the REQUIRE_GV flag was passed), we have to reify
15137                the CV’s GV, unless this is an anonymous sub.  This is not
15138                ideal for lexical subs, as its stringification will include
15139                the package.  But it is the best we can do.  */
15140             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
15141                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
15142                     namegv = CvGV(cv);
15143             }
15144             else namegv = MUTABLE_GV(cv);
15145             /* After a syntax error in a lexical sub, the cv that
15146                rv2cv_op_cv returns may be a nameless stub. */
15147             if (!namegv) return ck_entersub_args_list(o);
15148
15149         }
15150         return ckfun(aTHX_ o, namegv, ckobj);
15151     }
15152 }
15153
15154 OP *
15155 Perl_ck_svconst(pTHX_ OP *o)
15156 {
15157     SV * const sv = cSVOPo->op_sv;
15158     PERL_ARGS_ASSERT_CK_SVCONST;
15159     PERL_UNUSED_CONTEXT;
15160 #ifdef PERL_COPY_ON_WRITE
15161     /* Since the read-only flag may be used to protect a string buffer, we
15162        cannot do copy-on-write with existing read-only scalars that are not
15163        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
15164        that constant, mark the constant as COWable here, if it is not
15165        already read-only. */
15166     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
15167         SvIsCOW_on(sv);
15168         CowREFCNT(sv) = 0;
15169 # ifdef PERL_DEBUG_READONLY_COW
15170         sv_buf_to_ro(sv);
15171 # endif
15172     }
15173 #endif
15174     SvREADONLY_on(sv);
15175     return o;
15176 }
15177
15178 OP *
15179 Perl_ck_trunc(pTHX_ OP *o)
15180 {
15181     PERL_ARGS_ASSERT_CK_TRUNC;
15182
15183     if (o->op_flags & OPf_KIDS) {
15184         SVOP *kid = (SVOP*)cUNOPo->op_first;
15185
15186         if (kid->op_type == OP_NULL)
15187             kid = (SVOP*)OpSIBLING(kid);
15188         if (kid && kid->op_type == OP_CONST &&
15189             (kid->op_private & OPpCONST_BARE) &&
15190             !kid->op_folded)
15191         {
15192             o->op_flags |= OPf_SPECIAL;
15193             kid->op_private &= ~OPpCONST_STRICT;
15194         }
15195     }
15196     return ck_fun(o);
15197 }
15198
15199 OP *
15200 Perl_ck_substr(pTHX_ OP *o)
15201 {
15202     PERL_ARGS_ASSERT_CK_SUBSTR;
15203
15204     o = ck_fun(o);
15205     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15206         OP *kid = cLISTOPo->op_first;
15207
15208         if (kid->op_type == OP_NULL)
15209             kid = OpSIBLING(kid);
15210         if (kid)
15211             /* Historically, substr(delete $foo{bar},...) has been allowed
15212                with 4-arg substr.  Keep it working by applying entersub
15213                lvalue context.  */
15214             op_lvalue(kid, OP_ENTERSUB);
15215
15216     }
15217     return o;
15218 }
15219
15220 OP *
15221 Perl_ck_tell(pTHX_ OP *o)
15222 {
15223     PERL_ARGS_ASSERT_CK_TELL;
15224     o = ck_fun(o);
15225     if (o->op_flags & OPf_KIDS) {
15226      OP *kid = cLISTOPo->op_first;
15227      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15228      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15229     }
15230     return o;
15231 }
15232
15233 OP *
15234 Perl_ck_each(pTHX_ OP *o)
15235 {
15236     dVAR;
15237     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15238     const unsigned orig_type  = o->op_type;
15239
15240     PERL_ARGS_ASSERT_CK_EACH;
15241
15242     if (kid) {
15243         switch (kid->op_type) {
15244             case OP_PADHV:
15245             case OP_RV2HV:
15246                 break;
15247             case OP_PADAV:
15248             case OP_RV2AV:
15249                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15250                             : orig_type == OP_KEYS ? OP_AKEYS
15251                             :                        OP_AVALUES);
15252                 break;
15253             case OP_CONST:
15254                 if (kid->op_private == OPpCONST_BARE
15255                  || !SvROK(cSVOPx_sv(kid))
15256                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15257                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
15258                    )
15259                     goto bad;
15260                 /* FALLTHROUGH */
15261             default:
15262                 qerror(Perl_mess(aTHX_
15263                     "Experimental %s on scalar is now forbidden",
15264                      PL_op_desc[orig_type]));
15265                bad:
15266                 bad_type_pv(1, "hash or array", o, kid);
15267                 return o;
15268         }
15269     }
15270     return ck_fun(o);
15271 }
15272
15273 OP *
15274 Perl_ck_length(pTHX_ OP *o)
15275 {
15276     PERL_ARGS_ASSERT_CK_LENGTH;
15277
15278     o = ck_fun(o);
15279
15280     if (ckWARN(WARN_SYNTAX)) {
15281         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15282
15283         if (kid) {
15284             SV *name = NULL;
15285             const bool hash = kid->op_type == OP_PADHV
15286                            || kid->op_type == OP_RV2HV;
15287             switch (kid->op_type) {
15288                 case OP_PADHV:
15289                 case OP_PADAV:
15290                 case OP_RV2HV:
15291                 case OP_RV2AV:
15292                     name = S_op_varname(aTHX_ kid);
15293                     break;
15294                 default:
15295                     return o;
15296             }
15297             if (name)
15298                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15299                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15300                     ")\"?)",
15301                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
15302                 );
15303             else if (hash)
15304      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15305                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15306                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15307             else
15308      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15309                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15310                     "length() used on @array (did you mean \"scalar(@array)\"?)");
15311         }
15312     }
15313
15314     return o;
15315 }
15316
15317
15318 OP *
15319 Perl_ck_isa(pTHX_ OP *o)
15320 {
15321     OP *classop = cBINOPo->op_last;
15322
15323     PERL_ARGS_ASSERT_CK_ISA;
15324
15325     /* Convert barename into PV */
15326     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15327         /* TODO: Optionally convert package to raw HV here */
15328         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15329     }
15330
15331     return o;
15332 }
15333
15334
15335 /*
15336    ---------------------------------------------------------
15337
15338    Common vars in list assignment
15339
15340    There now follows some enums and static functions for detecting
15341    common variables in list assignments. Here is a little essay I wrote
15342    for myself when trying to get my head around this. DAPM.
15343
15344    ----
15345
15346    First some random observations:
15347
15348    * If a lexical var is an alias of something else, e.g.
15349        for my $x ($lex, $pkg, $a[0]) {...}
15350      then the act of aliasing will increase the reference count of the SV
15351
15352    * If a package var is an alias of something else, it may still have a
15353      reference count of 1, depending on how the alias was created, e.g.
15354      in *a = *b, $a may have a refcount of 1 since the GP is shared
15355      with a single GvSV pointer to the SV. So If it's an alias of another
15356      package var, then RC may be 1; if it's an alias of another scalar, e.g.
15357      a lexical var or an array element, then it will have RC > 1.
15358
15359    * There are many ways to create a package alias; ultimately, XS code
15360      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15361      run-time tracing mechanisms are unlikely to be able to catch all cases.
15362
15363    * When the LHS is all my declarations, the same vars can't appear directly
15364      on the RHS, but they can indirectly via closures, aliasing and lvalue
15365      subs. But those techniques all involve an increase in the lexical
15366      scalar's ref count.
15367
15368    * When the LHS is all lexical vars (but not necessarily my declarations),
15369      it is possible for the same lexicals to appear directly on the RHS, and
15370      without an increased ref count, since the stack isn't refcounted.
15371      This case can be detected at compile time by scanning for common lex
15372      vars with PL_generation.
15373
15374    * lvalue subs defeat common var detection, but they do at least
15375      return vars with a temporary ref count increment. Also, you can't
15376      tell at compile time whether a sub call is lvalue.
15377
15378
15379    So...
15380
15381    A: There are a few circumstances where there definitely can't be any
15382      commonality:
15383
15384        LHS empty:  () = (...);
15385        RHS empty:  (....) = ();
15386        RHS contains only constants or other 'can't possibly be shared'
15387            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
15388            i.e. they only contain ops not marked as dangerous, whose children
15389            are also not dangerous;
15390        LHS ditto;
15391        LHS contains a single scalar element: e.g. ($x) = (....); because
15392            after $x has been modified, it won't be used again on the RHS;
15393        RHS contains a single element with no aggregate on LHS: e.g.
15394            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
15395            won't be used again.
15396
15397    B: If LHS are all 'my' lexical var declarations (or safe ops, which
15398      we can ignore):
15399
15400        my ($a, $b, @c) = ...;
15401
15402        Due to closure and goto tricks, these vars may already have content.
15403        For the same reason, an element on the RHS may be a lexical or package
15404        alias of one of the vars on the left, or share common elements, for
15405        example:
15406
15407            my ($x,$y) = f(); # $x and $y on both sides
15408            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15409
15410        and
15411
15412            my $ra = f();
15413            my @a = @$ra;  # elements of @a on both sides
15414            sub f { @a = 1..4; \@a }
15415
15416
15417        First, just consider scalar vars on LHS:
15418
15419            RHS is safe only if (A), or in addition,
15420                * contains only lexical *scalar* vars, where neither side's
15421                  lexicals have been flagged as aliases
15422
15423            If RHS is not safe, then it's always legal to check LHS vars for
15424            RC==1, since the only RHS aliases will always be associated
15425            with an RC bump.
15426
15427            Note that in particular, RHS is not safe if:
15428
15429                * it contains package scalar vars; e.g.:
15430
15431                    f();
15432                    my ($x, $y) = (2, $x_alias);
15433                    sub f { $x = 1; *x_alias = \$x; }
15434
15435                * It contains other general elements, such as flattened or
15436                * spliced or single array or hash elements, e.g.
15437
15438                    f();
15439                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15440
15441                    sub f {
15442                        ($x, $y) = (1,2);
15443                        use feature 'refaliasing';
15444                        \($a[0], $a[1]) = \($y,$x);
15445                    }
15446
15447                  It doesn't matter if the array/hash is lexical or package.
15448
15449                * it contains a function call that happens to be an lvalue
15450                  sub which returns one or more of the above, e.g.
15451
15452                    f();
15453                    my ($x,$y) = f();
15454
15455                    sub f : lvalue {
15456                        ($x, $y) = (1,2);
15457                        *x1 = \$x;
15458                        $y, $x1;
15459                    }
15460
15461                    (so a sub call on the RHS should be treated the same
15462                    as having a package var on the RHS).
15463
15464                * any other "dangerous" thing, such an op or built-in that
15465                  returns one of the above, e.g. pp_preinc
15466
15467
15468            If RHS is not safe, what we can do however is at compile time flag
15469            that the LHS are all my declarations, and at run time check whether
15470            all the LHS have RC == 1, and if so skip the full scan.
15471
15472        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15473
15474            Here the issue is whether there can be elements of @a on the RHS
15475            which will get prematurely freed when @a is cleared prior to
15476            assignment. This is only a problem if the aliasing mechanism
15477            is one which doesn't increase the refcount - only if RC == 1
15478            will the RHS element be prematurely freed.
15479
15480            Because the array/hash is being INTROed, it or its elements
15481            can't directly appear on the RHS:
15482
15483                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15484
15485            but can indirectly, e.g.:
15486
15487                my $r = f();
15488                my (@a) = @$r;
15489                sub f { @a = 1..3; \@a }
15490
15491            So if the RHS isn't safe as defined by (A), we must always
15492            mortalise and bump the ref count of any remaining RHS elements
15493            when assigning to a non-empty LHS aggregate.
15494
15495            Lexical scalars on the RHS aren't safe if they've been involved in
15496            aliasing, e.g.
15497
15498                use feature 'refaliasing';
15499
15500                f();
15501                \(my $lex) = \$pkg;
15502                my @a = ($lex,3); # equivalent to ($a[0],3)
15503
15504                sub f {
15505                    @a = (1,2);
15506                    \$pkg = \$a[0];
15507                }
15508
15509            Similarly with lexical arrays and hashes on the RHS:
15510
15511                f();
15512                my @b;
15513                my @a = (@b);
15514
15515                sub f {
15516                    @a = (1,2);
15517                    \$b[0] = \$a[1];
15518                    \$b[1] = \$a[0];
15519                }
15520
15521
15522
15523    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15524        my $a; ($a, my $b) = (....);
15525
15526        The difference between (B) and (C) is that it is now physically
15527        possible for the LHS vars to appear on the RHS too, where they
15528        are not reference counted; but in this case, the compile-time
15529        PL_generation sweep will detect such common vars.
15530
15531        So the rules for (C) differ from (B) in that if common vars are
15532        detected, the runtime "test RC==1" optimisation can no longer be used,
15533        and a full mark and sweep is required
15534
15535    D: As (C), but in addition the LHS may contain package vars.
15536
15537        Since package vars can be aliased without a corresponding refcount
15538        increase, all bets are off. It's only safe if (A). E.g.
15539
15540            my ($x, $y) = (1,2);
15541
15542            for $x_alias ($x) {
15543                ($x_alias, $y) = (3, $x); # whoops
15544            }
15545
15546        Ditto for LHS aggregate package vars.
15547
15548    E: Any other dangerous ops on LHS, e.g.
15549            (f(), $a[0], @$r) = (...);
15550
15551        this is similar to (E) in that all bets are off. In addition, it's
15552        impossible to determine at compile time whether the LHS
15553        contains a scalar or an aggregate, e.g.
15554
15555            sub f : lvalue { @a }
15556            (f()) = 1..3;
15557
15558 * ---------------------------------------------------------
15559 */
15560
15561
15562 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15563  * that at least one of the things flagged was seen.
15564  */
15565
15566 enum {
15567     AAS_MY_SCALAR       = 0x001, /* my $scalar */
15568     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
15569     AAS_LEX_SCALAR      = 0x004, /* $lexical */
15570     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
15571     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15572     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
15573     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
15574     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
15575                                          that's flagged OA_DANGEROUS */
15576     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
15577                                         not in any of the categories above */
15578     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
15579 };
15580
15581
15582
15583 /* helper function for S_aassign_scan().
15584  * check a PAD-related op for commonality and/or set its generation number.
15585  * Returns a boolean indicating whether its shared */
15586
15587 static bool
15588 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15589 {
15590     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15591         /* lexical used in aliasing */
15592         return TRUE;
15593
15594     if (rhs)
15595         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15596     else
15597         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15598
15599     return FALSE;
15600 }
15601
15602
15603 /*
15604   Helper function for OPpASSIGN_COMMON* detection in rpeep().
15605   It scans the left or right hand subtree of the aassign op, and returns a
15606   set of flags indicating what sorts of things it found there.
15607   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15608   set PL_generation on lexical vars; if the latter, we see if
15609   PL_generation matches.
15610   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15611   This fn will increment it by the number seen. It's not intended to
15612   be an accurate count (especially as many ops can push a variable
15613   number of SVs onto the stack); rather it's used as to test whether there
15614   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15615 */
15616
15617 static int
15618 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15619 {
15620     OP *top_op           = o;
15621     OP *effective_top_op = o;
15622     int all_flags = 0;
15623
15624     while (1) {
15625     bool top = o == effective_top_op;
15626     int flags = 0;
15627     OP* next_kid = NULL;
15628
15629     /* first, look for a solitary @_ on the RHS */
15630     if (   rhs
15631         && top
15632         && (o->op_flags & OPf_KIDS)
15633         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15634     ) {
15635         OP *kid = cUNOPo->op_first;
15636         if (   (   kid->op_type == OP_PUSHMARK
15637                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15638             && ((kid = OpSIBLING(kid)))
15639             && !OpHAS_SIBLING(kid)
15640             && kid->op_type == OP_RV2AV
15641             && !(kid->op_flags & OPf_REF)
15642             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15643             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15644             && ((kid = cUNOPx(kid)->op_first))
15645             && kid->op_type == OP_GV
15646             && cGVOPx_gv(kid) == PL_defgv
15647         )
15648             flags = AAS_DEFAV;
15649     }
15650
15651     switch (o->op_type) {
15652     case OP_GVSV:
15653         (*scalars_p)++;
15654         all_flags |= AAS_PKG_SCALAR;
15655         goto do_next;
15656
15657     case OP_PADAV:
15658     case OP_PADHV:
15659         (*scalars_p) += 2;
15660         /* if !top, could be e.g. @a[0,1] */
15661         all_flags |=  (top && (o->op_flags & OPf_REF))
15662                         ? ((o->op_private & OPpLVAL_INTRO)
15663                             ? AAS_MY_AGG : AAS_LEX_AGG)
15664                         : AAS_DANGEROUS;
15665         goto do_next;
15666
15667     case OP_PADSV:
15668         {
15669             int comm = S_aassign_padcheck(aTHX_ o, rhs)
15670                         ?  AAS_LEX_SCALAR_COMM : 0;
15671             (*scalars_p)++;
15672             all_flags |= (o->op_private & OPpLVAL_INTRO)
15673                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15674             goto do_next;
15675
15676         }
15677
15678     case OP_RV2AV:
15679     case OP_RV2HV:
15680         (*scalars_p) += 2;
15681         if (cUNOPx(o)->op_first->op_type != OP_GV)
15682             all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15683         /* @pkg, %pkg */
15684         /* if !top, could be e.g. @a[0,1] */
15685         else if (top && (o->op_flags & OPf_REF))
15686             all_flags |= AAS_PKG_AGG;
15687         else
15688             all_flags |= AAS_DANGEROUS;
15689         goto do_next;
15690
15691     case OP_RV2SV:
15692         (*scalars_p)++;
15693         if (cUNOPx(o)->op_first->op_type != OP_GV) {
15694             (*scalars_p) += 2;
15695             all_flags |= AAS_DANGEROUS; /* ${expr} */
15696         }
15697         else
15698             all_flags |= AAS_PKG_SCALAR; /* $pkg */
15699         goto do_next;
15700
15701     case OP_SPLIT:
15702         if (o->op_private & OPpSPLIT_ASSIGN) {
15703             /* the assign in @a = split() has been optimised away
15704              * and the @a attached directly to the split op
15705              * Treat the array as appearing on the RHS, i.e.
15706              *    ... = (@a = split)
15707              * is treated like
15708              *    ... = @a;
15709              */
15710
15711             if (o->op_flags & OPf_STACKED) {
15712                 /* @{expr} = split() - the array expression is tacked
15713                  * on as an extra child to split - process kid */
15714                 next_kid = cLISTOPo->op_last;
15715                 goto do_next;
15716             }
15717
15718             /* ... else array is directly attached to split op */
15719             (*scalars_p) += 2;
15720             all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15721                             ? ((o->op_private & OPpLVAL_INTRO)
15722                                 ? AAS_MY_AGG : AAS_LEX_AGG)
15723                             : AAS_PKG_AGG;
15724             goto do_next;
15725         }
15726         (*scalars_p)++;
15727         /* other args of split can't be returned */
15728         all_flags |= AAS_SAFE_SCALAR;
15729         goto do_next;
15730
15731     case OP_UNDEF:
15732         /* undef counts as a scalar on the RHS:
15733          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
15734          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
15735          */
15736         if (rhs)
15737             (*scalars_p)++;
15738         flags = AAS_SAFE_SCALAR;
15739         break;
15740
15741     case OP_PUSHMARK:
15742     case OP_STUB:
15743         /* these are all no-ops; they don't push a potentially common SV
15744          * onto the stack, so they are neither AAS_DANGEROUS nor
15745          * AAS_SAFE_SCALAR */
15746         goto do_next;
15747
15748     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15749         break;
15750
15751     case OP_NULL:
15752     case OP_LIST:
15753         /* these do nothing, but may have children */
15754         break;
15755
15756     default:
15757         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15758             (*scalars_p) += 2;
15759             flags = AAS_DANGEROUS;
15760             break;
15761         }
15762
15763         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
15764             && (o->op_private & OPpTARGET_MY))
15765         {
15766             (*scalars_p)++;
15767             all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15768                             ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15769             goto do_next;
15770         }
15771
15772         /* if its an unrecognised, non-dangerous op, assume that it
15773          * it the cause of at least one safe scalar */
15774         (*scalars_p)++;
15775         flags = AAS_SAFE_SCALAR;
15776         break;
15777     }
15778
15779     all_flags |= flags;
15780
15781     /* by default, process all kids next
15782      * XXX this assumes that all other ops are "transparent" - i.e. that
15783      * they can return some of their children. While this true for e.g.
15784      * sort and grep, it's not true for e.g. map. We really need a
15785      * 'transparent' flag added to regen/opcodes
15786      */
15787     if (o->op_flags & OPf_KIDS) {
15788         next_kid = cUNOPo->op_first;
15789         /* these ops do nothing but may have children; but their
15790          * children should also be treated as top-level */
15791         if (   o == effective_top_op
15792             && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15793         )
15794             effective_top_op = next_kid;
15795     }
15796
15797
15798     /* If next_kid is set, someone in the code above wanted us to process
15799      * that kid and all its remaining siblings.  Otherwise, work our way
15800      * back up the tree */
15801   do_next:
15802     while (!next_kid) {
15803         if (o == top_op)
15804             return all_flags; /* at top; no parents/siblings to try */
15805         if (OpHAS_SIBLING(o)) {
15806             next_kid = o->op_sibparent;
15807             if (o == effective_top_op)
15808                 effective_top_op = next_kid;
15809         }
15810         else
15811             if (o == effective_top_op)
15812                 effective_top_op = o->op_sibparent;
15813             o = o->op_sibparent; /* try parent's next sibling */
15814
15815     }
15816     o = next_kid;
15817     } /* while */
15818
15819 }
15820
15821
15822 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15823    and modify the optree to make them work inplace */
15824
15825 STATIC void
15826 S_inplace_aassign(pTHX_ OP *o) {
15827
15828     OP *modop, *modop_pushmark;
15829     OP *oright;
15830     OP *oleft, *oleft_pushmark;
15831
15832     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15833
15834     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15835
15836     assert(cUNOPo->op_first->op_type == OP_NULL);
15837     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15838     assert(modop_pushmark->op_type == OP_PUSHMARK);
15839     modop = OpSIBLING(modop_pushmark);
15840
15841     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15842         return;
15843
15844     /* no other operation except sort/reverse */
15845     if (OpHAS_SIBLING(modop))
15846         return;
15847
15848     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15849     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15850
15851     if (modop->op_flags & OPf_STACKED) {
15852         /* skip sort subroutine/block */
15853         assert(oright->op_type == OP_NULL);
15854         oright = OpSIBLING(oright);
15855     }
15856
15857     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15858     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15859     assert(oleft_pushmark->op_type == OP_PUSHMARK);
15860     oleft = OpSIBLING(oleft_pushmark);
15861
15862     /* Check the lhs is an array */
15863     if (!oleft ||
15864         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15865         || OpHAS_SIBLING(oleft)
15866         || (oleft->op_private & OPpLVAL_INTRO)
15867     )
15868         return;
15869
15870     /* Only one thing on the rhs */
15871     if (OpHAS_SIBLING(oright))
15872         return;
15873
15874     /* check the array is the same on both sides */
15875     if (oleft->op_type == OP_RV2AV) {
15876         if (oright->op_type != OP_RV2AV
15877             || !cUNOPx(oright)->op_first
15878             || cUNOPx(oright)->op_first->op_type != OP_GV
15879             || cUNOPx(oleft )->op_first->op_type != OP_GV
15880             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15881                cGVOPx_gv(cUNOPx(oright)->op_first)
15882         )
15883             return;
15884     }
15885     else if (oright->op_type != OP_PADAV
15886         || oright->op_targ != oleft->op_targ
15887     )
15888         return;
15889
15890     /* This actually is an inplace assignment */
15891
15892     modop->op_private |= OPpSORT_INPLACE;
15893
15894     /* transfer MODishness etc from LHS arg to RHS arg */
15895     oright->op_flags = oleft->op_flags;
15896
15897     /* remove the aassign op and the lhs */
15898     op_null(o);
15899     op_null(oleft_pushmark);
15900     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15901         op_null(cUNOPx(oleft)->op_first);
15902     op_null(oleft);
15903 }
15904
15905
15906
15907 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15908  * that potentially represent a series of one or more aggregate derefs
15909  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15910  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15911  * additional ops left in too).
15912  *
15913  * The caller will have already verified that the first few ops in the
15914  * chain following 'start' indicate a multideref candidate, and will have
15915  * set 'orig_o' to the point further on in the chain where the first index
15916  * expression (if any) begins.  'orig_action' specifies what type of
15917  * beginning has already been determined by the ops between start..orig_o
15918  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
15919  *
15920  * 'hints' contains any hints flags that need adding (currently just
15921  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15922  */
15923
15924 STATIC void
15925 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15926 {
15927     dVAR;
15928     int pass;
15929     UNOP_AUX_item *arg_buf = NULL;
15930     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
15931     int index_skip         = -1;    /* don't output index arg on this action */
15932
15933     /* similar to regex compiling, do two passes; the first pass
15934      * determines whether the op chain is convertible and calculates the
15935      * buffer size; the second pass populates the buffer and makes any
15936      * changes necessary to ops (such as moving consts to the pad on
15937      * threaded builds).
15938      *
15939      * NB: for things like Coverity, note that both passes take the same
15940      * path through the logic tree (except for 'if (pass)' bits), since
15941      * both passes are following the same op_next chain; and in
15942      * particular, if it would return early on the second pass, it would
15943      * already have returned early on the first pass.
15944      */
15945     for (pass = 0; pass < 2; pass++) {
15946         OP *o                = orig_o;
15947         UV action            = orig_action;
15948         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
15949         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
15950         int action_count     = 0;     /* number of actions seen so far */
15951         int action_ix        = 0;     /* action_count % (actions per IV) */
15952         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
15953         bool is_last         = FALSE; /* no more derefs to follow */
15954         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15955         UV action_word       = 0;     /* all actions so far */
15956         UNOP_AUX_item *arg     = arg_buf;
15957         UNOP_AUX_item *action_ptr = arg_buf;
15958
15959         arg++; /* reserve slot for first action word */
15960
15961         switch (action) {
15962         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15963         case MDEREF_HV_gvhv_helem:
15964             next_is_hash = TRUE;
15965             /* FALLTHROUGH */
15966         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15967         case MDEREF_AV_gvav_aelem:
15968             if (pass) {
15969 #ifdef USE_ITHREADS
15970                 arg->pad_offset = cPADOPx(start)->op_padix;
15971                 /* stop it being swiped when nulled */
15972                 cPADOPx(start)->op_padix = 0;
15973 #else
15974                 arg->sv = cSVOPx(start)->op_sv;
15975                 cSVOPx(start)->op_sv = NULL;
15976 #endif
15977             }
15978             arg++;
15979             break;
15980
15981         case MDEREF_HV_padhv_helem:
15982         case MDEREF_HV_padsv_vivify_rv2hv_helem:
15983             next_is_hash = TRUE;
15984             /* FALLTHROUGH */
15985         case MDEREF_AV_padav_aelem:
15986         case MDEREF_AV_padsv_vivify_rv2av_aelem:
15987             if (pass) {
15988                 arg->pad_offset = start->op_targ;
15989                 /* we skip setting op_targ = 0 for now, since the intact
15990                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15991                 reset_start_targ = TRUE;
15992             }
15993             arg++;
15994             break;
15995
15996         case MDEREF_HV_pop_rv2hv_helem:
15997             next_is_hash = TRUE;
15998             /* FALLTHROUGH */
15999         case MDEREF_AV_pop_rv2av_aelem:
16000             break;
16001
16002         default:
16003             NOT_REACHED; /* NOTREACHED */
16004             return;
16005         }
16006
16007         while (!is_last) {
16008             /* look for another (rv2av/hv; get index;
16009              * aelem/helem/exists/delele) sequence */
16010
16011             OP *kid;
16012             bool is_deref;
16013             bool ok;
16014             UV index_type = MDEREF_INDEX_none;
16015
16016             if (action_count) {
16017                 /* if this is not the first lookup, consume the rv2av/hv  */
16018
16019                 /* for N levels of aggregate lookup, we normally expect
16020                  * that the first N-1 [ah]elem ops will be flagged as
16021                  * /DEREF (so they autovivifiy if necessary), and the last
16022                  * lookup op not to be.
16023                  * For other things (like @{$h{k1}{k2}}) extra scope or
16024                  * leave ops can appear, so abandon the effort in that
16025                  * case */
16026                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
16027                     return;
16028
16029                 /* rv2av or rv2hv sKR/1 */
16030
16031                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16032                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16033                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16034                     return;
16035
16036                 /* at this point, we wouldn't expect any of these
16037                  * possible private flags:
16038                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
16039                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
16040                  */
16041                 ASSUME(!(o->op_private &
16042                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
16043
16044                 hints = (o->op_private & OPpHINT_STRICT_REFS);
16045
16046                 /* make sure the type of the previous /DEREF matches the
16047                  * type of the next lookup */
16048                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
16049                 top_op = o;
16050
16051                 action = next_is_hash
16052                             ? MDEREF_HV_vivify_rv2hv_helem
16053                             : MDEREF_AV_vivify_rv2av_aelem;
16054                 o = o->op_next;
16055             }
16056
16057             /* if this is the second pass, and we're at the depth where
16058              * previously we encountered a non-simple index expression,
16059              * stop processing the index at this point */
16060             if (action_count != index_skip) {
16061
16062                 /* look for one or more simple ops that return an array
16063                  * index or hash key */
16064
16065                 switch (o->op_type) {
16066                 case OP_PADSV:
16067                     /* it may be a lexical var index */
16068                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
16069                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16070                     ASSUME(!(o->op_private &
16071                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16072
16073                     if (   OP_GIMME(o,0) == G_SCALAR
16074                         && !(o->op_flags & (OPf_REF|OPf_MOD))
16075                         && o->op_private == 0)
16076                     {
16077                         if (pass)
16078                             arg->pad_offset = o->op_targ;
16079                         arg++;
16080                         index_type = MDEREF_INDEX_padsv;
16081                         o = o->op_next;
16082                     }
16083                     break;
16084
16085                 case OP_CONST:
16086                     if (next_is_hash) {
16087                         /* it's a constant hash index */
16088                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
16089                             /* "use constant foo => FOO; $h{+foo}" for
16090                              * some weird FOO, can leave you with constants
16091                              * that aren't simple strings. It's not worth
16092                              * the extra hassle for those edge cases */
16093                             break;
16094
16095                         {
16096                             UNOP *rop = NULL;
16097                             OP * helem_op = o->op_next;
16098
16099                             ASSUME(   helem_op->op_type == OP_HELEM
16100                                    || helem_op->op_type == OP_NULL
16101                                    || pass == 0);
16102                             if (helem_op->op_type == OP_HELEM) {
16103                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
16104                                 if (   helem_op->op_private & OPpLVAL_INTRO
16105                                     || rop->op_type != OP_RV2HV
16106                                 )
16107                                     rop = NULL;
16108                             }
16109                             /* on first pass just check; on second pass
16110                              * hekify */
16111                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
16112                                                             pass);
16113                         }
16114
16115                         if (pass) {
16116 #ifdef USE_ITHREADS
16117                             /* Relocate sv to the pad for thread safety */
16118                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
16119                             arg->pad_offset = o->op_targ;
16120                             o->op_targ = 0;
16121 #else
16122                             arg->sv = cSVOPx_sv(o);
16123 #endif
16124                         }
16125                     }
16126                     else {
16127                         /* it's a constant array index */
16128                         IV iv;
16129                         SV *ix_sv = cSVOPo->op_sv;
16130                         if (!SvIOK(ix_sv))
16131                             break;
16132                         iv = SvIV(ix_sv);
16133
16134                         if (   action_count == 0
16135                             && iv >= -128
16136                             && iv <= 127
16137                             && (   action == MDEREF_AV_padav_aelem
16138                                 || action == MDEREF_AV_gvav_aelem)
16139                         )
16140                             maybe_aelemfast = TRUE;
16141
16142                         if (pass) {
16143                             arg->iv = iv;
16144                             SvREFCNT_dec_NN(cSVOPo->op_sv);
16145                         }
16146                     }
16147                     if (pass)
16148                         /* we've taken ownership of the SV */
16149                         cSVOPo->op_sv = NULL;
16150                     arg++;
16151                     index_type = MDEREF_INDEX_const;
16152                     o = o->op_next;
16153                     break;
16154
16155                 case OP_GV:
16156                     /* it may be a package var index */
16157
16158                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
16159                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
16160                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
16161                         || o->op_private != 0
16162                     )
16163                         break;
16164
16165                     kid = o->op_next;
16166                     if (kid->op_type != OP_RV2SV)
16167                         break;
16168
16169                     ASSUME(!(kid->op_flags &
16170                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
16171                              |OPf_SPECIAL|OPf_PARENS)));
16172                     ASSUME(!(kid->op_private &
16173                                     ~(OPpARG1_MASK
16174                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
16175                                      |OPpDEREF|OPpLVAL_INTRO)));
16176                     if(   (kid->op_flags &~ OPf_PARENS)
16177                             != (OPf_WANT_SCALAR|OPf_KIDS)
16178                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16179                     )
16180                         break;
16181
16182                     if (pass) {
16183 #ifdef USE_ITHREADS
16184                         arg->pad_offset = cPADOPx(o)->op_padix;
16185                         /* stop it being swiped when nulled */
16186                         cPADOPx(o)->op_padix = 0;
16187 #else
16188                         arg->sv = cSVOPx(o)->op_sv;
16189                         cSVOPo->op_sv = NULL;
16190 #endif
16191                     }
16192                     arg++;
16193                     index_type = MDEREF_INDEX_gvsv;
16194                     o = kid->op_next;
16195                     break;
16196
16197                 } /* switch */
16198             } /* action_count != index_skip */
16199
16200             action |= index_type;
16201
16202
16203             /* at this point we have either:
16204              *   * detected what looks like a simple index expression,
16205              *     and expect the next op to be an [ah]elem, or
16206              *     an nulled  [ah]elem followed by a delete or exists;
16207              *  * found a more complex expression, so something other
16208              *    than the above follows.
16209              */
16210
16211             /* possibly an optimised away [ah]elem (where op_next is
16212              * exists or delete) */
16213             if (o->op_type == OP_NULL)
16214                 o = o->op_next;
16215
16216             /* at this point we're looking for an OP_AELEM, OP_HELEM,
16217              * OP_EXISTS or OP_DELETE */
16218
16219             /* if a custom array/hash access checker is in scope,
16220              * abandon optimisation attempt */
16221             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16222                && PL_check[o->op_type] != Perl_ck_null)
16223                 return;
16224             /* similarly for customised exists and delete */
16225             if (  (o->op_type == OP_EXISTS)
16226                && PL_check[o->op_type] != Perl_ck_exists)
16227                 return;
16228             if (  (o->op_type == OP_DELETE)
16229                && PL_check[o->op_type] != Perl_ck_delete)
16230                 return;
16231
16232             if (   o->op_type != OP_AELEM
16233                 || (o->op_private &
16234                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16235                 )
16236                 maybe_aelemfast = FALSE;
16237
16238             /* look for aelem/helem/exists/delete. If it's not the last elem
16239              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16240              * flags; if it's the last, then it mustn't have
16241              * OPpDEREF_AV/HV, but may have lots of other flags, like
16242              * OPpLVAL_INTRO etc
16243              */
16244
16245             if (   index_type == MDEREF_INDEX_none
16246                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
16247                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16248             )
16249                 ok = FALSE;
16250             else {
16251                 /* we have aelem/helem/exists/delete with valid simple index */
16252
16253                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16254                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
16255                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16256
16257                 /* This doesn't make much sense but is legal:
16258                  *    @{ local $x[0][0] } = 1
16259                  * Since scope exit will undo the autovivification,
16260                  * don't bother in the first place. The OP_LEAVE
16261                  * assertion is in case there are other cases of both
16262                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16263                  * exit that would undo the local - in which case this
16264                  * block of code would need rethinking.
16265                  */
16266                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16267 #ifdef DEBUGGING
16268                     OP *n = o->op_next;
16269                     while (n && (  n->op_type == OP_NULL
16270                                 || n->op_type == OP_LIST
16271                                 || n->op_type == OP_SCALAR))
16272                         n = n->op_next;
16273                     assert(n && n->op_type == OP_LEAVE);
16274 #endif
16275                     o->op_private &= ~OPpDEREF;
16276                     is_deref = FALSE;
16277                 }
16278
16279                 if (is_deref) {
16280                     ASSUME(!(o->op_flags &
16281                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16282                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16283
16284                     ok =    (o->op_flags &~ OPf_PARENS)
16285                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16286                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16287                 }
16288                 else if (o->op_type == OP_EXISTS) {
16289                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16290                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16291                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16292                     ok =  !(o->op_private & ~OPpARG1_MASK);
16293                 }
16294                 else if (o->op_type == OP_DELETE) {
16295                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16296                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16297                     ASSUME(!(o->op_private &
16298                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16299                     /* don't handle slices or 'local delete'; the latter
16300                      * is fairly rare, and has a complex runtime */
16301                     ok =  !(o->op_private & ~OPpARG1_MASK);
16302                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16303                         /* skip handling run-tome error */
16304                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16305                 }
16306                 else {
16307                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16308                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16309                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16310                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16311                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16312                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16313                 }
16314             }
16315
16316             if (ok) {
16317                 if (!first_elem_op)
16318                     first_elem_op = o;
16319                 top_op = o;
16320                 if (is_deref) {
16321                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16322                     o = o->op_next;
16323                 }
16324                 else {
16325                     is_last = TRUE;
16326                     action |= MDEREF_FLAG_last;
16327                 }
16328             }
16329             else {
16330                 /* at this point we have something that started
16331                  * promisingly enough (with rv2av or whatever), but failed
16332                  * to find a simple index followed by an
16333                  * aelem/helem/exists/delete. If this is the first action,
16334                  * give up; but if we've already seen at least one
16335                  * aelem/helem, then keep them and add a new action with
16336                  * MDEREF_INDEX_none, which causes it to do the vivify
16337                  * from the end of the previous lookup, and do the deref,
16338                  * but stop at that point. So $a[0][expr] will do one
16339                  * av_fetch, vivify and deref, then continue executing at
16340                  * expr */
16341                 if (!action_count)
16342                     return;
16343                 is_last = TRUE;
16344                 index_skip = action_count;
16345                 action |= MDEREF_FLAG_last;
16346                 if (index_type != MDEREF_INDEX_none)
16347                     arg--;
16348             }
16349
16350             action_word |= (action << (action_ix * MDEREF_SHIFT));
16351             action_ix++;
16352             action_count++;
16353             /* if there's no space for the next action, reserve a new slot
16354              * for it *before* we start adding args for that action */
16355             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16356                 if (pass)
16357                     action_ptr->uv = action_word;
16358                 action_word = 0;
16359                 action_ptr = arg;
16360                 arg++;
16361                 action_ix = 0;
16362             }
16363         } /* while !is_last */
16364
16365         /* success! */
16366
16367         if (!action_ix)
16368             /* slot reserved for next action word not now needed */
16369             arg--;
16370         else if (pass)
16371             action_ptr->uv = action_word;
16372
16373         if (pass) {
16374             OP *mderef;
16375             OP *p, *q;
16376
16377             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16378             if (index_skip == -1) {
16379                 mderef->op_flags = o->op_flags
16380                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16381                 if (o->op_type == OP_EXISTS)
16382                     mderef->op_private = OPpMULTIDEREF_EXISTS;
16383                 else if (o->op_type == OP_DELETE)
16384                     mderef->op_private = OPpMULTIDEREF_DELETE;
16385                 else
16386                     mderef->op_private = o->op_private
16387                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16388             }
16389             /* accumulate strictness from every level (although I don't think
16390              * they can actually vary) */
16391             mderef->op_private |= hints;
16392
16393             /* integrate the new multideref op into the optree and the
16394              * op_next chain.
16395              *
16396              * In general an op like aelem or helem has two child
16397              * sub-trees: the aggregate expression (a_expr) and the
16398              * index expression (i_expr):
16399              *
16400              *     aelem
16401              *       |
16402              *     a_expr - i_expr
16403              *
16404              * The a_expr returns an AV or HV, while the i-expr returns an
16405              * index. In general a multideref replaces most or all of a
16406              * multi-level tree, e.g.
16407              *
16408              *     exists
16409              *       |
16410              *     ex-aelem
16411              *       |
16412              *     rv2av  - i_expr1
16413              *       |
16414              *     helem
16415              *       |
16416              *     rv2hv  - i_expr2
16417              *       |
16418              *     aelem
16419              *       |
16420              *     a_expr - i_expr3
16421              *
16422              * With multideref, all the i_exprs will be simple vars or
16423              * constants, except that i_expr1 may be arbitrary in the case
16424              * of MDEREF_INDEX_none.
16425              *
16426              * The bottom-most a_expr will be either:
16427              *   1) a simple var (so padXv or gv+rv2Xv);
16428              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
16429              *      so a simple var with an extra rv2Xv;
16430              *   3) or an arbitrary expression.
16431              *
16432              * 'start', the first op in the execution chain, will point to
16433              *   1),2): the padXv or gv op;
16434              *   3):    the rv2Xv which forms the last op in the a_expr
16435              *          execution chain, and the top-most op in the a_expr
16436              *          subtree.
16437              *
16438              * For all cases, the 'start' node is no longer required,
16439              * but we can't free it since one or more external nodes
16440              * may point to it. E.g. consider
16441              *     $h{foo} = $a ? $b : $c
16442              * Here, both the op_next and op_other branches of the
16443              * cond_expr point to the gv[*h] of the hash expression, so
16444              * we can't free the 'start' op.
16445              *
16446              * For expr->[...], we need to save the subtree containing the
16447              * expression; for the other cases, we just need to save the
16448              * start node.
16449              * So in all cases, we null the start op and keep it around by
16450              * making it the child of the multideref op; for the expr->
16451              * case, the expr will be a subtree of the start node.
16452              *
16453              * So in the simple 1,2 case the  optree above changes to
16454              *
16455              *     ex-exists
16456              *       |
16457              *     multideref
16458              *       |
16459              *     ex-gv (or ex-padxv)
16460              *
16461              *  with the op_next chain being
16462              *
16463              *  -> ex-gv -> multideref -> op-following-ex-exists ->
16464              *
16465              *  In the 3 case, we have
16466              *
16467              *     ex-exists
16468              *       |
16469              *     multideref
16470              *       |
16471              *     ex-rv2xv
16472              *       |
16473              *    rest-of-a_expr
16474              *      subtree
16475              *
16476              *  and
16477              *
16478              *  -> rest-of-a_expr subtree ->
16479              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
16480              *
16481              *
16482              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16483              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16484              * multideref attached as the child, e.g.
16485              *
16486              *     exists
16487              *       |
16488              *     ex-aelem
16489              *       |
16490              *     ex-rv2av  - i_expr1
16491              *       |
16492              *     multideref
16493              *       |
16494              *     ex-whatever
16495              *
16496              */
16497
16498             /* if we free this op, don't free the pad entry */
16499             if (reset_start_targ)
16500                 start->op_targ = 0;
16501
16502
16503             /* Cut the bit we need to save out of the tree and attach to
16504              * the multideref op, then free the rest of the tree */
16505
16506             /* find parent of node to be detached (for use by splice) */
16507             p = first_elem_op;
16508             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
16509                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16510             {
16511                 /* there is an arbitrary expression preceding us, e.g.
16512                  * expr->[..]? so we need to save the 'expr' subtree */
16513                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16514                     p = cUNOPx(p)->op_first;
16515                 ASSUME(   start->op_type == OP_RV2AV
16516                        || start->op_type == OP_RV2HV);
16517             }
16518             else {
16519                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16520                  * above for exists/delete. */
16521                 while (   (p->op_flags & OPf_KIDS)
16522                        && cUNOPx(p)->op_first != start
16523                 )
16524                     p = cUNOPx(p)->op_first;
16525             }
16526             ASSUME(cUNOPx(p)->op_first == start);
16527
16528             /* detach from main tree, and re-attach under the multideref */
16529             op_sibling_splice(mderef, NULL, 0,
16530                     op_sibling_splice(p, NULL, 1, NULL));
16531             op_null(start);
16532
16533             start->op_next = mderef;
16534
16535             mderef->op_next = index_skip == -1 ? o->op_next : o;
16536
16537             /* excise and free the original tree, and replace with
16538              * the multideref op */
16539             p = op_sibling_splice(top_op, NULL, -1, mderef);
16540             while (p) {
16541                 q = OpSIBLING(p);
16542                 op_free(p);
16543                 p = q;
16544             }
16545             op_null(top_op);
16546         }
16547         else {
16548             Size_t size = arg - arg_buf;
16549
16550             if (maybe_aelemfast && action_count == 1)
16551                 return;
16552
16553             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16554                                 sizeof(UNOP_AUX_item) * (size + 1));
16555             /* for dumping etc: store the length in a hidden first slot;
16556              * we set the op_aux pointer to the second slot */
16557             arg_buf->uv = size;
16558             arg_buf++;
16559         }
16560     } /* for (pass = ...) */
16561 }
16562
16563 /* See if the ops following o are such that o will always be executed in
16564  * boolean context: that is, the SV which o pushes onto the stack will
16565  * only ever be consumed by later ops via SvTRUE(sv) or similar.
16566  * If so, set a suitable private flag on o. Normally this will be
16567  * bool_flag; but see below why maybe_flag is needed too.
16568  *
16569  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16570  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16571  * already be taken, so you'll have to give that op two different flags.
16572  *
16573  * More explanation of 'maybe_flag' and 'safe_and' parameters.
16574  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16575  * those underlying ops) short-circuit, which means that rather than
16576  * necessarily returning a truth value, they may return the LH argument,
16577  * which may not be boolean. For example in $x = (keys %h || -1), keys
16578  * should return a key count rather than a boolean, even though its
16579  * sort-of being used in boolean context.
16580  *
16581  * So we only consider such logical ops to provide boolean context to
16582  * their LH argument if they themselves are in void or boolean context.
16583  * However, sometimes the context isn't known until run-time. In this
16584  * case the op is marked with the maybe_flag flag it.
16585  *
16586  * Consider the following.
16587  *
16588  *     sub f { ....;  if (%h) { .... } }
16589  *
16590  * This is actually compiled as
16591  *
16592  *     sub f { ....;  %h && do { .... } }
16593  *
16594  * Here we won't know until runtime whether the final statement (and hence
16595  * the &&) is in void context and so is safe to return a boolean value.
16596  * So mark o with maybe_flag rather than the bool_flag.
16597  * Note that there is cost associated with determining context at runtime
16598  * (e.g. a call to block_gimme()), so it may not be worth setting (at
16599  * compile time) and testing (at runtime) maybe_flag if the scalar verses
16600  * boolean costs savings are marginal.
16601  *
16602  * However, we can do slightly better with && (compared to || and //):
16603  * this op only returns its LH argument when that argument is false. In
16604  * this case, as long as the op promises to return a false value which is
16605  * valid in both boolean and scalar contexts, we can mark an op consumed
16606  * by && with bool_flag rather than maybe_flag.
16607  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16608  * than &PL_sv_no for a false result in boolean context, then it's safe. An
16609  * op which promises to handle this case is indicated by setting safe_and
16610  * to true.
16611  */
16612
16613 static void
16614 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16615 {
16616     OP *lop;
16617     U8 flag = 0;
16618
16619     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16620
16621     /* OPpTARGET_MY and boolean context probably don't mix well.
16622      * If someone finds a valid use case, maybe add an extra flag to this
16623      * function which indicates its safe to do so for this op? */
16624     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
16625              && (o->op_private & OPpTARGET_MY)));
16626
16627     lop = o->op_next;
16628
16629     while (lop) {
16630         switch (lop->op_type) {
16631         case OP_NULL:
16632         case OP_SCALAR:
16633             break;
16634
16635         /* these two consume the stack argument in the scalar case,
16636          * and treat it as a boolean in the non linenumber case */
16637         case OP_FLIP:
16638         case OP_FLOP:
16639             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16640                 || (lop->op_private & OPpFLIP_LINENUM))
16641             {
16642                 lop = NULL;
16643                 break;
16644             }
16645             /* FALLTHROUGH */
16646         /* these never leave the original value on the stack */
16647         case OP_NOT:
16648         case OP_XOR:
16649         case OP_COND_EXPR:
16650         case OP_GREPWHILE:
16651             flag = bool_flag;
16652             lop = NULL;
16653             break;
16654
16655         /* OR DOR and AND evaluate their arg as a boolean, but then may
16656          * leave the original scalar value on the stack when following the
16657          * op_next route. If not in void context, we need to ensure
16658          * that whatever follows consumes the arg only in boolean context
16659          * too.
16660          */
16661         case OP_AND:
16662             if (safe_and) {
16663                 flag = bool_flag;
16664                 lop = NULL;
16665                 break;
16666             }
16667             /* FALLTHROUGH */
16668         case OP_OR:
16669         case OP_DOR:
16670             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16671                 flag = bool_flag;
16672                 lop = NULL;
16673             }
16674             else if (!(lop->op_flags & OPf_WANT)) {
16675                 /* unknown context - decide at runtime */
16676                 flag = maybe_flag;
16677                 lop = NULL;
16678             }
16679             break;
16680
16681         default:
16682             lop = NULL;
16683             break;
16684         }
16685
16686         if (lop)
16687             lop = lop->op_next;
16688     }
16689
16690     o->op_private |= flag;
16691 }
16692
16693
16694
16695 /* mechanism for deferring recursion in rpeep() */
16696
16697 #define MAX_DEFERRED 4
16698
16699 #define DEFER(o) \
16700   STMT_START { \
16701     if (defer_ix == (MAX_DEFERRED-1)) { \
16702         OP **defer = defer_queue[defer_base]; \
16703         CALL_RPEEP(*defer); \
16704         S_prune_chain_head(defer); \
16705         defer_base = (defer_base + 1) % MAX_DEFERRED; \
16706         defer_ix--; \
16707     } \
16708     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16709   } STMT_END
16710
16711 #define IS_AND_OP(o)   (o->op_type == OP_AND)
16712 #define IS_OR_OP(o)    (o->op_type == OP_OR)
16713
16714
16715 /* A peephole optimizer.  We visit the ops in the order they're to execute.
16716  * See the comments at the top of this file for more details about when
16717  * peep() is called */
16718
16719 void
16720 Perl_rpeep(pTHX_ OP *o)
16721 {
16722     dVAR;
16723     OP* oldop = NULL;
16724     OP* oldoldop = NULL;
16725     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16726     int defer_base = 0;
16727     int defer_ix = -1;
16728
16729     if (!o || o->op_opt)
16730         return;
16731
16732     assert(o->op_type != OP_FREED);
16733
16734     ENTER;
16735     SAVEOP();
16736     SAVEVPTR(PL_curcop);
16737     for (;; o = o->op_next) {
16738         if (o && o->op_opt)
16739             o = NULL;
16740         if (!o) {
16741             while (defer_ix >= 0) {
16742                 OP **defer =
16743                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16744                 CALL_RPEEP(*defer);
16745                 S_prune_chain_head(defer);
16746             }
16747             break;
16748         }
16749
16750       redo:
16751
16752         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16753         assert(!oldoldop || oldoldop->op_next == oldop);
16754         assert(!oldop    || oldop->op_next    == o);
16755
16756         /* By default, this op has now been optimised. A couple of cases below
16757            clear this again.  */
16758         o->op_opt = 1;
16759         PL_op = o;
16760
16761         /* look for a series of 1 or more aggregate derefs, e.g.
16762          *   $a[1]{foo}[$i]{$k}
16763          * and replace with a single OP_MULTIDEREF op.
16764          * Each index must be either a const, or a simple variable,
16765          *
16766          * First, look for likely combinations of starting ops,
16767          * corresponding to (global and lexical variants of)
16768          *     $a[...]   $h{...}
16769          *     $r->[...] $r->{...}
16770          *     (preceding expression)->[...]
16771          *     (preceding expression)->{...}
16772          * and if so, call maybe_multideref() to do a full inspection
16773          * of the op chain and if appropriate, replace with an
16774          * OP_MULTIDEREF
16775          */
16776         {
16777             UV action;
16778             OP *o2 = o;
16779             U8 hints = 0;
16780
16781             switch (o2->op_type) {
16782             case OP_GV:
16783                 /* $pkg[..]   :   gv[*pkg]
16784                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
16785
16786                 /* Fail if there are new op flag combinations that we're
16787                  * not aware of, rather than:
16788                  *  * silently failing to optimise, or
16789                  *  * silently optimising the flag away.
16790                  * If this ASSUME starts failing, examine what new flag
16791                  * has been added to the op, and decide whether the
16792                  * optimisation should still occur with that flag, then
16793                  * update the code accordingly. This applies to all the
16794                  * other ASSUMEs in the block of code too.
16795                  */
16796                 ASSUME(!(o2->op_flags &
16797                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16798                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16799
16800                 o2 = o2->op_next;
16801
16802                 if (o2->op_type == OP_RV2AV) {
16803                     action = MDEREF_AV_gvav_aelem;
16804                     goto do_deref;
16805                 }
16806
16807                 if (o2->op_type == OP_RV2HV) {
16808                     action = MDEREF_HV_gvhv_helem;
16809                     goto do_deref;
16810                 }
16811
16812                 if (o2->op_type != OP_RV2SV)
16813                     break;
16814
16815                 /* at this point we've seen gv,rv2sv, so the only valid
16816                  * construct left is $pkg->[] or $pkg->{} */
16817
16818                 ASSUME(!(o2->op_flags & OPf_STACKED));
16819                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16820                             != (OPf_WANT_SCALAR|OPf_MOD))
16821                     break;
16822
16823                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16824                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16825                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16826                     break;
16827                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
16828                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16829                     break;
16830
16831                 o2 = o2->op_next;
16832                 if (o2->op_type == OP_RV2AV) {
16833                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16834                     goto do_deref;
16835                 }
16836                 if (o2->op_type == OP_RV2HV) {
16837                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16838                     goto do_deref;
16839                 }
16840                 break;
16841
16842             case OP_PADSV:
16843                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16844
16845                 ASSUME(!(o2->op_flags &
16846                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16847                 if ((o2->op_flags &
16848                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16849                      != (OPf_WANT_SCALAR|OPf_MOD))
16850                     break;
16851
16852                 ASSUME(!(o2->op_private &
16853                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16854                 /* skip if state or intro, or not a deref */
16855                 if (      o2->op_private != OPpDEREF_AV
16856                        && o2->op_private != OPpDEREF_HV)
16857                     break;
16858
16859                 o2 = o2->op_next;
16860                 if (o2->op_type == OP_RV2AV) {
16861                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16862                     goto do_deref;
16863                 }
16864                 if (o2->op_type == OP_RV2HV) {
16865                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16866                     goto do_deref;
16867                 }
16868                 break;
16869
16870             case OP_PADAV:
16871             case OP_PADHV:
16872                 /*    $lex[..]:  padav[@lex:1,2] sR *
16873                  * or $lex{..}:  padhv[%lex:1,2] sR */
16874                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16875                                             OPf_REF|OPf_SPECIAL)));
16876                 if ((o2->op_flags &
16877                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16878                      != (OPf_WANT_SCALAR|OPf_REF))
16879                     break;
16880                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16881                     break;
16882                 /* OPf_PARENS isn't currently used in this case;
16883                  * if that changes, let us know! */
16884                 ASSUME(!(o2->op_flags & OPf_PARENS));
16885
16886                 /* at this point, we wouldn't expect any of the remaining
16887                  * possible private flags:
16888                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16889                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16890                  *
16891                  * OPpSLICEWARNING shouldn't affect runtime
16892                  */
16893                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16894
16895                 action = o2->op_type == OP_PADAV
16896                             ? MDEREF_AV_padav_aelem
16897                             : MDEREF_HV_padhv_helem;
16898                 o2 = o2->op_next;
16899                 S_maybe_multideref(aTHX_ o, o2, action, 0);
16900                 break;
16901
16902
16903             case OP_RV2AV:
16904             case OP_RV2HV:
16905                 action = o2->op_type == OP_RV2AV
16906                             ? MDEREF_AV_pop_rv2av_aelem
16907                             : MDEREF_HV_pop_rv2hv_helem;
16908                 /* FALLTHROUGH */
16909             do_deref:
16910                 /* (expr)->[...]:  rv2av sKR/1;
16911                  * (expr)->{...}:  rv2hv sKR/1; */
16912
16913                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16914
16915                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16916                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16917                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16918                     break;
16919
16920                 /* at this point, we wouldn't expect any of these
16921                  * possible private flags:
16922                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16923                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16924                  */
16925                 ASSUME(!(o2->op_private &
16926                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16927                      |OPpOUR_INTRO)));
16928                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16929
16930                 o2 = o2->op_next;
16931
16932                 S_maybe_multideref(aTHX_ o, o2, action, hints);
16933                 break;
16934
16935             default:
16936                 break;
16937             }
16938         }
16939
16940
16941         switch (o->op_type) {
16942         case OP_DBSTATE:
16943             PL_curcop = ((COP*)o);              /* for warnings */
16944             break;
16945         case OP_NEXTSTATE:
16946             PL_curcop = ((COP*)o);              /* for warnings */
16947
16948             /* Optimise a "return ..." at the end of a sub to just be "...".
16949              * This saves 2 ops. Before:
16950              * 1  <;> nextstate(main 1 -e:1) v ->2
16951              * 4  <@> return K ->5
16952              * 2    <0> pushmark s ->3
16953              * -    <1> ex-rv2sv sK/1 ->4
16954              * 3      <#> gvsv[*cat] s ->4
16955              *
16956              * After:
16957              * -  <@> return K ->-
16958              * -    <0> pushmark s ->2
16959              * -    <1> ex-rv2sv sK/1 ->-
16960              * 2      <$> gvsv(*cat) s ->3
16961              */
16962             {
16963                 OP *next = o->op_next;
16964                 OP *sibling = OpSIBLING(o);
16965                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
16966                     && OP_TYPE_IS(sibling, OP_RETURN)
16967                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16968                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16969                        ||OP_TYPE_IS(sibling->op_next->op_next,
16970                                     OP_LEAVESUBLV))
16971                     && cUNOPx(sibling)->op_first == next
16972                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16973                     && next->op_next
16974                 ) {
16975                     /* Look through the PUSHMARK's siblings for one that
16976                      * points to the RETURN */
16977                     OP *top = OpSIBLING(next);
16978                     while (top && top->op_next) {
16979                         if (top->op_next == sibling) {
16980                             top->op_next = sibling->op_next;
16981                             o->op_next = next->op_next;
16982                             break;
16983                         }
16984                         top = OpSIBLING(top);
16985                     }
16986                 }
16987             }
16988
16989             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16990              *
16991              * This latter form is then suitable for conversion into padrange
16992              * later on. Convert:
16993              *
16994              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16995              *
16996              * into:
16997              *
16998              *   nextstate1 ->     listop     -> nextstate3
16999              *                 /            \
17000              *         pushmark -> padop1 -> padop2
17001              */
17002             if (o->op_next && (
17003                     o->op_next->op_type == OP_PADSV
17004                  || o->op_next->op_type == OP_PADAV
17005                  || o->op_next->op_type == OP_PADHV
17006                 )
17007                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
17008                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
17009                 && o->op_next->op_next->op_next && (
17010                     o->op_next->op_next->op_next->op_type == OP_PADSV
17011                  || o->op_next->op_next->op_next->op_type == OP_PADAV
17012                  || o->op_next->op_next->op_next->op_type == OP_PADHV
17013                 )
17014                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
17015                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
17016                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
17017                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
17018             ) {
17019                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
17020
17021                 pad1 =    o->op_next;
17022                 ns2  = pad1->op_next;
17023                 pad2 =  ns2->op_next;
17024                 ns3  = pad2->op_next;
17025
17026                 /* we assume here that the op_next chain is the same as
17027                  * the op_sibling chain */
17028                 assert(OpSIBLING(o)    == pad1);
17029                 assert(OpSIBLING(pad1) == ns2);
17030                 assert(OpSIBLING(ns2)  == pad2);
17031                 assert(OpSIBLING(pad2) == ns3);
17032
17033                 /* excise and delete ns2 */
17034                 op_sibling_splice(NULL, pad1, 1, NULL);
17035                 op_free(ns2);
17036
17037                 /* excise pad1 and pad2 */
17038                 op_sibling_splice(NULL, o, 2, NULL);
17039
17040                 /* create new listop, with children consisting of:
17041                  * a new pushmark, pad1, pad2. */
17042                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
17043                 newop->op_flags |= OPf_PARENS;
17044                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17045
17046                 /* insert newop between o and ns3 */
17047                 op_sibling_splice(NULL, o, 0, newop);
17048
17049                 /*fixup op_next chain */
17050                 newpm = cUNOPx(newop)->op_first; /* pushmark */
17051                 o    ->op_next = newpm;
17052                 newpm->op_next = pad1;
17053                 pad1 ->op_next = pad2;
17054                 pad2 ->op_next = newop; /* listop */
17055                 newop->op_next = ns3;
17056
17057                 /* Ensure pushmark has this flag if padops do */
17058                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
17059                     newpm->op_flags |= OPf_MOD;
17060                 }
17061
17062                 break;
17063             }
17064
17065             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
17066                to carry two labels. For now, take the easier option, and skip
17067                this optimisation if the first NEXTSTATE has a label.  */
17068             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
17069                 OP *nextop = o->op_next;
17070                 while (nextop) {
17071                     switch (nextop->op_type) {
17072                         case OP_NULL:
17073                         case OP_SCALAR:
17074                         case OP_LINESEQ:
17075                         case OP_SCOPE:
17076                             nextop = nextop->op_next;
17077                             continue;
17078                     }
17079                     break;
17080                 }
17081
17082                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
17083                     op_null(o);
17084                     if (oldop)
17085                         oldop->op_next = nextop;
17086                     o = nextop;
17087                     /* Skip (old)oldop assignment since the current oldop's
17088                        op_next already points to the next op.  */
17089                     goto redo;
17090                 }
17091             }
17092             break;
17093
17094         case OP_CONCAT:
17095             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
17096                 if (o->op_next->op_private & OPpTARGET_MY) {
17097                     if (o->op_flags & OPf_STACKED) /* chained concats */
17098                         break; /* ignore_optimization */
17099                     else {
17100                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
17101                         o->op_targ = o->op_next->op_targ;
17102                         o->op_next->op_targ = 0;
17103                         o->op_private |= OPpTARGET_MY;
17104                     }
17105                 }
17106                 op_null(o->op_next);
17107             }
17108             break;
17109         case OP_STUB:
17110             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
17111                 break; /* Scalar stub must produce undef.  List stub is noop */
17112             }
17113             goto nothin;
17114         case OP_NULL:
17115             if (o->op_targ == OP_NEXTSTATE
17116                 || o->op_targ == OP_DBSTATE)
17117             {
17118                 PL_curcop = ((COP*)o);
17119             }
17120             /* XXX: We avoid setting op_seq here to prevent later calls
17121                to rpeep() from mistakenly concluding that optimisation
17122                has already occurred. This doesn't fix the real problem,
17123                though (See 20010220.007 (#5874)). AMS 20010719 */
17124             /* op_seq functionality is now replaced by op_opt */
17125             o->op_opt = 0;
17126             /* FALLTHROUGH */
17127         case OP_SCALAR:
17128         case OP_LINESEQ:
17129         case OP_SCOPE:
17130         nothin:
17131             if (oldop) {
17132                 oldop->op_next = o->op_next;
17133                 o->op_opt = 0;
17134                 continue;
17135             }
17136             break;
17137
17138         case OP_PUSHMARK:
17139
17140             /* Given
17141                  5 repeat/DOLIST
17142                  3   ex-list
17143                  1     pushmark
17144                  2     scalar or const
17145                  4   const[0]
17146                convert repeat into a stub with no kids.
17147              */
17148             if (o->op_next->op_type == OP_CONST
17149              || (  o->op_next->op_type == OP_PADSV
17150                 && !(o->op_next->op_private & OPpLVAL_INTRO))
17151              || (  o->op_next->op_type == OP_GV
17152                 && o->op_next->op_next->op_type == OP_RV2SV
17153                 && !(o->op_next->op_next->op_private
17154                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
17155             {
17156                 const OP *kid = o->op_next->op_next;
17157                 if (o->op_next->op_type == OP_GV)
17158                    kid = kid->op_next;
17159                 /* kid is now the ex-list.  */
17160                 if (kid->op_type == OP_NULL
17161                  && (kid = kid->op_next)->op_type == OP_CONST
17162                     /* kid is now the repeat count.  */
17163                  && kid->op_next->op_type == OP_REPEAT
17164                  && kid->op_next->op_private & OPpREPEAT_DOLIST
17165                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
17166                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
17167                  && oldop)
17168                 {
17169                     o = kid->op_next; /* repeat */
17170                     oldop->op_next = o;
17171                     op_free(cBINOPo->op_first);
17172                     op_free(cBINOPo->op_last );
17173                     o->op_flags &=~ OPf_KIDS;
17174                     /* stub is a baseop; repeat is a binop */
17175                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
17176                     OpTYPE_set(o, OP_STUB);
17177                     o->op_private = 0;
17178                     break;
17179                 }
17180             }
17181
17182             /* Convert a series of PAD ops for my vars plus support into a
17183              * single padrange op. Basically
17184              *
17185              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17186              *
17187              * becomes, depending on circumstances, one of
17188              *
17189              *    padrange  ----------------------------------> (list) -> rest
17190              *    padrange  --------------------------------------------> rest
17191              *
17192              * where all the pad indexes are sequential and of the same type
17193              * (INTRO or not).
17194              * We convert the pushmark into a padrange op, then skip
17195              * any other pad ops, and possibly some trailing ops.
17196              * Note that we don't null() the skipped ops, to make it
17197              * easier for Deparse to undo this optimisation (and none of
17198              * the skipped ops are holding any resourses). It also makes
17199              * it easier for find_uninit_var(), as it can just ignore
17200              * padrange, and examine the original pad ops.
17201              */
17202         {
17203             OP *p;
17204             OP *followop = NULL; /* the op that will follow the padrange op */
17205             U8 count = 0;
17206             U8 intro = 0;
17207             PADOFFSET base = 0; /* init only to stop compiler whining */
17208             bool gvoid = 0;     /* init only to stop compiler whining */
17209             bool defav = 0;  /* seen (...) = @_ */
17210             bool reuse = 0;  /* reuse an existing padrange op */
17211
17212             /* look for a pushmark -> gv[_] -> rv2av */
17213
17214             {
17215                 OP *rv2av, *q;
17216                 p = o->op_next;
17217                 if (   p->op_type == OP_GV
17218                     && cGVOPx_gv(p) == PL_defgv
17219                     && (rv2av = p->op_next)
17220                     && rv2av->op_type == OP_RV2AV
17221                     && !(rv2av->op_flags & OPf_REF)
17222                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17223                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17224                 ) {
17225                     q = rv2av->op_next;
17226                     if (q->op_type == OP_NULL)
17227                         q = q->op_next;
17228                     if (q->op_type == OP_PUSHMARK) {
17229                         defav = 1;
17230                         p = q;
17231                     }
17232                 }
17233             }
17234             if (!defav) {
17235                 p = o;
17236             }
17237
17238             /* scan for PAD ops */
17239
17240             for (p = p->op_next; p; p = p->op_next) {
17241                 if (p->op_type == OP_NULL)
17242                     continue;
17243
17244                 if ((     p->op_type != OP_PADSV
17245                        && p->op_type != OP_PADAV
17246                        && p->op_type != OP_PADHV
17247                     )
17248                       /* any private flag other than INTRO? e.g. STATE */
17249                    || (p->op_private & ~OPpLVAL_INTRO)
17250                 )
17251                     break;
17252
17253                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17254                  * instead */
17255                 if (   p->op_type == OP_PADAV
17256                     && p->op_next
17257                     && p->op_next->op_type == OP_CONST
17258                     && p->op_next->op_next
17259                     && p->op_next->op_next->op_type == OP_AELEM
17260                 )
17261                     break;
17262
17263                 /* for 1st padop, note what type it is and the range
17264                  * start; for the others, check that it's the same type
17265                  * and that the targs are contiguous */
17266                 if (count == 0) {
17267                     intro = (p->op_private & OPpLVAL_INTRO);
17268                     base = p->op_targ;
17269                     gvoid = OP_GIMME(p,0) == G_VOID;
17270                 }
17271                 else {
17272                     if ((p->op_private & OPpLVAL_INTRO) != intro)
17273                         break;
17274                     /* Note that you'd normally  expect targs to be
17275                      * contiguous in my($a,$b,$c), but that's not the case
17276                      * when external modules start doing things, e.g.
17277                      * Function::Parameters */
17278                     if (p->op_targ != base + count)
17279                         break;
17280                     assert(p->op_targ == base + count);
17281                     /* Either all the padops or none of the padops should
17282                        be in void context.  Since we only do the optimisa-
17283                        tion for av/hv when the aggregate itself is pushed
17284                        on to the stack (one item), there is no need to dis-
17285                        tinguish list from scalar context.  */
17286                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
17287                         break;
17288                 }
17289
17290                 /* for AV, HV, only when we're not flattening */
17291                 if (   p->op_type != OP_PADSV
17292                     && !gvoid
17293                     && !(p->op_flags & OPf_REF)
17294                 )
17295                     break;
17296
17297                 if (count >= OPpPADRANGE_COUNTMASK)
17298                     break;
17299
17300                 /* there's a biggest base we can fit into a
17301                  * SAVEt_CLEARPADRANGE in pp_padrange.
17302                  * (The sizeof() stuff will be constant-folded, and is
17303                  * intended to avoid getting "comparison is always false"
17304                  * compiler warnings. See the comments above
17305                  * MEM_WRAP_CHECK for more explanation on why we do this
17306                  * in a weird way to avoid compiler warnings.)
17307                  */
17308                 if (   intro
17309                     && (8*sizeof(base) >
17310                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17311                         ? (Size_t)base
17312                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17313                         ) >
17314                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17315                 )
17316                     break;
17317
17318                 /* Success! We've got another valid pad op to optimise away */
17319                 count++;
17320                 followop = p->op_next;
17321             }
17322
17323             if (count < 1 || (count == 1 && !defav))
17324                 break;
17325
17326             /* pp_padrange in specifically compile-time void context
17327              * skips pushing a mark and lexicals; in all other contexts
17328              * (including unknown till runtime) it pushes a mark and the
17329              * lexicals. We must be very careful then, that the ops we
17330              * optimise away would have exactly the same effect as the
17331              * padrange.
17332              * In particular in void context, we can only optimise to
17333              * a padrange if we see the complete sequence
17334              *     pushmark, pad*v, ...., list
17335              * which has the net effect of leaving the markstack as it
17336              * was.  Not pushing onto the stack (whereas padsv does touch
17337              * the stack) makes no difference in void context.
17338              */
17339             assert(followop);
17340             if (gvoid) {
17341                 if (followop->op_type == OP_LIST
17342                         && OP_GIMME(followop,0) == G_VOID
17343                    )
17344                 {
17345                     followop = followop->op_next; /* skip OP_LIST */
17346
17347                     /* consolidate two successive my(...);'s */
17348
17349                     if (   oldoldop
17350                         && oldoldop->op_type == OP_PADRANGE
17351                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17352                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17353                         && !(oldoldop->op_flags & OPf_SPECIAL)
17354                     ) {
17355                         U8 old_count;
17356                         assert(oldoldop->op_next == oldop);
17357                         assert(   oldop->op_type == OP_NEXTSTATE
17358                                || oldop->op_type == OP_DBSTATE);
17359                         assert(oldop->op_next == o);
17360
17361                         old_count
17362                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17363
17364                        /* Do not assume pad offsets for $c and $d are con-
17365                           tiguous in
17366                             my ($a,$b,$c);
17367                             my ($d,$e,$f);
17368                         */
17369                         if (  oldoldop->op_targ + old_count == base
17370                            && old_count < OPpPADRANGE_COUNTMASK - count) {
17371                             base = oldoldop->op_targ;
17372                             count += old_count;
17373                             reuse = 1;
17374                         }
17375                     }
17376
17377                     /* if there's any immediately following singleton
17378                      * my var's; then swallow them and the associated
17379                      * nextstates; i.e.
17380                      *    my ($a,$b); my $c; my $d;
17381                      * is treated as
17382                      *    my ($a,$b,$c,$d);
17383                      */
17384
17385                     while (    ((p = followop->op_next))
17386                             && (  p->op_type == OP_PADSV
17387                                || p->op_type == OP_PADAV
17388                                || p->op_type == OP_PADHV)
17389                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17390                             && (p->op_private & OPpLVAL_INTRO) == intro
17391                             && !(p->op_private & ~OPpLVAL_INTRO)
17392                             && p->op_next
17393                             && (   p->op_next->op_type == OP_NEXTSTATE
17394                                 || p->op_next->op_type == OP_DBSTATE)
17395                             && count < OPpPADRANGE_COUNTMASK
17396                             && base + count == p->op_targ
17397                     ) {
17398                         count++;
17399                         followop = p->op_next;
17400                     }
17401                 }
17402                 else
17403                     break;
17404             }
17405
17406             if (reuse) {
17407                 assert(oldoldop->op_type == OP_PADRANGE);
17408                 oldoldop->op_next = followop;
17409                 oldoldop->op_private = (intro | count);
17410                 o = oldoldop;
17411                 oldop = NULL;
17412                 oldoldop = NULL;
17413             }
17414             else {
17415                 /* Convert the pushmark into a padrange.
17416                  * To make Deparse easier, we guarantee that a padrange was
17417                  * *always* formerly a pushmark */
17418                 assert(o->op_type == OP_PUSHMARK);
17419                 o->op_next = followop;
17420                 OpTYPE_set(o, OP_PADRANGE);
17421                 o->op_targ = base;
17422                 /* bit 7: INTRO; bit 6..0: count */
17423                 o->op_private = (intro | count);
17424                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17425                               | gvoid * OPf_WANT_VOID
17426                               | (defav ? OPf_SPECIAL : 0));
17427             }
17428             break;
17429         }
17430
17431         case OP_RV2AV:
17432             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17433                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17434             break;
17435
17436         case OP_RV2HV:
17437         case OP_PADHV:
17438             /*'keys %h' in void or scalar context: skip the OP_KEYS
17439              * and perform the functionality directly in the RV2HV/PADHV
17440              * op
17441              */
17442             if (o->op_flags & OPf_REF) {
17443                 OP *k = o->op_next;
17444                 U8 want = (k->op_flags & OPf_WANT);
17445                 if (   k
17446                     && k->op_type == OP_KEYS
17447                     && (   want == OPf_WANT_VOID
17448                         || want == OPf_WANT_SCALAR)
17449                     && !(k->op_private & OPpMAYBE_LVSUB)
17450                     && !(k->op_flags & OPf_MOD)
17451                 ) {
17452                     o->op_next     = k->op_next;
17453                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
17454                     o->op_flags   |= want;
17455                     o->op_private |= (o->op_type == OP_PADHV ?
17456                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17457                     /* for keys(%lex), hold onto the OP_KEYS's targ
17458                      * since padhv doesn't have its own targ to return
17459                      * an int with */
17460                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17461                         op_null(k);
17462                 }
17463             }
17464
17465             /* see if %h is used in boolean context */
17466             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17467                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17468
17469
17470             if (o->op_type != OP_PADHV)
17471                 break;
17472             /* FALLTHROUGH */
17473         case OP_PADAV:
17474             if (   o->op_type == OP_PADAV
17475                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17476             )
17477                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17478             /* FALLTHROUGH */
17479         case OP_PADSV:
17480             /* Skip over state($x) in void context.  */
17481             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17482              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17483             {
17484                 oldop->op_next = o->op_next;
17485                 goto redo_nextstate;
17486             }
17487             if (o->op_type != OP_PADAV)
17488                 break;
17489             /* FALLTHROUGH */
17490         case OP_GV:
17491             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17492                 OP* const pop = (o->op_type == OP_PADAV) ?
17493                             o->op_next : o->op_next->op_next;
17494                 IV i;
17495                 if (pop && pop->op_type == OP_CONST &&
17496                     ((PL_op = pop->op_next)) &&
17497                     pop->op_next->op_type == OP_AELEM &&
17498                     !(pop->op_next->op_private &
17499                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17500                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17501                 {
17502                     GV *gv;
17503                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17504                         no_bareword_allowed(pop);
17505                     if (o->op_type == OP_GV)
17506                         op_null(o->op_next);
17507                     op_null(pop->op_next);
17508                     op_null(pop);
17509                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17510                     o->op_next = pop->op_next->op_next;
17511                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17512                     o->op_private = (U8)i;
17513                     if (o->op_type == OP_GV) {
17514                         gv = cGVOPo_gv;
17515                         GvAVn(gv);
17516                         o->op_type = OP_AELEMFAST;
17517                     }
17518                     else
17519                         o->op_type = OP_AELEMFAST_LEX;
17520                 }
17521                 if (o->op_type != OP_GV)
17522                     break;
17523             }
17524
17525             /* Remove $foo from the op_next chain in void context.  */
17526             if (oldop
17527              && (  o->op_next->op_type == OP_RV2SV
17528                 || o->op_next->op_type == OP_RV2AV
17529                 || o->op_next->op_type == OP_RV2HV  )
17530              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17531              && !(o->op_next->op_private & OPpLVAL_INTRO))
17532             {
17533                 oldop->op_next = o->op_next->op_next;
17534                 /* Reprocess the previous op if it is a nextstate, to
17535                    allow double-nextstate optimisation.  */
17536               redo_nextstate:
17537                 if (oldop->op_type == OP_NEXTSTATE) {
17538                     oldop->op_opt = 0;
17539                     o = oldop;
17540                     oldop = oldoldop;
17541                     oldoldop = NULL;
17542                     goto redo;
17543                 }
17544                 o = oldop->op_next;
17545                 goto redo;
17546             }
17547             else if (o->op_next->op_type == OP_RV2SV) {
17548                 if (!(o->op_next->op_private & OPpDEREF)) {
17549                     op_null(o->op_next);
17550                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17551                                                                | OPpOUR_INTRO);
17552                     o->op_next = o->op_next->op_next;
17553                     OpTYPE_set(o, OP_GVSV);
17554                 }
17555             }
17556             else if (o->op_next->op_type == OP_READLINE
17557                     && o->op_next->op_next->op_type == OP_CONCAT
17558                     && (o->op_next->op_next->op_flags & OPf_STACKED))
17559             {
17560                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17561                 OpTYPE_set(o, OP_RCATLINE);
17562                 o->op_flags |= OPf_STACKED;
17563                 op_null(o->op_next->op_next);
17564                 op_null(o->op_next);
17565             }
17566
17567             break;
17568
17569         case OP_NOT:
17570             break;
17571
17572         case OP_AND:
17573         case OP_OR:
17574         case OP_DOR:
17575         case OP_CMPCHAIN_AND:
17576             while (cLOGOP->op_other->op_type == OP_NULL)
17577                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17578             while (o->op_next && (   o->op_type == o->op_next->op_type
17579                                   || o->op_next->op_type == OP_NULL))
17580                 o->op_next = o->op_next->op_next;
17581
17582             /* If we're an OR and our next is an AND in void context, we'll
17583                follow its op_other on short circuit, same for reverse.
17584                We can't do this with OP_DOR since if it's true, its return
17585                value is the underlying value which must be evaluated
17586                by the next op. */
17587             if (o->op_next &&
17588                 (
17589                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17590                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17591                 )
17592                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17593             ) {
17594                 o->op_next = ((LOGOP*)o->op_next)->op_other;
17595             }
17596             DEFER(cLOGOP->op_other);
17597             o->op_opt = 1;
17598             break;
17599
17600         case OP_GREPWHILE:
17601             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17602                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17603             /* FALLTHROUGH */
17604         case OP_COND_EXPR:
17605         case OP_MAPWHILE:
17606         case OP_ANDASSIGN:
17607         case OP_ORASSIGN:
17608         case OP_DORASSIGN:
17609         case OP_RANGE:
17610         case OP_ONCE:
17611         case OP_ARGDEFELEM:
17612             while (cLOGOP->op_other->op_type == OP_NULL)
17613                 cLOGOP->op_other = cLOGOP->op_other->op_next;
17614             DEFER(cLOGOP->op_other);
17615             break;
17616
17617         case OP_ENTERLOOP:
17618         case OP_ENTERITER:
17619             while (cLOOP->op_redoop->op_type == OP_NULL)
17620                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17621             while (cLOOP->op_nextop->op_type == OP_NULL)
17622                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17623             while (cLOOP->op_lastop->op_type == OP_NULL)
17624                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17625             /* a while(1) loop doesn't have an op_next that escapes the
17626              * loop, so we have to explicitly follow the op_lastop to
17627              * process the rest of the code */
17628             DEFER(cLOOP->op_lastop);
17629             break;
17630
17631         case OP_ENTERTRY:
17632             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17633             DEFER(cLOGOPo->op_other);
17634             break;
17635
17636         case OP_SUBST:
17637             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17638                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17639             assert(!(cPMOP->op_pmflags & PMf_ONCE));
17640             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17641                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17642                 cPMOP->op_pmstashstartu.op_pmreplstart
17643                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17644             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17645             break;
17646
17647         case OP_SORT: {
17648             OP *oright;
17649
17650             if (o->op_flags & OPf_SPECIAL) {
17651                 /* first arg is a code block */
17652                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17653                 OP * kid          = cUNOPx(nullop)->op_first;
17654
17655                 assert(nullop->op_type == OP_NULL);
17656                 assert(kid->op_type == OP_SCOPE
17657                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17658                 /* since OP_SORT doesn't have a handy op_other-style
17659                  * field that can point directly to the start of the code
17660                  * block, store it in the otherwise-unused op_next field
17661                  * of the top-level OP_NULL. This will be quicker at
17662                  * run-time, and it will also allow us to remove leading
17663                  * OP_NULLs by just messing with op_nexts without
17664                  * altering the basic op_first/op_sibling layout. */
17665                 kid = kLISTOP->op_first;
17666                 assert(
17667                       (kid->op_type == OP_NULL
17668                       && (  kid->op_targ == OP_NEXTSTATE
17669                          || kid->op_targ == OP_DBSTATE  ))
17670                     || kid->op_type == OP_STUB
17671                     || kid->op_type == OP_ENTER
17672                     || (PL_parser && PL_parser->error_count));
17673                 nullop->op_next = kid->op_next;
17674                 DEFER(nullop->op_next);
17675             }
17676
17677             /* check that RHS of sort is a single plain array */
17678             oright = cUNOPo->op_first;
17679             if (!oright || oright->op_type != OP_PUSHMARK)
17680                 break;
17681
17682             if (o->op_private & OPpSORT_INPLACE)
17683                 break;
17684
17685             /* reverse sort ... can be optimised.  */
17686             if (!OpHAS_SIBLING(cUNOPo)) {
17687                 /* Nothing follows us on the list. */
17688                 OP * const reverse = o->op_next;
17689
17690                 if (reverse->op_type == OP_REVERSE &&
17691                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17692                     OP * const pushmark = cUNOPx(reverse)->op_first;
17693                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17694                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17695                         /* reverse -> pushmark -> sort */
17696                         o->op_private |= OPpSORT_REVERSE;
17697                         op_null(reverse);
17698                         pushmark->op_next = oright->op_next;
17699                         op_null(oright);
17700                     }
17701                 }
17702             }
17703
17704             break;
17705         }
17706
17707         case OP_REVERSE: {
17708             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17709             OP *gvop = NULL;
17710             LISTOP *enter, *exlist;
17711
17712             if (o->op_private & OPpSORT_INPLACE)
17713                 break;
17714
17715             enter = (LISTOP *) o->op_next;
17716             if (!enter)
17717                 break;
17718             if (enter->op_type == OP_NULL) {
17719                 enter = (LISTOP *) enter->op_next;
17720                 if (!enter)
17721                     break;
17722             }
17723             /* for $a (...) will have OP_GV then OP_RV2GV here.
17724                for (...) just has an OP_GV.  */
17725             if (enter->op_type == OP_GV) {
17726                 gvop = (OP *) enter;
17727                 enter = (LISTOP *) enter->op_next;
17728                 if (!enter)
17729                     break;
17730                 if (enter->op_type == OP_RV2GV) {
17731                   enter = (LISTOP *) enter->op_next;
17732                   if (!enter)
17733                     break;
17734                 }
17735             }
17736
17737             if (enter->op_type != OP_ENTERITER)
17738                 break;
17739
17740             iter = enter->op_next;
17741             if (!iter || iter->op_type != OP_ITER)
17742                 break;
17743
17744             expushmark = enter->op_first;
17745             if (!expushmark || expushmark->op_type != OP_NULL
17746                 || expushmark->op_targ != OP_PUSHMARK)
17747                 break;
17748
17749             exlist = (LISTOP *) OpSIBLING(expushmark);
17750             if (!exlist || exlist->op_type != OP_NULL
17751                 || exlist->op_targ != OP_LIST)
17752                 break;
17753
17754             if (exlist->op_last != o) {
17755                 /* Mmm. Was expecting to point back to this op.  */
17756                 break;
17757             }
17758             theirmark = exlist->op_first;
17759             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17760                 break;
17761
17762             if (OpSIBLING(theirmark) != o) {
17763                 /* There's something between the mark and the reverse, eg
17764                    for (1, reverse (...))
17765                    so no go.  */
17766                 break;
17767             }
17768
17769             ourmark = ((LISTOP *)o)->op_first;
17770             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17771                 break;
17772
17773             ourlast = ((LISTOP *)o)->op_last;
17774             if (!ourlast || ourlast->op_next != o)
17775                 break;
17776
17777             rv2av = OpSIBLING(ourmark);
17778             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17779                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17780                 /* We're just reversing a single array.  */
17781                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17782                 enter->op_flags |= OPf_STACKED;
17783             }
17784
17785             /* We don't have control over who points to theirmark, so sacrifice
17786                ours.  */
17787             theirmark->op_next = ourmark->op_next;
17788             theirmark->op_flags = ourmark->op_flags;
17789             ourlast->op_next = gvop ? gvop : (OP *) enter;
17790             op_null(ourmark);
17791             op_null(o);
17792             enter->op_private |= OPpITER_REVERSED;
17793             iter->op_private |= OPpITER_REVERSED;
17794
17795             oldoldop = NULL;
17796             oldop    = ourlast;
17797             o        = oldop->op_next;
17798             goto redo;
17799             NOT_REACHED; /* NOTREACHED */
17800             break;
17801         }
17802
17803         case OP_QR:
17804         case OP_MATCH:
17805             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17806                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17807             }
17808             break;
17809
17810         case OP_RUNCV:
17811             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17812              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17813             {
17814                 SV *sv;
17815                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17816                 else {
17817                     sv = newRV((SV *)PL_compcv);
17818                     sv_rvweaken(sv);
17819                     SvREADONLY_on(sv);
17820                 }
17821                 OpTYPE_set(o, OP_CONST);
17822                 o->op_flags |= OPf_SPECIAL;
17823                 cSVOPo->op_sv = sv;
17824             }
17825             break;
17826
17827         case OP_SASSIGN:
17828             if (OP_GIMME(o,0) == G_VOID
17829              || (  o->op_next->op_type == OP_LINESEQ
17830                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
17831                    || (  o->op_next->op_next->op_type == OP_RETURN
17832                       && !CvLVALUE(PL_compcv)))))
17833             {
17834                 OP *right = cBINOP->op_first;
17835                 if (right) {
17836                     /*   sassign
17837                     *      RIGHT
17838                     *      substr
17839                     *         pushmark
17840                     *         arg1
17841                     *         arg2
17842                     *         ...
17843                     * becomes
17844                     *
17845                     *  ex-sassign
17846                     *     substr
17847                     *        pushmark
17848                     *        RIGHT
17849                     *        arg1
17850                     *        arg2
17851                     *        ...
17852                     */
17853                     OP *left = OpSIBLING(right);
17854                     if (left->op_type == OP_SUBSTR
17855                          && (left->op_private & 7) < 4) {
17856                         op_null(o);
17857                         /* cut out right */
17858                         op_sibling_splice(o, NULL, 1, NULL);
17859                         /* and insert it as second child of OP_SUBSTR */
17860                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17861                                     right);
17862                         left->op_private |= OPpSUBSTR_REPL_FIRST;
17863                         left->op_flags =
17864                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17865                     }
17866                 }
17867             }
17868             break;
17869
17870         case OP_AASSIGN: {
17871             int l, r, lr, lscalars, rscalars;
17872
17873             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17874                Note that we do this now rather than in newASSIGNOP(),
17875                since only by now are aliased lexicals flagged as such
17876
17877                See the essay "Common vars in list assignment" above for
17878                the full details of the rationale behind all the conditions
17879                below.
17880
17881                PL_generation sorcery:
17882                To detect whether there are common vars, the global var
17883                PL_generation is incremented for each assign op we scan.
17884                Then we run through all the lexical variables on the LHS,
17885                of the assignment, setting a spare slot in each of them to
17886                PL_generation.  Then we scan the RHS, and if any lexicals
17887                already have that value, we know we've got commonality.
17888                Also, if the generation number is already set to
17889                PERL_INT_MAX, then the variable is involved in aliasing, so
17890                we also have potential commonality in that case.
17891              */
17892
17893             PL_generation++;
17894             /* scan LHS */
17895             lscalars = 0;
17896             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, &lscalars);
17897             /* scan RHS */
17898             rscalars = 0;
17899             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17900             lr = (l|r);
17901
17902
17903             /* After looking for things which are *always* safe, this main
17904              * if/else chain selects primarily based on the type of the
17905              * LHS, gradually working its way down from the more dangerous
17906              * to the more restrictive and thus safer cases */
17907
17908             if (   !l                      /* () = ....; */
17909                 || !r                      /* .... = (); */
17910                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17911                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17912                 || (lscalars < 2)          /* ($x, undef) = ... */
17913             ) {
17914                 NOOP; /* always safe */
17915             }
17916             else if (l & AAS_DANGEROUS) {
17917                 /* always dangerous */
17918                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17919                 o->op_private |= OPpASSIGN_COMMON_AGG;
17920             }
17921             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17922                 /* package vars are always dangerous - too many
17923                  * aliasing possibilities */
17924                 if (l & AAS_PKG_SCALAR)
17925                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
17926                 if (l & AAS_PKG_AGG)
17927                     o->op_private |= OPpASSIGN_COMMON_AGG;
17928             }
17929             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17930                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
17931             {
17932                 /* LHS contains only lexicals and safe ops */
17933
17934                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17935                     o->op_private |= OPpASSIGN_COMMON_AGG;
17936
17937                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17938                     if (lr & AAS_LEX_SCALAR_COMM)
17939                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
17940                     else if (   !(l & AAS_LEX_SCALAR)
17941                              && (r & AAS_DEFAV))
17942                     {
17943                         /* falsely mark
17944                          *    my (...) = @_
17945                          * as scalar-safe for performance reasons.
17946                          * (it will still have been marked _AGG if necessary */
17947                         NOOP;
17948                     }
17949                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17950                         /* if there are only lexicals on the LHS and no
17951                          * common ones on the RHS, then we assume that the
17952                          * only way those lexicals could also get
17953                          * on the RHS is via some sort of dereffing or
17954                          * closure, e.g.
17955                          *    $r = \$lex;
17956                          *    ($lex, $x) = (1, $$r)
17957                          * and in this case we assume the var must have
17958                          *  a bumped ref count. So if its ref count is 1,
17959                          *  it must only be on the LHS.
17960                          */
17961                         o->op_private |= OPpASSIGN_COMMON_RC1;
17962                 }
17963             }
17964
17965             /* ... = ($x)
17966              * may have to handle aggregate on LHS, but we can't
17967              * have common scalars. */
17968             if (rscalars < 2)
17969                 o->op_private &=
17970                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17971
17972             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17973                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17974             break;
17975         }
17976
17977         case OP_REF:
17978             /* see if ref() is used in boolean context */
17979             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17980                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17981             break;
17982
17983         case OP_LENGTH:
17984             /* see if the op is used in known boolean context,
17985              * but not if OA_TARGLEX optimisation is enabled */
17986             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17987                 && !(o->op_private & OPpTARGET_MY)
17988             )
17989                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17990             break;
17991
17992         case OP_POS:
17993             /* see if the op is used in known boolean context */
17994             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17995                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17996             break;
17997
17998         case OP_CUSTOM: {
17999             Perl_cpeep_t cpeep =
18000                 XopENTRYCUSTOM(o, xop_peep);
18001             if (cpeep)
18002                 cpeep(aTHX_ o, oldop);
18003             break;
18004         }
18005
18006         }
18007         /* did we just null the current op? If so, re-process it to handle
18008          * eliding "empty" ops from the chain */
18009         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
18010             o->op_opt = 0;
18011             o = oldop;
18012         }
18013         else {
18014             oldoldop = oldop;
18015             oldop = o;
18016         }
18017     }
18018     LEAVE;
18019 }
18020
18021 void
18022 Perl_peep(pTHX_ OP *o)
18023 {
18024     CALL_RPEEP(o);
18025 }
18026
18027 /*
18028 =head1 Custom Operators
18029
18030 =for apidoc Perl_custom_op_xop
18031 Return the XOP structure for a given custom op.  This macro should be
18032 considered internal to C<OP_NAME> and the other access macros: use them instead.
18033 This macro does call a function.  Prior
18034 to 5.19.6, this was implemented as a
18035 function.
18036
18037 =cut
18038 */
18039
18040
18041 /* use PERL_MAGIC_ext to call a function to free the xop structure when
18042  * freeing PL_custom_ops */
18043
18044 static int
18045 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
18046 {
18047     XOP *xop;
18048
18049     PERL_UNUSED_ARG(mg);
18050     xop = INT2PTR(XOP *, SvIV(sv));
18051     Safefree(xop->xop_name);
18052     Safefree(xop->xop_desc);
18053     Safefree(xop);
18054     return 0;
18055 }
18056
18057
18058 static const MGVTBL custom_op_register_vtbl = {
18059     0,                          /* get */
18060     0,                          /* set */
18061     0,                          /* len */
18062     0,                          /* clear */
18063     custom_op_register_free,     /* free */
18064     0,                          /* copy */
18065     0,                          /* dup */
18066 #ifdef MGf_LOCAL
18067     0,                          /* local */
18068 #endif
18069 };
18070
18071
18072 XOPRETANY
18073 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
18074 {
18075     SV *keysv;
18076     HE *he = NULL;
18077     XOP *xop;
18078
18079     static const XOP xop_null = { 0, 0, 0, 0, 0 };
18080
18081     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
18082     assert(o->op_type == OP_CUSTOM);
18083
18084     /* This is wrong. It assumes a function pointer can be cast to IV,
18085      * which isn't guaranteed, but this is what the old custom OP code
18086      * did. In principle it should be safer to Copy the bytes of the
18087      * pointer into a PV: since the new interface is hidden behind
18088      * functions, this can be changed later if necessary.  */
18089     /* Change custom_op_xop if this ever happens */
18090     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
18091
18092     if (PL_custom_ops)
18093         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18094
18095     /* See if the op isn't registered, but its name *is* registered.
18096      * That implies someone is using the pre-5.14 API,where only name and
18097      * description could be registered. If so, fake up a real
18098      * registration.
18099      * We only check for an existing name, and assume no one will have
18100      * just registered a desc */
18101     if (!he && PL_custom_op_names &&
18102         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
18103     ) {
18104         const char *pv;
18105         STRLEN l;
18106
18107         /* XXX does all this need to be shared mem? */
18108         Newxz(xop, 1, XOP);
18109         pv = SvPV(HeVAL(he), l);
18110         XopENTRY_set(xop, xop_name, savepvn(pv, l));
18111         if (PL_custom_op_descs &&
18112             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
18113         ) {
18114             pv = SvPV(HeVAL(he), l);
18115             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
18116         }
18117         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
18118         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
18119         /* add magic to the SV so that the xop struct (pointed to by
18120          * SvIV(sv)) is freed. Normally a static xop is registered, but
18121          * for this backcompat hack, we've alloced one */
18122         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
18123                 &custom_op_register_vtbl, NULL, 0);
18124
18125     }
18126     else {
18127         if (!he)
18128             xop = (XOP *)&xop_null;
18129         else
18130             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
18131     }
18132     {
18133         XOPRETANY any;
18134         if(field == XOPe_xop_ptr) {
18135             any.xop_ptr = xop;
18136         } else {
18137             const U32 flags = XopFLAGS(xop);
18138             if(flags & field) {
18139                 switch(field) {
18140                 case XOPe_xop_name:
18141                     any.xop_name = xop->xop_name;
18142                     break;
18143                 case XOPe_xop_desc:
18144                     any.xop_desc = xop->xop_desc;
18145                     break;
18146                 case XOPe_xop_class:
18147                     any.xop_class = xop->xop_class;
18148                     break;
18149                 case XOPe_xop_peep:
18150                     any.xop_peep = xop->xop_peep;
18151                     break;
18152                 default:
18153                     NOT_REACHED; /* NOTREACHED */
18154                     break;
18155                 }
18156             } else {
18157                 switch(field) {
18158                 case XOPe_xop_name:
18159                     any.xop_name = XOPd_xop_name;
18160                     break;
18161                 case XOPe_xop_desc:
18162                     any.xop_desc = XOPd_xop_desc;
18163                     break;
18164                 case XOPe_xop_class:
18165                     any.xop_class = XOPd_xop_class;
18166                     break;
18167                 case XOPe_xop_peep:
18168                     any.xop_peep = XOPd_xop_peep;
18169                     break;
18170                 default:
18171                     NOT_REACHED; /* NOTREACHED */
18172                     break;
18173                 }
18174             }
18175         }
18176         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
18177          * op.c: In function 'Perl_custom_op_get_field':
18178          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
18179          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
18180          * expands to assert(0), which expands to ((0) ? (void)0 :
18181          * __assert(...)), and gcc doesn't know that __assert can never return. */
18182         return any;
18183     }
18184 }
18185
18186 /*
18187 =for apidoc custom_op_register
18188 Register a custom op.  See L<perlguts/"Custom Operators">.
18189
18190 =cut
18191 */
18192
18193 void
18194 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18195 {
18196     SV *keysv;
18197
18198     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18199
18200     /* see the comment in custom_op_xop */
18201     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18202
18203     if (!PL_custom_ops)
18204         PL_custom_ops = newHV();
18205
18206     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18207         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18208 }
18209
18210 /*
18211
18212 =for apidoc core_prototype
18213
18214 This function assigns the prototype of the named core function to C<sv>, or
18215 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
18216 C<NULL> if the core function has no prototype.  C<code> is a code as returned
18217 by C<keyword()>.  It must not be equal to 0.
18218
18219 =cut
18220 */
18221
18222 SV *
18223 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18224                           int * const opnum)
18225 {
18226     int i = 0, n = 0, seen_question = 0, defgv = 0;
18227     I32 oa;
18228 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18229     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18230     bool nullret = FALSE;
18231
18232     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18233
18234     assert (code);
18235
18236     if (!sv) sv = sv_newmortal();
18237
18238 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18239
18240     switch (code < 0 ? -code : code) {
18241     case KEY_and   : case KEY_chop: case KEY_chomp:
18242     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
18243     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
18244     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
18245     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
18246     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
18247     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
18248     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
18249     case KEY_x     : case KEY_xor    :
18250         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18251     case KEY_glob:    retsetpvs("_;", OP_GLOB);
18252     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
18253     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
18254     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
18255     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
18256     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18257         retsetpvs("", 0);
18258     case KEY_evalbytes:
18259         name = "entereval"; break;
18260     case KEY_readpipe:
18261         name = "backtick";
18262     }
18263
18264 #undef retsetpvs
18265
18266   findopnum:
18267     while (i < MAXO) {  /* The slow way. */
18268         if (strEQ(name, PL_op_name[i])
18269             || strEQ(name, PL_op_desc[i]))
18270         {
18271             if (nullret) { assert(opnum); *opnum = i; return NULL; }
18272             goto found;
18273         }
18274         i++;
18275     }
18276     return NULL;
18277   found:
18278     defgv = PL_opargs[i] & OA_DEFGV;
18279     oa = PL_opargs[i] >> OASHIFT;
18280     while (oa) {
18281         if (oa & OA_OPTIONAL && !seen_question && (
18282               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18283         )) {
18284             seen_question = 1;
18285             str[n++] = ';';
18286         }
18287         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18288             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18289             /* But globs are already references (kinda) */
18290             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18291         ) {
18292             str[n++] = '\\';
18293         }
18294         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18295          && !scalar_mod_type(NULL, i)) {
18296             str[n++] = '[';
18297             str[n++] = '$';
18298             str[n++] = '@';
18299             str[n++] = '%';
18300             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18301             str[n++] = '*';
18302             str[n++] = ']';
18303         }
18304         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18305         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18306             str[n-1] = '_'; defgv = 0;
18307         }
18308         oa = oa >> 4;
18309     }
18310     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18311     str[n++] = '\0';
18312     sv_setpvn(sv, str, n - 1);
18313     if (opnum) *opnum = i;
18314     return sv;
18315 }
18316
18317 OP *
18318 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18319                       const int opnum)
18320 {
18321     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18322                                         newSVOP(OP_COREARGS,0,coreargssv);
18323     OP *o;
18324
18325     PERL_ARGS_ASSERT_CORESUB_OP;
18326
18327     switch(opnum) {
18328     case 0:
18329         return op_append_elem(OP_LINESEQ,
18330                        argop,
18331                        newSLICEOP(0,
18332                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18333                                   newOP(OP_CALLER,0)
18334                        )
18335                );
18336     case OP_EACH:
18337     case OP_KEYS:
18338     case OP_VALUES:
18339         o = newUNOP(OP_AVHVSWITCH,0,argop);
18340         o->op_private = opnum-OP_EACH;
18341         return o;
18342     case OP_SELECT: /* which represents OP_SSELECT as well */
18343         if (code)
18344             return newCONDOP(
18345                          0,
18346                          newBINOP(OP_GT, 0,
18347                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18348                                   newSVOP(OP_CONST, 0, newSVuv(1))
18349                                  ),
18350                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
18351                                     OP_SSELECT),
18352                          coresub_op(coreargssv, 0, OP_SELECT)
18353                    );
18354         /* FALLTHROUGH */
18355     default:
18356         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18357         case OA_BASEOP:
18358             return op_append_elem(
18359                         OP_LINESEQ, argop,
18360                         newOP(opnum,
18361                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
18362                                 ? OPpOFFBYONE << 8 : 0)
18363                    );
18364         case OA_BASEOP_OR_UNOP:
18365             if (opnum == OP_ENTEREVAL) {
18366                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18367                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18368             }
18369             else o = newUNOP(opnum,0,argop);
18370             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18371             else {
18372           onearg:
18373               if (is_handle_constructor(o, 1))
18374                 argop->op_private |= OPpCOREARGS_DEREF1;
18375               if (scalar_mod_type(NULL, opnum))
18376                 argop->op_private |= OPpCOREARGS_SCALARMOD;
18377             }
18378             return o;
18379         default:
18380             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18381             if (is_handle_constructor(o, 2))
18382                 argop->op_private |= OPpCOREARGS_DEREF2;
18383             if (opnum == OP_SUBSTR) {
18384                 o->op_private |= OPpMAYBE_LVSUB;
18385                 return o;
18386             }
18387             else goto onearg;
18388         }
18389     }
18390 }
18391
18392 void
18393 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18394                                SV * const *new_const_svp)
18395 {
18396     const char *hvname;
18397     bool is_const = !!CvCONST(old_cv);
18398     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18399
18400     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18401
18402     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18403         return;
18404         /* They are 2 constant subroutines generated from
18405            the same constant. This probably means that
18406            they are really the "same" proxy subroutine
18407            instantiated in 2 places. Most likely this is
18408            when a constant is exported twice.  Don't warn.
18409         */
18410     if (
18411         (ckWARN(WARN_REDEFINE)
18412          && !(
18413                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18414              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18415              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18416                  strEQ(hvname, "autouse"))
18417              )
18418         )
18419      || (is_const
18420          && ckWARN_d(WARN_REDEFINE)
18421          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18422         )
18423     )
18424         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18425                           is_const
18426                             ? "Constant subroutine %" SVf " redefined"
18427                             : "Subroutine %" SVf " redefined",
18428                           SVfARG(name));
18429 }
18430
18431 /*
18432 =head1 Hook manipulation
18433
18434 These functions provide convenient and thread-safe means of manipulating
18435 hook variables.
18436
18437 =cut
18438 */
18439
18440 /*
18441 =for apidoc wrap_op_checker
18442
18443 Puts a C function into the chain of check functions for a specified op
18444 type.  This is the preferred way to manipulate the L</PL_check> array.
18445 C<opcode> specifies which type of op is to be affected.  C<new_checker>
18446 is a pointer to the C function that is to be added to that opcode's
18447 check chain, and C<old_checker_p> points to the storage location where a
18448 pointer to the next function in the chain will be stored.  The value of
18449 C<new_checker> is written into the L</PL_check> array, while the value
18450 previously stored there is written to C<*old_checker_p>.
18451
18452 L</PL_check> is global to an entire process, and a module wishing to
18453 hook op checking may find itself invoked more than once per process,
18454 typically in different threads.  To handle that situation, this function
18455 is idempotent.  The location C<*old_checker_p> must initially (once
18456 per process) contain a null pointer.  A C variable of static duration
18457 (declared at file scope, typically also marked C<static> to give
18458 it internal linkage) will be implicitly initialised appropriately,
18459 if it does not have an explicit initialiser.  This function will only
18460 actually modify the check chain if it finds C<*old_checker_p> to be null.
18461 This function is also thread safe on the small scale.  It uses appropriate
18462 locking to avoid race conditions in accessing L</PL_check>.
18463
18464 When this function is called, the function referenced by C<new_checker>
18465 must be ready to be called, except for C<*old_checker_p> being unfilled.
18466 In a threading situation, C<new_checker> may be called immediately,
18467 even before this function has returned.  C<*old_checker_p> will always
18468 be appropriately set before C<new_checker> is called.  If C<new_checker>
18469 decides not to do anything special with an op that it is given (which
18470 is the usual case for most uses of op check hooking), it must chain the
18471 check function referenced by C<*old_checker_p>.
18472
18473 Taken all together, XS code to hook an op checker should typically look
18474 something like this:
18475
18476     static Perl_check_t nxck_frob;
18477     static OP *myck_frob(pTHX_ OP *op) {
18478         ...
18479         op = nxck_frob(aTHX_ op);
18480         ...
18481         return op;
18482     }
18483     BOOT:
18484         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18485
18486 If you want to influence compilation of calls to a specific subroutine,
18487 then use L</cv_set_call_checker_flags> rather than hooking checking of
18488 all C<entersub> ops.
18489
18490 =cut
18491 */
18492
18493 void
18494 Perl_wrap_op_checker(pTHX_ Optype opcode,
18495     Perl_check_t new_checker, Perl_check_t *old_checker_p)
18496 {
18497     dVAR;
18498
18499     PERL_UNUSED_CONTEXT;
18500     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18501     if (*old_checker_p) return;
18502     OP_CHECK_MUTEX_LOCK;
18503     if (!*old_checker_p) {
18504         *old_checker_p = PL_check[opcode];
18505         PL_check[opcode] = new_checker;
18506     }
18507     OP_CHECK_MUTEX_UNLOCK;
18508 }
18509
18510 #include "XSUB.h"
18511
18512 /* Efficient sub that returns a constant scalar value. */
18513 static void
18514 const_sv_xsub(pTHX_ CV* cv)
18515 {
18516     dXSARGS;
18517     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18518     PERL_UNUSED_ARG(items);
18519     if (!sv) {
18520         XSRETURN(0);
18521     }
18522     EXTEND(sp, 1);
18523     ST(0) = sv;
18524     XSRETURN(1);
18525 }
18526
18527 static void
18528 const_av_xsub(pTHX_ CV* cv)
18529 {
18530     dXSARGS;
18531     AV * const av = MUTABLE_AV(XSANY.any_ptr);
18532     SP -= items;
18533     assert(av);
18534 #ifndef DEBUGGING
18535     if (!av) {
18536         XSRETURN(0);
18537     }
18538 #endif
18539     if (SvRMAGICAL(av))
18540         Perl_croak(aTHX_ "Magical list constants are not supported");
18541     if (GIMME_V != G_ARRAY) {
18542         EXTEND(SP, 1);
18543         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18544         XSRETURN(1);
18545     }
18546     EXTEND(SP, AvFILLp(av)+1);
18547     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18548     XSRETURN(AvFILLp(av)+1);
18549 }
18550
18551 /* Copy an existing cop->cop_warnings field.
18552  * If it's one of the standard addresses, just re-use the address.
18553  * This is the e implementation for the DUP_WARNINGS() macro
18554  */
18555
18556 STRLEN*
18557 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18558 {
18559     Size_t size;
18560     STRLEN *new_warnings;
18561
18562     if (warnings == NULL || specialWARN(warnings))
18563         return warnings;
18564
18565     size = sizeof(*warnings) + *warnings;
18566
18567     new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18568     Copy(warnings, new_warnings, size, char);
18569     return new_warnings;
18570 }
18571
18572 /*
18573  * ex: set ts=8 sts=4 sw=4 et:
18574  */