op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 /* make freed ops die if they're inadvertently executed */
 423 #ifdef DEBUGGING
 424 static OP *
 425 S_pp_freed(pTHX)
 426 {
 427     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 428 }
 429 #endif
 430
 431 void
 432 Perl_Slab_Free(pTHX_ void *op)
 433 {
 434     OP * const o = (OP *)op;
 435     OPSLAB *slab;
 436
 437     PERL_ARGS_ASSERT_SLAB_FREE;
 438
 439 #ifdef DEBUGGING
 440     o->op_ppaddr = S_pp_freed;
 441 #endif
 442
 443     if (!o->op_slabbed) {
 444         if (!o->op_static)
 445             PerlMemShared_free(op);
 446         return;
 447     }
 448
 449     slab = OpSLAB(o);
 450     /* If this op is already freed, our refcount will get screwy. */
 451     assert(o->op_type != OP_FREED);
 452     o->op_type = OP_FREED;
 453     o->op_next = slab->opslab_freed;
 454     slab->opslab_freed = o;
 455     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 456     OpslabREFCNT_dec_padok(slab);
 457 }
 458
 459 void
 460 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 461 {
 462     const bool havepad = !!PL_comppad;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 464     if (havepad) {
 465         ENTER;
 466         PAD_SAVE_SETNULLPAD();
 467     }
 468     opslab_free(slab);
 469     if (havepad) LEAVE;
 470 }
 471
 472 void
 473 Perl_opslab_free(pTHX_ OPSLAB *slab)
 474 {
 475     OPSLAB *slab2;
 476     PERL_ARGS_ASSERT_OPSLAB_FREE;
 477     PERL_UNUSED_CONTEXT;
 478     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 479     assert(slab->opslab_refcnt == 1);
 480     do {
 481         slab2 = slab->opslab_next;
 482 #ifdef DEBUGGING
 483         slab->opslab_refcnt = ~(size_t)0;
 484 #endif
 485 #ifdef PERL_DEBUG_READONLY_OPS
 486         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 487                                                (void*)slab));
 488         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 489             perror("munmap failed");
 490             abort();
 491         }
 492 #else
 493         PerlMemShared_free(slab);
 494 #endif
 495         slab = slab2;
 496     } while (slab);
 497 }
 498
 499 void
 500 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 501 {
 502     OPSLAB *slab2;
 503 #ifdef DEBUGGING
 504     size_t savestack_count = 0;
 505 #endif
 506     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 507     slab2 = slab;
 508     do {
 509         OPSLOT *slot;
 510         for (slot = slab2->opslab_first;
 511              slot->opslot_next;
 512              slot = slot->opslot_next) {
 513             if (slot->opslot_op.op_type != OP_FREED
 514              && !(slot->opslot_op.op_savefree
 515 #ifdef DEBUGGING
 516                   && ++savestack_count
 517 #endif
 518                  )
 519             ) {
 520                 assert(slot->opslot_op.op_slabbed);
 521                 op_free(&slot->opslot_op);
 522                 if (slab->opslab_refcnt == 1) goto free;
 523             }
 524         }
 525     } while ((slab2 = slab2->opslab_next));
 526     /* > 1 because the CV still holds a reference count. */
 527     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 528 #ifdef DEBUGGING
 529         assert(savestack_count == slab->opslab_refcnt-1);
 530 #endif
 531         /* Remove the CV’s reference count. */
 532         slab->opslab_refcnt--;
 533         return;
 534     }
 535    free:
 536     opslab_free(slab);
 537 }
 538
 539 #ifdef PERL_DEBUG_READONLY_OPS
 540 OP *
 541 Perl_op_refcnt_inc(pTHX_ OP *o)
 542 {
 543     if(o) {
 544         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 545         if (slab && slab->opslab_readonly) {
 546             Slab_to_rw(slab);
 547             ++o->op_targ;
 548             Slab_to_ro(slab);
 549         } else {
 550             ++o->op_targ;
 551         }
 552     }
 553     return o;
 554
 555 }
 556
 557 PADOFFSET
 558 Perl_op_refcnt_dec(pTHX_ OP *o)
 559 {
 560     PADOFFSET result;
 561     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 562
 563     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 564
 565     if (slab && slab->opslab_readonly) {
 566         Slab_to_rw(slab);
 567         result = --o->op_targ;
 568         Slab_to_ro(slab);
 569     } else {
 570         result = --o->op_targ;
 571     }
 572     return result;
 573 }
 574 #endif
 575 /*
 576  * In the following definition, the ", (OP*)0" is just to make the compiler
 577  * think the expression is of the right type: croak actually does a Siglongjmp.
 578  */
 579 #define CHECKOP(type,o) \
 580     ((PL_op_mask && PL_op_mask[type])                           \
 581      ? ( op_free((OP*)o),                                       \
 582          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 583          (OP*)0 )                                               \
 584      : PL_check[type](aTHX_ (OP*)o))
 585
 586 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 587
 588 #define OpTYPE_set(o,type) \
 589     STMT_START {                                \
 590         o->op_type = (OPCODE)type;              \
 591         o->op_ppaddr = PL_ppaddr[type];         \
 592     } STMT_END
 593
 594 STATIC OP *
 595 S_no_fh_allowed(pTHX_ OP *o)
 596 {
 597     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 598
 599     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 600                  OP_DESC(o)));
 601     return o;
 602 }
 603
 604 STATIC OP *
 605 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 606 {
 607     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 608     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 609     return o;
 610 }
 611
 612 STATIC OP *
 613 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 614 {
 615     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 616
 617     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 618     return o;
 619 }
 620
 621 STATIC void
 622 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 623 {
 624     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 625
 626     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 627                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 628 }
 629
 630 /* remove flags var, its unused in all callers, move to to right end since gv
 631   and kid are always the same */
 632 STATIC void
 633 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 634 {
 635     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 636     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 637
 638     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 639                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 640 }
 641
 642 STATIC void
 643 S_no_bareword_allowed(pTHX_ OP *o)
 644 {
 645     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 646
 647     qerror(Perl_mess(aTHX_
 648                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 649                      SVfARG(cSVOPo_sv)));
 650     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 651 }
 652
 653 /* "register" allocation */
 654
 655 PADOFFSET
 656 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 657 {
 658     PADOFFSET off;
 659     const bool is_our = (PL_parser->in_my == KEY_our);
 660
 661     PERL_ARGS_ASSERT_ALLOCMY;
 662
 663     if (flags & ~SVf_UTF8)
 664         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 665                    (UV)flags);
 666
 667     /* complain about "my $<special_var>" etc etc */
 668     if (   len
 669         && !(  is_our
 670             || isALPHA(name[1])
 671             || (   (flags & SVf_UTF8)
 672                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 673             || (name[1] == '_' && len > 2)))
 674     {
 675         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 676          && isASCII(name[1])
 677          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 678             /* diag_listed_as: Can't use global %s in "%s" */
 679             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 680                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 681                               PL_parser->in_my == KEY_state ? "state" : "my"));
 682         } else {
 683             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 684                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 685         }
 686     }
 687
 688     /* allocate a spare slot and store the name in that slot */
 689
 690     off = pad_add_name_pvn(name, len,
 691                        (is_our ? padadd_OUR :
 692                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 693                     PL_parser->in_my_stash,
 694                     (is_our
 695                         /* $_ is always in main::, even with our */
 696                         ? (PL_curstash && !memEQs(name,len,"$_")
 697                             ? PL_curstash
 698                             : PL_defstash)
 699                         : NULL
 700                     )
 701     );
 702     /* anon sub prototypes contains state vars should always be cloned,
 703      * otherwise the state var would be shared between anon subs */
 704
 705     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 706         CvCLONE_on(PL_compcv);
 707
 708     return off;
 709 }
 710
 711 /*
 712 =head1 Optree Manipulation Functions
 713
 714 =for apidoc alloccopstash
 715
 716 Available only under threaded builds, this function allocates an entry in
 717 C<PL_stashpad> for the stash passed to it.
 718
 719 =cut
 720 */
 721
 722 #ifdef USE_ITHREADS
 723 PADOFFSET
 724 Perl_alloccopstash(pTHX_ HV *hv)
 725 {
 726     PADOFFSET off = 0, o = 1;
 727     bool found_slot = FALSE;
 728
 729     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 730
 731     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 732
 733     for (; o < PL_stashpadmax; ++o) {
 734         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 735         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 736             found_slot = TRUE, off = o;
 737     }
 738     if (!found_slot) {
 739         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 740         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 741         off = PL_stashpadmax;
 742         PL_stashpadmax += 10;
 743     }
 744
 745     PL_stashpad[PL_stashpadix = off] = hv;
 746     return off;
 747 }
 748 #endif
 749
 750 /* free the body of an op without examining its contents.
 751  * Always use this rather than FreeOp directly */
 752
 753 static void
 754 S_op_destroy(pTHX_ OP *o)
 755 {
 756     FreeOp(o);
 757 }
 758
 759 /* Destructor */
 760
 761 /*
 762 =for apidoc Am|void|op_free|OP *o
 763
 764 Free an op.  Only use this when an op is no longer linked to from any
 765 optree.
 766
 767 =cut
 768 */
 769
 770 void
 771 Perl_op_free(pTHX_ OP *o)
 772 {
 773     dVAR;
 774     OPCODE type;
 775     SSize_t defer_ix = -1;
 776     SSize_t defer_stack_alloc = 0;
 777     OP **defer_stack = NULL;
 778
 779     do {
 780
 781         /* Though ops may be freed twice, freeing the op after its slab is a
 782            big no-no. */
 783         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 784         /* During the forced freeing of ops after compilation failure, kidops
 785            may be freed before their parents. */
 786         if (!o || o->op_type == OP_FREED)
 787             continue;
 788
 789         type = o->op_type;
 790
 791         /* an op should only ever acquire op_private flags that we know about.
 792          * If this fails, you may need to fix something in regen/op_private.
 793          * Don't bother testing if:
 794          *   * the op_ppaddr doesn't match the op; someone may have
 795          *     overridden the op and be doing strange things with it;
 796          *   * we've errored, as op flags are often left in an
 797          *     inconsistent state then. Note that an error when
 798          *     compiling the main program leaves PL_parser NULL, so
 799          *     we can't spot faults in the main code, only
 800          *     evaled/required code */
 801 #ifdef DEBUGGING
 802         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 803             && PL_parser
 804             && !PL_parser->error_count)
 805         {
 806             assert(!(o->op_private & ~PL_op_private_valid[type]));
 807         }
 808 #endif
 809
 810         if (o->op_private & OPpREFCOUNTED) {
 811             switch (type) {
 812             case OP_LEAVESUB:
 813             case OP_LEAVESUBLV:
 814             case OP_LEAVEEVAL:
 815             case OP_LEAVE:
 816             case OP_SCOPE:
 817             case OP_LEAVEWRITE:
 818                 {
 819                 PADOFFSET refcnt;
 820                 OP_REFCNT_LOCK;
 821                 refcnt = OpREFCNT_dec(o);
 822                 OP_REFCNT_UNLOCK;
 823                 if (refcnt) {
 824                     /* Need to find and remove any pattern match ops from the list
 825                        we maintain for reset().  */
 826                     find_and_forget_pmops(o);
 827                     continue;
 828                 }
 829                 }
 830                 break;
 831             default:
 832                 break;
 833             }
 834         }
 835
 836         /* Call the op_free hook if it has been set. Do it now so that it's called
 837          * at the right time for refcounted ops, but still before all of the kids
 838          * are freed. */
 839         CALL_OPFREEHOOK(o);
 840
 841         if (o->op_flags & OPf_KIDS) {
 842             OP *kid, *nextkid;
 843             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 844                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 845                 if (!kid || kid->op_type == OP_FREED)
 846                     /* During the forced freeing of ops after
 847                        compilation failure, kidops may be freed before
 848                        their parents. */
 849                     continue;
 850                 if (!(kid->op_flags & OPf_KIDS))
 851                     /* If it has no kids, just free it now */
 852                     op_free(kid);
 853                 else
 854                     DEFER_OP(kid);
 855             }
 856         }
 857         if (type == OP_NULL)
 858             type = (OPCODE)o->op_targ;
 859
 860         if (o->op_slabbed)
 861             Slab_to_rw(OpSLAB(o));
 862
 863         /* COP* is not cleared by op_clear() so that we may track line
 864          * numbers etc even after null() */
 865         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 866             cop_free((COP*)o);
 867         }
 868
 869         op_clear(o);
 870         FreeOp(o);
 871         if (PL_op == o)
 872             PL_op = NULL;
 873     } while ( (o = POP_DEFERRED_OP()) );
 874
 875     Safefree(defer_stack);
 876 }
 877
 878 /* S_op_clear_gv(): free a GV attached to an OP */
 879
 880 STATIC
 881 #ifdef USE_ITHREADS
 882 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 883 #else
 884 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 885 #endif
 886 {
 887
 888     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 889             || o->op_type == OP_MULTIDEREF)
 890 #ifdef USE_ITHREADS
 891                 && PL_curpad
 892                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 893 #else
 894                 ? (GV*)(*svp) : NULL;
 895 #endif
 896     /* It's possible during global destruction that the GV is freed
 897        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 898        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 899        will trigger an assertion failure, because the entry to sv_clear
 900        checks that the scalar is not already freed.  A check of for
 901        !SvIS_FREED(gv) turns out to be invalid, because during global
 902        destruction the reference count can be forced down to zero
 903        (with SVf_BREAK set).  In which case raising to 1 and then
 904        dropping to 0 triggers cleanup before it should happen.  I
 905        *think* that this might actually be a general, systematic,
 906        weakness of the whole idea of SVf_BREAK, in that code *is*
 907        allowed to raise and lower references during global destruction,
 908        so any *valid* code that happens to do this during global
 909        destruction might well trigger premature cleanup.  */
 910     bool still_valid = gv && SvREFCNT(gv);
 911
 912     if (still_valid)
 913         SvREFCNT_inc_simple_void(gv);
 914 #ifdef USE_ITHREADS
 915     if (*ixp > 0) {
 916         pad_swipe(*ixp, TRUE);
 917         *ixp = 0;
 918     }
 919 #else
 920     SvREFCNT_dec(*svp);
 921     *svp = NULL;
 922 #endif
 923     if (still_valid) {
 924         int try_downgrade = SvREFCNT(gv) == 2;
 925         SvREFCNT_dec_NN(gv);
 926         if (try_downgrade)
 927             gv_try_downgrade(gv);
 928     }
 929 }
 930
 931
 932 void
 933 Perl_op_clear(pTHX_ OP *o)
 934 {
 935
 936     dVAR;
 937
 938     PERL_ARGS_ASSERT_OP_CLEAR;
 939
 940     switch (o->op_type) {
 941     case OP_NULL:       /* Was holding old type, if any. */
 942         /* FALLTHROUGH */
 943     case OP_ENTERTRY:
 944     case OP_ENTEREVAL:  /* Was holding hints. */
 945     case OP_ARGDEFELEM: /* Was holding signature index. */
 946         o->op_targ = 0;
 947         break;
 948     default:
 949         if (!(o->op_flags & OPf_REF)
 950             || (PL_check[o->op_type] != Perl_ck_ftst))
 951             break;
 952         /* FALLTHROUGH */
 953     case OP_GVSV:
 954     case OP_GV:
 955     case OP_AELEMFAST:
 956 #ifdef USE_ITHREADS
 957             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 958 #else
 959             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 960 #endif
 961         break;
 962     case OP_METHOD_REDIR:
 963     case OP_METHOD_REDIR_SUPER:
 964 #ifdef USE_ITHREADS
 965         if (cMETHOPx(o)->op_rclass_targ) {
 966             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 967             cMETHOPx(o)->op_rclass_targ = 0;
 968         }
 969 #else
 970         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 971         cMETHOPx(o)->op_rclass_sv = NULL;
 972 #endif
 973         /* FALLTHROUGH */
 974     case OP_METHOD_NAMED:
 975     case OP_METHOD_SUPER:
 976         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 977         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 978 #ifdef USE_ITHREADS
 979         if (o->op_targ) {
 980             pad_swipe(o->op_targ, 1);
 981             o->op_targ = 0;
 982         }
 983 #endif
 984         break;
 985     case OP_CONST:
 986     case OP_HINTSEVAL:
 987         SvREFCNT_dec(cSVOPo->op_sv);
 988         cSVOPo->op_sv = NULL;
 989 #ifdef USE_ITHREADS
 990         /** Bug #15654
 991           Even if op_clear does a pad_free for the target of the op,
 992           pad_free doesn't actually remove the sv that exists in the pad;
 993           instead it lives on. This results in that it could be reused as
 994           a target later on when the pad was reallocated.
 995         **/
 996         if(o->op_targ) {
 997           pad_swipe(o->op_targ,1);
 998           o->op_targ = 0;
 999         }
1000 #endif
1001         break;
1002     case OP_DUMP:
1003     case OP_GOTO:
1004     case OP_NEXT:
1005     case OP_LAST:
1006     case OP_REDO:
1007         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1008             break;
1009         /* FALLTHROUGH */
1010     case OP_TRANS:
1011     case OP_TRANSR:
1012         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1013             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1014         {
1015 #ifdef USE_ITHREADS
1016             if (cPADOPo->op_padix > 0) {
1017                 pad_swipe(cPADOPo->op_padix, TRUE);
1018                 cPADOPo->op_padix = 0;
1019             }
1020 #else
1021             SvREFCNT_dec(cSVOPo->op_sv);
1022             cSVOPo->op_sv = NULL;
1023 #endif
1024         }
1025         else {
1026             PerlMemShared_free(cPVOPo->op_pv);
1027             cPVOPo->op_pv = NULL;
1028         }
1029         break;
1030     case OP_SUBST:
1031         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1032         goto clear_pmop;
1033
1034     case OP_SPLIT:
1035         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1036             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1037         {
1038             if (o->op_private & OPpSPLIT_LEX)
1039                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1040             else
1041 #ifdef USE_ITHREADS
1042                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1043 #else
1044                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1045 #endif
1046         }
1047         /* FALLTHROUGH */
1048     case OP_MATCH:
1049     case OP_QR:
1050     clear_pmop:
1051         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1052             op_free(cPMOPo->op_code_list);
1053         cPMOPo->op_code_list = NULL;
1054         forget_pmop(cPMOPo);
1055         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1056         /* we use the same protection as the "SAFE" version of the PM_ macros
1057          * here since sv_clean_all might release some PMOPs
1058          * after PL_regex_padav has been cleared
1059          * and the clearing of PL_regex_padav needs to
1060          * happen before sv_clean_all
1061          */
1062 #ifdef USE_ITHREADS
1063         if(PL_regex_pad) {        /* We could be in destruction */
1064             const IV offset = (cPMOPo)->op_pmoffset;
1065             ReREFCNT_dec(PM_GETRE(cPMOPo));
1066             PL_regex_pad[offset] = &PL_sv_undef;
1067             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1068                            sizeof(offset));
1069         }
1070 #else
1071         ReREFCNT_dec(PM_GETRE(cPMOPo));
1072         PM_SETRE(cPMOPo, NULL);
1073 #endif
1074
1075         break;
1076
1077     case OP_ARGCHECK:
1078         PerlMemShared_free(cUNOP_AUXo->op_aux);
1079         break;
1080
1081     case OP_MULTICONCAT:
1082         {
1083             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1084             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1085              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1086              * utf8 shared strings */
1087             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1088             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1089             if (p1)
1090                 PerlMemShared_free(p1);
1091             if (p2 && p1 != p2)
1092                 PerlMemShared_free(p2);
1093             PerlMemShared_free(aux);
1094         }
1095         break;
1096
1097     case OP_MULTIDEREF:
1098         {
1099             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1100             UV actions = items->uv;
1101             bool last = 0;
1102             bool is_hash = FALSE;
1103
1104             while (!last) {
1105                 switch (actions & MDEREF_ACTION_MASK) {
1106
1107                 case MDEREF_reload:
1108                     actions = (++items)->uv;
1109                     continue;
1110
1111                 case MDEREF_HV_padhv_helem:
1112                     is_hash = TRUE;
1113                     /* FALLTHROUGH */
1114                 case MDEREF_AV_padav_aelem:
1115                     pad_free((++items)->pad_offset);
1116                     goto do_elem;
1117
1118                 case MDEREF_HV_gvhv_helem:
1119                     is_hash = TRUE;
1120                     /* FALLTHROUGH */
1121                 case MDEREF_AV_gvav_aelem:
1122 #ifdef USE_ITHREADS
1123                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1124 #else
1125                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1126 #endif
1127                     goto do_elem;
1128
1129                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1130                     is_hash = TRUE;
1131                     /* FALLTHROUGH */
1132                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1133 #ifdef USE_ITHREADS
1134                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1135 #else
1136                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1137 #endif
1138                     goto do_vivify_rv2xv_elem;
1139
1140                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1141                     is_hash = TRUE;
1142                     /* FALLTHROUGH */
1143                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1144                     pad_free((++items)->pad_offset);
1145                     goto do_vivify_rv2xv_elem;
1146
1147                 case MDEREF_HV_pop_rv2hv_helem:
1148                 case MDEREF_HV_vivify_rv2hv_helem:
1149                     is_hash = TRUE;
1150                     /* FALLTHROUGH */
1151                 do_vivify_rv2xv_elem:
1152                 case MDEREF_AV_pop_rv2av_aelem:
1153                 case MDEREF_AV_vivify_rv2av_aelem:
1154                 do_elem:
1155                     switch (actions & MDEREF_INDEX_MASK) {
1156                     case MDEREF_INDEX_none:
1157                         last = 1;
1158                         break;
1159                     case MDEREF_INDEX_const:
1160                         if (is_hash) {
1161 #ifdef USE_ITHREADS
1162                             /* see RT #15654 */
1163                             pad_swipe((++items)->pad_offset, 1);
1164 #else
1165                             SvREFCNT_dec((++items)->sv);
1166 #endif
1167                         }
1168                         else
1169                             items++;
1170                         break;
1171                     case MDEREF_INDEX_padsv:
1172                         pad_free((++items)->pad_offset);
1173                         break;
1174                     case MDEREF_INDEX_gvsv:
1175 #ifdef USE_ITHREADS
1176                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1177 #else
1178                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1179 #endif
1180                         break;
1181                     }
1182
1183                     if (actions & MDEREF_FLAG_last)
1184                         last = 1;
1185                     is_hash = FALSE;
1186
1187                     break;
1188
1189                 default:
1190                     assert(0);
1191                     last = 1;
1192                     break;
1193
1194                 } /* switch */
1195
1196                 actions >>= MDEREF_SHIFT;
1197             } /* while */
1198
1199             /* start of malloc is at op_aux[-1], where the length is
1200              * stored */
1201             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1202         }
1203         break;
1204     }
1205
1206     if (o->op_targ > 0) {
1207         pad_free(o->op_targ);
1208         o->op_targ = 0;
1209     }
1210 }
1211
1212 STATIC void
1213 S_cop_free(pTHX_ COP* cop)
1214 {
1215     PERL_ARGS_ASSERT_COP_FREE;
1216
1217     CopFILE_free(cop);
1218     if (! specialWARN(cop->cop_warnings))
1219         PerlMemShared_free(cop->cop_warnings);
1220     cophh_free(CopHINTHASH_get(cop));
1221     if (PL_curcop == cop)
1222        PL_curcop = NULL;
1223 }
1224
1225 STATIC void
1226 S_forget_pmop(pTHX_ PMOP *const o
1227               )
1228 {
1229     HV * const pmstash = PmopSTASH(o);
1230
1231     PERL_ARGS_ASSERT_FORGET_PMOP;
1232
1233     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1234         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1235         if (mg) {
1236             PMOP **const array = (PMOP**) mg->mg_ptr;
1237             U32 count = mg->mg_len / sizeof(PMOP**);
1238             U32 i = count;
1239
1240             while (i--) {
1241                 if (array[i] == o) {
1242                     /* Found it. Move the entry at the end to overwrite it.  */
1243                     array[i] = array[--count];
1244                     mg->mg_len = count * sizeof(PMOP**);
1245                     /* Could realloc smaller at this point always, but probably
1246                        not worth it. Probably worth free()ing if we're the
1247                        last.  */
1248                     if(!count) {
1249                         Safefree(mg->mg_ptr);
1250                         mg->mg_ptr = NULL;
1251                     }
1252                     break;
1253                 }
1254             }
1255         }
1256     }
1257     if (PL_curpm == o)
1258         PL_curpm = NULL;
1259 }
1260
1261 STATIC void
1262 S_find_and_forget_pmops(pTHX_ OP *o)
1263 {
1264     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1265
1266     if (o->op_flags & OPf_KIDS) {
1267         OP *kid = cUNOPo->op_first;
1268         while (kid) {
1269             switch (kid->op_type) {
1270             case OP_SUBST:
1271             case OP_SPLIT:
1272             case OP_MATCH:
1273             case OP_QR:
1274                 forget_pmop((PMOP*)kid);
1275             }
1276             find_and_forget_pmops(kid);
1277             kid = OpSIBLING(kid);
1278         }
1279     }
1280 }
1281
1282 /*
1283 =for apidoc Am|void|op_null|OP *o
1284
1285 Neutralizes an op when it is no longer needed, but is still linked to from
1286 other ops.
1287
1288 =cut
1289 */
1290
1291 void
1292 Perl_op_null(pTHX_ OP *o)
1293 {
1294     dVAR;
1295
1296     PERL_ARGS_ASSERT_OP_NULL;
1297
1298     if (o->op_type == OP_NULL)
1299         return;
1300     op_clear(o);
1301     o->op_targ = o->op_type;
1302     OpTYPE_set(o, OP_NULL);
1303 }
1304
1305 void
1306 Perl_op_refcnt_lock(pTHX)
1307   PERL_TSA_ACQUIRE(PL_op_mutex)
1308 {
1309 #ifdef USE_ITHREADS
1310     dVAR;
1311 #endif
1312     PERL_UNUSED_CONTEXT;
1313     OP_REFCNT_LOCK;
1314 }
1315
1316 void
1317 Perl_op_refcnt_unlock(pTHX)
1318   PERL_TSA_RELEASE(PL_op_mutex)
1319 {
1320 #ifdef USE_ITHREADS
1321     dVAR;
1322 #endif
1323     PERL_UNUSED_CONTEXT;
1324     OP_REFCNT_UNLOCK;
1325 }
1326
1327
1328 /*
1329 =for apidoc op_sibling_splice
1330
1331 A general function for editing the structure of an existing chain of
1332 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1333 you to delete zero or more sequential nodes, replacing them with zero or
1334 more different nodes.  Performs the necessary op_first/op_last
1335 housekeeping on the parent node and op_sibling manipulation on the
1336 children.  The last deleted node will be marked as as the last node by
1337 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1338
1339 Note that op_next is not manipulated, and nodes are not freed; that is the
1340 responsibility of the caller.  It also won't create a new list op for an
1341 empty list etc; use higher-level functions like op_append_elem() for that.
1342
1343 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1344 the splicing doesn't affect the first or last op in the chain.
1345
1346 C<start> is the node preceding the first node to be spliced.  Node(s)
1347 following it will be deleted, and ops will be inserted after it.  If it is
1348 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1349 beginning.
1350
1351 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1352 If -1 or greater than or equal to the number of remaining kids, all
1353 remaining kids are deleted.
1354
1355 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1356 If C<NULL>, no nodes are inserted.
1357
1358 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1359 deleted.
1360
1361 For example:
1362
1363     action                    before      after         returns
1364     ------                    -----       -----         -------
1365
1366                               P           P
1367     splice(P, A, 2, X-Y-Z)    |           |             B-C
1368                               A-B-C-D     A-X-Y-Z-D
1369
1370                               P           P
1371     splice(P, NULL, 1, X-Y)   |           |             A
1372                               A-B-C-D     X-Y-B-C-D
1373
1374                               P           P
1375     splice(P, NULL, 3, NULL)  |           |             A-B-C
1376                               A-B-C-D     D
1377
1378                               P           P
1379     splice(P, B, 0, X-Y)      |           |             NULL
1380                               A-B-C-D     A-B-X-Y-C-D
1381
1382
1383 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1384 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1385
1386 =cut
1387 */
1388
1389 OP *
1390 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1391 {
1392     OP *first;
1393     OP *rest;
1394     OP *last_del = NULL;
1395     OP *last_ins = NULL;
1396
1397     if (start)
1398         first = OpSIBLING(start);
1399     else if (!parent)
1400         goto no_parent;
1401     else
1402         first = cLISTOPx(parent)->op_first;
1403
1404     assert(del_count >= -1);
1405
1406     if (del_count && first) {
1407         last_del = first;
1408         while (--del_count && OpHAS_SIBLING(last_del))
1409             last_del = OpSIBLING(last_del);
1410         rest = OpSIBLING(last_del);
1411         OpLASTSIB_set(last_del, NULL);
1412     }
1413     else
1414         rest = first;
1415
1416     if (insert) {
1417         last_ins = insert;
1418         while (OpHAS_SIBLING(last_ins))
1419             last_ins = OpSIBLING(last_ins);
1420         OpMAYBESIB_set(last_ins, rest, NULL);
1421     }
1422     else
1423         insert = rest;
1424
1425     if (start) {
1426         OpMAYBESIB_set(start, insert, NULL);
1427     }
1428     else {
1429         if (!parent)
1430             goto no_parent;
1431         cLISTOPx(parent)->op_first = insert;
1432         if (insert)
1433             parent->op_flags |= OPf_KIDS;
1434         else
1435             parent->op_flags &= ~OPf_KIDS;
1436     }
1437
1438     if (!rest) {
1439         /* update op_last etc */
1440         U32 type;
1441         OP *lastop;
1442
1443         if (!parent)
1444             goto no_parent;
1445
1446         /* ought to use OP_CLASS(parent) here, but that can't handle
1447          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1448          * either */
1449         type = parent->op_type;
1450         if (type == OP_CUSTOM) {
1451             dTHX;
1452             type = XopENTRYCUSTOM(parent, xop_class);
1453         }
1454         else {
1455             if (type == OP_NULL)
1456                 type = parent->op_targ;
1457             type = PL_opargs[type] & OA_CLASS_MASK;
1458         }
1459
1460         lastop = last_ins ? last_ins : start ? start : NULL;
1461         if (   type == OA_BINOP
1462             || type == OA_LISTOP
1463             || type == OA_PMOP
1464             || type == OA_LOOP
1465         )
1466             cLISTOPx(parent)->op_last = lastop;
1467
1468         if (lastop)
1469             OpLASTSIB_set(lastop, parent);
1470     }
1471     return last_del ? first : NULL;
1472
1473   no_parent:
1474     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1475 }
1476
1477
1478 #ifdef PERL_OP_PARENT
1479
1480 /*
1481 =for apidoc op_parent
1482
1483 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1484 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1485
1486 =cut
1487 */
1488
1489 OP *
1490 Perl_op_parent(OP *o)
1491 {
1492     PERL_ARGS_ASSERT_OP_PARENT;
1493     while (OpHAS_SIBLING(o))
1494         o = OpSIBLING(o);
1495     return o->op_sibparent;
1496 }
1497
1498 #endif
1499
1500
1501 /* replace the sibling following start with a new UNOP, which becomes
1502  * the parent of the original sibling; e.g.
1503  *
1504  *  op_sibling_newUNOP(P, A, unop-args...)
1505  *
1506  *  P              P
1507  *  |      becomes |
1508  *  A-B-C          A-U-C
1509  *                   |
1510  *                   B
1511  *
1512  * where U is the new UNOP.
1513  *
1514  * parent and start args are the same as for op_sibling_splice();
1515  * type and flags args are as newUNOP().
1516  *
1517  * Returns the new UNOP.
1518  */
1519
1520 STATIC OP *
1521 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1522 {
1523     OP *kid, *newop;
1524
1525     kid = op_sibling_splice(parent, start, 1, NULL);
1526     newop = newUNOP(type, flags, kid);
1527     op_sibling_splice(parent, start, 0, newop);
1528     return newop;
1529 }
1530
1531
1532 /* lowest-level newLOGOP-style function - just allocates and populates
1533  * the struct. Higher-level stuff should be done by S_new_logop() /
1534  * newLOGOP(). This function exists mainly to avoid op_first assignment
1535  * being spread throughout this file.
1536  */
1537
1538 LOGOP *
1539 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1540 {
1541     dVAR;
1542     LOGOP *logop;
1543     OP *kid = first;
1544     NewOp(1101, logop, 1, LOGOP);
1545     OpTYPE_set(logop, type);
1546     logop->op_first = first;
1547     logop->op_other = other;
1548     logop->op_flags = OPf_KIDS;
1549     while (kid && OpHAS_SIBLING(kid))
1550         kid = OpSIBLING(kid);
1551     if (kid)
1552         OpLASTSIB_set(kid, (OP*)logop);
1553     return logop;
1554 }
1555
1556
1557 /* Contextualizers */
1558
1559 /*
1560 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1561
1562 Applies a syntactic context to an op tree representing an expression.
1563 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1564 or C<G_VOID> to specify the context to apply.  The modified op tree
1565 is returned.
1566
1567 =cut
1568 */
1569
1570 OP *
1571 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1572 {
1573     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1574     switch (context) {
1575         case G_SCALAR: return scalar(o);
1576         case G_ARRAY:  return list(o);
1577         case G_VOID:   return scalarvoid(o);
1578         default:
1579             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1580                        (long) context);
1581     }
1582 }
1583
1584 /*
1585
1586 =for apidoc Am|OP*|op_linklist|OP *o
1587 This function is the implementation of the L</LINKLIST> macro.  It should
1588 not be called directly.
1589
1590 =cut
1591 */
1592
1593 OP *
1594 Perl_op_linklist(pTHX_ OP *o)
1595 {
1596     OP *first;
1597
1598     PERL_ARGS_ASSERT_OP_LINKLIST;
1599
1600     if (o->op_next)
1601         return o->op_next;
1602
1603     /* establish postfix order */
1604     first = cUNOPo->op_first;
1605     if (first) {
1606         OP *kid;
1607         o->op_next = LINKLIST(first);
1608         kid = first;
1609         for (;;) {
1610             OP *sibl = OpSIBLING(kid);
1611             if (sibl) {
1612                 kid->op_next = LINKLIST(sibl);
1613                 kid = sibl;
1614             } else {
1615                 kid->op_next = o;
1616                 break;
1617             }
1618         }
1619     }
1620     else
1621         o->op_next = o;
1622
1623     return o->op_next;
1624 }
1625
1626 static OP *
1627 S_scalarkids(pTHX_ OP *o)
1628 {
1629     if (o && o->op_flags & OPf_KIDS) {
1630         OP *kid;
1631         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1632             scalar(kid);
1633     }
1634     return o;
1635 }
1636
1637 STATIC OP *
1638 S_scalarboolean(pTHX_ OP *o)
1639 {
1640     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1641
1642     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1643          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1644         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1645          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1646          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1647         if (ckWARN(WARN_SYNTAX)) {
1648             const line_t oldline = CopLINE(PL_curcop);
1649
1650             if (PL_parser && PL_parser->copline != NOLINE) {
1651                 /* This ensures that warnings are reported at the first line
1652                    of the conditional, not the last.  */
1653                 CopLINE_set(PL_curcop, PL_parser->copline);
1654             }
1655             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1656             CopLINE_set(PL_curcop, oldline);
1657         }
1658     }
1659     return scalar(o);
1660 }
1661
1662 static SV *
1663 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1664 {
1665     assert(o);
1666     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1667            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1668     {
1669         const char funny  = o->op_type == OP_PADAV
1670                          || o->op_type == OP_RV2AV ? '@' : '%';
1671         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1672             GV *gv;
1673             if (cUNOPo->op_first->op_type != OP_GV
1674              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1675                 return NULL;
1676             return varname(gv, funny, 0, NULL, 0, subscript_type);
1677         }
1678         return
1679             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1680     }
1681 }
1682
1683 static SV *
1684 S_op_varname(pTHX_ const OP *o)
1685 {
1686     return S_op_varname_subscript(aTHX_ o, 1);
1687 }
1688
1689 static void
1690 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1691 { /* or not so pretty :-) */
1692     if (o->op_type == OP_CONST) {
1693         *retsv = cSVOPo_sv;
1694         if (SvPOK(*retsv)) {
1695             SV *sv = *retsv;
1696             *retsv = sv_newmortal();
1697             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1698                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1699         }
1700         else if (!SvOK(*retsv))
1701             *retpv = "undef";
1702     }
1703     else *retpv = "...";
1704 }
1705
1706 static void
1707 S_scalar_slice_warning(pTHX_ const OP *o)
1708 {
1709     OP *kid;
1710     const bool h = o->op_type == OP_HSLICE
1711                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1712     const char lbrack =
1713         h ? '{' : '[';
1714     const char rbrack =
1715         h ? '}' : ']';
1716     SV *name;
1717     SV *keysv = NULL; /* just to silence compiler warnings */
1718     const char *key = NULL;
1719
1720     if (!(o->op_private & OPpSLICEWARNING))
1721         return;
1722     if (PL_parser && PL_parser->error_count)
1723         /* This warning can be nonsensical when there is a syntax error. */
1724         return;
1725
1726     kid = cLISTOPo->op_first;
1727     kid = OpSIBLING(kid); /* get past pushmark */
1728     /* weed out false positives: any ops that can return lists */
1729     switch (kid->op_type) {
1730     case OP_BACKTICK:
1731     case OP_GLOB:
1732     case OP_READLINE:
1733     case OP_MATCH:
1734     case OP_RV2AV:
1735     case OP_EACH:
1736     case OP_VALUES:
1737     case OP_KEYS:
1738     case OP_SPLIT:
1739     case OP_LIST:
1740     case OP_SORT:
1741     case OP_REVERSE:
1742     case OP_ENTERSUB:
1743     case OP_CALLER:
1744     case OP_LSTAT:
1745     case OP_STAT:
1746     case OP_READDIR:
1747     case OP_SYSTEM:
1748     case OP_TMS:
1749     case OP_LOCALTIME:
1750     case OP_GMTIME:
1751     case OP_ENTEREVAL:
1752         return;
1753     }
1754
1755     /* Don't warn if we have a nulled list either. */
1756     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1757         return;
1758
1759     assert(OpSIBLING(kid));
1760     name = S_op_varname(aTHX_ OpSIBLING(kid));
1761     if (!name) /* XS module fiddling with the op tree */
1762         return;
1763     S_op_pretty(aTHX_ kid, &keysv, &key);
1764     assert(SvPOK(name));
1765     sv_chop(name,SvPVX(name)+1);
1766     if (key)
1767        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1768         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1769                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1770                    "%c%s%c",
1771                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1772                     lbrack, key, rbrack);
1773     else
1774        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1775         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1776                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1777                     SVf "%c%" SVf "%c",
1778                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1779                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1780 }
1781
1782 OP *
1783 Perl_scalar(pTHX_ OP *o)
1784 {
1785     OP *kid;
1786
1787     /* assumes no premature commitment */
1788     if (!o || (PL_parser && PL_parser->error_count)
1789          || (o->op_flags & OPf_WANT)
1790          || o->op_type == OP_RETURN)
1791     {
1792         return o;
1793     }
1794
1795     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1796
1797     switch (o->op_type) {
1798     case OP_REPEAT:
1799         scalar(cBINOPo->op_first);
1800         if (o->op_private & OPpREPEAT_DOLIST) {
1801             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1802             assert(kid->op_type == OP_PUSHMARK);
1803             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1804                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1805                 o->op_private &=~ OPpREPEAT_DOLIST;
1806             }
1807         }
1808         break;
1809     case OP_OR:
1810     case OP_AND:
1811     case OP_COND_EXPR:
1812         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1813             scalar(kid);
1814         break;
1815         /* FALLTHROUGH */
1816     case OP_SPLIT:
1817     case OP_MATCH:
1818     case OP_QR:
1819     case OP_SUBST:
1820     case OP_NULL:
1821     default:
1822         if (o->op_flags & OPf_KIDS) {
1823             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1824                 scalar(kid);
1825         }
1826         break;
1827     case OP_LEAVE:
1828     case OP_LEAVETRY:
1829         kid = cLISTOPo->op_first;
1830         scalar(kid);
1831         kid = OpSIBLING(kid);
1832     do_kids:
1833         while (kid) {
1834             OP *sib = OpSIBLING(kid);
1835             if (sib && kid->op_type != OP_LEAVEWHEN
1836              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1837                 || (  sib->op_targ != OP_NEXTSTATE
1838                    && sib->op_targ != OP_DBSTATE  )))
1839                 scalarvoid(kid);
1840             else
1841                 scalar(kid);
1842             kid = sib;
1843         }
1844         PL_curcop = &PL_compiling;
1845         break;
1846     case OP_SCOPE:
1847     case OP_LINESEQ:
1848     case OP_LIST:
1849         kid = cLISTOPo->op_first;
1850         goto do_kids;
1851     case OP_SORT:
1852         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1853         break;
1854     case OP_KVHSLICE:
1855     case OP_KVASLICE:
1856     {
1857         /* Warn about scalar context */
1858         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1859         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1860         SV *name;
1861         SV *keysv;
1862         const char *key = NULL;
1863
1864         /* This warning can be nonsensical when there is a syntax error. */
1865         if (PL_parser && PL_parser->error_count)
1866             break;
1867
1868         if (!ckWARN(WARN_SYNTAX)) break;
1869
1870         kid = cLISTOPo->op_first;
1871         kid = OpSIBLING(kid); /* get past pushmark */
1872         assert(OpSIBLING(kid));
1873         name = S_op_varname(aTHX_ OpSIBLING(kid));
1874         if (!name) /* XS module fiddling with the op tree */
1875             break;
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: %%s[%s] in scalar context better written as $%s[%s] */
1881             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1882                        "%%%" SVf "%c%s%c in scalar context better written "
1883                        "as $%" SVf "%c%s%c",
1884                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1885                         lbrack, key, rbrack);
1886         else
1887   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1888             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1889                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1890                        "written as $%" SVf "%c%" SVf "%c",
1891                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1892                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1893     }
1894     }
1895     return o;
1896 }
1897
1898 OP *
1899 Perl_scalarvoid(pTHX_ OP *arg)
1900 {
1901     dVAR;
1902     OP *kid;
1903     SV* sv;
1904     SSize_t defer_stack_alloc = 0;
1905     SSize_t defer_ix = -1;
1906     OP **defer_stack = NULL;
1907     OP *o = arg;
1908
1909     PERL_ARGS_ASSERT_SCALARVOID;
1910
1911     do {
1912         U8 want;
1913         SV *useless_sv = NULL;
1914         const char* useless = NULL;
1915
1916         if (o->op_type == OP_NEXTSTATE
1917             || o->op_type == OP_DBSTATE
1918             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1919                                           || o->op_targ == OP_DBSTATE)))
1920             PL_curcop = (COP*)o;                /* for warning below */
1921
1922         /* assumes no premature commitment */
1923         want = o->op_flags & OPf_WANT;
1924         if ((want && want != OPf_WANT_SCALAR)
1925             || (PL_parser && PL_parser->error_count)
1926             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1927         {
1928             continue;
1929         }
1930
1931         if ((o->op_private & OPpTARGET_MY)
1932             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1933         {
1934             /* newASSIGNOP has already applied scalar context, which we
1935                leave, as if this op is inside SASSIGN.  */
1936             continue;
1937         }
1938
1939         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1940
1941         switch (o->op_type) {
1942         default:
1943             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1944                 break;
1945             /* FALLTHROUGH */
1946         case OP_REPEAT:
1947             if (o->op_flags & OPf_STACKED)
1948                 break;
1949             if (o->op_type == OP_REPEAT)
1950                 scalar(cBINOPo->op_first);
1951             goto func_ops;
1952         case OP_CONCAT:
1953             if ((o->op_flags & OPf_STACKED) &&
1954                     !(o->op_private & OPpCONCAT_NESTED))
1955                 break;
1956             goto func_ops;
1957         case OP_SUBSTR:
1958             if (o->op_private == 4)
1959                 break;
1960             /* FALLTHROUGH */
1961         case OP_WANTARRAY:
1962         case OP_GV:
1963         case OP_SMARTMATCH:
1964         case OP_AV2ARYLEN:
1965         case OP_REF:
1966         case OP_REFGEN:
1967         case OP_SREFGEN:
1968         case OP_DEFINED:
1969         case OP_HEX:
1970         case OP_OCT:
1971         case OP_LENGTH:
1972         case OP_VEC:
1973         case OP_INDEX:
1974         case OP_RINDEX:
1975         case OP_SPRINTF:
1976         case OP_KVASLICE:
1977         case OP_KVHSLICE:
1978         case OP_UNPACK:
1979         case OP_PACK:
1980         case OP_JOIN:
1981         case OP_LSLICE:
1982         case OP_ANONLIST:
1983         case OP_ANONHASH:
1984         case OP_SORT:
1985         case OP_REVERSE:
1986         case OP_RANGE:
1987         case OP_FLIP:
1988         case OP_FLOP:
1989         case OP_CALLER:
1990         case OP_FILENO:
1991         case OP_EOF:
1992         case OP_TELL:
1993         case OP_GETSOCKNAME:
1994         case OP_GETPEERNAME:
1995         case OP_READLINK:
1996         case OP_TELLDIR:
1997         case OP_GETPPID:
1998         case OP_GETPGRP:
1999         case OP_GETPRIORITY:
2000         case OP_TIME:
2001         case OP_TMS:
2002         case OP_LOCALTIME:
2003         case OP_GMTIME:
2004         case OP_GHBYNAME:
2005         case OP_GHBYADDR:
2006         case OP_GHOSTENT:
2007         case OP_GNBYNAME:
2008         case OP_GNBYADDR:
2009         case OP_GNETENT:
2010         case OP_GPBYNAME:
2011         case OP_GPBYNUMBER:
2012         case OP_GPROTOENT:
2013         case OP_GSBYNAME:
2014         case OP_GSBYPORT:
2015         case OP_GSERVENT:
2016         case OP_GPWNAM:
2017         case OP_GPWUID:
2018         case OP_GGRNAM:
2019         case OP_GGRGID:
2020         case OP_GETLOGIN:
2021         case OP_PROTOTYPE:
2022         case OP_RUNCV:
2023         func_ops:
2024             useless = OP_DESC(o);
2025             break;
2026
2027         case OP_GVSV:
2028         case OP_PADSV:
2029         case OP_PADAV:
2030         case OP_PADHV:
2031         case OP_PADANY:
2032         case OP_AELEM:
2033         case OP_AELEMFAST:
2034         case OP_AELEMFAST_LEX:
2035         case OP_ASLICE:
2036         case OP_HELEM:
2037         case OP_HSLICE:
2038             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2039                 /* Otherwise it's "Useless use of grep iterator" */
2040                 useless = OP_DESC(o);
2041             break;
2042
2043         case OP_SPLIT:
2044             if (!(o->op_private & OPpSPLIT_ASSIGN))
2045                 useless = OP_DESC(o);
2046             break;
2047
2048         case OP_NOT:
2049             kid = cUNOPo->op_first;
2050             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2051                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2052                 goto func_ops;
2053             }
2054             useless = "negative pattern binding (!~)";
2055             break;
2056
2057         case OP_SUBST:
2058             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2059                 useless = "non-destructive substitution (s///r)";
2060             break;
2061
2062         case OP_TRANSR:
2063             useless = "non-destructive transliteration (tr///r)";
2064             break;
2065
2066         case OP_RV2GV:
2067         case OP_RV2SV:
2068         case OP_RV2AV:
2069         case OP_RV2HV:
2070             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2071                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2072                 useless = "a variable";
2073             break;
2074
2075         case OP_CONST:
2076             sv = cSVOPo_sv;
2077             if (cSVOPo->op_private & OPpCONST_STRICT)
2078                 no_bareword_allowed(o);
2079             else {
2080                 if (ckWARN(WARN_VOID)) {
2081                     NV nv;
2082                     /* don't warn on optimised away booleans, eg
2083                      * use constant Foo, 5; Foo || print; */
2084                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2085                         useless = NULL;
2086                     /* the constants 0 and 1 are permitted as they are
2087                        conventionally used as dummies in constructs like
2088                        1 while some_condition_with_side_effects;  */
2089                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2090                         useless = NULL;
2091                     else if (SvPOK(sv)) {
2092                         SV * const dsv = newSVpvs("");
2093                         useless_sv
2094                             = Perl_newSVpvf(aTHX_
2095                                             "a constant (%s)",
2096                                             pv_pretty(dsv, SvPVX_const(sv),
2097                                                       SvCUR(sv), 32, NULL, NULL,
2098                                                       PERL_PV_PRETTY_DUMP
2099                                                       | PERL_PV_ESCAPE_NOCLEAR
2100                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2101                         SvREFCNT_dec_NN(dsv);
2102                     }
2103                     else if (SvOK(sv)) {
2104                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2105                     }
2106                     else
2107                         useless = "a constant (undef)";
2108                 }
2109             }
2110             op_null(o);         /* don't execute or even remember it */
2111             break;
2112
2113         case OP_POSTINC:
2114             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2115             break;
2116
2117         case OP_POSTDEC:
2118             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2119             break;
2120
2121         case OP_I_POSTINC:
2122             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2123             break;
2124
2125         case OP_I_POSTDEC:
2126             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2127             break;
2128
2129         case OP_SASSIGN: {
2130             OP *rv2gv;
2131             UNOP *refgen, *rv2cv;
2132             LISTOP *exlist;
2133
2134             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2135                 break;
2136
2137             rv2gv = ((BINOP *)o)->op_last;
2138             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2139                 break;
2140
2141             refgen = (UNOP *)((BINOP *)o)->op_first;
2142
2143             if (!refgen || (refgen->op_type != OP_REFGEN
2144                             && refgen->op_type != OP_SREFGEN))
2145                 break;
2146
2147             exlist = (LISTOP *)refgen->op_first;
2148             if (!exlist || exlist->op_type != OP_NULL
2149                 || exlist->op_targ != OP_LIST)
2150                 break;
2151
2152             if (exlist->op_first->op_type != OP_PUSHMARK
2153                 && exlist->op_first != exlist->op_last)
2154                 break;
2155
2156             rv2cv = (UNOP*)exlist->op_last;
2157
2158             if (rv2cv->op_type != OP_RV2CV)
2159                 break;
2160
2161             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2162             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2163             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2164
2165             o->op_private |= OPpASSIGN_CV_TO_GV;
2166             rv2gv->op_private |= OPpDONT_INIT_GV;
2167             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2168
2169             break;
2170         }
2171
2172         case OP_AASSIGN: {
2173             inplace_aassign(o);
2174             break;
2175         }
2176
2177         case OP_OR:
2178         case OP_AND:
2179             kid = cLOGOPo->op_first;
2180             if (kid->op_type == OP_NOT
2181                 && (kid->op_flags & OPf_KIDS)) {
2182                 if (o->op_type == OP_AND) {
2183                     OpTYPE_set(o, OP_OR);
2184                 } else {
2185                     OpTYPE_set(o, OP_AND);
2186                 }
2187                 op_null(kid);
2188             }
2189             /* FALLTHROUGH */
2190
2191         case OP_DOR:
2192         case OP_COND_EXPR:
2193         case OP_ENTERGIVEN:
2194         case OP_ENTERWHEN:
2195             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2196                 if (!(kid->op_flags & OPf_KIDS))
2197                     scalarvoid(kid);
2198                 else
2199                     DEFER_OP(kid);
2200         break;
2201
2202         case OP_NULL:
2203             if (o->op_flags & OPf_STACKED)
2204                 break;
2205             /* FALLTHROUGH */
2206         case OP_NEXTSTATE:
2207         case OP_DBSTATE:
2208         case OP_ENTERTRY:
2209         case OP_ENTER:
2210             if (!(o->op_flags & OPf_KIDS))
2211                 break;
2212             /* FALLTHROUGH */
2213         case OP_SCOPE:
2214         case OP_LEAVE:
2215         case OP_LEAVETRY:
2216         case OP_LEAVELOOP:
2217         case OP_LINESEQ:
2218         case OP_LEAVEGIVEN:
2219         case OP_LEAVEWHEN:
2220         kids:
2221             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2222                 if (!(kid->op_flags & OPf_KIDS))
2223                     scalarvoid(kid);
2224                 else
2225                     DEFER_OP(kid);
2226             break;
2227         case OP_LIST:
2228             /* If the first kid after pushmark is something that the padrange
2229                optimisation would reject, then null the list and the pushmark.
2230             */
2231             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2232                 && (  !(kid = OpSIBLING(kid))
2233                       || (  kid->op_type != OP_PADSV
2234                             && kid->op_type != OP_PADAV
2235                             && kid->op_type != OP_PADHV)
2236                       || kid->op_private & ~OPpLVAL_INTRO
2237                       || !(kid = OpSIBLING(kid))
2238                       || (  kid->op_type != OP_PADSV
2239                             && kid->op_type != OP_PADAV
2240                             && kid->op_type != OP_PADHV)
2241                       || kid->op_private & ~OPpLVAL_INTRO)
2242             ) {
2243                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2244                 op_null(o); /* NULL the list */
2245             }
2246             goto kids;
2247         case OP_ENTEREVAL:
2248             scalarkids(o);
2249             break;
2250         case OP_SCALAR:
2251             scalar(o);
2252             break;
2253         }
2254
2255         if (useless_sv) {
2256             /* mortalise it, in case warnings are fatal.  */
2257             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2258                            "Useless use of %" SVf " in void context",
2259                            SVfARG(sv_2mortal(useless_sv)));
2260         }
2261         else if (useless) {
2262             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2263                            "Useless use of %s in void context",
2264                            useless);
2265         }
2266     } while ( (o = POP_DEFERRED_OP()) );
2267
2268     Safefree(defer_stack);
2269
2270     return arg;
2271 }
2272
2273 static OP *
2274 S_listkids(pTHX_ OP *o)
2275 {
2276     if (o && o->op_flags & OPf_KIDS) {
2277         OP *kid;
2278         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2279             list(kid);
2280     }
2281     return o;
2282 }
2283
2284 OP *
2285 Perl_list(pTHX_ OP *o)
2286 {
2287     OP *kid;
2288
2289     /* assumes no premature commitment */
2290     if (!o || (o->op_flags & OPf_WANT)
2291          || (PL_parser && PL_parser->error_count)
2292          || o->op_type == OP_RETURN)
2293     {
2294         return o;
2295     }
2296
2297     if ((o->op_private & OPpTARGET_MY)
2298         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2299     {
2300         return o;                               /* As if inside SASSIGN */
2301     }
2302
2303     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2304
2305     switch (o->op_type) {
2306     case OP_FLOP:
2307         list(cBINOPo->op_first);
2308         break;
2309     case OP_REPEAT:
2310         if (o->op_private & OPpREPEAT_DOLIST
2311          && !(o->op_flags & OPf_STACKED))
2312         {
2313             list(cBINOPo->op_first);
2314             kid = cBINOPo->op_last;
2315             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2316              && SvIVX(kSVOP_sv) == 1)
2317             {
2318                 op_null(o); /* repeat */
2319                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2320                 /* const (rhs): */
2321                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2322             }
2323         }
2324         break;
2325     case OP_OR:
2326     case OP_AND:
2327     case OP_COND_EXPR:
2328         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2329             list(kid);
2330         break;
2331     default:
2332     case OP_MATCH:
2333     case OP_QR:
2334     case OP_SUBST:
2335     case OP_NULL:
2336         if (!(o->op_flags & OPf_KIDS))
2337             break;
2338         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2339             list(cBINOPo->op_first);
2340             return gen_constant_list(o);
2341         }
2342         listkids(o);
2343         break;
2344     case OP_LIST:
2345         listkids(o);
2346         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2347             op_null(cUNOPo->op_first); /* NULL the pushmark */
2348             op_null(o); /* NULL the list */
2349         }
2350         break;
2351     case OP_LEAVE:
2352     case OP_LEAVETRY:
2353         kid = cLISTOPo->op_first;
2354         list(kid);
2355         kid = OpSIBLING(kid);
2356     do_kids:
2357         while (kid) {
2358             OP *sib = OpSIBLING(kid);
2359             if (sib && kid->op_type != OP_LEAVEWHEN)
2360                 scalarvoid(kid);
2361             else
2362                 list(kid);
2363             kid = sib;
2364         }
2365         PL_curcop = &PL_compiling;
2366         break;
2367     case OP_SCOPE:
2368     case OP_LINESEQ:
2369         kid = cLISTOPo->op_first;
2370         goto do_kids;
2371     }
2372     return o;
2373 }
2374
2375 static OP *
2376 S_scalarseq(pTHX_ OP *o)
2377 {
2378     if (o) {
2379         const OPCODE type = o->op_type;
2380
2381         if (type == OP_LINESEQ || type == OP_SCOPE ||
2382             type == OP_LEAVE || type == OP_LEAVETRY)
2383         {
2384             OP *kid, *sib;
2385             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2386                 if ((sib = OpSIBLING(kid))
2387                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2388                     || (  sib->op_targ != OP_NEXTSTATE
2389                        && sib->op_targ != OP_DBSTATE  )))
2390                 {
2391                     scalarvoid(kid);
2392                 }
2393             }
2394             PL_curcop = &PL_compiling;
2395         }
2396         o->op_flags &= ~OPf_PARENS;
2397         if (PL_hints & HINT_BLOCK_SCOPE)
2398             o->op_flags |= OPf_PARENS;
2399     }
2400     else
2401         o = newOP(OP_STUB, 0);
2402     return o;
2403 }
2404
2405 STATIC OP *
2406 S_modkids(pTHX_ OP *o, I32 type)
2407 {
2408     if (o && o->op_flags & OPf_KIDS) {
2409         OP *kid;
2410         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2411             op_lvalue(kid, type);
2412     }
2413     return o;
2414 }
2415
2416
2417 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2418  * const fields. Also, convert CONST keys to HEK-in-SVs.
2419  * rop is the op that retrieves the hash;
2420  * key_op is the first key
2421  */
2422
2423 STATIC void
2424 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2425 {
2426     PADNAME *lexname;
2427     GV **fields;
2428     bool check_fields;
2429
2430     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2431     if (rop) {
2432         if (rop->op_first->op_type == OP_PADSV)
2433             /* @$hash{qw(keys here)} */
2434             rop = (UNOP*)rop->op_first;
2435         else {
2436             /* @{$hash}{qw(keys here)} */
2437             if (rop->op_first->op_type == OP_SCOPE
2438                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2439                 {
2440                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2441                 }
2442             else
2443                 rop = NULL;
2444         }
2445     }
2446
2447     lexname = NULL; /* just to silence compiler warnings */
2448     fields  = NULL; /* just to silence compiler warnings */
2449
2450     check_fields =
2451             rop
2452          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2453              SvPAD_TYPED(lexname))
2454          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2455          && isGV(*fields) && GvHV(*fields);
2456
2457     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2458         SV **svp, *sv;
2459         if (key_op->op_type != OP_CONST)
2460             continue;
2461         svp = cSVOPx_svp(key_op);
2462
2463         /* make sure it's not a bareword under strict subs */
2464         if (key_op->op_private & OPpCONST_BARE &&
2465             key_op->op_private & OPpCONST_STRICT)
2466         {
2467             no_bareword_allowed((OP*)key_op);
2468         }
2469
2470         /* Make the CONST have a shared SV */
2471         if (   !SvIsCOW_shared_hash(sv = *svp)
2472             && SvTYPE(sv) < SVt_PVMG
2473             && SvOK(sv)
2474             && !SvROK(sv))
2475         {
2476             SSize_t keylen;
2477             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2478             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2479             SvREFCNT_dec_NN(sv);
2480             *svp = nsv;
2481         }
2482
2483         if (   check_fields
2484             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2485         {
2486             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2487                         "in variable %" PNf " of type %" HEKf,
2488                         SVfARG(*svp), PNfARG(lexname),
2489                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2490         }
2491     }
2492 }
2493
2494 /* info returned by S_sprintf_is_multiconcatable() */
2495
2496 struct sprintf_ismc_info {
2497     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2498     char  *start;     /* start of raw format string */
2499     char  *end;       /* bytes after end of raw format string */
2500     STRLEN total_len; /* total length (in bytes) of format string, not
2501                          including '%s' and  half of '%%' */
2502     STRLEN variant;   /* number of bytes by which total_len_p would grow
2503                          if upgraded to utf8 */
2504     bool   utf8;      /* whether the format is utf8 */
2505 };
2506
2507
2508 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2509  * i.e. its format argument is a const string with only '%s' and '%%'
2510  * formats, and the number of args is known, e.g.
2511  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2512  * but not
2513  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2514  *
2515  * If successful, the sprintf_ismc_info struct pointed to by info will be
2516  * populated.
2517  */
2518
2519 STATIC bool
2520 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2521 {
2522     OP    *pm, *constop, *kid;
2523     SV    *sv;
2524     char  *s, *e, *p;
2525     SSize_t nargs, nformats;
2526     STRLEN cur, total_len, variant;
2527     bool   utf8;
2528
2529     /* if sprintf's behaviour changes, die here so that someone
2530      * can decide whether to enhance this function or skip optimising
2531      * under those new circumstances */
2532     assert(!(o->op_flags & OPf_STACKED));
2533     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2534     assert(!(o->op_private & ~OPpARG4_MASK));
2535
2536     pm = cUNOPo->op_first;
2537     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2538         return FALSE;
2539     constop = OpSIBLING(pm);
2540     if (!constop || constop->op_type != OP_CONST)
2541         return FALSE;
2542     sv = cSVOPx_sv(constop);
2543     if (SvMAGICAL(sv) || !SvPOK(sv))
2544         return FALSE;
2545
2546     s = SvPV(sv, cur);
2547     e = s + cur;
2548
2549     /* Scan format for %% and %s and work out how many %s there are.
2550      * Abandon if other format types are found.
2551      */
2552
2553     nformats  = 0;
2554     total_len = 0;
2555     variant   = 0;
2556
2557     for (p = s; p < e; p++) {
2558         if (*p != '%') {
2559             total_len++;
2560             if (!UTF8_IS_INVARIANT(*p))
2561                 variant++;
2562             continue;
2563         }
2564         p++;
2565         if (p >= e)
2566             return FALSE; /* lone % at end gives "Invalid conversion" */
2567         if (*p == '%')
2568             total_len++;
2569         else if (*p == 's')
2570             nformats++;
2571         else
2572             return FALSE;
2573     }
2574
2575     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2576         return FALSE;
2577
2578     utf8 = cBOOL(SvUTF8(sv));
2579     if (utf8)
2580         variant = 0;
2581
2582     /* scan args; they must all be in scalar cxt */
2583
2584     nargs = 0;
2585     kid = OpSIBLING(constop);
2586
2587     while (kid) {
2588         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2589             return FALSE;
2590         nargs++;
2591         kid = OpSIBLING(kid);
2592     }
2593
2594     if (nargs != nformats)
2595         return FALSE; /* e.g. sprintf("%s%s", $a); */
2596
2597
2598     info->nargs      = nargs;
2599     info->start      = s;
2600     info->end        = e;
2601     info->total_len  = total_len;
2602     info->variant    = variant;
2603     info->utf8       = utf8;
2604
2605     return TRUE;
2606 }
2607
2608
2609
2610 /* S_maybe_multiconcat():
2611  *
2612  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2613  * convert it (and its children) into an OP_MULTICONCAT. See the code
2614  * comments just before pp_multiconcat() for the full details of what
2615  * OP_MULTICONCAT supports.
2616  *
2617  * Basically we're looking for an optree with a chain of OP_CONCATS down
2618  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2619  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2620  *
2621  *      $x = "$a$b-$c"
2622  *
2623  *  looks like
2624  *
2625  *      SASSIGN
2626  *         |
2627  *      STRINGIFY   -- PADSV[$x]
2628  *         |
2629  *         |
2630  *      ex-PUSHMARK -- CONCAT/S
2631  *                        |
2632  *                     CONCAT/S  -- PADSV[$d]
2633  *                        |
2634  *                     CONCAT    -- CONST["-"]
2635  *                        |
2636  *                     PADSV[$a] -- PADSV[$b]
2637  *
2638  * Note that at this stage the OP_SASSIGN may have already been optimised
2639  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2640  */
2641
2642 STATIC void
2643 S_maybe_multiconcat(pTHX_ OP *o)
2644 {
2645     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2646     OP *topop;       /* the top-most op in the concat tree (often equals o,
2647                         unless there are assign/stringify ops above it */
2648     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2649     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2650     OP *targetop;    /* the op corresponding to target=... or target.=... */
2651     OP *stringop;    /* the OP_STRINGIFY op, if any */
2652     OP *nextop;      /* used for recreating the op_next chain without consts */
2653     OP *kid;         /* general-purpose op pointer */
2654     UNOP_AUX_item *aux;
2655     UNOP_AUX_item *lenp;
2656     char *const_str, *p;
2657     struct sprintf_ismc_info sprintf_info;
2658
2659                      /* store info about each arg in args[];
2660                       * toparg is the highest used slot; argp is a general
2661                       * pointer to args[] slots */
2662     struct {
2663         void *p;      /* initially points to const sv (or null for op);
2664                          later, set to SvPV(constsv), with ... */
2665         STRLEN len;   /* ... len set to SvPV(..., len) */
2666     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2667
2668     SSize_t nargs  = 0;
2669     SSize_t nconst = 0;
2670     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2671     STRLEN variant;
2672     bool utf8 = FALSE;
2673     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2674                                  the last-processed arg will the LHS of one,
2675                                  as args are processed in reverse order */
2676     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2677     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2678     U8 flags          = 0;   /* what will become the op_flags and ... */
2679     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2680     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2681     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2682     bool prev_was_const = FALSE; /* previous arg was a const */
2683
2684     /* -----------------------------------------------------------------
2685      * Phase 1:
2686      *
2687      * Examine the optree non-destructively to determine whether it's
2688      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2689      * information about the optree in args[].
2690      */
2691
2692     argp     = args;
2693     targmyop = NULL;
2694     targetop = NULL;
2695     stringop = NULL;
2696     topop    = o;
2697     parentop = o;
2698
2699     assert(   o->op_type == OP_SASSIGN
2700            || o->op_type == OP_CONCAT
2701            || o->op_type == OP_SPRINTF
2702            || o->op_type == OP_STRINGIFY);
2703
2704     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2705
2706     /* first see if, at the top of the tree, there is an assign,
2707      * append and/or stringify */
2708
2709     if (topop->op_type == OP_SASSIGN) {
2710         /* expr = ..... */
2711         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2712             return;
2713         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2714             return;
2715         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2716
2717         parentop = topop;
2718         topop = cBINOPo->op_first;
2719         targetop = OpSIBLING(topop);
2720         if (!targetop) /* probably some sort of syntax error */
2721             return;
2722     }
2723     else if (   topop->op_type == OP_CONCAT
2724              && (topop->op_flags & OPf_STACKED)
2725              && (cUNOPo->op_first->op_flags & OPf_MOD)
2726              && (!(topop->op_private & OPpCONCAT_NESTED))
2727             )
2728     {
2729         /* expr .= ..... */
2730
2731         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2732          * decide what to do about it */
2733         assert(!(o->op_private & OPpTARGET_MY));
2734
2735         /* barf on unknown flags */
2736         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2737         private_flags |= OPpMULTICONCAT_APPEND;
2738         targetop = cBINOPo->op_first;
2739         parentop = topop;
2740         topop    = OpSIBLING(targetop);
2741
2742         /* $x .= <FOO> gets optimised to rcatline instead */
2743         if (topop->op_type == OP_READLINE)
2744             return;
2745     }
2746
2747     if (targetop) {
2748         /* Can targetop (the LHS) if it's a padsv, be be optimised
2749          * away and use OPpTARGET_MY instead?
2750          */
2751         if (    (targetop->op_type == OP_PADSV)
2752             && !(targetop->op_private & OPpDEREF)
2753             && !(targetop->op_private & OPpPAD_STATE)
2754                /* we don't support 'my $x .= ...' */
2755             && (   o->op_type == OP_SASSIGN
2756                 || !(targetop->op_private & OPpLVAL_INTRO))
2757         )
2758             is_targable = TRUE;
2759     }
2760
2761     if (topop->op_type == OP_STRINGIFY) {
2762         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2763             return;
2764         stringop = topop;
2765
2766         /* barf on unknown flags */
2767         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2768
2769         if ((topop->op_private & OPpTARGET_MY)) {
2770             if (o->op_type == OP_SASSIGN)
2771                 return; /* can't have two assigns */
2772             targmyop = topop;
2773         }
2774
2775         private_flags |= OPpMULTICONCAT_STRINGIFY;
2776         parentop = topop;
2777         topop = cBINOPx(topop)->op_first;
2778         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2779         topop = OpSIBLING(topop);
2780     }
2781
2782     if (topop->op_type == OP_SPRINTF) {
2783         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2784             return;
2785         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2786             nargs     = sprintf_info.nargs;
2787             total_len = sprintf_info.total_len;
2788             variant   = sprintf_info.variant;
2789             utf8      = sprintf_info.utf8;
2790             is_sprintf = TRUE;
2791             private_flags |= OPpMULTICONCAT_FAKE;
2792             toparg = argp;
2793             /* we have an sprintf op rather than a concat optree.
2794              * Skip most of the code below which is associated with
2795              * processing that optree. We also skip phase 2, determining
2796              * whether its cost effective to optimise, since for sprintf,
2797              * multiconcat is *always* faster */
2798             goto create_aux;
2799         }
2800         /* note that even if the sprintf itself isn't multiconcatable,
2801          * the expression as a whole may be, e.g. in
2802          *    $x .= sprintf("%d",...)
2803          * the sprintf op will be left as-is, but the concat/S op may
2804          * be upgraded to multiconcat
2805          */
2806     }
2807     else if (topop->op_type == OP_CONCAT) {
2808         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2809             return;
2810
2811         if ((topop->op_private & OPpTARGET_MY)) {
2812             if (o->op_type == OP_SASSIGN || targmyop)
2813                 return; /* can't have two assigns */
2814             targmyop = topop;
2815         }
2816     }
2817
2818     /* Is it safe to convert a sassign/stringify/concat op into
2819      * a multiconcat? */
2820     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2821     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2822     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2823     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2824     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2825                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2826     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2827                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2828
2829     /* Now scan the down the tree looking for a series of
2830      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2831      * stacked). For example this tree:
2832      *
2833      *     |
2834      *   CONCAT/STACKED
2835      *     |
2836      *   CONCAT/STACKED -- EXPR5
2837      *     |
2838      *   CONCAT/STACKED -- EXPR4
2839      *     |
2840      *   CONCAT -- EXPR3
2841      *     |
2842      *   EXPR1  -- EXPR2
2843      *
2844      * corresponds to an expression like
2845      *
2846      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2847      *
2848      * Record info about each EXPR in args[]: in particular, whether it is
2849      * a stringifiable OP_CONST and if so what the const sv is.
2850      *
2851      * The reason why the last concat can't be STACKED is the difference
2852      * between
2853      *
2854      *    ((($a .= $a) .= $a) .= $a) .= $a
2855      *
2856      * and
2857      *    $a . $a . $a . $a . $a
2858      *
2859      * The main difference between the optrees for those two constructs
2860      * is the presence of the last STACKED. As well as modifying $a,
2861      * the former sees the changed $a between each concat, so if $s is
2862      * initially 'a', the first returns 'a' x 16, while the latter returns
2863      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2864      */
2865
2866     kid = topop;
2867
2868     for (;;) {
2869         OP *argop;
2870         SV *sv;
2871         bool last = FALSE;
2872
2873         if (    kid->op_type == OP_CONCAT
2874             && !kid_is_last
2875         ) {
2876             OP *k1, *k2;
2877             k1 = cUNOPx(kid)->op_first;
2878             k2 = OpSIBLING(k1);
2879             /* shouldn't happen except maybe after compile err? */
2880             if (!k2)
2881                 return;
2882
2883             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2884             if (kid->op_private & OPpTARGET_MY)
2885                 kid_is_last = TRUE;
2886
2887             stacked_last = (kid->op_flags & OPf_STACKED);
2888             if (!stacked_last)
2889                 kid_is_last = TRUE;
2890
2891             kid   = k1;
2892             argop = k2;
2893         }
2894         else {
2895             argop = kid;
2896             last = TRUE;
2897         }
2898
2899         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2900             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2901         {
2902             /* At least two spare slots are needed to decompose both
2903              * concat args. If there are no slots left, continue to
2904              * examine the rest of the optree, but don't push new values
2905              * on args[]. If the optree as a whole is legal for conversion
2906              * (in particular that the last concat isn't STACKED), then
2907              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2908              * can be converted into an OP_MULTICONCAT now, with the first
2909              * child of that op being the remainder of the optree -
2910              * which may itself later be converted to a multiconcat op
2911              * too.
2912              */
2913             if (last) {
2914                 /* the last arg is the rest of the optree */
2915                 argp++->p = NULL;
2916                 nargs++;
2917             }
2918         }
2919         else if (   argop->op_type == OP_CONST
2920             && ((sv = cSVOPx_sv(argop)))
2921             /* defer stringification until runtime of 'constant'
2922              * things that might stringify variantly, e.g. the radix
2923              * point of NVs, or overloaded RVs */
2924             && (SvPOK(sv) || SvIOK(sv))
2925             && (!SvGMAGICAL(sv))
2926         ) {
2927             argp++->p = sv;
2928             utf8   |= cBOOL(SvUTF8(sv));
2929             nconst++;
2930             if (prev_was_const)
2931                 /* this const may be demoted back to a plain arg later;
2932                  * make sure we have enough arg slots left */
2933                 nadjconst++;
2934             prev_was_const = !prev_was_const;
2935         }
2936         else {
2937             argp++->p = NULL;
2938             nargs++;
2939             prev_was_const = FALSE;
2940         }
2941
2942         if (last)
2943             break;
2944     }
2945
2946     toparg = argp - 1;
2947
2948     if (stacked_last)
2949         return; /* we don't support ((A.=B).=C)...) */
2950
2951     /* look for two adjacent consts and don't fold them together:
2952      *     $o . "a" . "b"
2953      * should do
2954      *     $o->concat("a")->concat("b")
2955      * rather than
2956      *     $o->concat("ab")
2957      * (but $o .=  "a" . "b" should still fold)
2958      */
2959     {
2960         bool seen_nonconst = FALSE;
2961         for (argp = toparg; argp >= args; argp--) {
2962             if (argp->p == NULL) {
2963                 seen_nonconst = TRUE;
2964                 continue;
2965             }
2966             if (!seen_nonconst)
2967                 continue;
2968             if (argp[1].p) {
2969                 /* both previous and current arg were constants;
2970                  * leave the current OP_CONST as-is */
2971                 argp->p = NULL;
2972                 nconst--;
2973                 nargs++;
2974             }
2975         }
2976     }
2977
2978     /* -----------------------------------------------------------------
2979      * Phase 2:
2980      *
2981      * At this point we have determined that the optree *can* be converted
2982      * into a multiconcat. Having gathered all the evidence, we now decide
2983      * whether it *should*.
2984      */
2985
2986
2987     /* we need at least one concat action, e.g.:
2988      *
2989      *  Y . Z
2990      *  X = Y . Z
2991      *  X .= Y
2992      *
2993      * otherwise we could be doing something like $x = "foo", which
2994      * if treated as as a concat, would fail to COW.
2995      */
2996     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2997         return;
2998
2999     /* Benchmarking seems to indicate that we gain if:
3000      * * we optimise at least two actions into a single multiconcat
3001      *    (e.g concat+concat, sassign+concat);
3002      * * or if we can eliminate at least 1 OP_CONST;
3003      * * or if we can eliminate a padsv via OPpTARGET_MY
3004      */
3005
3006     if (
3007            /* eliminated at least one OP_CONST */
3008            nconst >= 1
3009            /* eliminated an OP_SASSIGN */
3010         || o->op_type == OP_SASSIGN
3011            /* eliminated an OP_PADSV */
3012         || (!targmyop && is_targable)
3013     )
3014         /* definitely a net gain to optimise */
3015         goto optimise;
3016
3017     /* ... if not, what else? */
3018
3019     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3020      * multiconcat is faster (due to not creating a temporary copy of
3021      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3022      * faster.
3023      */
3024     if (   nconst == 0
3025          && nargs == 2
3026          && targmyop
3027          && topop->op_type == OP_CONCAT
3028     ) {
3029         PADOFFSET t = targmyop->op_targ;
3030         OP *k1 = cBINOPx(topop)->op_first;
3031         OP *k2 = cBINOPx(topop)->op_last;
3032         if (   k2->op_type == OP_PADSV
3033             && k2->op_targ == t
3034             && (   k1->op_type != OP_PADSV
3035                 || k1->op_targ != t)
3036         )
3037             goto optimise;
3038     }
3039
3040     /* need at least two concats */
3041     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3042         return;
3043
3044
3045
3046     /* -----------------------------------------------------------------
3047      * Phase 3:
3048      *
3049      * At this point the optree has been verified as ok to be optimised
3050      * into an OP_MULTICONCAT. Now start changing things.
3051      */
3052
3053    optimise:
3054
3055     /* stringify all const args and determine utf8ness */
3056
3057     variant = 0;
3058     for (argp = args; argp <= toparg; argp++) {
3059         SV *sv = (SV*)argp->p;
3060         if (!sv)
3061             continue; /* not a const op */
3062         if (utf8 && !SvUTF8(sv))
3063             sv_utf8_upgrade_nomg(sv);
3064         argp->p = SvPV_nomg(sv, argp->len);
3065         total_len += argp->len;
3066
3067         /* see if any strings would grow if converted to utf8 */
3068         if (!utf8) {
3069             char *p    = (char*)argp->p;
3070             STRLEN len = argp->len;
3071             while (len--) {
3072                 U8 c = *p++;
3073                 if (!UTF8_IS_INVARIANT(c))
3074                     variant++;
3075             }
3076         }
3077     }
3078
3079     /* create and populate aux struct */
3080
3081   create_aux:
3082
3083     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3084                     sizeof(UNOP_AUX_item)
3085                     *  (
3086                            PERL_MULTICONCAT_HEADER_SIZE
3087                          + ((nargs + 1) * (variant ? 2 : 1))
3088                         )
3089                     );
3090     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3091
3092     /* Extract all the non-const expressions from the concat tree then
3093      * dispose of the old tree, e.g. convert the tree from this:
3094      *
3095      *  o => SASSIGN
3096      *         |
3097      *       STRINGIFY   -- TARGET
3098      *         |
3099      *       ex-PUSHMARK -- CONCAT
3100      *                        |
3101      *                      CONCAT -- EXPR5
3102      *                        |
3103      *                      CONCAT -- EXPR4
3104      *                        |
3105      *                      CONCAT -- EXPR3
3106      *                        |
3107      *                      EXPR1  -- EXPR2
3108      *
3109      *
3110      * to:
3111      *
3112      *  o => MULTICONCAT
3113      *         |
3114      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3115      *
3116      * except that if EXPRi is an OP_CONST, it's discarded.
3117      *
3118      * During the conversion process, EXPR ops are stripped from the tree
3119      * and unshifted onto o. Finally, any of o's remaining original
3120      * childen are discarded and o is converted into an OP_MULTICONCAT.
3121      *
3122      * In this middle of this, o may contain both: unshifted args on the
3123      * left, and some remaining original args on the right. lastkidop
3124      * is set to point to the right-most unshifted arg to delineate
3125      * between the two sets.
3126      */
3127
3128
3129     if (is_sprintf) {
3130         /* create a copy of the format with the %'s removed, and record
3131          * the sizes of the const string segments in the aux struct */
3132         char *q, *oldq;
3133         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3134
3135         p    = sprintf_info.start;
3136         q    = const_str;
3137         oldq = q;
3138         for (; p < sprintf_info.end; p++) {
3139             if (*p == '%') {
3140                 p++;
3141                 if (*p != '%') {
3142                     (lenp++)->ssize = q - oldq;
3143                     oldq = q;
3144                     continue;
3145                 }
3146             }
3147             *q++ = *p;
3148         }
3149         lenp->ssize = q - oldq;
3150         assert((STRLEN)(q - const_str) == total_len);
3151
3152         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3153          * may or may not be topop) The pushmark and const ops need to be
3154          * kept in case they're an op_next entry point.
3155          */
3156         lastkidop = cLISTOPx(topop)->op_last;
3157         kid = cUNOPx(topop)->op_first; /* pushmark */
3158         op_null(kid);
3159         op_null(OpSIBLING(kid));       /* const */
3160         if (o != topop) {
3161             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3162             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3163             lastkidop->op_next = o;
3164         }
3165     }
3166     else {
3167         p = const_str;
3168         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3169
3170         lenp->ssize = -1;
3171
3172         /* Concatenate all const strings into const_str.
3173          * Note that args[] contains the RHS args in reverse order, so
3174          * we scan args[] from top to bottom to get constant strings
3175          * in L-R order
3176          */
3177         for (argp = toparg; argp >= args; argp--) {
3178             if (!argp->p)
3179                 /* not a const op */
3180                 (++lenp)->ssize = -1;
3181             else {
3182                 STRLEN l = argp->len;
3183                 Copy(argp->p, p, l, char);
3184                 p += l;
3185                 if (lenp->ssize == -1)
3186                     lenp->ssize = l;
3187                 else
3188                     lenp->ssize += l;
3189             }
3190         }
3191
3192         kid = topop;
3193         nextop = o;
3194         lastkidop = NULL;
3195
3196         for (argp = args; argp <= toparg; argp++) {
3197             /* only keep non-const args, except keep the first-in-next-chain
3198              * arg no matter what it is (but nulled if OP_CONST), because it
3199              * may be the entry point to this subtree from the previous
3200              * op_next.
3201              */
3202             bool last = (argp == toparg);
3203             OP *prev;
3204
3205             /* set prev to the sibling *before* the arg to be cut out,
3206              * e.g.:
3207              *
3208              *         |
3209              * kid=  CONST
3210              *         |
3211              * prev= CONST -- EXPR
3212              *         |
3213              */
3214             if (argp == args && kid->op_type != OP_CONCAT) {
3215                 /* in e.g. '$x . = f(1)' there's no RHS concat tree
3216                  * so the expression to be cut isn't kid->op_last but
3217                  * kid itself */
3218                 OP *o1, *o2;
3219                 /* find the op before kid */
3220                 o1 = NULL;
3221                 o2 = cUNOPx(parentop)->op_first;
3222                 while (o2 && o2 != kid) {
3223                     o1 = o2;
3224                     o2 = OpSIBLING(o2);
3225                 }
3226                 assert(o2 == kid);
3227                 prev = o1;
3228                 kid  = parentop;
3229             }
3230             else if (kid == o && lastkidop)
3231                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3232             else
3233                 prev = last ? NULL : cUNOPx(kid)->op_first;
3234
3235             if (!argp->p || last) {
3236                 /* cut RH op */
3237                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3238                 /* and unshift to front of o */
3239                 op_sibling_splice(o, NULL, 0, aop);
3240                 /* record the right-most op added to o: later we will
3241                  * free anything to the right of it */
3242                 if (!lastkidop)
3243                     lastkidop = aop;
3244                 aop->op_next = nextop;
3245                 if (last) {
3246                     if (argp->p)
3247                         /* null the const at start of op_next chain */
3248                         op_null(aop);
3249                 }
3250                 else if (prev)
3251                     nextop = prev->op_next;
3252             }
3253
3254             /* the last two arguments are both attached to the same concat op */
3255             if (argp < toparg - 1)
3256                 kid = prev;
3257         }
3258     }
3259
3260     /* Populate the aux struct */
3261
3262     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3263     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3264     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3265     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3266     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3267
3268     /* if variant > 0, calculate a variant const string and lengths where
3269      * the utf8 version of the string will take 'variant' more bytes than
3270      * the plain one. */
3271
3272     if (variant) {
3273         char              *p = const_str;
3274         STRLEN          ulen = total_len + variant;
3275         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3276         UNOP_AUX_item *ulens = lens + (nargs + 1);
3277         char             *up = (char*)PerlMemShared_malloc(ulen);
3278         SSize_t            n;
3279
3280         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3281         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3282
3283         for (n = 0; n < (nargs + 1); n++) {
3284             SSize_t i;
3285             char * orig_up = up;
3286             for (i = (lens++)->ssize; i > 0; i--) {
3287                 U8 c = *p++;
3288                 append_utf8_from_native_byte(c, (U8**)&up);
3289             }
3290             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3291         }
3292     }
3293
3294     if (stringop) {
3295         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3296          * that op's first child - an ex-PUSHMARK - because the op_next of
3297          * the previous op may point to it (i.e. it's the entry point for
3298          * the o optree)
3299          */
3300         OP *pmop =
3301             (stringop == o)
3302                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3303                 : op_sibling_splice(stringop, NULL, 1, NULL);
3304         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3305         op_sibling_splice(o, NULL, 0, pmop);
3306         if (!lastkidop)
3307             lastkidop = pmop;
3308     }
3309
3310     /* Optimise
3311      *    target  = A.B.C...
3312      *    target .= A.B.C...
3313      */
3314
3315     if (targetop) {
3316         assert(!targmyop);
3317
3318         if (o->op_type == OP_SASSIGN) {
3319             /* Move the target subtree from being the last of o's children
3320              * to being the last of o's preserved children.
3321              * Note the difference between 'target = ...' and 'target .= ...':
3322              * for the former, target is executed last; for the latter,
3323              * first.
3324              */
3325             kid = OpSIBLING(lastkidop);
3326             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3327             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3328             lastkidop->op_next = kid->op_next;
3329             lastkidop = targetop;
3330         }
3331         else {
3332             /* Move the target subtree from being the first of o's
3333              * original children to being the first of *all* o's children.
3334              */
3335             if (lastkidop) {
3336                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3337                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3338             }
3339             else {
3340                 /* if the RHS of .= doesn't contain a concat (e.g.
3341                  * $x .= "foo"), it gets missed by the "strip ops from the
3342                  * tree and add to o" loop earlier */
3343                 assert(topop->op_type != OP_CONCAT);
3344                 if (stringop) {
3345                     /* in e.g. $x .= "$y", move the $y expression
3346                      * from being a child of OP_STRINGIFY to being the
3347                      * second child of the OP_CONCAT
3348                      */
3349                     assert(cUNOPx(stringop)->op_first == topop);
3350                     op_sibling_splice(stringop, NULL, 1, NULL);
3351                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3352                 }
3353                 assert(topop == OpSIBLING(cBINOPo->op_first));
3354                 if (toparg->p)
3355                     op_null(topop);
3356                 lastkidop = topop;
3357             }
3358         }
3359
3360         if (is_targable) {
3361             /* optimise
3362              *  my $lex  = A.B.C...
3363              *     $lex  = A.B.C...
3364              *     $lex .= A.B.C...
3365              * The original padsv op is kept but nulled in case it's the
3366              * entry point for the optree (which it will be for
3367              * '$lex .=  ... '
3368              */
3369             private_flags |= OPpTARGET_MY;
3370             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3371             o->op_targ = targetop->op_targ;
3372             targetop->op_targ = 0;
3373             op_null(targetop);
3374         }
3375         else
3376             flags |= OPf_STACKED;
3377     }
3378     else if (targmyop) {
3379         private_flags |= OPpTARGET_MY;
3380         if (o != targmyop) {
3381             o->op_targ = targmyop->op_targ;
3382             targmyop->op_targ = 0;
3383         }
3384     }
3385
3386     /* detach the emaciated husk of the sprintf/concat optree and free it */
3387     for (;;) {
3388         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3389         if (!kid)
3390             break;
3391         op_free(kid);
3392     }
3393
3394     /* and convert o into a multiconcat */
3395
3396     o->op_flags        = (flags|OPf_KIDS|stacked_last
3397                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3398     o->op_private      = private_flags;
3399     o->op_type         = OP_MULTICONCAT;
3400     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3401     cUNOP_AUXo->op_aux = aux;
3402 }
3403
3404
3405 /* do all the final processing on an optree (e.g. running the peephole
3406  * optimiser on it), then attach it to cv (if cv is non-null)
3407  */
3408
3409 static void
3410 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3411 {
3412     OP **startp;
3413
3414     /* XXX for some reason, evals, require and main optrees are
3415      * never attached to their CV; instead they just hang off
3416      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3417      * and get manually freed when appropriate */
3418     if (cv)
3419         startp = &CvSTART(cv);
3420     else
3421         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3422
3423     *startp = start;
3424     optree->op_private |= OPpREFCOUNTED;
3425     OpREFCNT_set(optree, 1);
3426     optimize_optree(optree);
3427     CALL_PEEP(*startp);
3428     finalize_optree(optree);
3429     S_prune_chain_head(startp);
3430
3431     if (cv) {
3432         /* now that optimizer has done its work, adjust pad values */
3433         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3434                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3435     }
3436 }
3437
3438
3439 /*
3440 =for apidoc optimize_optree
3441
3442 This function applies some optimisations to the optree in top-down order.
3443 It is called before the peephole optimizer, which processes ops in
3444 execution order. Note that finalize_optree() also does a top-down scan,
3445 but is called *after* the peephole optimizer.
3446
3447 =cut
3448 */
3449
3450 void
3451 Perl_optimize_optree(pTHX_ OP* o)
3452 {
3453     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3454
3455     ENTER;
3456     SAVEVPTR(PL_curcop);
3457
3458     optimize_op(o);
3459
3460     LEAVE;
3461 }
3462
3463
3464 /* helper for optimize_optree() which optimises on op then recurses
3465  * to optimise any children.
3466  */
3467
3468 STATIC void
3469 S_optimize_op(pTHX_ OP* o)
3470 {
3471     OP *kid;
3472
3473     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3474     assert(o->op_type != OP_FREED);
3475
3476     switch (o->op_type) {
3477     case OP_NEXTSTATE:
3478     case OP_DBSTATE:
3479         PL_curcop = ((COP*)o);          /* for warnings */
3480         break;
3481
3482
3483     case OP_CONCAT:
3484     case OP_SASSIGN:
3485     case OP_STRINGIFY:
3486     case OP_SPRINTF:
3487         S_maybe_multiconcat(aTHX_ o);
3488         break;
3489
3490     case OP_SUBST:
3491         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3492             optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3493         break;
3494
3495     default:
3496         break;
3497     }
3498
3499     if (!(o->op_flags & OPf_KIDS))
3500         return;
3501
3502     for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3503         optimize_op(kid);
3504 }
3505
3506
3507 /*
3508 =for apidoc finalize_optree
3509
3510 This function finalizes the optree.  Should be called directly after
3511 the complete optree is built.  It does some additional
3512 checking which can't be done in the normal C<ck_>xxx functions and makes
3513 the tree thread-safe.
3514
3515 =cut
3516 */
3517 void
3518 Perl_finalize_optree(pTHX_ OP* o)
3519 {
3520     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3521
3522     ENTER;
3523     SAVEVPTR(PL_curcop);
3524
3525     finalize_op(o);
3526
3527     LEAVE;
3528 }
3529
3530 #ifdef USE_ITHREADS
3531 /* Relocate sv to the pad for thread safety.
3532  * Despite being a "constant", the SV is written to,
3533  * for reference counts, sv_upgrade() etc. */
3534 PERL_STATIC_INLINE void
3535 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3536 {
3537     PADOFFSET ix;
3538     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3539     if (!*svp) return;
3540     ix = pad_alloc(OP_CONST, SVf_READONLY);
3541     SvREFCNT_dec(PAD_SVl(ix));
3542     PAD_SETSV(ix, *svp);
3543     /* XXX I don't know how this isn't readonly already. */
3544     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3545     *svp = NULL;
3546     *targp = ix;
3547 }
3548 #endif
3549
3550
3551 STATIC void
3552 S_finalize_op(pTHX_ OP* o)
3553 {
3554     PERL_ARGS_ASSERT_FINALIZE_OP;
3555
3556     assert(o->op_type != OP_FREED);
3557
3558     switch (o->op_type) {
3559     case OP_NEXTSTATE:
3560     case OP_DBSTATE:
3561         PL_curcop = ((COP*)o);          /* for warnings */
3562         break;
3563     case OP_EXEC:
3564         if (OpHAS_SIBLING(o)) {
3565             OP *sib = OpSIBLING(o);
3566             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3567                 && ckWARN(WARN_EXEC)
3568                 && OpHAS_SIBLING(sib))
3569             {
3570                     const OPCODE type = OpSIBLING(sib)->op_type;
3571                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3572                         const line_t oldline = CopLINE(PL_curcop);
3573                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3574                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3575                             "Statement unlikely to be reached");
3576                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3577                             "\t(Maybe you meant system() when you said exec()?)\n");
3578                         CopLINE_set(PL_curcop, oldline);
3579                     }
3580             }
3581         }
3582         break;
3583
3584     case OP_GV:
3585         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3586             GV * const gv = cGVOPo_gv;
3587             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3588                 /* XXX could check prototype here instead of just carping */
3589                 SV * const sv = sv_newmortal();
3590                 gv_efullname3(sv, gv, NULL);
3591                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3592                     "%" SVf "() called too early to check prototype",
3593                     SVfARG(sv));
3594             }
3595         }
3596         break;
3597
3598     case OP_CONST:
3599         if (cSVOPo->op_private & OPpCONST_STRICT)
3600             no_bareword_allowed(o);
3601 #ifdef USE_ITHREADS
3602         /* FALLTHROUGH */
3603     case OP_HINTSEVAL:
3604         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3605 #endif
3606         break;
3607
3608 #ifdef USE_ITHREADS
3609     /* Relocate all the METHOP's SVs to the pad for thread safety. */
3610     case OP_METHOD_NAMED:
3611     case OP_METHOD_SUPER:
3612     case OP_METHOD_REDIR:
3613     case OP_METHOD_REDIR_SUPER:
3614         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3615         break;
3616 #endif
3617
3618     case OP_HELEM: {
3619         UNOP *rop;
3620         SVOP *key_op;
3621         OP *kid;
3622
3623         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3624             break;
3625
3626         rop = (UNOP*)((BINOP*)o)->op_first;
3627
3628         goto check_keys;
3629
3630     case OP_HSLICE:
3631         S_scalar_slice_warning(aTHX_ o);
3632         /* FALLTHROUGH */
3633
3634     case OP_KVHSLICE:
3635         kid = OpSIBLING(cLISTOPo->op_first);
3636         if (/* I bet there's always a pushmark... */
3637             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3638             && OP_TYPE_ISNT_NN(kid, OP_CONST))
3639         {
3640             break;
3641         }
3642
3643         key_op = (SVOP*)(kid->op_type == OP_CONST
3644                                 ? kid
3645                                 : OpSIBLING(kLISTOP->op_first));
3646
3647         rop = (UNOP*)((LISTOP*)o)->op_last;
3648
3649       check_keys:
3650         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3651             rop = NULL;
3652         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3653         break;
3654     }
3655     case OP_NULL:
3656         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3657             break;
3658         /* FALLTHROUGH */
3659     case OP_ASLICE:
3660         S_scalar_slice_warning(aTHX_ o);
3661         break;
3662
3663     case OP_SUBST: {
3664         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3665             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3666         break;
3667     }
3668     default:
3669         break;
3670     }
3671
3672     if (o->op_flags & OPf_KIDS) {
3673         OP *kid;
3674
3675 #ifdef DEBUGGING
3676         /* check that op_last points to the last sibling, and that
3677          * the last op_sibling/op_sibparent field points back to the
3678          * parent, and that the only ops with KIDS are those which are
3679          * entitled to them */
3680         U32 type = o->op_type;
3681         U32 family;
3682         bool has_last;
3683
3684         if (type == OP_NULL) {
3685             type = o->op_targ;
3686             /* ck_glob creates a null UNOP with ex-type GLOB
3687              * (which is a list op. So pretend it wasn't a listop */
3688             if (type == OP_GLOB)
3689                 type = OP_NULL;
3690         }
3691         family = PL_opargs[type] & OA_CLASS_MASK;
3692
3693         has_last = (   family == OA_BINOP
3694                     || family == OA_LISTOP
3695                     || family == OA_PMOP
3696                     || family == OA_LOOP
3697                    );
3698         assert(  has_last /* has op_first and op_last, or ...
3699               ... has (or may have) op_first: */
3700               || family == OA_UNOP
3701               || family == OA_UNOP_AUX
3702               || family == OA_LOGOP
3703               || family == OA_BASEOP_OR_UNOP
3704               || family == OA_FILESTATOP
3705               || family == OA_LOOPEXOP
3706               || family == OA_METHOP
3707               || type == OP_CUSTOM
3708               || type == OP_NULL /* new_logop does this */
3709               );
3710
3711         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3712 #  ifdef PERL_OP_PARENT
3713             if (!OpHAS_SIBLING(kid)) {
3714                 if (has_last)
3715                     assert(kid == cLISTOPo->op_last);
3716                 assert(kid->op_sibparent == o);
3717             }
3718 #  else
3719             if (has_last && !OpHAS_SIBLING(kid))
3720                 assert(kid == cLISTOPo->op_last);
3721 #  endif
3722         }
3723 #endif
3724
3725         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3726             finalize_op(kid);
3727     }
3728 }
3729
3730 /*
3731 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3732
3733 Propagate lvalue ("modifiable") context to an op and its children.
3734 C<type> represents the context type, roughly based on the type of op that
3735 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3736 because it has no op type of its own (it is signalled by a flag on
3737 the lvalue op).
3738
3739 This function detects things that can't be modified, such as C<$x+1>, and
3740 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3741 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3742
3743 It also flags things that need to behave specially in an lvalue context,
3744 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3745
3746 =cut
3747 */
3748
3749 static void
3750 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3751 {
3752     CV *cv = PL_compcv;
3753     PadnameLVALUE_on(pn);
3754     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3755         cv = CvOUTSIDE(cv);
3756         /* RT #127786: cv can be NULL due to an eval within the DB package
3757          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3758          * unless they contain an eval, but calling eval within DB
3759          * pretends the eval was done in the caller's scope.
3760          */
3761         if (!cv)
3762             break;
3763         assert(CvPADLIST(cv));
3764         pn =
3765            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3766         assert(PadnameLEN(pn));
3767         PadnameLVALUE_on(pn);
3768     }
3769 }
3770
3771 static bool
3772 S_vivifies(const OPCODE type)
3773 {
3774     switch(type) {
3775     case OP_RV2AV:     case   OP_ASLICE:
3776     case OP_RV2HV:     case OP_KVASLICE:
3777     case OP_RV2SV:     case   OP_HSLICE:
3778     case OP_AELEMFAST: case OP_KVHSLICE:
3779     case OP_HELEM:
3780     case OP_AELEM:
3781         return 1;
3782     }
3783     return 0;
3784 }
3785
3786 static void
3787 S_lvref(pTHX_ OP *o, I32 type)
3788 {
3789     dVAR;
3790     OP *kid;
3791     switch (o->op_type) {
3792     case OP_COND_EXPR:
3793         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3794              kid = OpSIBLING(kid))
3795             S_lvref(aTHX_ kid, type);
3796         /* FALLTHROUGH */
3797     case OP_PUSHMARK:
3798         return;
3799     case OP_RV2AV:
3800         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3801         o->op_flags |= OPf_STACKED;
3802         if (o->op_flags & OPf_PARENS) {
3803             if (o->op_private & OPpLVAL_INTRO) {
3804                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3805                       "localized parenthesized array in list assignment"));
3806                 return;
3807             }
3808           slurpy:
3809             OpTYPE_set(o, OP_LVAVREF);
3810             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3811             o->op_flags |= OPf_MOD|OPf_REF;
3812             return;
3813         }
3814         o->op_private |= OPpLVREF_AV;
3815         goto checkgv;
3816     case OP_RV2CV:
3817         kid = cUNOPo->op_first;
3818         if (kid->op_type == OP_NULL)
3819             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3820                 ->op_first;
3821         o->op_private = OPpLVREF_CV;
3822         if (kid->op_type == OP_GV)
3823             o->op_flags |= OPf_STACKED;
3824         else if (kid->op_type == OP_PADCV) {
3825             o->op_targ = kid->op_targ;
3826             kid->op_targ = 0;
3827             op_free(cUNOPo->op_first);
3828             cUNOPo->op_first = NULL;
3829             o->op_flags &=~ OPf_KIDS;
3830         }
3831         else goto badref;
3832         break;
3833     case OP_RV2HV:
3834         if (o->op_flags & OPf_PARENS) {
3835           parenhash:
3836             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3837                                  "parenthesized hash in list assignment"));
3838                 return;
3839         }
3840         o->op_private |= OPpLVREF_HV;
3841         /* FALLTHROUGH */
3842     case OP_RV2SV:
3843       checkgv:
3844         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3845         o->op_flags |= OPf_STACKED;
3846         break;
3847     case OP_PADHV:
3848         if (o->op_flags & OPf_PARENS) goto parenhash;
3849         o->op_private |= OPpLVREF_HV;
3850         /* FALLTHROUGH */
3851     case OP_PADSV:
3852         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3853         break;
3854     case OP_PADAV:
3855         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3856         if (o->op_flags & OPf_PARENS) goto slurpy;
3857         o->op_private |= OPpLVREF_AV;
3858         break;
3859     case OP_AELEM:
3860     case OP_HELEM:
3861         o->op_private |= OPpLVREF_ELEM;
3862         o->op_flags   |= OPf_STACKED;
3863         break;
3864     case OP_ASLICE:
3865     case OP_HSLICE:
3866         OpTYPE_set(o, OP_LVREFSLICE);
3867         o->op_private &= OPpLVAL_INTRO;
3868         return;
3869     case OP_NULL:
3870         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3871             goto badref;
3872         else if (!(o->op_flags & OPf_KIDS))
3873             return;
3874         if (o->op_targ != OP_LIST) {
3875             S_lvref(aTHX_ cBINOPo->op_first, type);
3876             return;
3877         }
3878         /* FALLTHROUGH */
3879     case OP_LIST:
3880         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3881             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3882             S_lvref(aTHX_ kid, type);
3883         }
3884         return;
3885     case OP_STUB:
3886         if (o->op_flags & OPf_PARENS)
3887             return;
3888         /* FALLTHROUGH */
3889     default:
3890       badref:
3891         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3892         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3893                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3894                       ? "do block"
3895                       : OP_DESC(o),
3896                      PL_op_desc[type]));
3897         return;
3898     }
3899     OpTYPE_set(o, OP_LVREF);
3900     o->op_private &=
3901         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3902     if (type == OP_ENTERLOOP)
3903         o->op_private |= OPpLVREF_ITER;
3904 }
3905
3906 PERL_STATIC_INLINE bool
3907 S_potential_mod_type(I32 type)
3908 {
3909     /* Types that only potentially result in modification.  */
3910     return type == OP_GREPSTART || type == OP_ENTERSUB
3911         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3912 }
3913
3914 OP *
3915 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3916 {
3917     dVAR;
3918     OP *kid;
3919     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3920     int localize = -1;
3921
3922     if (!o || (PL_parser && PL_parser->error_count))
3923         return o;
3924
3925     if ((o->op_private & OPpTARGET_MY)
3926         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3927     {
3928         return o;
3929     }
3930
3931     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3932
3933     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3934
3935     switch (o->op_type) {
3936     case OP_UNDEF:
3937         PL_modcount++;
3938         return o;
3939     case OP_STUB:
3940         if ((o->op_flags & OPf_PARENS))
3941             break;
3942         goto nomod;
3943     case OP_ENTERSUB:
3944         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3945             !(o->op_flags & OPf_STACKED)) {
3946             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3947             assert(cUNOPo->op_first->op_type == OP_NULL);
3948             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3949             break;
3950         }
3951         else {                          /* lvalue subroutine call */
3952             o->op_private |= OPpLVAL_INTRO;
3953             PL_modcount = RETURN_UNLIMITED_NUMBER;
3954             if (S_potential_mod_type(type)) {
3955                 o->op_private |= OPpENTERSUB_INARGS;
3956                 break;
3957             }
3958             else {                      /* Compile-time error message: */
3959                 OP *kid = cUNOPo->op_first;
3960                 CV *cv;
3961                 GV *gv;
3962                 SV *namesv;
3963
3964                 if (kid->op_type != OP_PUSHMARK) {
3965                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3966                         Perl_croak(aTHX_
3967                                 "panic: unexpected lvalue entersub "
3968                                 "args: type/targ %ld:%" UVuf,
3969                                 (long)kid->op_type, (UV)kid->op_targ);
3970                     kid = kLISTOP->op_first;
3971                 }
3972                 while (OpHAS_SIBLING(kid))
3973                     kid = OpSIBLING(kid);
3974                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3975                     break;      /* Postpone until runtime */
3976                 }
3977
3978                 kid = kUNOP->op_first;
3979                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3980                     kid = kUNOP->op_first;
3981                 if (kid->op_type == OP_NULL)
3982                     Perl_croak(aTHX_
3983                                "Unexpected constant lvalue entersub "
3984                                "entry via type/targ %ld:%" UVuf,
3985                                (long)kid->op_type, (UV)kid->op_targ);
3986                 if (kid->op_type != OP_GV) {
3987                     break;
3988                 }
3989
3990                 gv = kGVOP_gv;
3991                 cv = isGV(gv)
3992                     ? GvCV(gv)
3993                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3994                         ? MUTABLE_CV(SvRV(gv))
3995                         : NULL;
3996                 if (!cv)
3997                     break;
3998                 if (CvLVALUE(cv))
3999                     break;
4000                 if (flags & OP_LVALUE_NO_CROAK)
4001                     return NULL;
4002
4003                 namesv = cv_name(cv, NULL, 0);
4004                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4005                                      "subroutine call of &%" SVf " in %s",
4006                                      SVfARG(namesv), PL_op_desc[type]),
4007                            SvUTF8(namesv));
4008                 return o;
4009             }
4010         }
4011         /* FALLTHROUGH */
4012     default:
4013       nomod:
4014         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4015         /* grep, foreach, subcalls, refgen */
4016         if (S_potential_mod_type(type))
4017             break;
4018         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4019                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4020                       ? "do block"
4021                       : OP_DESC(o)),
4022                      type ? PL_op_desc[type] : "local"));
4023         return o;
4024
4025     case OP_PREINC:
4026     case OP_PREDEC:
4027     case OP_POW:
4028     case OP_MULTIPLY:
4029     case OP_DIVIDE:
4030     case OP_MODULO:
4031     case OP_ADD:
4032     case OP_SUBTRACT:
4033     case OP_CONCAT:
4034     case OP_LEFT_SHIFT:
4035     case OP_RIGHT_SHIFT:
4036     case OP_BIT_AND:
4037     case OP_BIT_XOR:
4038     case OP_BIT_OR:
4039     case OP_I_MULTIPLY:
4040     case OP_I_DIVIDE:
4041     case OP_I_MODULO:
4042     case OP_I_ADD:
4043     case OP_I_SUBTRACT:
4044         if (!(o->op_flags & OPf_STACKED))
4045             goto nomod;
4046         PL_modcount++;
4047         break;
4048
4049     case OP_REPEAT:
4050         if (o->op_flags & OPf_STACKED) {
4051             PL_modcount++;
4052             break;
4053         }
4054         if (!(o->op_private & OPpREPEAT_DOLIST))
4055             goto nomod;
4056         else {
4057             const I32 mods = PL_modcount;
4058             modkids(cBINOPo->op_first, type);
4059             if (type != OP_AASSIGN)
4060                 goto nomod;
4061             kid = cBINOPo->op_last;
4062             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4063                 const IV iv = SvIV(kSVOP_sv);
4064                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4065                     PL_modcount =
4066                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4067             }
4068             else
4069                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4070         }
4071         break;
4072
4073     case OP_COND_EXPR:
4074         localize = 1;
4075         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4076             op_lvalue(kid, type);
4077         break;
4078
4079     case OP_RV2AV:
4080     case OP_RV2HV:
4081         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4082            PL_modcount = RETURN_UNLIMITED_NUMBER;
4083             return o;           /* Treat \(@foo) like ordinary list. */
4084         }
4085         /* FALLTHROUGH */
4086     case OP_RV2GV:
4087         if (scalar_mod_type(o, type))
4088             goto nomod;
4089         ref(cUNOPo->op_first, o->op_type);
4090         /* FALLTHROUGH */
4091     case OP_ASLICE:
4092     case OP_HSLICE:
4093         localize = 1;
4094         /* FALLTHROUGH */
4095     case OP_AASSIGN:
4096         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4097         if (type == OP_LEAVESUBLV && (
4098                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4099              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4100            ))
4101             o->op_private |= OPpMAYBE_LVSUB;
4102         /* FALLTHROUGH */
4103     case OP_NEXTSTATE:
4104     case OP_DBSTATE:
4105        PL_modcount = RETURN_UNLIMITED_NUMBER;
4106         break;
4107     case OP_KVHSLICE:
4108     case OP_KVASLICE:
4109     case OP_AKEYS:
4110         if (type == OP_LEAVESUBLV)
4111             o->op_private |= OPpMAYBE_LVSUB;
4112         goto nomod;
4113     case OP_AVHVSWITCH:
4114         if (type == OP_LEAVESUBLV
4115          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4116             o->op_private |= OPpMAYBE_LVSUB;
4117         goto nomod;
4118     case OP_AV2ARYLEN:
4119         PL_hints |= HINT_BLOCK_SCOPE;
4120         if (type == OP_LEAVESUBLV)
4121             o->op_private |= OPpMAYBE_LVSUB;
4122         PL_modcount++;
4123         break;
4124     case OP_RV2SV:
4125         ref(cUNOPo->op_first, o->op_type);
4126         localize = 1;
4127         /* FALLTHROUGH */
4128     case OP_GV:
4129         PL_hints |= HINT_BLOCK_SCOPE;
4130         /* FALLTHROUGH */
4131     case OP_SASSIGN:
4132     case OP_ANDASSIGN:
4133     case OP_ORASSIGN:
4134     case OP_DORASSIGN:
4135         PL_modcount++;
4136         break;
4137
4138     case OP_AELEMFAST:
4139     case OP_AELEMFAST_LEX:
4140         localize = -1;
4141         PL_modcount++;
4142         break;
4143
4144     case OP_PADAV:
4145     case OP_PADHV:
4146        PL_modcount = RETURN_UNLIMITED_NUMBER;
4147         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4148             return o;           /* Treat \(@foo) like ordinary list. */
4149         if (scalar_mod_type(o, type))
4150             goto nomod;
4151         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4152           && type == OP_LEAVESUBLV)
4153             o->op_private |= OPpMAYBE_LVSUB;
4154         /* FALLTHROUGH */
4155     case OP_PADSV:
4156         PL_modcount++;
4157         if (!type) /* local() */
4158             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4159                               PNfARG(PAD_COMPNAME(o->op_targ)));
4160         if (!(o->op_private & OPpLVAL_INTRO)
4161          || (  type != OP_SASSIGN && type != OP_AASSIGN
4162             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4163             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4164         break;
4165
4166     case OP_PUSHMARK:
4167         localize = 0;
4168         break;
4169
4170     case OP_KEYS:
4171         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4172             goto nomod;
4173         goto lvalue_func;
4174     case OP_SUBSTR:
4175         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4176             goto nomod;
4177         /* FALLTHROUGH */
4178     case OP_POS:
4179     case OP_VEC:
4180       lvalue_func:
4181         if (type == OP_LEAVESUBLV)
4182             o->op_private |= OPpMAYBE_LVSUB;
4183         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4184             /* substr and vec */
4185             /* If this op is in merely potential (non-fatal) modifiable
4186                context, then apply OP_ENTERSUB context to
4187                the kid op (to avoid croaking).  Other-
4188                wise pass this op’s own type so the correct op is mentioned
4189                in error messages.  */
4190             op_lvalue(OpSIBLING(cBINOPo->op_first),
4191                       S_potential_mod_type(type)
4192                         ? (I32)OP_ENTERSUB
4193                         : o->op_type);
4194         }
4195         break;
4196
4197     case OP_AELEM:
4198     case OP_HELEM:
4199         ref(cBINOPo->op_first, o->op_type);
4200         if (type == OP_ENTERSUB &&
4201              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4202             o->op_private |= OPpLVAL_DEFER;
4203         if (type == OP_LEAVESUBLV)
4204             o->op_private |= OPpMAYBE_LVSUB;
4205         localize = 1;
4206         PL_modcount++;
4207         break;
4208
4209     case OP_LEAVE:
4210     case OP_LEAVELOOP:
4211         o->op_private |= OPpLVALUE;
4212         /* FALLTHROUGH */
4213     case OP_SCOPE:
4214     case OP_ENTER:
4215     case OP_LINESEQ:
4216         localize = 0;
4217         if (o->op_flags & OPf_KIDS)
4218             op_lvalue(cLISTOPo->op_last, type);
4219         break;
4220
4221     case OP_NULL:
4222         localize = 0;
4223         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4224             goto nomod;
4225         else if (!(o->op_flags & OPf_KIDS))
4226             break;
4227
4228         if (o->op_targ != OP_LIST) {
4229             OP *sib = OpSIBLING(cLISTOPo->op_first);
4230             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4231              * that looks like
4232              *
4233              *   null
4234              *      arg
4235              *      trans
4236              *
4237              * compared with things like OP_MATCH which have the argument
4238              * as a child:
4239              *
4240              *   match
4241              *      arg
4242              *
4243              * so handle specially to correctly get "Can't modify" croaks etc
4244              */
4245
4246             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4247             {
4248                 /* this should trigger a "Can't modify transliteration" err */
4249                 op_lvalue(sib, type);
4250             }
4251             op_lvalue(cBINOPo->op_first, type);
4252             break;
4253         }
4254         /* FALLTHROUGH */
4255     case OP_LIST:
4256         localize = 0;
4257         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4258             /* elements might be in void context because the list is
4259                in scalar context or because they are attribute sub calls */
4260             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4261                 op_lvalue(kid, type);
4262         break;
4263
4264     case OP_COREARGS:
4265         return o;
4266
4267     case OP_AND:
4268     case OP_OR:
4269         if (type == OP_LEAVESUBLV
4270          || !S_vivifies(cLOGOPo->op_first->op_type))
4271             op_lvalue(cLOGOPo->op_first, type);
4272         if (type == OP_LEAVESUBLV
4273          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4274             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4275         goto nomod;
4276
4277     case OP_SREFGEN:
4278         if (type == OP_NULL) { /* local */
4279           local_refgen:
4280             if (!FEATURE_MYREF_IS_ENABLED)
4281                 Perl_croak(aTHX_ "The experimental declared_refs "
4282                                  "feature is not enabled");
4283             Perl_ck_warner_d(aTHX_
4284                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4285                     "Declaring references is experimental");
4286             op_lvalue(cUNOPo->op_first, OP_NULL);
4287             return o;
4288         }
4289         if (type != OP_AASSIGN && type != OP_SASSIGN
4290          && type != OP_ENTERLOOP)
4291             goto nomod;
4292         /* Don’t bother applying lvalue context to the ex-list.  */
4293         kid = cUNOPx(cUNOPo->op_first)->op_first;
4294         assert (!OpHAS_SIBLING(kid));
4295         goto kid_2lvref;
4296     case OP_REFGEN:
4297         if (type == OP_NULL) /* local */
4298             goto local_refgen;
4299         if (type != OP_AASSIGN) goto nomod;
4300         kid = cUNOPo->op_first;
4301       kid_2lvref:
4302         {
4303             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4304             S_lvref(aTHX_ kid, type);
4305             if (!PL_parser || PL_parser->error_count == ec) {
4306                 if (!FEATURE_REFALIASING_IS_ENABLED)
4307                     Perl_croak(aTHX_
4308                        "Experimental aliasing via reference not enabled");
4309                 Perl_ck_warner_d(aTHX_
4310                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4311                                 "Aliasing via reference is experimental");
4312             }
4313         }
4314         if (o->op_type == OP_REFGEN)
4315             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4316         op_null(o);
4317         return o;
4318
4319     case OP_SPLIT:
4320         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4321             /* This is actually @array = split.  */
4322             PL_modcount = RETURN_UNLIMITED_NUMBER;
4323             break;
4324         }
4325         goto nomod;
4326
4327     case OP_SCALAR:
4328         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4329         goto nomod;
4330     }
4331
4332     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4333        their argument is a filehandle; thus \stat(".") should not set
4334        it. AMS 20011102 */
4335     if (type == OP_REFGEN &&
4336         PL_check[o->op_type] == Perl_ck_ftst)
4337         return o;
4338
4339     if (type != OP_LEAVESUBLV)
4340         o->op_flags |= OPf_MOD;
4341
4342     if (type == OP_AASSIGN || type == OP_SASSIGN)
4343         o->op_flags |= OPf_SPECIAL
4344                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4345     else if (!type) { /* local() */
4346         switch (localize) {
4347         case 1:
4348             o->op_private |= OPpLVAL_INTRO;
4349             o->op_flags &= ~OPf_SPECIAL;
4350             PL_hints |= HINT_BLOCK_SCOPE;
4351             break;
4352         case 0:
4353             break;
4354         case -1:
4355             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4356                            "Useless localization of %s", OP_DESC(o));
4357         }
4358     }
4359     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4360              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4361         o->op_flags |= OPf_REF;
4362     return o;
4363 }
4364
4365 STATIC bool
4366 S_scalar_mod_type(const OP *o, I32 type)
4367 {
4368     switch (type) {
4369     case OP_POS:
4370     case OP_SASSIGN:
4371         if (o && o->op_type == OP_RV2GV)
4372             return FALSE;
4373         /* FALLTHROUGH */
4374     case OP_PREINC:
4375     case OP_PREDEC:
4376     case OP_POSTINC:
4377     case OP_POSTDEC:
4378     case OP_I_PREINC:
4379     case OP_I_PREDEC:
4380     case OP_I_POSTINC:
4381     case OP_I_POSTDEC:
4382     case OP_POW:
4383     case OP_MULTIPLY:
4384     case OP_DIVIDE:
4385     case OP_MODULO:
4386     case OP_REPEAT:
4387     case OP_ADD:
4388     case OP_SUBTRACT:
4389     case OP_I_MULTIPLY:
4390     case OP_I_DIVIDE:
4391     case OP_I_MODULO:
4392     case OP_I_ADD:
4393     case OP_I_SUBTRACT:
4394     case OP_LEFT_SHIFT:
4395     case OP_RIGHT_SHIFT:
4396     case OP_BIT_AND:
4397     case OP_BIT_XOR:
4398     case OP_BIT_OR:
4399     case OP_NBIT_AND:
4400     case OP_NBIT_XOR:
4401     case OP_NBIT_OR:
4402     case OP_SBIT_AND:
4403     case OP_SBIT_XOR:
4404     case OP_SBIT_OR:
4405     case OP_CONCAT:
4406     case OP_SUBST:
4407     case OP_TRANS:
4408     case OP_TRANSR:
4409     case OP_READ:
4410     case OP_SYSREAD:
4411     case OP_RECV:
4412     case OP_ANDASSIGN:
4413     case OP_ORASSIGN:
4414     case OP_DORASSIGN:
4415     case OP_VEC:
4416     case OP_SUBSTR:
4417         return TRUE;
4418     default:
4419         return FALSE;
4420     }
4421 }
4422
4423 STATIC bool
4424 S_is_handle_constructor(const OP *o, I32 numargs)
4425 {
4426     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4427
4428     switch (o->op_type) {
4429     case OP_PIPE_OP:
4430     case OP_SOCKPAIR:
4431         if (numargs == 2)
4432             return TRUE;
4433         /* FALLTHROUGH */
4434     case OP_SYSOPEN:
4435     case OP_OPEN:
4436     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4437     case OP_SOCKET:
4438     case OP_OPEN_DIR:
4439     case OP_ACCEPT:
4440         if (numargs == 1)
4441             return TRUE;
4442         /* FALLTHROUGH */
4443     default:
4444         return FALSE;
4445     }
4446 }
4447
4448 static OP *
4449 S_refkids(pTHX_ OP *o, I32 type)
4450 {
4451     if (o && o->op_flags & OPf_KIDS) {
4452         OP *kid;
4453         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4454             ref(kid, type);
4455     }
4456     return o;
4457 }
4458
4459 OP *
4460 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4461 {
4462     dVAR;
4463     OP *kid;
4464
4465     PERL_ARGS_ASSERT_DOREF;
4466
4467     if (PL_parser && PL_parser->error_count)
4468         return o;
4469
4470     switch (o->op_type) {
4471     case OP_ENTERSUB:
4472         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4473             !(o->op_flags & OPf_STACKED)) {
4474             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4475             assert(cUNOPo->op_first->op_type == OP_NULL);
4476             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4477             o->op_flags |= OPf_SPECIAL;
4478         }
4479         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4480             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4481                               : type == OP_RV2HV ? OPpDEREF_HV
4482                               : OPpDEREF_SV);
4483             o->op_flags |= OPf_MOD;
4484         }
4485
4486         break;
4487
4488     case OP_COND_EXPR:
4489         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4490             doref(kid, type, set_op_ref);
4491         break;
4492     case OP_RV2SV:
4493         if (type == OP_DEFINED)
4494             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4495         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4496         /* FALLTHROUGH */
4497     case OP_PADSV:
4498         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4499             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4500                               : type == OP_RV2HV ? OPpDEREF_HV
4501                               : OPpDEREF_SV);
4502             o->op_flags |= OPf_MOD;
4503         }
4504         break;
4505
4506     case OP_RV2AV:
4507     case OP_RV2HV:
4508         if (set_op_ref)
4509             o->op_flags |= OPf_REF;
4510         /* FALLTHROUGH */
4511     case OP_RV2GV:
4512         if (type == OP_DEFINED)
4513             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4514         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4515         break;
4516
4517     case OP_PADAV:
4518     case OP_PADHV:
4519         if (set_op_ref)
4520             o->op_flags |= OPf_REF;
4521         break;
4522
4523     case OP_SCALAR:
4524     case OP_NULL:
4525         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4526             break;
4527         doref(cBINOPo->op_first, type, set_op_ref);
4528         break;
4529     case OP_AELEM:
4530     case OP_HELEM:
4531         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4532         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4533             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4534                               : type == OP_RV2HV ? OPpDEREF_HV
4535                               : OPpDEREF_SV);
4536             o->op_flags |= OPf_MOD;
4537         }
4538         break;
4539
4540     case OP_SCOPE:
4541     case OP_LEAVE:
4542         set_op_ref = FALSE;
4543         /* FALLTHROUGH */
4544     case OP_ENTER:
4545     case OP_LIST:
4546         if (!(o->op_flags & OPf_KIDS))
4547             break;
4548         doref(cLISTOPo->op_last, type, set_op_ref);
4549         break;
4550     default:
4551         break;
4552     }
4553     return scalar(o);
4554
4555 }
4556
4557 STATIC OP *
4558 S_dup_attrlist(pTHX_ OP *o)
4559 {
4560     OP *rop;
4561
4562     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4563
4564     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4565      * where the first kid is OP_PUSHMARK and the remaining ones
4566      * are OP_CONST.  We need to push the OP_CONST values.
4567      */
4568     if (o->op_type == OP_CONST)
4569         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4570     else {
4571         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4572         rop = NULL;
4573         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4574             if (o->op_type == OP_CONST)
4575                 rop = op_append_elem(OP_LIST, rop,
4576                                   newSVOP(OP_CONST, o->op_flags,
4577                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4578         }
4579     }
4580     return rop;
4581 }
4582
4583 STATIC void
4584 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4585 {
4586     PERL_ARGS_ASSERT_APPLY_ATTRS;
4587     {
4588         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4589
4590         /* fake up C<use attributes $pkg,$rv,@attrs> */
4591
4592 #define ATTRSMODULE "attributes"
4593 #define ATTRSMODULE_PM "attributes.pm"
4594
4595         Perl_load_module(
4596           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4597           newSVpvs(ATTRSMODULE),
4598           NULL,
4599           op_prepend_elem(OP_LIST,
4600                           newSVOP(OP_CONST, 0, stashsv),
4601                           op_prepend_elem(OP_LIST,
4602                                           newSVOP(OP_CONST, 0,
4603                                                   newRV(target)),
4604                                           dup_attrlist(attrs))));
4605     }
4606 }
4607
4608 STATIC void
4609 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4610 {
4611     OP *pack, *imop, *arg;
4612     SV *meth, *stashsv, **svp;
4613
4614     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4615
4616     if (!attrs)
4617         return;
4618
4619     assert(target->op_type == OP_PADSV ||
4620            target->op_type == OP_PADHV ||
4621            target->op_type == OP_PADAV);
4622
4623     /* Ensure that attributes.pm is loaded. */
4624     /* Don't force the C<use> if we don't need it. */
4625     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4626     if (svp && *svp != &PL_sv_undef)
4627         NOOP;   /* already in %INC */
4628     else
4629         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4630                                newSVpvs(ATTRSMODULE), NULL);
4631
4632     /* Need package name for method call. */
4633     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4634
4635     /* Build up the real arg-list. */
4636     stashsv = newSVhek(HvNAME_HEK(stash));
4637
4638     arg = newOP(OP_PADSV, 0);
4639     arg->op_targ = target->op_targ;
4640     arg = op_prepend_elem(OP_LIST,
4641                        newSVOP(OP_CONST, 0, stashsv),
4642                        op_prepend_elem(OP_LIST,
4643                                     newUNOP(OP_REFGEN, 0,
4644                                             arg),
4645                                     dup_attrlist(attrs)));
4646
4647     /* Fake up a method call to import */
4648     meth = newSVpvs_share("import");
4649     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4650                    op_append_elem(OP_LIST,
4651                                op_prepend_elem(OP_LIST, pack, arg),
4652                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4653
4654     /* Combine the ops. */
4655     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4656 }
4657
4658 /*
4659 =notfor apidoc apply_attrs_string
4660
4661 Attempts to apply a list of attributes specified by the C<attrstr> and
4662 C<len> arguments to the subroutine identified by the C<cv> argument which
4663 is expected to be associated with the package identified by the C<stashpv>
4664 argument (see L<attributes>).  It gets this wrong, though, in that it
4665 does not correctly identify the boundaries of the individual attribute
4666 specifications within C<attrstr>.  This is not really intended for the
4667 public API, but has to be listed here for systems such as AIX which
4668 need an explicit export list for symbols.  (It's called from XS code
4669 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4670 to respect attribute syntax properly would be welcome.
4671
4672 =cut
4673 */
4674
4675 void
4676 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4677                         const char *attrstr, STRLEN len)
4678 {
4679     OP *attrs = NULL;
4680
4681     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4682
4683     if (!len) {
4684         len = strlen(attrstr);
4685     }
4686
4687     while (len) {
4688         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4689         if (len) {
4690             const char * const sstr = attrstr;
4691             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4692             attrs = op_append_elem(OP_LIST, attrs,
4693                                 newSVOP(OP_CONST, 0,
4694                                         newSVpvn(sstr, attrstr-sstr)));
4695         }
4696     }
4697
4698     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4699                      newSVpvs(ATTRSMODULE),
4700                      NULL, op_prepend_elem(OP_LIST,
4701                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4702                                   op_prepend_elem(OP_LIST,
4703                                                newSVOP(OP_CONST, 0,
4704                                                        newRV(MUTABLE_SV(cv))),
4705                                                attrs)));
4706 }
4707
4708 STATIC void
4709 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4710                         bool curstash)
4711 {
4712     OP *new_proto = NULL;
4713     STRLEN pvlen;
4714     char *pv;
4715     OP *o;
4716
4717     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4718
4719     if (!*attrs)
4720         return;
4721
4722     o = *attrs;
4723     if (o->op_type == OP_CONST) {
4724         pv = SvPV(cSVOPo_sv, pvlen);
4725         if (memBEGINs(pv, pvlen, "prototype(")) {
4726             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4727             SV ** const tmpo = cSVOPx_svp(o);
4728             SvREFCNT_dec(cSVOPo_sv);
4729             *tmpo = tmpsv;
4730             new_proto = o;
4731             *attrs = NULL;
4732         }
4733     } else if (o->op_type == OP_LIST) {
4734         OP * lasto;
4735         assert(o->op_flags & OPf_KIDS);
4736         lasto = cLISTOPo->op_first;
4737         assert(lasto->op_type == OP_PUSHMARK);
4738         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4739             if (o->op_type == OP_CONST) {
4740                 pv = SvPV(cSVOPo_sv, pvlen);
4741                 if (memBEGINs(pv, pvlen, "prototype(")) {
4742                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4743                     SV ** const tmpo = cSVOPx_svp(o);
4744                     SvREFCNT_dec(cSVOPo_sv);
4745                     *tmpo = tmpsv;
4746                     if (new_proto && ckWARN(WARN_MISC)) {
4747                         STRLEN new_len;
4748                         const char * newp = SvPV(cSVOPo_sv, new_len);
4749                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4750                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4751                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4752                         op_free(new_proto);
4753                     }
4754                     else if (new_proto)
4755                         op_free(new_proto);
4756                     new_proto = o;
4757                     /* excise new_proto from the list */
4758                     op_sibling_splice(*attrs, lasto, 1, NULL);
4759                     o = lasto;
4760                     continue;
4761                 }
4762             }
4763             lasto = o;
4764         }
4765         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4766            would get pulled in with no real need */
4767         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4768             op_free(*attrs);
4769             *attrs = NULL;
4770         }
4771     }
4772
4773     if (new_proto) {
4774         SV *svname;
4775         if (isGV(name)) {
4776             svname = sv_newmortal();
4777             gv_efullname3(svname, name, NULL);
4778         }
4779         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4780             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4781         else
4782             svname = (SV *)name;
4783         if (ckWARN(WARN_ILLEGALPROTO))
4784             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4785                                  curstash);
4786         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4787             STRLEN old_len, new_len;
4788             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4789             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4790
4791             if (curstash && svname == (SV *)name
4792              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4793                 svname = sv_2mortal(newSVsv(PL_curstname));
4794                 sv_catpvs(svname, "::");
4795                 sv_catsv(svname, (SV *)name);
4796             }
4797
4798             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4799                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4800                 " in %" SVf,
4801                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4802                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4803                 SVfARG(svname));
4804         }
4805         if (*proto)
4806             op_free(*proto);
4807         *proto = new_proto;
4808     }
4809 }
4810
4811 static void
4812 S_cant_declare(pTHX_ OP *o)
4813 {
4814     if (o->op_type == OP_NULL
4815      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4816         o = cUNOPo->op_first;
4817     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4818                              o->op_type == OP_NULL
4819                                && o->op_flags & OPf_SPECIAL
4820                                  ? "do block"
4821                                  : OP_DESC(o),
4822                              PL_parser->in_my == KEY_our   ? "our"   :
4823                              PL_parser->in_my == KEY_state ? "state" :
4824                                                              "my"));
4825 }
4826
4827 STATIC OP *
4828 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4829 {
4830     I32 type;
4831     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4832
4833     PERL_ARGS_ASSERT_MY_KID;
4834
4835     if (!o || (PL_parser && PL_parser->error_count))
4836         return o;
4837
4838     type = o->op_type;
4839
4840     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4841         OP *kid;
4842         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4843             my_kid(kid, attrs, imopsp);
4844         return o;
4845     } else if (type == OP_UNDEF || type == OP_STUB) {
4846         return o;
4847     } else if (type == OP_RV2SV ||      /* "our" declaration */
4848                type == OP_RV2AV ||
4849                type == OP_RV2HV) {
4850         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4851             S_cant_declare(aTHX_ o);
4852         } else if (attrs) {
4853             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4854             assert(PL_parser);
4855             PL_parser->in_my = FALSE;
4856             PL_parser->in_my_stash = NULL;
4857             apply_attrs(GvSTASH(gv),
4858                         (type == OP_RV2SV ? GvSVn(gv) :
4859                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4860                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4861                         attrs);
4862         }
4863         o->op_private |= OPpOUR_INTRO;
4864         return o;
4865     }
4866     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4867         if (!FEATURE_MYREF_IS_ENABLED)
4868             Perl_croak(aTHX_ "The experimental declared_refs "
4869                              "feature is not enabled");
4870         Perl_ck_warner_d(aTHX_
4871              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4872             "Declaring references is experimental");
4873         /* Kid is a nulled OP_LIST, handled above.  */
4874         my_kid(cUNOPo->op_first, attrs, imopsp);
4875         return o;
4876     }
4877     else if (type != OP_PADSV &&
4878              type != OP_PADAV &&
4879              type != OP_PADHV &&
4880              type != OP_PUSHMARK)
4881     {
4882         S_cant_declare(aTHX_ o);
4883         return o;
4884     }
4885     else if (attrs && type != OP_PUSHMARK) {
4886         HV *stash;
4887
4888         assert(PL_parser);
4889         PL_parser->in_my = FALSE;
4890         PL_parser->in_my_stash = NULL;
4891
4892         /* check for C<my Dog $spot> when deciding package */
4893         stash = PAD_COMPNAME_TYPE(o->op_targ);
4894         if (!stash)
4895             stash = PL_curstash;
4896         apply_attrs_my(stash, o, attrs, imopsp);
4897     }
4898     o->op_flags |= OPf_MOD;
4899     o->op_private |= OPpLVAL_INTRO;
4900     if (stately)
4901         o->op_private |= OPpPAD_STATE;
4902     return o;
4903 }
4904
4905 OP *
4906 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4907 {
4908     OP *rops;
4909     int maybe_scalar = 0;
4910
4911     PERL_ARGS_ASSERT_MY_ATTRS;
4912
4913 /* [perl #17376]: this appears to be premature, and results in code such as
4914    C< our(%x); > executing in list mode rather than void mode */
4915 #if 0
4916     if (o->op_flags & OPf_PARENS)
4917         list(o);
4918     else
4919         maybe_scalar = 1;
4920 #else
4921     maybe_scalar = 1;
4922 #endif
4923     if (attrs)
4924         SAVEFREEOP(attrs);
4925     rops = NULL;
4926     o = my_kid(o, attrs, &rops);
4927     if (rops) {
4928         if (maybe_scalar && o->op_type == OP_PADSV) {
4929             o = scalar(op_append_list(OP_LIST, rops, o));
4930             o->op_private |= OPpLVAL_INTRO;
4931         }
4932         else {
4933             /* The listop in rops might have a pushmark at the beginning,
4934                which will mess up list assignment. */
4935             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4936             if (rops->op_type == OP_LIST &&
4937                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4938             {
4939                 OP * const pushmark = lrops->op_first;
4940                 /* excise pushmark */
4941                 op_sibling_splice(rops, NULL, 1, NULL);
4942                 op_free(pushmark);
4943             }
4944             o = op_append_list(OP_LIST, o, rops);
4945         }
4946     }
4947     PL_parser->in_my = FALSE;
4948     PL_parser->in_my_stash = NULL;
4949     return o;
4950 }
4951
4952 OP *
4953 Perl_sawparens(pTHX_ OP *o)
4954 {
4955     PERL_UNUSED_CONTEXT;
4956     if (o)
4957         o->op_flags |= OPf_PARENS;
4958     return o;
4959 }
4960
4961 OP *
4962 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4963 {
4964     OP *o;
4965     bool ismatchop = 0;
4966     const OPCODE ltype = left->op_type;
4967     const OPCODE rtype = right->op_type;
4968
4969     PERL_ARGS_ASSERT_BIND_MATCH;
4970
4971     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4972           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4973     {
4974       const char * const desc
4975           = PL_op_desc[(
4976                           rtype == OP_SUBST || rtype == OP_TRANS
4977                        || rtype == OP_TRANSR
4978                        )
4979                        ? (int)rtype : OP_MATCH];
4980       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4981       SV * const name =
4982         S_op_varname(aTHX_ left);
4983       if (name)
4984         Perl_warner(aTHX_ packWARN(WARN_MISC),
4985              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4986              desc, SVfARG(name), SVfARG(name));
4987       else {
4988         const char * const sample = (isary
4989              ? "@array" : "%hash");
4990         Perl_warner(aTHX_ packWARN(WARN_MISC),
4991              "Applying %s to %s will act on scalar(%s)",
4992              desc, sample, sample);
4993       }
4994     }
4995
4996     if (rtype == OP_CONST &&
4997         cSVOPx(right)->op_private & OPpCONST_BARE &&
4998         cSVOPx(right)->op_private & OPpCONST_STRICT)
4999     {
5000         no_bareword_allowed(right);
5001     }
5002
5003     /* !~ doesn't make sense with /r, so error on it for now */
5004     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5005         type == OP_NOT)
5006         /* diag_listed_as: Using !~ with %s doesn't make sense */
5007         yyerror("Using !~ with s///r doesn't make sense");
5008     if (rtype == OP_TRANSR && type == OP_NOT)
5009         /* diag_listed_as: Using !~ with %s doesn't make sense */
5010         yyerror("Using !~ with tr///r doesn't make sense");
5011
5012     ismatchop = (rtype == OP_MATCH ||
5013                  rtype == OP_SUBST ||
5014                  rtype == OP_TRANS || rtype == OP_TRANSR)
5015              && !(right->op_flags & OPf_SPECIAL);
5016     if (ismatchop && right->op_private & OPpTARGET_MY) {
5017         right->op_targ = 0;
5018         right->op_private &= ~OPpTARGET_MY;
5019     }
5020     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5021         if (left->op_type == OP_PADSV
5022          && !(left->op_private & OPpLVAL_INTRO))
5023         {
5024             right->op_targ = left->op_targ;
5025             op_free(left);
5026             o = right;
5027         }
5028         else {
5029             right->op_flags |= OPf_STACKED;
5030             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5031             ! (rtype == OP_TRANS &&
5032                right->op_private & OPpTRANS_IDENTICAL) &&
5033             ! (rtype == OP_SUBST &&
5034                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5035                 left = op_lvalue(left, rtype);
5036             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5037                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5038             else
5039                 o = op_prepend_elem(rtype, scalar(left), right);
5040         }
5041         if (type == OP_NOT)
5042             return newUNOP(OP_NOT, 0, scalar(o));
5043         return o;
5044     }
5045     else
5046         return bind_match(type, left,
5047                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5048 }
5049
5050 OP *
5051 Perl_invert(pTHX_ OP *o)
5052 {
5053     if (!o)
5054         return NULL;
5055     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5056 }
5057
5058 /*
5059 =for apidoc Amx|OP *|op_scope|OP *o
5060
5061 Wraps up an op tree with some additional ops so that at runtime a dynamic
5062 scope will be created.  The original ops run in the new dynamic scope,
5063 and then, provided that they exit normally, the scope will be unwound.
5064 The additional ops used to create and unwind the dynamic scope will
5065 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5066 instead if the ops are simple enough to not need the full dynamic scope
5067 structure.
5068
5069 =cut
5070 */
5071
5072 OP *
5073 Perl_op_scope(pTHX_ OP *o)
5074 {
5075     dVAR;
5076     if (o) {
5077         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5078             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5079             OpTYPE_set(o, OP_LEAVE);
5080         }
5081         else if (o->op_type == OP_LINESEQ) {
5082             OP *kid;
5083             OpTYPE_set(o, OP_SCOPE);
5084             kid = ((LISTOP*)o)->op_first;
5085             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5086                 op_null(kid);
5087
5088                 /* The following deals with things like 'do {1 for 1}' */
5089                 kid = OpSIBLING(kid);
5090                 if (kid &&
5091                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5092                     op_null(kid);
5093             }
5094         }
5095         else
5096             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5097     }
5098     return o;
5099 }
5100
5101 OP *
5102 Perl_op_unscope(pTHX_ OP *o)
5103 {
5104     if (o && o->op_type == OP_LINESEQ) {
5105         OP *kid = cLISTOPo->op_first;
5106         for(; kid; kid = OpSIBLING(kid))
5107             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5108                 op_null(kid);
5109     }
5110     return o;
5111 }
5112
5113 /*
5114 =for apidoc Am|int|block_start|int full
5115
5116 Handles compile-time scope entry.
5117 Arranges for hints to be restored on block
5118 exit and also handles pad sequence numbers to make lexical variables scope
5119 right.  Returns a savestack index for use with C<block_end>.
5120
5121 =cut
5122 */
5123
5124 int
5125 Perl_block_start(pTHX_ int full)
5126 {
5127     const int retval = PL_savestack_ix;
5128
5129     PL_compiling.cop_seq = PL_cop_seqmax;
5130     COP_SEQMAX_INC;
5131     pad_block_start(full);
5132     SAVEHINTS();
5133     PL_hints &= ~HINT_BLOCK_SCOPE;
5134     SAVECOMPILEWARNINGS();
5135     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5136     SAVEI32(PL_compiling.cop_seq);
5137     PL_compiling.cop_seq = 0;
5138
5139     CALL_BLOCK_HOOKS(bhk_start, full);
5140
5141     return retval;
5142 }
5143
5144 /*
5145 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5146
5147 Handles compile-time scope exit.  C<floor>
5148 is the savestack index returned by
5149 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5150 possibly modified.
5151
5152 =cut
5153 */
5154
5155 OP*
5156 Perl_block_end(pTHX_ I32 floor, OP *seq)
5157 {
5158     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5159     OP* retval = scalarseq(seq);
5160     OP *o;
5161
5162     /* XXX Is the null PL_parser check necessary here? */
5163     assert(PL_parser); /* Let’s find out under debugging builds.  */
5164     if (PL_parser && PL_parser->parsed_sub) {
5165         o = newSTATEOP(0, NULL, NULL);
5166         op_null(o);
5167         retval = op_append_elem(OP_LINESEQ, retval, o);
5168     }
5169
5170     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5171
5172     LEAVE_SCOPE(floor);
5173     if (needblockscope)
5174         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5175     o = pad_leavemy();
5176
5177     if (o) {
5178         /* pad_leavemy has created a sequence of introcv ops for all my
5179            subs declared in the block.  We have to replicate that list with
5180            clonecv ops, to deal with this situation:
5181
5182                sub {
5183                    my sub s1;
5184                    my sub s2;
5185                    sub s1 { state sub foo { \&s2 } }
5186                }->()
5187
5188            Originally, I was going to have introcv clone the CV and turn
5189            off the stale flag.  Since &s1 is declared before &s2, the
5190            introcv op for &s1 is executed (on sub entry) before the one for
5191            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5192            cloned, since it is a state sub) closes over &s2 and expects
5193            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5194            then &s2 is still marked stale.  Since &s1 is not active, and
5195            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5196            ble will not stay shared’ warning.  Because it is the same stub
5197            that will be used when the introcv op for &s2 is executed, clos-
5198            ing over it is safe.  Hence, we have to turn off the stale flag
5199            on all lexical subs in the block before we clone any of them.
5200            Hence, having introcv clone the sub cannot work.  So we create a
5201            list of ops like this:
5202
5203                lineseq
5204                   |
5205                   +-- introcv
5206                   |
5207                   +-- introcv
5208                   |
5209                   +-- introcv
5210                   |
5211                   .
5212                   .
5213                   .
5214                   |
5215                   +-- clonecv
5216                   |
5217                   +-- clonecv
5218                   |
5219                   +-- clonecv
5220                   |
5221                   .
5222                   .
5223                   .
5224          */
5225         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5226         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5227         for (;; kid = OpSIBLING(kid)) {
5228             OP *newkid = newOP(OP_CLONECV, 0);
5229             newkid->op_targ = kid->op_targ;
5230             o = op_append_elem(OP_LINESEQ, o, newkid);
5231             if (kid == last) break;
5232         }
5233         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5234     }
5235
5236     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5237
5238     return retval;
5239 }
5240
5241 /*
5242 =head1 Compile-time scope hooks
5243
5244 =for apidoc Aox||blockhook_register
5245
5246 Register a set of hooks to be called when the Perl lexical scope changes
5247 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5248
5249 =cut
5250 */
5251
5252 void
5253 Perl_blockhook_register(pTHX_ BHK *hk)
5254 {
5255     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5256
5257     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5258 }
5259
5260 void
5261 Perl_newPROG(pTHX_ OP *o)
5262 {
5263     OP *start;
5264
5265     PERL_ARGS_ASSERT_NEWPROG;
5266
5267     if (PL_in_eval) {
5268         PERL_CONTEXT *cx;
5269         I32 i;
5270         if (PL_eval_root)
5271                 return;
5272         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5273                                ((PL_in_eval & EVAL_KEEPERR)
5274                                 ? OPf_SPECIAL : 0), o);
5275
5276         cx = CX_CUR();
5277         assert(CxTYPE(cx) == CXt_EVAL);
5278
5279         if ((cx->blk_gimme & G_WANT) == G_VOID)
5280             scalarvoid(PL_eval_root);
5281         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5282             list(PL_eval_root);
5283         else
5284             scalar(PL_eval_root);
5285
5286         start = op_linklist(PL_eval_root);
5287         PL_eval_root->op_next = 0;
5288         i = PL_savestack_ix;
5289         SAVEFREEOP(o);
5290         ENTER;
5291         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5292         LEAVE;
5293         PL_savestack_ix = i;
5294     }
5295     else {
5296         if (o->op_type == OP_STUB) {
5297             /* This block is entered if nothing is compiled for the main
5298                program. This will be the case for an genuinely empty main
5299                program, or one which only has BEGIN blocks etc, so already
5300                run and freed.
5301
5302                Historically (5.000) the guard above was !o. However, commit
5303                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5304                c71fccf11fde0068, changed perly.y so that newPROG() is now
5305                called with the output of block_end(), which returns a new
5306                OP_STUB for the case of an empty optree. ByteLoader (and
5307                maybe other things) also take this path, because they set up
5308                PL_main_start and PL_main_root directly, without generating an
5309                optree.
5310
5311                If the parsing the main program aborts (due to parse errors,
5312                or due to BEGIN or similar calling exit), then newPROG()
5313                isn't even called, and hence this code path and its cleanups
5314                are skipped. This shouldn't make a make a difference:
5315                * a non-zero return from perl_parse is a failure, and
5316                  perl_destruct() should be called immediately.
5317                * however, if exit(0) is called during the parse, then
5318                  perl_parse() returns 0, and perl_run() is called. As
5319                  PL_main_start will be NULL, perl_run() will return
5320                  promptly, and the exit code will remain 0.
5321             */
5322
5323             PL_comppad_name = 0;
5324             PL_compcv = 0;
5325             S_op_destroy(aTHX_ o);
5326             return;
5327         }
5328         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5329         PL_curcop = &PL_compiling;
5330         start = LINKLIST(PL_main_root);
5331         PL_main_root->op_next = 0;
5332         S_process_optree(aTHX_ NULL, PL_main_root, start);
5333         cv_forget_slab(PL_compcv);
5334         PL_compcv = 0;
5335
5336         /* Register with debugger */
5337         if (PERLDB_INTER) {
5338             CV * const cv = get_cvs("DB::postponed", 0);
5339             if (cv) {
5340                 dSP;
5341                 PUSHMARK(SP);
5342                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5343                 PUTBACK;
5344                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5345             }
5346         }
5347     }
5348 }
5349
5350 OP *
5351 Perl_localize(pTHX_ OP *o, I32 lex)
5352 {
5353     PERL_ARGS_ASSERT_LOCALIZE;
5354
5355     if (o->op_flags & OPf_PARENS)
5356 /* [perl #17376]: this appears to be premature, and results in code such as
5357    C< our(%x); > executing in list mode rather than void mode */
5358 #if 0
5359         list(o);
5360 #else
5361         NOOP;
5362 #endif
5363     else {
5364         if ( PL_parser->bufptr > PL_parser->oldbufptr
5365             && PL_parser->bufptr[-1] == ','
5366             && ckWARN(WARN_PARENTHESIS))
5367         {
5368             char *s = PL_parser->bufptr;
5369             bool sigil = FALSE;
5370
5371             /* some heuristics to detect a potential error */
5372             while (*s && (strchr(", \t\n", *s)))
5373                 s++;
5374
5375             while (1) {
5376                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5377                        && *++s
5378                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5379                     s++;
5380                     sigil = TRUE;
5381                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5382                         s++;
5383                     while (*s && (strchr(", \t\n", *s)))
5384                         s++;
5385                 }
5386                 else
5387                     break;
5388             }
5389             if (sigil && (*s == ';' || *s == '=')) {
5390                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5391                                 "Parentheses missing around \"%s\" list",
5392                                 lex
5393                                     ? (PL_parser->in_my == KEY_our
5394                                         ? "our"
5395                                         : PL_parser->in_my == KEY_state
5396                                             ? "state"
5397                                             : "my")
5398                                     : "local");
5399             }
5400         }
5401     }
5402     if (lex)
5403         o = my(o);
5404     else
5405         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5406     PL_parser->in_my = FALSE;
5407     PL_parser->in_my_stash = NULL;
5408     return o;
5409 }
5410
5411 OP *
5412 Perl_jmaybe(pTHX_ OP *o)
5413 {
5414     PERL_ARGS_ASSERT_JMAYBE;
5415
5416     if (o->op_type == OP_LIST) {
5417         OP * const o2
5418             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5419         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5420     }
5421     return o;
5422 }
5423
5424 PERL_STATIC_INLINE OP *
5425 S_op_std_init(pTHX_ OP *o)
5426 {
5427     I32 type = o->op_type;
5428
5429     PERL_ARGS_ASSERT_OP_STD_INIT;
5430
5431     if (PL_opargs[type] & OA_RETSCALAR)
5432         scalar(o);
5433     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5434         o->op_targ = pad_alloc(type, SVs_PADTMP);
5435
5436     return o;
5437 }
5438
5439 PERL_STATIC_INLINE OP *
5440 S_op_integerize(pTHX_ OP *o)
5441 {
5442     I32 type = o->op_type;
5443
5444     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5445
5446     /* integerize op. */
5447     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5448     {
5449         dVAR;
5450         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5451     }
5452
5453     if (type == OP_NEGATE)
5454         /* XXX might want a ck_negate() for this */
5455         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5456
5457     return o;
5458 }
5459
5460 static OP *
5461 S_fold_constants(pTHX_ OP *const o)
5462 {
5463     dVAR;
5464     OP * volatile curop;
5465     OP *newop;
5466     volatile I32 type = o->op_type;
5467     bool is_stringify;
5468     SV * volatile sv = NULL;
5469     int ret = 0;
5470     OP *old_next;
5471     SV * const oldwarnhook = PL_warnhook;
5472     SV * const olddiehook  = PL_diehook;
5473     COP not_compiling;
5474     U8 oldwarn = PL_dowarn;
5475     I32 old_cxix;
5476     dJMPENV;
5477
5478     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5479
5480     if (!(PL_opargs[type] & OA_FOLDCONST))
5481         goto nope;
5482
5483     switch (type) {
5484     case OP_UCFIRST:
5485     case OP_LCFIRST:
5486     case OP_UC:
5487     case OP_LC:
5488     case OP_FC:
5489 #ifdef USE_LOCALE_CTYPE
5490         if (IN_LC_COMPILETIME(LC_CTYPE))
5491             goto nope;
5492 #endif
5493         break;
5494     case OP_SLT:
5495     case OP_SGT:
5496     case OP_SLE:
5497     case OP_SGE:
5498     case OP_SCMP:
5499 #ifdef USE_LOCALE_COLLATE
5500         if (IN_LC_COMPILETIME(LC_COLLATE))
5501             goto nope;
5502 #endif
5503         break;
5504     case OP_SPRINTF:
5505         /* XXX what about the numeric ops? */
5506 #ifdef USE_LOCALE_NUMERIC
5507         if (IN_LC_COMPILETIME(LC_NUMERIC))
5508             goto nope;
5509 #endif
5510         break;
5511     case OP_PACK:
5512         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5513           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5514             goto nope;
5515         {
5516             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5517             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5518             {
5519                 const char *s = SvPVX_const(sv);
5520                 while (s < SvEND(sv)) {
5521                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5522                     s++;
5523                 }
5524             }
5525         }
5526         break;
5527     case OP_REPEAT:
5528         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5529         break;
5530     case OP_SREFGEN:
5531         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5532          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5533             goto nope;
5534     }
5535
5536     if (PL_parser && PL_parser->error_count)
5537         goto nope;              /* Don't try to run w/ errors */
5538
5539     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5540         switch (curop->op_type) {
5541         case OP_CONST:
5542             if (   (curop->op_private & OPpCONST_BARE)
5543                 && (curop->op_private & OPpCONST_STRICT)) {
5544                 no_bareword_allowed(curop);
5545                 goto nope;
5546             }
5547             /* FALLTHROUGH */
5548         case OP_LIST:
5549         case OP_SCALAR:
5550         case OP_NULL:
5551         case OP_PUSHMARK:
5552             /* Foldable; move to next op in list */
5553             break;
5554
5555         default:
5556             /* No other op types are considered foldable */
5557             goto nope;
5558         }
5559     }
5560
5561     curop = LINKLIST(o);
5562     old_next = o->op_next;
5563     o->op_next = 0;
5564     PL_op = curop;
5565
5566     old_cxix = cxstack_ix;
5567     create_eval_scope(NULL, G_FAKINGEVAL);
5568
5569     /* Verify that we don't need to save it:  */
5570     assert(PL_curcop == &PL_compiling);
5571     StructCopy(&PL_compiling, &not_compiling, COP);
5572     PL_curcop = &not_compiling;
5573     /* The above ensures that we run with all the correct hints of the
5574        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5575     assert(IN_PERL_RUNTIME);
5576     PL_warnhook = PERL_WARNHOOK_FATAL;
5577     PL_diehook  = NULL;
5578     JMPENV_PUSH(ret);
5579
5580     /* Effective $^W=1.  */
5581     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5582         PL_dowarn |= G_WARN_ON;
5583
5584     switch (ret) {
5585     case 0:
5586         CALLRUNOPS(aTHX);
5587         sv = *(PL_stack_sp--);
5588         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5589             pad_swipe(o->op_targ,  FALSE);
5590         }
5591         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5592             SvREFCNT_inc_simple_void(sv);
5593             SvTEMP_off(sv);
5594         }
5595         else { assert(SvIMMORTAL(sv)); }
5596         break;
5597     case 3:
5598         /* Something tried to die.  Abandon constant folding.  */
5599         /* Pretend the error never happened.  */
5600         CLEAR_ERRSV();
5601         o->op_next = old_next;
5602         break;
5603     default:
5604         JMPENV_POP;
5605         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5606         PL_warnhook = oldwarnhook;
5607         PL_diehook  = olddiehook;
5608         /* XXX note that this croak may fail as we've already blown away
5609          * the stack - eg any nested evals */
5610         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5611     }
5612     JMPENV_POP;
5613     PL_dowarn   = oldwarn;
5614     PL_warnhook = oldwarnhook;
5615     PL_diehook  = olddiehook;
5616     PL_curcop = &PL_compiling;
5617
5618     /* if we croaked, depending on how we croaked the eval scope
5619      * may or may not have already been popped */
5620     if (cxstack_ix > old_cxix) {
5621         assert(cxstack_ix == old_cxix + 1);
5622         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5623         delete_eval_scope();
5624     }
5625     if (ret)
5626         goto nope;
5627
5628     /* OP_STRINGIFY and constant folding are used to implement qq.
5629        Here the constant folding is an implementation detail that we
5630        want to hide.  If the stringify op is itself already marked
5631        folded, however, then it is actually a folded join.  */
5632     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5633     op_free(o);
5634     assert(sv);
5635     if (is_stringify)
5636         SvPADTMP_off(sv);
5637     else if (!SvIMMORTAL(sv)) {
5638         SvPADTMP_on(sv);
5639         SvREADONLY_on(sv);
5640     }
5641     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5642     if (!is_stringify) newop->op_folded = 1;
5643     return newop;
5644
5645  nope:
5646     return o;
5647 }
5648
5649 static OP *
5650 S_gen_constant_list(pTHX_ OP *o)
5651 {
5652     dVAR;
5653     OP *curop, *old_next;
5654     SV * const oldwarnhook = PL_warnhook;
5655     SV * const olddiehook  = PL_diehook;
5656     COP *old_curcop;
5657     U8 oldwarn = PL_dowarn;
5658     SV **svp;
5659     AV *av;
5660     I32 old_cxix;
5661     COP not_compiling;
5662     int ret = 0;
5663     dJMPENV;
5664     bool op_was_null;
5665
5666     list(o);
5667     if (PL_parser && PL_parser->error_count)
5668         return o;               /* Don't attempt to run with errors */
5669
5670     curop = LINKLIST(o);
5671     old_next = o->op_next;
5672     o->op_next = 0;
5673     op_was_null = o->op_type == OP_NULL;
5674     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5675         o->op_type = OP_CUSTOM;
5676     CALL_PEEP(curop);
5677     if (op_was_null)
5678         o->op_type = OP_NULL;
5679     S_prune_chain_head(&curop);
5680     PL_op = curop;
5681
5682     old_cxix = cxstack_ix;
5683     create_eval_scope(NULL, G_FAKINGEVAL);
5684
5685     old_curcop = PL_curcop;
5686     StructCopy(old_curcop, &not_compiling, COP);
5687     PL_curcop = &not_compiling;
5688     /* The above ensures that we run with all the correct hints of the
5689        current COP, but that IN_PERL_RUNTIME is true. */
5690     assert(IN_PERL_RUNTIME);
5691     PL_warnhook = PERL_WARNHOOK_FATAL;
5692     PL_diehook  = NULL;
5693     JMPENV_PUSH(ret);
5694
5695     /* Effective $^W=1.  */
5696     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5697         PL_dowarn |= G_WARN_ON;
5698
5699     switch (ret) {
5700     case 0:
5701 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5702         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5703 #endif
5704         Perl_pp_pushmark(aTHX);
5705         CALLRUNOPS(aTHX);
5706         PL_op = curop;
5707         assert (!(curop->op_flags & OPf_SPECIAL));
5708         assert(curop->op_type == OP_RANGE);
5709         Perl_pp_anonlist(aTHX);
5710         break;
5711     case 3:
5712         CLEAR_ERRSV();
5713         o->op_next = old_next;
5714         break;
5715     default:
5716         JMPENV_POP;
5717         PL_warnhook = oldwarnhook;
5718         PL_diehook = olddiehook;
5719         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5720             ret);
5721     }
5722
5723     JMPENV_POP;
5724     PL_dowarn = oldwarn;
5725     PL_warnhook = oldwarnhook;
5726     PL_diehook = olddiehook;
5727     PL_curcop = old_curcop;
5728
5729     if (cxstack_ix > old_cxix) {
5730         assert(cxstack_ix == old_cxix + 1);
5731         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5732         delete_eval_scope();
5733     }
5734     if (ret)
5735         return o;
5736
5737     OpTYPE_set(o, OP_RV2AV);
5738     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5739     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5740     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5741     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5742
5743     /* replace subtree with an OP_CONST */
5744     curop = ((UNOP*)o)->op_first;
5745     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5746     op_free(curop);
5747
5748     if (AvFILLp(av) != -1)
5749         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5750         {
5751             SvPADTMP_on(*svp);
5752             SvREADONLY_on(*svp);
5753         }
5754     LINKLIST(o);
5755     return list(o);
5756 }
5757
5758 /*
5759 =head1 Optree Manipulation Functions
5760 */
5761
5762 /* List constructors */
5763
5764 /*
5765 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5766
5767 Append an item to the list of ops contained directly within a list-type
5768 op, returning the lengthened list.  C<first> is the list-type op,
5769 and C<last> is the op to append to the list.  C<optype> specifies the
5770 intended opcode for the list.  If C<first> is not already a list of the
5771 right type, it will be upgraded into one.  If either C<first> or C<last>
5772 is null, the other is returned unchanged.
5773
5774 =cut
5775 */
5776
5777 OP *
5778 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5779 {
5780     if (!first)
5781         return last;
5782
5783     if (!last)
5784         return first;
5785
5786     if (first->op_type != (unsigned)type
5787         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5788     {
5789         return newLISTOP(type, 0, first, last);
5790     }
5791
5792     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5793     first->op_flags |= OPf_KIDS;
5794     return first;
5795 }
5796
5797 /*
5798 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5799
5800 Concatenate the lists of ops contained directly within two list-type ops,
5801 returning the combined list.  C<first> and C<last> are the list-type ops
5802 to concatenate.  C<optype> specifies the intended opcode for the list.
5803 If either C<first> or C<last> is not already a list of the right type,
5804 it will be upgraded into one.  If either C<first> or C<last> is null,
5805 the other is returned unchanged.
5806
5807 =cut
5808 */
5809
5810 OP *
5811 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5812 {
5813     if (!first)
5814         return last;
5815
5816     if (!last)
5817         return first;
5818
5819     if (first->op_type != (unsigned)type)
5820         return op_prepend_elem(type, first, last);
5821
5822     if (last->op_type != (unsigned)type)
5823         return op_append_elem(type, first, last);
5824
5825     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5826     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5827     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5828     first->op_flags |= (last->op_flags & OPf_KIDS);
5829
5830     S_op_destroy(aTHX_ last);
5831
5832     return first;
5833 }
5834
5835 /*
5836 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5837
5838 Prepend an item to the list of ops contained directly within a list-type
5839 op, returning the lengthened list.  C<first> is the op to prepend to the
5840 list, and C<last> is the list-type op.  C<optype> specifies the intended
5841 opcode for the list.  If C<last> is not already a list of the right type,
5842 it will be upgraded into one.  If either C<first> or C<last> is null,
5843 the other is returned unchanged.
5844
5845 =cut
5846 */
5847
5848 OP *
5849 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5850 {
5851     if (!first)
5852         return last;
5853
5854     if (!last)
5855         return first;
5856
5857     if (last->op_type == (unsigned)type) {
5858         if (type == OP_LIST) {  /* already a PUSHMARK there */
5859             /* insert 'first' after pushmark */
5860             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5861             if (!(first->op_flags & OPf_PARENS))
5862                 last->op_flags &= ~OPf_PARENS;
5863         }
5864         else
5865             op_sibling_splice(last, NULL, 0, first);
5866         last->op_flags |= OPf_KIDS;
5867         return last;
5868     }
5869
5870     return newLISTOP(type, 0, first, last);
5871 }
5872
5873 /*
5874 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5875
5876 Converts C<o> into a list op if it is not one already, and then converts it
5877 into the specified C<type>, calling its check function, allocating a target if
5878 it needs one, and folding constants.
5879
5880 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5881 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5882 C<op_convert_list> to make it the right type.
5883
5884 =cut
5885 */
5886
5887 OP *
5888 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5889 {
5890     dVAR;
5891     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5892     if (!o || o->op_type != OP_LIST)
5893         o = force_list(o, 0);
5894     else
5895     {
5896         o->op_flags &= ~OPf_WANT;
5897         o->op_private &= ~OPpLVAL_INTRO;
5898     }
5899
5900     if (!(PL_opargs[type] & OA_MARK))
5901         op_null(cLISTOPo->op_first);
5902     else {
5903         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5904         if (kid2 && kid2->op_type == OP_COREARGS) {
5905             op_null(cLISTOPo->op_first);
5906             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5907         }
5908     }
5909
5910     if (type != OP_SPLIT)
5911         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5912          * ck_split() create a real PMOP and leave the op's type as listop
5913          * for now. Otherwise op_free() etc will crash.
5914          */
5915         OpTYPE_set(o, type);
5916
5917     o->op_flags |= flags;
5918     if (flags & OPf_FOLDED)
5919         o->op_folded = 1;
5920
5921     o = CHECKOP(type, o);
5922     if (o->op_type != (unsigned)type)
5923         return o;
5924
5925     return fold_constants(op_integerize(op_std_init(o)));
5926 }
5927
5928 /* Constructors */
5929
5930
5931 /*
5932 =head1 Optree construction
5933
5934 =for apidoc Am|OP *|newNULLLIST
5935
5936 Constructs, checks, and returns a new C<stub> op, which represents an
5937 empty list expression.
5938
5939 =cut
5940 */
5941
5942 OP *
5943 Perl_newNULLLIST(pTHX)
5944 {
5945     return newOP(OP_STUB, 0);
5946 }
5947
5948 /* promote o and any siblings to be a list if its not already; i.e.
5949  *
5950  *  o - A - B
5951  *
5952  * becomes
5953  *
5954  *  list
5955  *    |
5956  *  pushmark - o - A - B
5957  *
5958  * If nullit it true, the list op is nulled.
5959  */
5960
5961 static OP *
5962 S_force_list(pTHX_ OP *o, bool nullit)
5963 {
5964     if (!o || o->op_type != OP_LIST) {
5965         OP *rest = NULL;
5966         if (o) {
5967             /* manually detach any siblings then add them back later */
5968             rest = OpSIBLING(o);
5969             OpLASTSIB_set(o, NULL);
5970         }
5971         o = newLISTOP(OP_LIST, 0, o, NULL);
5972         if (rest)
5973             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5974     }
5975     if (nullit)
5976         op_null(o);
5977     return o;
5978 }
5979
5980 /*
5981 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5982
5983 Constructs, checks, and returns an op of any list type.  C<type> is
5984 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5985 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5986 supply up to two ops to be direct children of the list op; they are
5987 consumed by this function and become part of the constructed op tree.
5988
5989 For most list operators, the check function expects all the kid ops to be
5990 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5991 appropriate.  What you want to do in that case is create an op of type
5992 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5993 See L</op_convert_list> for more information.
5994
5995
5996 =cut
5997 */
5998
5999 OP *
6000 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6001 {
6002     dVAR;
6003     LISTOP *listop;
6004
6005     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6006         || type == OP_CUSTOM);
6007
6008     NewOp(1101, listop, 1, LISTOP);
6009
6010     OpTYPE_set(listop, type);
6011     if (first || last)
6012         flags |= OPf_KIDS;
6013     listop->op_flags = (U8)flags;
6014
6015     if (!last && first)
6016         last = first;
6017     else if (!first && last)
6018         first = last;
6019     else if (first)
6020         OpMORESIB_set(first, last);
6021     listop->op_first = first;
6022     listop->op_last = last;
6023     if (type == OP_LIST) {
6024         OP* const pushop = newOP(OP_PUSHMARK, 0);
6025         OpMORESIB_set(pushop, first);
6026         listop->op_first = pushop;
6027         listop->op_flags |= OPf_KIDS;
6028         if (!last)
6029             listop->op_last = pushop;
6030     }
6031     if (listop->op_last)
6032         OpLASTSIB_set(listop->op_last, (OP*)listop);
6033
6034     return CHECKOP(type, listop);
6035 }
6036
6037 /*
6038 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6039
6040 Constructs, checks, and returns an op of any base type (any type that
6041 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6042 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6043 of C<op_private>.
6044
6045 =cut
6046 */
6047
6048 OP *
6049 Perl_newOP(pTHX_ I32 type, I32 flags)
6050 {
6051     dVAR;
6052     OP *o;
6053
6054     if (type == -OP_ENTEREVAL) {
6055         type = OP_ENTEREVAL;
6056         flags |= OPpEVAL_BYTES<<8;
6057     }
6058
6059     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6060         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6061         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6062         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6063
6064     NewOp(1101, o, 1, OP);
6065     OpTYPE_set(o, type);
6066     o->op_flags = (U8)flags;
6067
6068     o->op_next = o;
6069     o->op_private = (U8)(0 | (flags >> 8));
6070     if (PL_opargs[type] & OA_RETSCALAR)
6071         scalar(o);
6072     if (PL_opargs[type] & OA_TARGET)
6073         o->op_targ = pad_alloc(type, SVs_PADTMP);
6074     return CHECKOP(type, o);
6075 }
6076
6077 /*
6078 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6079
6080 Constructs, checks, and returns an op of any unary type.  C<type> is
6081 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6082 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6083 bits, the eight bits of C<op_private>, except that the bit with value 1
6084 is automatically set.  C<first> supplies an optional op to be the direct
6085 child of the unary op; it is consumed by this function and become part
6086 of the constructed op tree.
6087
6088 =cut
6089 */
6090
6091 OP *
6092 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6093 {
6094     dVAR;
6095     UNOP *unop;
6096
6097     if (type == -OP_ENTEREVAL) {
6098         type = OP_ENTEREVAL;
6099         flags |= OPpEVAL_BYTES<<8;
6100     }
6101
6102     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6103         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6104         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6105         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6106         || type == OP_SASSIGN
6107         || type == OP_ENTERTRY
6108         || type == OP_CUSTOM
6109         || type == OP_NULL );
6110
6111     if (!first)
6112         first = newOP(OP_STUB, 0);
6113     if (PL_opargs[type] & OA_MARK)
6114         first = force_list(first, 1);
6115
6116     NewOp(1101, unop, 1, UNOP);
6117     OpTYPE_set(unop, type);
6118     unop->op_first = first;
6119     unop->op_flags = (U8)(flags | OPf_KIDS);
6120     unop->op_private = (U8)(1 | (flags >> 8));
6121
6122     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6123         OpLASTSIB_set(first, (OP*)unop);
6124
6125     unop = (UNOP*) CHECKOP(type, unop);
6126     if (unop->op_next)
6127         return (OP*)unop;
6128
6129     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6130 }
6131
6132 /*
6133 =for apidoc newUNOP_AUX
6134
6135 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6136 initialised to C<aux>
6137
6138 =cut
6139 */
6140
6141 OP *
6142 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6143 {
6144     dVAR;
6145     UNOP_AUX *unop;
6146
6147     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6148         || type == OP_CUSTOM);
6149
6150     NewOp(1101, unop, 1, UNOP_AUX);
6151     unop->op_type = (OPCODE)type;
6152     unop->op_ppaddr = PL_ppaddr[type];
6153     unop->op_first = first;
6154     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6155     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6156     unop->op_aux = aux;
6157
6158     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6159         OpLASTSIB_set(first, (OP*)unop);
6160
6161     unop = (UNOP_AUX*) CHECKOP(type, unop);
6162
6163     return op_std_init((OP *) unop);
6164 }
6165
6166 /*
6167 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6168
6169 Constructs, checks, and returns an op of method type with a method name
6170 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6171 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6172 and, shifted up eight bits, the eight bits of C<op_private>, except that
6173 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6174 op which evaluates method name; it is consumed by this function and
6175 become part of the constructed op tree.
6176 Supported optypes: C<OP_METHOD>.
6177
6178 =cut
6179 */
6180
6181 static OP*
6182 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6183     dVAR;
6184     METHOP *methop;
6185
6186     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6187         || type == OP_CUSTOM);
6188
6189     NewOp(1101, methop, 1, METHOP);
6190     if (dynamic_meth) {
6191         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6192         methop->op_flags = (U8)(flags | OPf_KIDS);
6193         methop->op_u.op_first = dynamic_meth;
6194         methop->op_private = (U8)(1 | (flags >> 8));
6195
6196         if (!OpHAS_SIBLING(dynamic_meth))
6197             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6198     }
6199     else {
6200         assert(const_meth);
6201         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6202         methop->op_u.op_meth_sv = const_meth;
6203         methop->op_private = (U8)(0 | (flags >> 8));
6204         methop->op_next = (OP*)methop;
6205     }
6206
6207 #ifdef USE_ITHREADS
6208     methop->op_rclass_targ = 0;
6209 #else
6210     methop->op_rclass_sv = NULL;
6211 #endif
6212
6213     OpTYPE_set(methop, type);
6214     return CHECKOP(type, methop);
6215 }
6216
6217 OP *
6218 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6219     PERL_ARGS_ASSERT_NEWMETHOP;
6220     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6221 }
6222
6223 /*
6224 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6225
6226 Constructs, checks, and returns an op of method type with a constant
6227 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6228 C<op_flags>, and, shifted up eight bits, the eight bits of
6229 C<op_private>.  C<const_meth> supplies a constant method name;
6230 it must be a shared COW string.
6231 Supported optypes: C<OP_METHOD_NAMED>.
6232
6233 =cut
6234 */
6235
6236 OP *
6237 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6238     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6239     return newMETHOP_internal(type, flags, NULL, const_meth);
6240 }
6241
6242 /*
6243 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6244
6245 Constructs, checks, and returns an op of any binary type.  C<type>
6246 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6247 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6248 the eight bits of C<op_private>, except that the bit with value 1 or
6249 2 is automatically set as required.  C<first> and C<last> supply up to
6250 two ops to be the direct children of the binary op; they are consumed
6251 by this function and become part of the constructed op tree.
6252
6253 =cut
6254 */
6255
6256 OP *
6257 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6258 {
6259     dVAR;
6260     BINOP *binop;
6261
6262     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6263         || type == OP_NULL || type == OP_CUSTOM);
6264
6265     NewOp(1101, binop, 1, BINOP);
6266
6267     if (!first)
6268         first = newOP(OP_NULL, 0);
6269
6270     OpTYPE_set(binop, type);
6271     binop->op_first = first;
6272     binop->op_flags = (U8)(flags | OPf_KIDS);
6273     if (!last) {
6274         last = first;
6275         binop->op_private = (U8)(1 | (flags >> 8));
6276     }
6277     else {
6278         binop->op_private = (U8)(2 | (flags >> 8));
6279         OpMORESIB_set(first, last);
6280     }
6281
6282     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6283         OpLASTSIB_set(last, (OP*)binop);
6284
6285     binop->op_last = OpSIBLING(binop->op_first);
6286     if (binop->op_last)
6287         OpLASTSIB_set(binop->op_last, (OP*)binop);
6288
6289     binop = (BINOP*)CHECKOP(type, binop);
6290     if (binop->op_next || binop->op_type != (OPCODE)type)
6291         return (OP*)binop;
6292
6293     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6294 }
6295
6296 static int uvcompare(const void *a, const void *b)
6297     __attribute__nonnull__(1)
6298     __attribute__nonnull__(2)
6299     __attribute__pure__;
6300 static int uvcompare(const void *a, const void *b)
6301 {
6302     if (*((const UV *)a) < (*(const UV *)b))
6303         return -1;
6304     if (*((const UV *)a) > (*(const UV *)b))
6305         return 1;
6306     if (*((const UV *)a+1) < (*(const UV *)b+1))
6307         return -1;
6308     if (*((const UV *)a+1) > (*(const UV *)b+1))
6309         return 1;
6310     return 0;
6311 }
6312
6313 static OP *
6314 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6315 {
6316     SV * const tstr = ((SVOP*)expr)->op_sv;
6317     SV * const rstr =
6318                               ((SVOP*)repl)->op_sv;
6319     STRLEN tlen;
6320     STRLEN rlen;
6321     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6322     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6323     I32 i;
6324     I32 j;
6325     I32 grows = 0;
6326     short *tbl;
6327
6328     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
6329     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
6330     I32 del              = o->op_private & OPpTRANS_DELETE;
6331     SV* swash;
6332
6333     PERL_ARGS_ASSERT_PMTRANS;
6334
6335     PL_hints |= HINT_BLOCK_SCOPE;
6336
6337     if (SvUTF8(tstr))
6338         o->op_private |= OPpTRANS_FROM_UTF;
6339
6340     if (SvUTF8(rstr))
6341         o->op_private |= OPpTRANS_TO_UTF;
6342
6343     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6344         SV* const listsv = newSVpvs("# comment\n");
6345         SV* transv = NULL;
6346         const U8* tend = t + tlen;
6347         const U8* rend = r + rlen;
6348         STRLEN ulen;
6349         UV tfirst = 1;
6350         UV tlast = 0;
6351         IV tdiff;
6352         STRLEN tcount = 0;
6353         UV rfirst = 1;
6354         UV rlast = 0;
6355         IV rdiff;
6356         STRLEN rcount = 0;
6357         IV diff;
6358         I32 none = 0;
6359         U32 max = 0;
6360         I32 bits;
6361         I32 havefinal = 0;
6362         U32 final = 0;
6363         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6364         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6365         U8* tsave = NULL;
6366         U8* rsave = NULL;
6367         const U32 flags = UTF8_ALLOW_DEFAULT;
6368
6369         if (!from_utf) {
6370             STRLEN len = tlen;
6371             t = tsave = bytes_to_utf8(t, &len);
6372             tend = t + len;
6373         }
6374         if (!to_utf && rlen) {
6375             STRLEN len = rlen;
6376             r = rsave = bytes_to_utf8(r, &len);
6377             rend = r + len;
6378         }
6379
6380 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6381  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6382  * odd.  */
6383
6384         if (complement) {
6385             U8 tmpbuf[UTF8_MAXBYTES+1];
6386             UV *cp;
6387             UV nextmin = 0;
6388             Newx(cp, 2*tlen, UV);
6389             i = 0;
6390             transv = newSVpvs("");
6391             while (t < tend) {
6392                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6393                 t += ulen;
6394                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6395                     t++;
6396                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6397                     t += ulen;
6398                 }
6399                 else {
6400                  cp[2*i+1] = cp[2*i];
6401                 }
6402                 i++;
6403             }
6404             qsort(cp, i, 2*sizeof(UV), uvcompare);
6405             for (j = 0; j < i; j++) {
6406                 UV  val = cp[2*j];
6407                 diff = val - nextmin;
6408                 if (diff > 0) {
6409                     t = uvchr_to_utf8(tmpbuf,nextmin);
6410                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6411                     if (diff > 1) {
6412                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6413                         t = uvchr_to_utf8(tmpbuf, val - 1);
6414                         sv_catpvn(transv, (char *)&range_mark, 1);
6415                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6416                     }
6417                 }
6418                 val = cp[2*j+1];
6419                 if (val >= nextmin)
6420                     nextmin = val + 1;
6421             }
6422             t = uvchr_to_utf8(tmpbuf,nextmin);
6423             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6424             {
6425                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6426                 sv_catpvn(transv, (char *)&range_mark, 1);
6427             }
6428             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6429             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6430             t = (const U8*)SvPVX_const(transv);
6431             tlen = SvCUR(transv);
6432             tend = t + tlen;
6433             Safefree(cp);
6434         }
6435         else if (!rlen && !del) {
6436             r = t; rlen = tlen; rend = tend;
6437         }
6438         if (!squash) {
6439                 if ((!rlen && !del) || t == r ||
6440                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6441                 {
6442                     o->op_private |= OPpTRANS_IDENTICAL;
6443                 }
6444         }
6445
6446         while (t < tend || tfirst <= tlast) {
6447             /* see if we need more "t" chars */
6448             if (tfirst > tlast) {
6449                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6450                 t += ulen;
6451                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6452                     t++;
6453                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6454                     t += ulen;
6455                 }
6456                 else
6457                     tlast = tfirst;
6458             }
6459
6460             /* now see if we need more "r" chars */
6461             if (rfirst > rlast) {
6462                 if (r < rend) {
6463                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6464                     r += ulen;
6465                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6466                         r++;
6467                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6468                         r += ulen;
6469                     }
6470                     else
6471                         rlast = rfirst;
6472                 }
6473                 else {
6474                     if (!havefinal++)
6475                         final = rlast;
6476                     rfirst = rlast = 0xffffffff;
6477                 }
6478             }
6479
6480             /* now see which range will peter out first, if either. */
6481             tdiff = tlast - tfirst;
6482             rdiff = rlast - rfirst;
6483             tcount += tdiff + 1;
6484             rcount += rdiff + 1;
6485
6486             if (tdiff <= rdiff)
6487                 diff = tdiff;
6488             else
6489                 diff = rdiff;
6490
6491             if (rfirst == 0xffffffff) {
6492                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6493                 if (diff > 0)
6494                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6495                                    (long)tfirst, (long)tlast);
6496                 else
6497                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6498             }
6499             else {
6500                 if (diff > 0)
6501                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6502                                    (long)tfirst, (long)(tfirst + diff),
6503                                    (long)rfirst);
6504                 else
6505                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6506                                    (long)tfirst, (long)rfirst);
6507
6508                 if (rfirst + diff > max)
6509                     max = rfirst + diff;
6510                 if (!grows)
6511                     grows = (tfirst < rfirst &&
6512                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6513                 rfirst += diff + 1;
6514             }
6515             tfirst += diff + 1;
6516         }
6517
6518         none = ++max;
6519         if (del)
6520             del = ++max;
6521
6522         if (max > 0xffff)
6523             bits = 32;
6524         else if (max > 0xff)
6525             bits = 16;
6526         else
6527             bits = 8;
6528
6529         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6530 #ifdef USE_ITHREADS
6531         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6532         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6533         PAD_SETSV(cPADOPo->op_padix, swash);
6534         SvPADTMP_on(swash);
6535         SvREADONLY_on(swash);
6536 #else
6537         cSVOPo->op_sv = swash;
6538 #endif
6539         SvREFCNT_dec(listsv);
6540         SvREFCNT_dec(transv);
6541
6542         if (!del && havefinal && rlen)
6543             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6544                            newSVuv((UV)final), 0);
6545
6546         Safefree(tsave);
6547         Safefree(rsave);
6548
6549         tlen = tcount;
6550         rlen = rcount;
6551         if (r < rend)
6552             rlen++;
6553         else if (rlast == 0xffffffff)
6554             rlen = 0;
6555
6556         goto warnins;
6557     }
6558
6559     tbl = (short*)PerlMemShared_calloc(
6560         (o->op_private & OPpTRANS_COMPLEMENT) &&
6561             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
6562         sizeof(short));
6563     cPVOPo->op_pv = (char*)tbl;
6564     if (complement) {
6565         for (i = 0; i < (I32)tlen; i++)
6566             tbl[t[i]] = -1;
6567         for (i = 0, j = 0; i < 256; i++) {
6568             if (!tbl[i]) {
6569                 if (j >= (I32)rlen) {
6570                     if (del)
6571                         tbl[i] = -2;
6572                     else if (rlen)
6573                         tbl[i] = r[j-1];
6574                     else
6575                         tbl[i] = (short)i;
6576                 }
6577                 else {
6578                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
6579                         grows = 1;
6580                     tbl[i] = r[j++];
6581                 }
6582             }
6583         }
6584         if (!del) {
6585             if (!rlen) {
6586                 j = rlen;
6587                 if (!squash)
6588                     o->op_private |= OPpTRANS_IDENTICAL;
6589             }
6590             else if (j >= (I32)rlen)
6591                 j = rlen - 1;
6592             else {
6593                 tbl =
6594                     (short *)
6595                     PerlMemShared_realloc(tbl,
6596                                           (0x101+rlen-j) * sizeof(short));
6597                 cPVOPo->op_pv = (char*)tbl;
6598             }
6599             tbl[0x100] = (short)(rlen - j);
6600             for (i=0; i < (I32)rlen - j; i++)
6601                 tbl[0x101+i] = r[j+i];
6602         }
6603     }
6604     else {
6605         if (!rlen && !del) {
6606             r = t; rlen = tlen;
6607             if (!squash)
6608                 o->op_private |= OPpTRANS_IDENTICAL;
6609         }
6610         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6611             o->op_private |= OPpTRANS_IDENTICAL;
6612         }
6613         for (i = 0; i < 256; i++)
6614             tbl[i] = -1;
6615         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
6616             if (j >= (I32)rlen) {
6617                 if (del) {
6618                     if (tbl[t[i]] == -1)
6619                         tbl[t[i]] = -2;
6620                     continue;
6621                 }
6622                 --j;
6623             }
6624             if (tbl[t[i]] == -1) {
6625                 if (     UVCHR_IS_INVARIANT(t[i])
6626                     && ! UVCHR_IS_INVARIANT(r[j]))
6627                     grows = 1;
6628                 tbl[t[i]] = r[j];
6629             }
6630         }
6631     }
6632
6633   warnins:
6634     if(del && rlen == tlen) {
6635         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6636     } else if(rlen > tlen && !complement) {
6637         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6638     }
6639
6640     if (grows)
6641         o->op_private |= OPpTRANS_GROWS;
6642     op_free(expr);
6643     op_free(repl);
6644
6645     return o;
6646 }
6647
6648 /*
6649 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6650
6651 Constructs, checks, and returns an op of any pattern matching type.
6652 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6653 and, shifted up eight bits, the eight bits of C<op_private>.
6654
6655 =cut
6656 */
6657
6658 OP *
6659 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6660 {
6661     dVAR;
6662     PMOP *pmop;
6663
6664     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6665         || type == OP_CUSTOM);
6666
6667     NewOp(1101, pmop, 1, PMOP);
6668     OpTYPE_set(pmop, type);
6669     pmop->op_flags = (U8)flags;
6670     pmop->op_private = (U8)(0 | (flags >> 8));
6671     if (PL_opargs[type] & OA_RETSCALAR)
6672         scalar((OP *)pmop);
6673
6674     if (PL_hints & HINT_RE_TAINT)
6675         pmop->op_pmflags |= PMf_RETAINT;
6676 #ifdef USE_LOCALE_CTYPE
6677     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6678         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6679     }
6680     else
6681 #endif
6682          if (IN_UNI_8_BIT) {
6683         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6684     }
6685     if (PL_hints & HINT_RE_FLAGS) {
6686         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6687          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6688         );
6689         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6690         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6691          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6692         );
6693         if (reflags && SvOK(reflags)) {
6694             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6695         }
6696     }
6697
6698
6699 #ifdef USE_ITHREADS
6700     assert(SvPOK(PL_regex_pad[0]));
6701     if (SvCUR(PL_regex_pad[0])) {
6702         /* Pop off the "packed" IV from the end.  */
6703         SV *const repointer_list = PL_regex_pad[0];
6704         const char *p = SvEND(repointer_list) - sizeof(IV);
6705         const IV offset = *((IV*)p);
6706
6707         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6708
6709         SvEND_set(repointer_list, p);
6710
6711         pmop->op_pmoffset = offset;
6712         /* This slot should be free, so assert this:  */
6713         assert(PL_regex_pad[offset] == &PL_sv_undef);
6714     } else {
6715         SV * const repointer = &PL_sv_undef;
6716         av_push(PL_regex_padav, repointer);
6717         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6718         PL_regex_pad = AvARRAY(PL_regex_padav);
6719     }
6720 #endif
6721
6722     return CHECKOP(type, pmop);
6723 }
6724
6725 static void
6726 S_set_haseval(pTHX)
6727 {
6728     PADOFFSET i = 1;
6729     PL_cv_has_eval = 1;
6730     /* Any pad names in scope are potentially lvalues.  */
6731     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6732         PADNAME *pn = PAD_COMPNAME_SV(i);
6733         if (!pn || !PadnameLEN(pn))
6734             continue;
6735         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6736             S_mark_padname_lvalue(aTHX_ pn);
6737     }
6738 }
6739
6740 /* Given some sort of match op o, and an expression expr containing a
6741  * pattern, either compile expr into a regex and attach it to o (if it's
6742  * constant), or convert expr into a runtime regcomp op sequence (if it's
6743  * not)
6744  *
6745  * Flags currently has 2 bits of meaning:
6746  * 1: isreg indicates that the pattern is part of a regex construct, eg
6747  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6748  * split "pattern", which aren't. In the former case, expr will be a list
6749  * if the pattern contains more than one term (eg /a$b/).
6750  * 2: The pattern is for a split.
6751  *
6752  * When the pattern has been compiled within a new anon CV (for
6753  * qr/(?{...})/ ), then floor indicates the savestack level just before
6754  * the new sub was created
6755  */
6756
6757 OP *
6758 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6759 {
6760     PMOP *pm;
6761     LOGOP *rcop;
6762     I32 repl_has_vars = 0;
6763     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6764     bool is_compiletime;
6765     bool has_code;
6766     bool isreg    = cBOOL(flags & 1);
6767     bool is_split = cBOOL(flags & 2);
6768
6769     PERL_ARGS_ASSERT_PMRUNTIME;
6770
6771     if (is_trans) {
6772         return pmtrans(o, expr, repl);
6773     }
6774
6775     /* find whether we have any runtime or code elements;
6776      * at the same time, temporarily set the op_next of each DO block;
6777      * then when we LINKLIST, this will cause the DO blocks to be excluded
6778      * from the op_next chain (and from having LINKLIST recursively
6779      * applied to them). We fix up the DOs specially later */
6780
6781     is_compiletime = 1;
6782     has_code = 0;
6783     if (expr->op_type == OP_LIST) {
6784         OP *o;
6785         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6786             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6787                 has_code = 1;
6788                 assert(!o->op_next);
6789                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6790                     assert(PL_parser && PL_parser->error_count);
6791                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6792                        the op we were expecting to see, to avoid crashing
6793                        elsewhere.  */
6794                     op_sibling_splice(expr, o, 0,
6795                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6796                 }
6797                 o->op_next = OpSIBLING(o);
6798             }
6799             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6800                 is_compiletime = 0;
6801         }
6802     }
6803     else if (expr->op_type != OP_CONST)
6804         is_compiletime = 0;
6805
6806     LINKLIST(expr);
6807
6808     /* fix up DO blocks; treat each one as a separate little sub;
6809      * also, mark any arrays as LIST/REF */
6810
6811     if (expr->op_type == OP_LIST) {
6812         OP *o;
6813         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6814
6815             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6816                 assert( !(o->op_flags  & OPf_WANT));
6817                 /* push the array rather than its contents. The regex
6818                  * engine will retrieve and join the elements later */
6819                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6820                 continue;
6821             }
6822
6823             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6824                 continue;
6825             o->op_next = NULL; /* undo temporary hack from above */
6826             scalar(o);
6827             LINKLIST(o);
6828             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6829                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6830                 /* skip ENTER */
6831                 assert(leaveop->op_first->op_type == OP_ENTER);
6832                 assert(OpHAS_SIBLING(leaveop->op_first));
6833                 o->op_next = OpSIBLING(leaveop->op_first);
6834                 /* skip leave */
6835                 assert(leaveop->op_flags & OPf_KIDS);
6836                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6837                 leaveop->op_next = NULL; /* stop on last op */
6838                 op_null((OP*)leaveop);
6839             }
6840             else {
6841                 /* skip SCOPE */
6842                 OP *scope = cLISTOPo->op_first;
6843                 assert(scope->op_type == OP_SCOPE);
6844                 assert(scope->op_flags & OPf_KIDS);
6845                 scope->op_next = NULL; /* stop on last op */
6846                 op_null(scope);
6847             }
6848
6849             if (is_compiletime)
6850                 /* runtime finalizes as part of finalizing whole tree */
6851                 optimize_optree(o);
6852
6853             /* have to peep the DOs individually as we've removed it from
6854              * the op_next chain */
6855             CALL_PEEP(o);
6856             S_prune_chain_head(&(o->op_next));
6857             if (is_compiletime)
6858                 /* runtime finalizes as part of finalizing whole tree */
6859                 finalize_optree(o);
6860         }
6861     }
6862     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6863         assert( !(expr->op_flags  & OPf_WANT));
6864         /* push the array rather than its contents. The regex
6865          * engine will retrieve and join the elements later */
6866         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6867     }
6868
6869     PL_hints |= HINT_BLOCK_SCOPE;
6870     pm = (PMOP*)o;
6871     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6872
6873     if (is_compiletime) {
6874         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6875         regexp_engine const *eng = current_re_engine();
6876
6877         if (is_split) {
6878             /* make engine handle split ' ' specially */
6879             pm->op_pmflags |= PMf_SPLIT;
6880             rx_flags |= RXf_SPLIT;
6881         }
6882
6883         /* Skip compiling if parser found an error for this pattern */
6884         if (pm->op_pmflags & PMf_HAS_ERROR) {
6885             return o;
6886         }
6887
6888         if (!has_code || !eng->op_comp) {
6889             /* compile-time simple constant pattern */
6890
6891             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
6892                 /* whoops! we guessed that a qr// had a code block, but we
6893                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
6894                  * that isn't required now. Note that we have to be pretty
6895                  * confident that nothing used that CV's pad while the
6896                  * regex was parsed, except maybe op targets for \Q etc.
6897                  * If there were any op targets, though, they should have
6898                  * been stolen by constant folding.
6899                  */
6900 #ifdef DEBUGGING
6901                 SSize_t i = 0;
6902                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
6903                 while (++i <= AvFILLp(PL_comppad)) {
6904 #  ifdef USE_PAD_RESET
6905                     /* under USE_PAD_RESET, pad swipe replaces a swiped
6906                      * folded constant with a fresh padtmp */
6907                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
6908 #  else
6909                     assert(!PL_curpad[i]);
6910 #  endif
6911                 }
6912 #endif
6913                 /* But we know that one op is using this CV's slab. */
6914                 cv_forget_slab(PL_compcv);
6915                 LEAVE_SCOPE(floor);
6916                 pm->op_pmflags &= ~PMf_HAS_CV;
6917             }
6918
6919             PM_SETRE(pm,
6920                 eng->op_comp
6921                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6922                                         rx_flags, pm->op_pmflags)
6923                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6924                                         rx_flags, pm->op_pmflags)
6925             );
6926             op_free(expr);
6927         }
6928         else {
6929             /* compile-time pattern that includes literal code blocks */
6930             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6931                         rx_flags,
6932                         (pm->op_pmflags |
6933                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
6934                     );
6935             PM_SETRE(pm, re);
6936             if (pm->op_pmflags & PMf_HAS_CV) {
6937                 CV *cv;
6938                 /* this QR op (and the anon sub we embed it in) is never
6939                  * actually executed. It's just a placeholder where we can
6940                  * squirrel away expr in op_code_list without the peephole
6941                  * optimiser etc processing it for a second time */
6942                 OP *qr = newPMOP(OP_QR, 0);
6943                 ((PMOP*)qr)->op_code_list = expr;
6944
6945                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
6946                 SvREFCNT_inc_simple_void(PL_compcv);
6947                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
6948                 ReANY(re)->qr_anoncv = cv;
6949
6950                 /* attach the anon CV to the pad so that
6951                  * pad_fixup_inner_anons() can find it */
6952                 (void)pad_add_anon(cv, o->op_type);
6953                 SvREFCNT_inc_simple_void(cv);
6954             }
6955             else {
6956                 pm->op_code_list = expr;
6957             }
6958         }
6959     }
6960     else {
6961         /* runtime pattern: build chain of regcomp etc ops */
6962         bool reglist;
6963         PADOFFSET cv_targ = 0;
6964
6965         reglist = isreg && expr->op_type == OP_LIST;
6966         if (reglist)
6967             op_null(expr);
6968
6969         if (has_code) {
6970             pm->op_code_list = expr;
6971             /* don't free op_code_list; its ops are embedded elsewhere too */
6972             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
6973         }
6974
6975         if (is_split)
6976             /* make engine handle split ' ' specially */
6977             pm->op_pmflags |= PMf_SPLIT;
6978
6979         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
6980          * to allow its op_next to be pointed past the regcomp and
6981          * preceding stacking ops;
6982          * OP_REGCRESET is there to reset taint before executing the
6983          * stacking ops */
6984         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
6985             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
6986
6987         if (pm->op_pmflags & PMf_HAS_CV) {
6988             /* we have a runtime qr with literal code. This means
6989              * that the qr// has been wrapped in a new CV, which
6990              * means that runtime consts, vars etc will have been compiled
6991              * against a new pad. So... we need to execute those ops
6992              * within the environment of the new CV. So wrap them in a call
6993              * to a new anon sub. i.e. for
6994              *
6995              *     qr/a$b(?{...})/,
6996              *
6997              * we build an anon sub that looks like
6998              *
6999              *     sub { "a", $b, '(?{...})' }
7000              *
7001              * and call it, passing the returned list to regcomp.
7002              * Or to put it another way, the list of ops that get executed
7003              * are:
7004              *
7005              *     normal              PMf_HAS_CV
7006              *     ------              -------------------
7007              *                         pushmark (for regcomp)
7008              *                         pushmark (for entersub)
7009              *                         anoncode
7010              *                         srefgen
7011              *                         entersub
7012              *     regcreset                  regcreset
7013              *     pushmark                   pushmark
7014              *     const("a")                 const("a")
7015              *     gvsv(b)                    gvsv(b)
7016              *     const("(?{...})")          const("(?{...})")
7017              *                                leavesub
7018              *     regcomp             regcomp
7019              */
7020
7021             SvREFCNT_inc_simple_void(PL_compcv);
7022             CvLVALUE_on(PL_compcv);
7023             /* these lines are just an unrolled newANONATTRSUB */
7024             expr = newSVOP(OP_ANONCODE, 0,
7025                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7026             cv_targ = expr->op_targ;
7027             expr = newUNOP(OP_REFGEN, 0, expr);
7028
7029             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7030         }
7031
7032         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7033         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7034                            | (reglist ? OPf_STACKED : 0);
7035         rcop->op_targ = cv_targ;
7036
7037         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7038         if (PL_hints & HINT_RE_EVAL)
7039             S_set_haseval(aTHX);
7040
7041         /* establish postfix order */
7042         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7043             LINKLIST(expr);
7044             rcop->op_next = expr;
7045             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7046         }
7047         else {
7048             rcop->op_next = LINKLIST(expr);
7049             expr->op_next = (OP*)rcop;
7050         }
7051
7052         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7053     }
7054
7055     if (repl) {
7056         OP *curop = repl;
7057         bool konst;
7058         /* If we are looking at s//.../e with a single statement, get past
7059            the implicit do{}. */
7060         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7061              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7062              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7063          {
7064             OP *sib;
7065             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7066             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7067              && !OpHAS_SIBLING(sib))
7068                 curop = sib;
7069         }
7070         if (curop->op_type == OP_CONST)
7071             konst = TRUE;
7072         else if (( (curop->op_type == OP_RV2SV ||
7073                     curop->op_type == OP_RV2AV ||
7074                     curop->op_type == OP_RV2HV ||
7075                     curop->op_type == OP_RV2GV)
7076                    && cUNOPx(curop)->op_first
7077                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7078                 || curop->op_type == OP_PADSV
7079                 || curop->op_type == OP_PADAV
7080                 || curop->op_type == OP_PADHV
7081                 || curop->op_type == OP_PADANY) {
7082             repl_has_vars = 1;
7083             konst = TRUE;
7084         }
7085         else konst = FALSE;
7086         if (konst
7087             && !(repl_has_vars
7088                  && (!PM_GETRE(pm)
7089                      || !RX_PRELEN(PM_GETRE(pm))
7090                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7091         {
7092             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7093             op_prepend_elem(o->op_type, scalar(repl), o);
7094         }
7095         else {
7096             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7097             rcop->op_private = 1;
7098
7099             /* establish postfix order */
7100             rcop->op_next = LINKLIST(repl);
7101             repl->op_next = (OP*)rcop;
7102
7103             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7104             assert(!(pm->op_pmflags & PMf_ONCE));
7105             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7106             rcop->op_next = 0;
7107         }
7108     }
7109
7110     return (OP*)pm;
7111 }
7112
7113 /*
7114 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7115
7116 Constructs, checks, and returns an op of any type that involves an
7117 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7118 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7119 takes ownership of one reference to it.
7120
7121 =cut
7122 */
7123
7124 OP *
7125 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7126 {
7127     dVAR;
7128     SVOP *svop;
7129
7130     PERL_ARGS_ASSERT_NEWSVOP;
7131
7132     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7133         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7134         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7135         || type == OP_CUSTOM);
7136
7137     NewOp(1101, svop, 1, SVOP);
7138     OpTYPE_set(svop, type);
7139     svop->op_sv = sv;
7140     svop->op_next = (OP*)svop;
7141     svop->op_flags = (U8)flags;
7142     svop->op_private = (U8)(0 | (flags >> 8));
7143     if (PL_opargs[type] & OA_RETSCALAR)
7144         scalar((OP*)svop);
7145     if (PL_opargs[type] & OA_TARGET)
7146         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7147     return CHECKOP(type, svop);
7148 }
7149
7150 /*
7151 =for apidoc Am|OP *|newDEFSVOP|
7152
7153 Constructs and returns an op to access C<$_>.
7154
7155 =cut
7156 */
7157
7158 OP *
7159 Perl_newDEFSVOP(pTHX)
7160 {
7161         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7162 }
7163
7164 #ifdef USE_ITHREADS
7165
7166 /*
7167 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7168
7169 Constructs, checks, and returns an op of any type that involves a
7170 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7171 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7172 is populated with C<sv>; this function takes ownership of one reference
7173 to it.
7174
7175 This function only exists if Perl has been compiled to use ithreads.
7176
7177 =cut
7178 */
7179
7180 OP *
7181 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7182 {
7183     dVAR;
7184     PADOP *padop;
7185
7186     PERL_ARGS_ASSERT_NEWPADOP;
7187
7188     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7189         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7190         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7191         || type == OP_CUSTOM);
7192
7193     NewOp(1101, padop, 1, PADOP);
7194     OpTYPE_set(padop, type);
7195     padop->op_padix =
7196         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7197     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7198     PAD_SETSV(padop->op_padix, sv);
7199     assert(sv);
7200     padop->op_next = (OP*)padop;
7201     padop->op_flags = (U8)flags;
7202     if (PL_opargs[type] & OA_RETSCALAR)
7203         scalar((OP*)padop);
7204     if (PL_opargs[type] & OA_TARGET)
7205         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7206     return CHECKOP(type, padop);
7207 }
7208
7209 #endif /* USE_ITHREADS */
7210
7211 /*
7212 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7213
7214 Constructs, checks, and returns an op of any type that involves an
7215 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7216 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7217 reference; calling this function does not transfer ownership of any
7218 reference to it.
7219
7220 =cut
7221 */
7222
7223 OP *
7224 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7225 {
7226     PERL_ARGS_ASSERT_NEWGVOP;
7227
7228 #ifdef USE_ITHREADS
7229     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7230 #else
7231     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7232 #endif
7233 }
7234
7235 /*
7236 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7237
7238 Constructs, checks, and returns an op of any type that involves an
7239 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7240 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7241 Depending on the op type, the memory referenced by C<pv> may be freed
7242 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7243 have been allocated using C<PerlMemShared_malloc>.
7244
7245 =cut
7246 */
7247
7248 OP *
7249 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7250 {
7251     dVAR;
7252     const bool utf8 = cBOOL(flags & SVf_UTF8);
7253     PVOP *pvop;
7254
7255     flags &= ~SVf_UTF8;
7256
7257     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7258         || type == OP_RUNCV || type == OP_CUSTOM
7259         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7260
7261     NewOp(1101, pvop, 1, PVOP);
7262     OpTYPE_set(pvop, type);
7263     pvop->op_pv = pv;
7264     pvop->op_next = (OP*)pvop;
7265     pvop->op_flags = (U8)flags;
7266     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7267     if (PL_opargs[type] & OA_RETSCALAR)
7268         scalar((OP*)pvop);
7269     if (PL_opargs[type] & OA_TARGET)
7270         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7271     return CHECKOP(type, pvop);
7272 }
7273
7274 void
7275 Perl_package(pTHX_ OP *o)
7276 {
7277     SV *const sv = cSVOPo->op_sv;
7278
7279     PERL_ARGS_ASSERT_PACKAGE;
7280
7281     SAVEGENERICSV(PL_curstash);
7282     save_item(PL_curstname);
7283
7284     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7285
7286     sv_setsv(PL_curstname, sv);
7287
7288     PL_hints |= HINT_BLOCK_SCOPE;
7289     PL_parser->copline = NOLINE;
7290
7291     op_free(o);
7292 }
7293
7294 void
7295 Perl_package_version( pTHX_ OP *v )
7296 {
7297     U32 savehints = PL_hints;
7298     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7299     PL_hints &= ~HINT_STRICT_VARS;
7300     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7301     PL_hints = savehints;
7302     op_free(v);
7303 }
7304
7305 void
7306 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7307 {
7308     OP *pack;
7309     OP *imop;
7310     OP *veop;
7311     SV *use_version = NULL;
7312
7313     PERL_ARGS_ASSERT_UTILIZE;
7314
7315     if (idop->op_type != OP_CONST)
7316         Perl_croak(aTHX_ "Module name must be constant");
7317
7318     veop = NULL;
7319
7320     if (version) {
7321         SV * const vesv = ((SVOP*)version)->op_sv;
7322
7323         if (!arg && !SvNIOKp(vesv)) {
7324             arg = version;
7325         }
7326         else {
7327             OP *pack;
7328             SV *meth;
7329
7330             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7331                 Perl_croak(aTHX_ "Version number must be a constant number");
7332
7333             /* Make copy of idop so we don't free it twice */
7334             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7335
7336             /* Fake up a method call to VERSION */
7337             meth = newSVpvs_share("VERSION");
7338             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7339                             op_append_elem(OP_LIST,
7340                                         op_prepend_elem(OP_LIST, pack, version),
7341                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7342         }
7343     }
7344
7345     /* Fake up an import/unimport */
7346     if (arg && arg->op_type == OP_STUB) {
7347         imop = arg;             /* no import on explicit () */
7348     }
7349     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7350         imop = NULL;            /* use 5.0; */
7351         if (aver)
7352             use_version = ((SVOP*)idop)->op_sv;
7353         else
7354             idop->op_private |= OPpCONST_NOVER;
7355     }
7356     else {
7357         SV *meth;
7358
7359         /* Make copy of idop so we don't free it twice */
7360         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7361
7362         /* Fake up a method call to import/unimport */
7363         meth = aver
7364             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7365         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7366                        op_append_elem(OP_LIST,
7367                                    op_prepend_elem(OP_LIST, pack, arg),
7368                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7369                        ));
7370     }
7371
7372     /* Fake up the BEGIN {}, which does its thing immediately. */
7373     newATTRSUB(floor,
7374         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7375         NULL,
7376         NULL,
7377         op_append_elem(OP_LINESEQ,
7378             op_append_elem(OP_LINESEQ,
7379                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7380                 newSTATEOP(0, NULL, veop)),
7381             newSTATEOP(0, NULL, imop) ));
7382
7383     if (use_version) {
7384         /* Enable the
7385          * feature bundle that corresponds to the required version. */
7386         use_version = sv_2mortal(new_version(use_version));
7387         S_enable_feature_bundle(aTHX_ use_version);
7388
7389         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7390         if (vcmp(use_version,
7391                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7392             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7393                 PL_hints |= HINT_STRICT_REFS;
7394             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7395                 PL_hints |= HINT_STRICT_SUBS;
7396             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7397                 PL_hints |= HINT_STRICT_VARS;
7398         }
7399         /* otherwise they are off */
7400         else {
7401             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7402                 PL_hints &= ~HINT_STRICT_REFS;
7403             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7404                 PL_hints &= ~HINT_STRICT_SUBS;
7405             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7406                 PL_hints &= ~HINT_STRICT_VARS;
7407         }
7408     }
7409
7410     /* The "did you use incorrect case?" warning used to be here.
7411      * The problem is that on case-insensitive filesystems one
7412      * might get false positives for "use" (and "require"):
7413      * "use Strict" or "require CARP" will work.  This causes
7414      * portability problems for the script: in case-strict
7415      * filesystems the script will stop working.
7416      *
7417      * The "incorrect case" warning checked whether "use Foo"
7418      * imported "Foo" to your namespace, but that is wrong, too:
7419      * there is no requirement nor promise in the language that
7420      * a Foo.pm should or would contain anything in package "Foo".
7421      *
7422      * There is very little Configure-wise that can be done, either:
7423      * the case-sensitivity of the build filesystem of Perl does not
7424      * help in guessing the case-sensitivity of the runtime environment.
7425      */
7426
7427     PL_hints |= HINT_BLOCK_SCOPE;
7428     PL_parser->copline = NOLINE;
7429     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7430 }
7431
7432 /*
7433 =head1 Embedding Functions
7434
7435 =for apidoc load_module
7436
7437 Loads the module whose name is pointed to by the string part of C<name>.
7438 Note that the actual module name, not its filename, should be given.
7439 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7440 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7441 trailing arguments can be used to specify arguments to the module's C<import()>
7442 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7443 on the flags. The flags argument is a bitwise-ORed collection of any of
7444 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7445 (or 0 for no flags).
7446
7447 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7448 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7449 the trailing optional arguments may be omitted entirely. Otherwise, if
7450 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7451 exactly one C<OP*>, containing the op tree that produces the relevant import
7452 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7453 will be used as import arguments; and the list must be terminated with C<(SV*)
7454 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7455 set, the trailing C<NULL> pointer is needed even if no import arguments are
7456 desired. The reference count for each specified C<SV*> argument is
7457 decremented. In addition, the C<name> argument is modified.
7458
7459 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7460 than C<use>.
7461
7462 =cut */
7463
7464 void
7465 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7466 {
7467     va_list args;
7468
7469     PERL_ARGS_ASSERT_LOAD_MODULE;
7470
7471     va_start(args, ver);
7472     vload_module(flags, name, ver, &args);
7473     va_end(args);
7474 }
7475
7476 #ifdef PERL_IMPLICIT_CONTEXT
7477 void
7478 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7479 {
7480     dTHX;
7481     va_list args;
7482     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7483     va_start(args, ver);
7484     vload_module(flags, name, ver, &args);
7485     va_end(args);
7486 }
7487 #endif
7488
7489 void
7490 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7491 {
7492     OP *veop, *imop;
7493     OP * const modname = newSVOP(OP_CONST, 0, name);
7494
7495     PERL_ARGS_ASSERT_VLOAD_MODULE;
7496
7497     modname->op_private |= OPpCONST_BARE;
7498     if (ver) {
7499         veop = newSVOP(OP_CONST, 0, ver);
7500     }
7501     else
7502         veop = NULL;
7503     if (flags & PERL_LOADMOD_NOIMPORT) {
7504         imop = sawparens(newNULLLIST());
7505     }
7506     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7507         imop = va_arg(*args, OP*);
7508     }
7509     else {
7510         SV *sv;
7511         imop = NULL;
7512         sv = va_arg(*args, SV*);
7513         while (sv) {
7514             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7515             sv = va_arg(*args, SV*);
7516         }
7517     }
7518
7519     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7520      * that it has a PL_parser to play with while doing that, and also
7521      * that it doesn't mess with any existing parser, by creating a tmp
7522      * new parser with lex_start(). This won't actually be used for much,
7523      * since pp_require() will create another parser for the real work.
7524      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7525
7526     ENTER;
7527     SAVEVPTR(PL_curcop);
7528     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7529     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7530             veop, modname, imop);
7531     LEAVE;
7532 }
7533
7534 PERL_STATIC_INLINE OP *
7535 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7536 {
7537     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7538                    newLISTOP(OP_LIST, 0, arg,
7539                              newUNOP(OP_RV2CV, 0,
7540                                      newGVOP(OP_GV, 0, gv))));
7541 }
7542
7543 OP *
7544 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7545 {
7546     OP *doop;
7547     GV *gv;
7548
7549     PERL_ARGS_ASSERT_DOFILE;
7550
7551     if (!force_builtin && (gv = gv_override("do", 2))) {
7552         doop = S_new_entersubop(aTHX_ gv, term);
7553     }
7554     else {
7555         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7556     }
7557     return doop;
7558 }
7559
7560 /*
7561 =head1 Optree construction
7562
7563 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7564
7565 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7566 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7567 be set automatically, and, shifted up eight bits, the eight bits of
7568 C<op_private>, except that the bit with value 1 or 2 is automatically
7569 set as required.  C<listval> and C<subscript> supply the parameters of
7570 the slice; they are consumed by this function and become part of the
7571 constructed op tree.
7572
7573 =cut
7574 */
7575
7576 OP *
7577 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7578 {
7579     return newBINOP(OP_LSLICE, flags,
7580             list(force_list(subscript, 1)),
7581             list(force_list(listval,   1)) );
7582 }
7583
7584 #define ASSIGN_LIST   1
7585 #define ASSIGN_REF    2
7586
7587 STATIC I32
7588 S_assignment_type(pTHX_ const OP *o)
7589 {
7590     unsigned type;
7591     U8 flags;
7592     U8 ret;
7593
7594     if (!o)
7595         return TRUE;
7596
7597     if (o->op_type == OP_SREFGEN)
7598     {
7599         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7600         type = kid->op_type;
7601         flags = o->op_flags | kid->op_flags;
7602         if (!(flags & OPf_PARENS)
7603           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7604               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7605             return ASSIGN_REF;
7606         ret = ASSIGN_REF;
7607     } else {
7608         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7609             o = cUNOPo->op_first;
7610         flags = o->op_flags;
7611         type = o->op_type;
7612         ret = 0;
7613     }
7614
7615     if (type == OP_COND_EXPR) {
7616         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7617         const I32 t = assignment_type(sib);
7618         const I32 f = assignment_type(OpSIBLING(sib));
7619
7620         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7621             return ASSIGN_LIST;
7622         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7623             yyerror("Assignment to both a list and a scalar");
7624         return FALSE;
7625     }
7626
7627     if (type == OP_LIST &&
7628         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7629         o->op_private & OPpLVAL_INTRO)
7630         return ret;
7631
7632     if (type == OP_LIST || flags & OPf_PARENS ||
7633         type == OP_RV2AV || type == OP_RV2HV ||
7634         type == OP_ASLICE || type == OP_HSLICE ||
7635         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7636         return TRUE;
7637
7638     if (type == OP_PADAV || type == OP_PADHV)
7639         return TRUE;
7640
7641     if (type == OP_RV2SV)
7642         return ret;
7643
7644     return ret;
7645 }
7646
7647 static OP *
7648 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7649 {
7650     const PADOFFSET target = padop->op_targ;
7651     OP *const other = newOP(OP_PADSV,
7652                             padop->op_flags
7653                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7654     OP *const first = newOP(OP_NULL, 0);
7655     OP *const nullop = newCONDOP(0, first, initop, other);
7656     /* XXX targlex disabled for now; see ticket #124160
7657         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7658      */
7659     OP *const condop = first->op_next;
7660
7661     OpTYPE_set(condop, OP_ONCE);
7662     other->op_targ = target;
7663     nullop->op_flags |= OPf_WANT_SCALAR;
7664
7665     /* Store the initializedness of state vars in a separate
7666        pad entry.  */
7667     condop->op_targ =
7668       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7669     /* hijacking PADSTALE for uninitialized state variables */
7670     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7671
7672     return nullop;
7673 }
7674
7675 /*
7676 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7677
7678 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7679 supply the parameters of the assignment; they are consumed by this
7680 function and become part of the constructed op tree.
7681
7682 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7683 a suitable conditional optree is constructed.  If C<optype> is the opcode
7684 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7685 performs the binary operation and assigns the result to the left argument.
7686 Either way, if C<optype> is non-zero then C<flags> has no effect.
7687
7688 If C<optype> is zero, then a plain scalar or list assignment is
7689 constructed.  Which type of assignment it is is automatically determined.
7690 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7691 will be set automatically, and, shifted up eight bits, the eight bits
7692 of C<op_private>, except that the bit with value 1 or 2 is automatically
7693 set as required.
7694
7695 =cut
7696 */
7697
7698 OP *
7699 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7700 {
7701     OP *o;
7702     I32 assign_type;
7703
7704     if (optype) {
7705         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7706             right = scalar(right);
7707             return newLOGOP(optype, 0,
7708                 op_lvalue(scalar(left), optype),
7709                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7710         }
7711         else {
7712             return newBINOP(optype, OPf_STACKED,
7713                 op_lvalue(scalar(left), optype), scalar(right));
7714         }
7715     }
7716
7717     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7718         OP *state_var_op = NULL;
7719         static const char no_list_state[] = "Initialization of state variables"
7720             " in list currently forbidden";
7721         OP *curop;
7722
7723         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7724             left->op_private &= ~ OPpSLICEWARNING;
7725
7726         PL_modcount = 0;
7727         left = op_lvalue(left, OP_AASSIGN);
7728         curop = list(force_list(left, 1));
7729         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7730         o->op_private = (U8)(0 | (flags >> 8));
7731
7732         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7733         {
7734             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7735             if (!(left->op_flags & OPf_PARENS) &&
7736                     lop->op_type == OP_PUSHMARK &&
7737                     (vop = OpSIBLING(lop)) &&
7738                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7739                     !(vop->op_flags & OPf_PARENS) &&
7740                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7741                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7742                     (eop = OpSIBLING(vop)) &&
7743                     eop->op_type == OP_ENTERSUB &&
7744                     !OpHAS_SIBLING(eop)) {
7745                 state_var_op = vop;
7746             } else {
7747                 while (lop) {
7748                     if ((lop->op_type == OP_PADSV ||
7749                          lop->op_type == OP_PADAV ||
7750                          lop->op_type == OP_PADHV ||
7751                          lop->op_type == OP_PADANY)
7752                       && (lop->op_private & OPpPAD_STATE)
7753                     )
7754                         yyerror(no_list_state);
7755                     lop = OpSIBLING(lop);
7756                 }
7757             }
7758         }
7759         else if (  (left->op_private & OPpLVAL_INTRO)
7760                 && (left->op_private & OPpPAD_STATE)
7761                 && (   left->op_type == OP_PADSV
7762                     || left->op_type == OP_PADAV
7763                     || left->op_type == OP_PADHV
7764                     || left->op_type == OP_PADANY)
7765         ) {
7766                 /* All single variable list context state assignments, hence
7767                    state ($a) = ...
7768                    (state $a) = ...
7769                    state @a = ...
7770                    state (@a) = ...
7771                    (state @a) = ...
7772                    state %a = ...
7773                    state (%a) = ...
7774                    (state %a) = ...
7775                 */
7776                 if (left->op_flags & OPf_PARENS)
7777                     yyerror(no_list_state);
7778                 else
7779                     state_var_op = left;
7780         }
7781
7782         /* optimise @a = split(...) into:
7783         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7784         * @a, my @a, local @a:  split(...)          (where @a is attached to
7785         *                                            the split op itself)
7786         */
7787
7788         if (   right
7789             && right->op_type == OP_SPLIT
7790             /* don't do twice, e.g. @b = (@a = split) */
7791             && !(right->op_private & OPpSPLIT_ASSIGN))
7792         {
7793             OP *gvop = NULL;
7794
7795             if (   (  left->op_type == OP_RV2AV
7796                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7797                 || left->op_type == OP_PADAV)
7798             {
7799                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7800                 OP *tmpop;
7801                 if (gvop) {
7802 #ifdef USE_ITHREADS
7803                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7804                         = cPADOPx(gvop)->op_padix;
7805                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7806 #else
7807                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7808                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7809                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7810 #endif
7811                     right->op_private |=
7812                         left->op_private & OPpOUR_INTRO;
7813                 }
7814                 else {
7815                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7816                     left->op_targ = 0;  /* steal it */
7817                     right->op_private |= OPpSPLIT_LEX;
7818                 }
7819                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7820
7821               detach_split:
7822                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7823                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7824                 assert(OpSIBLING(tmpop) == right);
7825                 assert(!OpHAS_SIBLING(right));
7826                 /* detach the split subtreee from the o tree,
7827                  * then free the residual o tree */
7828                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7829                 op_free(o);                     /* blow off assign */
7830                 right->op_private |= OPpSPLIT_ASSIGN;
7831                 right->op_flags &= ~OPf_WANT;
7832                         /* "I don't know and I don't care." */
7833                 return right;
7834             }
7835             else if (left->op_type == OP_RV2AV) {
7836                 /* @{expr} */
7837
7838                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7839                 assert(OpSIBLING(pushop) == left);
7840                 /* Detach the array ...  */
7841                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7842                 /* ... and attach it to the split.  */
7843                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7844                                   0, left);
7845                 right->op_flags |= OPf_STACKED;
7846                 /* Detach split and expunge aassign as above.  */
7847                 goto detach_split;
7848             }
7849             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7850                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
7851             {
7852                 /* convert split(...,0) to split(..., PL_modcount+1) */
7853                 SV ** const svp =
7854                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7855                 SV * const sv = *svp;
7856                 if (SvIOK(sv) && SvIVX(sv) == 0)
7857                 {
7858                   if (right->op_private & OPpSPLIT_IMPLIM) {
7859                     /* our own SV, created in ck_split */
7860                     SvREADONLY_off(sv);
7861                     sv_setiv(sv, PL_modcount+1);
7862                   }
7863                   else {
7864                     /* SV may belong to someone else */
7865                     SvREFCNT_dec(sv);
7866                     *svp = newSViv(PL_modcount+1);
7867                   }
7868                 }
7869             }
7870         }
7871
7872         if (state_var_op)
7873             o = S_newONCEOP(aTHX_ o, state_var_op);
7874         return o;
7875     }
7876     if (assign_type == ASSIGN_REF)
7877         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7878     if (!right)
7879         right = newOP(OP_UNDEF, 0);
7880     if (right->op_type == OP_READLINE) {
7881         right->op_flags |= OPf_STACKED;
7882         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7883                 scalar(right));
7884     }
7885     else {
7886         o = newBINOP(OP_SASSIGN, flags,
7887             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
7888     }
7889     return o;
7890 }
7891
7892 /*
7893 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
7894
7895 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
7896 but will be a C<dbstate> op if debugging is enabled for currently-compiled
7897 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
7898 If C<label> is non-null, it supplies the name of a label to attach to
7899 the state op; this function takes ownership of the memory pointed at by
7900 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
7901 for the state op.
7902
7903 If C<o> is null, the state op is returned.  Otherwise the state op is
7904 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
7905 is consumed by this function and becomes part of the returned op tree.
7906
7907 =cut
7908 */
7909
7910 OP *
7911 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
7912 {
7913     dVAR;
7914     const U32 seq = intro_my();
7915     const U32 utf8 = flags & SVf_UTF8;
7916     COP *cop;
7917
7918     PL_parser->parsed_sub = 0;
7919
7920     flags &= ~SVf_UTF8;
7921
7922     NewOp(1101, cop, 1, COP);
7923     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
7924         OpTYPE_set(cop, OP_DBSTATE);
7925     }
7926     else {
7927         OpTYPE_set(cop, OP_NEXTSTATE);
7928     }
7929     cop->op_flags = (U8)flags;
7930     CopHINTS_set(cop, PL_hints);
7931 #ifdef VMS
7932     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
7933 #endif
7934     cop->op_next = (OP*)cop;
7935
7936     cop->cop_seq = seq;
7937     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7938     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
7939     if (label) {
7940         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
7941
7942         PL_hints |= HINT_BLOCK_SCOPE;
7943         /* It seems that we need to defer freeing this pointer, as other parts
7944            of the grammar end up wanting to copy it after this op has been
7945            created. */
7946         SAVEFREEPV(label);
7947     }
7948
7949     if (PL_parser->preambling != NOLINE) {
7950         CopLINE_set(cop, PL_parser->preambling);
7951         PL_parser->copline = NOLINE;
7952     }
7953     else if (PL_parser->copline == NOLINE)
7954         CopLINE_set(cop, CopLINE(PL_curcop));
7955     else {
7956         CopLINE_set(cop, PL_parser->copline);
7957         PL_parser->copline = NOLINE;
7958     }
7959 #ifdef USE_ITHREADS
7960     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
7961 #else
7962     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
7963 #endif
7964     CopSTASH_set(cop, PL_curstash);
7965
7966     if (cop->op_type == OP_DBSTATE) {
7967         /* this line can have a breakpoint - store the cop in IV */
7968         AV *av = CopFILEAVx(PL_curcop);
7969         if (av) {
7970             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
7971             if (svp && *svp != &PL_sv_undef ) {
7972                 (void)SvIOK_on(*svp);
7973                 SvIV_set(*svp, PTR2IV(cop));
7974             }
7975         }
7976     }
7977
7978     if (flags & OPf_SPECIAL)
7979         op_null((OP*)cop);
7980     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
7981 }
7982
7983 /*
7984 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
7985
7986 Constructs, checks, and returns a logical (flow control) op.  C<type>
7987 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
7988 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
7989 the eight bits of C<op_private>, except that the bit with value 1 is
7990 automatically set.  C<first> supplies the expression controlling the
7991 flow, and C<other> supplies the side (alternate) chain of ops; they are
7992 consumed by this function and become part of the constructed op tree.
7993
7994 =cut
7995 */
7996
7997 OP *
7998 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
7999 {
8000     PERL_ARGS_ASSERT_NEWLOGOP;
8001
8002     return new_logop(type, flags, &first, &other);
8003 }
8004
8005 STATIC OP *
8006 S_search_const(pTHX_ OP *o)
8007 {
8008     PERL_ARGS_ASSERT_SEARCH_CONST;
8009
8010     switch (o->op_type) {
8011         case OP_CONST:
8012             return o;
8013         case OP_NULL:
8014             if (o->op_flags & OPf_KIDS)
8015                 return search_const(cUNOPo->op_first);
8016             break;
8017         case OP_LEAVE:
8018         case OP_SCOPE:
8019         case OP_LINESEQ:
8020         {
8021             OP *kid;
8022             if (!(o->op_flags & OPf_KIDS))
8023                 return NULL;
8024             kid = cLISTOPo->op_first;
8025             do {
8026                 switch (kid->op_type) {
8027                     case OP_ENTER:
8028                     case OP_NULL:
8029                     case OP_NEXTSTATE:
8030                         kid = OpSIBLING(kid);
8031                         break;
8032                     default:
8033                         if (kid != cLISTOPo->op_last)
8034                             return NULL;
8035                         goto last;
8036                 }
8037             } while (kid);
8038             if (!kid)
8039                 kid = cLISTOPo->op_last;
8040           last:
8041             return search_const(kid);
8042         }
8043     }
8044
8045     return NULL;
8046 }
8047
8048 STATIC OP *
8049 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8050 {
8051     dVAR;
8052     LOGOP *logop;
8053     OP *o;
8054     OP *first;
8055     OP *other;
8056     OP *cstop = NULL;
8057     int prepend_not = 0;
8058
8059     PERL_ARGS_ASSERT_NEW_LOGOP;
8060
8061     first = *firstp;
8062     other = *otherp;
8063
8064     /* [perl #59802]: Warn about things like "return $a or $b", which
8065        is parsed as "(return $a) or $b" rather than "return ($a or
8066        $b)".  NB: This also applies to xor, which is why we do it
8067        here.
8068      */
8069     switch (first->op_type) {
8070     case OP_NEXT:
8071     case OP_LAST:
8072     case OP_REDO:
8073         /* XXX: Perhaps we should emit a stronger warning for these.
8074            Even with the high-precedence operator they don't seem to do
8075            anything sensible.
8076
8077            But until we do, fall through here.
8078          */
8079     case OP_RETURN:
8080     case OP_EXIT:
8081     case OP_DIE:
8082     case OP_GOTO:
8083         /* XXX: Currently we allow people to "shoot themselves in the
8084            foot" by explicitly writing "(return $a) or $b".
8085
8086            Warn unless we are looking at the result from folding or if
8087            the programmer explicitly grouped the operators like this.
8088            The former can occur with e.g.
8089
8090                 use constant FEATURE => ( $] >= ... );
8091                 sub { not FEATURE and return or do_stuff(); }
8092          */
8093         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8094             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8095                            "Possible precedence issue with control flow operator");
8096         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8097            the "or $b" part)?
8098         */
8099         break;
8100     }
8101
8102     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8103         return newBINOP(type, flags, scalar(first), scalar(other));
8104
8105     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8106         || type == OP_CUSTOM);
8107
8108     scalarboolean(first);
8109
8110     /* search for a constant op that could let us fold the test */
8111     if ((cstop = search_const(first))) {
8112         if (cstop->op_private & OPpCONST_STRICT)
8113             no_bareword_allowed(cstop);
8114         else if ((cstop->op_private & OPpCONST_BARE))
8115                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8116         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8117             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8118             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8119             /* Elide the (constant) lhs, since it can't affect the outcome */
8120             *firstp = NULL;
8121             if (other->op_type == OP_CONST)
8122                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8123             op_free(first);
8124             if (other->op_type == OP_LEAVE)
8125                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8126             else if (other->op_type == OP_MATCH
8127                   || other->op_type == OP_SUBST
8128                   || other->op_type == OP_TRANSR
8129                   || other->op_type == OP_TRANS)
8130                 /* Mark the op as being unbindable with =~ */
8131                 other->op_flags |= OPf_SPECIAL;
8132
8133             other->op_folded = 1;
8134             return other;
8135         }
8136         else {
8137             /* Elide the rhs, since the outcome is entirely determined by
8138              * the (constant) lhs */
8139
8140             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8141             const OP *o2 = other;
8142             if ( ! (o2->op_type == OP_LIST
8143                     && (( o2 = cUNOPx(o2)->op_first))
8144                     && o2->op_type == OP_PUSHMARK
8145                     && (( o2 = OpSIBLING(o2))) )
8146             )
8147                 o2 = other;
8148             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8149                         || o2->op_type == OP_PADHV)
8150                 && o2->op_private & OPpLVAL_INTRO
8151                 && !(o2->op_private & OPpPAD_STATE))
8152             {
8153                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8154                                 "Deprecated use of my() in false conditional. "
8155                                 "This will be a fatal error in Perl 5.30");
8156             }
8157
8158             *otherp = NULL;
8159             if (cstop->op_type == OP_CONST)
8160                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8161             op_free(other);
8162             return first;
8163         }
8164     }
8165     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8166         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8167     {
8168         const OP * const k1 = ((UNOP*)first)->op_first;
8169         const OP * const k2 = OpSIBLING(k1);
8170         OPCODE warnop = 0;
8171         switch (first->op_type)
8172         {
8173         case OP_NULL:
8174             if (k2 && k2->op_type == OP_READLINE
8175                   && (k2->op_flags & OPf_STACKED)
8176                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8177             {
8178                 warnop = k2->op_type;
8179             }
8180             break;
8181
8182         case OP_SASSIGN:
8183             if (k1->op_type == OP_READDIR
8184                   || k1->op_type == OP_GLOB
8185                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8186                  || k1->op_type == OP_EACH
8187                  || k1->op_type == OP_AEACH)
8188             {
8189                 warnop = ((k1->op_type == OP_NULL)
8190                           ? (OPCODE)k1->op_targ : k1->op_type);
8191             }
8192             break;
8193         }
8194         if (warnop) {
8195             const line_t oldline = CopLINE(PL_curcop);
8196             /* This ensures that warnings are reported at the first line
8197                of the construction, not the last.  */
8198             CopLINE_set(PL_curcop, PL_parser->copline);
8199             Perl_warner(aTHX_ packWARN(WARN_MISC),
8200                  "Value of %s%s can be \"0\"; test with defined()",
8201                  PL_op_desc[warnop],
8202                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8203                   ? " construct" : "() operator"));
8204             CopLINE_set(PL_curcop, oldline);
8205         }
8206     }
8207
8208     /* optimize AND and OR ops that have NOTs as children */
8209     if (first->op_type == OP_NOT
8210         && (first->op_flags & OPf_KIDS)
8211         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8212             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8213         ) {
8214         if (type == OP_AND || type == OP_OR) {
8215             if (type == OP_AND)
8216                 type = OP_OR;
8217             else
8218                 type = OP_AND;
8219             op_null(first);
8220             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8221                 op_null(other);
8222                 prepend_not = 1; /* prepend a NOT op later */
8223             }
8224         }
8225     }
8226
8227     logop = alloc_LOGOP(type, first, LINKLIST(other));
8228     logop->op_flags |= (U8)flags;
8229     logop->op_private = (U8)(1 | (flags >> 8));
8230
8231     /* establish postfix order */
8232     logop->op_next = LINKLIST(first);
8233     first->op_next = (OP*)logop;
8234     assert(!OpHAS_SIBLING(first));
8235     op_sibling_splice((OP*)logop, first, 0, other);
8236
8237     CHECKOP(type,logop);
8238
8239     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8240                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8241                 (OP*)logop);
8242     other->op_next = o;
8243
8244     return o;
8245 }
8246
8247 /*
8248 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8249
8250 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8251 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8252 will be set automatically, and, shifted up eight bits, the eight bits of
8253 C<op_private>, except that the bit with value 1 is automatically set.
8254 C<first> supplies the expression selecting between the two branches,
8255 and C<trueop> and C<falseop> supply the branches; they are consumed by
8256 this function and become part of the constructed op tree.
8257
8258 =cut
8259 */
8260
8261 OP *
8262 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8263 {
8264     dVAR;
8265     LOGOP *logop;
8266     OP *start;
8267     OP *o;
8268     OP *cstop;
8269
8270     PERL_ARGS_ASSERT_NEWCONDOP;
8271
8272     if (!falseop)
8273         return newLOGOP(OP_AND, 0, first, trueop);
8274     if (!trueop)
8275         return newLOGOP(OP_OR, 0, first, falseop);
8276
8277     scalarboolean(first);
8278     if ((cstop = search_const(first))) {
8279         /* Left or right arm of the conditional?  */
8280         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8281         OP *live = left ? trueop : falseop;
8282         OP *const dead = left ? falseop : trueop;
8283         if (cstop->op_private & OPpCONST_BARE &&
8284             cstop->op_private & OPpCONST_STRICT) {
8285             no_bareword_allowed(cstop);
8286         }
8287         op_free(first);
8288         op_free(dead);
8289         if (live->op_type == OP_LEAVE)
8290             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8291         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8292               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8293             /* Mark the op as being unbindable with =~ */
8294             live->op_flags |= OPf_SPECIAL;
8295         live->op_folded = 1;
8296         return live;
8297     }
8298     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8299     logop->op_flags |= (U8)flags;
8300     logop->op_private = (U8)(1 | (flags >> 8));
8301     logop->op_next = LINKLIST(falseop);
8302
8303     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8304             logop);
8305
8306     /* establish postfix order */
8307     start = LINKLIST(first);
8308     first->op_next = (OP*)logop;
8309
8310     /* make first, trueop, falseop siblings */
8311     op_sibling_splice((OP*)logop, first,  0, trueop);
8312     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8313
8314     o = newUNOP(OP_NULL, 0, (OP*)logop);
8315
8316     trueop->op_next = falseop->op_next = o;
8317
8318     o->op_next = start;
8319     return o;
8320 }
8321
8322 /*
8323 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8324
8325 Constructs and returns a C<range> op, with subordinate C<flip> and
8326 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8327 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8328 for both the C<flip> and C<range> ops, except that the bit with value
8329 1 is automatically set.  C<left> and C<right> supply the expressions
8330 controlling the endpoints of the range; they are consumed by this function
8331 and become part of the constructed op tree.
8332
8333 =cut
8334 */
8335
8336 OP *
8337 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8338 {
8339     LOGOP *range;
8340     OP *flip;
8341     OP *flop;
8342     OP *leftstart;
8343     OP *o;
8344
8345     PERL_ARGS_ASSERT_NEWRANGE;
8346
8347     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8348     range->op_flags = OPf_KIDS;
8349     leftstart = LINKLIST(left);
8350     range->op_private = (U8)(1 | (flags >> 8));
8351
8352     /* make left and right siblings */
8353     op_sibling_splice((OP*)range, left, 0, right);
8354
8355     range->op_next = (OP*)range;
8356     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8357     flop = newUNOP(OP_FLOP, 0, flip);
8358     o = newUNOP(OP_NULL, 0, flop);
8359     LINKLIST(flop);
8360     range->op_next = leftstart;
8361
8362     left->op_next = flip;
8363     right->op_next = flop;
8364
8365     range->op_targ =
8366         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8367     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8368     flip->op_targ =
8369         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8370     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8371     SvPADTMP_on(PAD_SV(flip->op_targ));
8372
8373     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8374     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8375
8376     /* check barewords before they might be optimized aways */
8377     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8378         no_bareword_allowed(left);
8379     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8380         no_bareword_allowed(right);
8381
8382     flip->op_next = o;
8383     if (!flip->op_private || !flop->op_private)
8384         LINKLIST(o);            /* blow off optimizer unless constant */
8385
8386     return o;
8387 }
8388
8389 /*
8390 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8391
8392 Constructs, checks, and returns an op tree expressing a loop.  This is
8393 only a loop in the control flow through the op tree; it does not have
8394 the heavyweight loop structure that allows exiting the loop by C<last>
8395 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8396 top-level op, except that some bits will be set automatically as required.
8397 C<expr> supplies the expression controlling loop iteration, and C<block>
8398 supplies the body of the loop; they are consumed by this function and
8399 become part of the constructed op tree.  C<debuggable> is currently
8400 unused and should always be 1.
8401
8402 =cut
8403 */
8404
8405 OP *
8406 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8407 {
8408     OP* listop;
8409     OP* o;
8410     const bool once = block && block->op_flags & OPf_SPECIAL &&
8411                       block->op_type == OP_NULL;
8412
8413     PERL_UNUSED_ARG(debuggable);
8414
8415     if (expr) {
8416         if (once && (
8417               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8418            || (  expr->op_type == OP_NOT
8419               && cUNOPx(expr)->op_first->op_type == OP_CONST
8420               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8421               )
8422            ))
8423             /* Return the block now, so that S_new_logop does not try to
8424                fold it away. */
8425             return block;       /* do {} while 0 does once */
8426         if (expr->op_type == OP_READLINE
8427             || expr->op_type == OP_READDIR
8428             || expr->op_type == OP_GLOB
8429             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8430             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8431             expr = newUNOP(OP_DEFINED, 0,
8432                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8433         } else if (expr->op_flags & OPf_KIDS) {
8434             const OP * const k1 = ((UNOP*)expr)->op_first;
8435             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8436             switch (expr->op_type) {
8437               case OP_NULL:
8438                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8439                       && (k2->op_flags & OPf_STACKED)
8440                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8441                     expr = newUNOP(OP_DEFINED, 0, expr);
8442                 break;
8443
8444               case OP_SASSIGN:
8445                 if (k1 && (k1->op_type == OP_READDIR
8446                       || k1->op_type == OP_GLOB
8447                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8448                      || k1->op_type == OP_EACH
8449                      || k1->op_type == OP_AEACH))
8450                     expr = newUNOP(OP_DEFINED, 0, expr);
8451                 break;
8452             }
8453         }
8454     }
8455
8456     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8457      * op, in listop. This is wrong. [perl #27024] */
8458     if (!block)
8459         block = newOP(OP_NULL, 0);
8460     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8461     o = new_logop(OP_AND, 0, &expr, &listop);
8462
8463     if (once) {
8464         ASSUME(listop);
8465     }
8466
8467     if (listop)
8468         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8469
8470     if (once && o != listop)
8471     {
8472         assert(cUNOPo->op_first->op_type == OP_AND
8473             || cUNOPo->op_first->op_type == OP_OR);
8474         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8475     }
8476
8477     if (o == listop)
8478         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8479
8480     o->op_flags |= flags;
8481     o = op_scope(o);
8482     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8483     return o;
8484 }
8485
8486 /*
8487 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8488
8489 Constructs, checks, and returns an op tree expressing a C<while> loop.
8490 This is a heavyweight loop, with structure that allows exiting the loop
8491 by C<last> and suchlike.
8492
8493 C<loop> is an optional preconstructed C<enterloop> op to use in the
8494 loop; if it is null then a suitable op will be constructed automatically.
8495 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8496 main body of the loop, and C<cont> optionally supplies a C<continue> block
8497 that operates as a second half of the body.  All of these optree inputs
8498 are consumed by this function and become part of the constructed op tree.
8499
8500 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8501 op and, shifted up eight bits, the eight bits of C<op_private> for
8502 the C<leaveloop> op, except that (in both cases) some bits will be set
8503 automatically.  C<debuggable> is currently unused and should always be 1.
8504 C<has_my> can be supplied as true to force the
8505 loop body to be enclosed in its own scope.
8506
8507 =cut
8508 */
8509
8510 OP *
8511 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8512         OP *expr, OP *block, OP *cont, I32 has_my)
8513 {
8514     dVAR;
8515     OP *redo;
8516     OP *next = NULL;
8517     OP *listop;
8518     OP *o;
8519     U8 loopflags = 0;
8520
8521     PERL_UNUSED_ARG(debuggable);
8522
8523     if (expr) {
8524         if (expr->op_type == OP_READLINE
8525          || expr->op_type == OP_READDIR
8526          || expr->op_type == OP_GLOB
8527          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8528                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8529             expr = newUNOP(OP_DEFINED, 0,
8530                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8531         } else if (expr->op_flags & OPf_KIDS) {
8532             const OP * const k1 = ((UNOP*)expr)->op_first;
8533             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8534             switch (expr->op_type) {
8535               case OP_NULL:
8536                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8537                       && (k2->op_flags & OPf_STACKED)
8538                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8539                     expr = newUNOP(OP_DEFINED, 0, expr);
8540                 break;
8541
8542               case OP_SASSIGN:
8543                 if (k1 && (k1->op_type == OP_READDIR
8544                       || k1->op_type == OP_GLOB
8545                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8546                      || k1->op_type == OP_EACH
8547                      || k1->op_type == OP_AEACH))
8548                     expr = newUNOP(OP_DEFINED, 0, expr);
8549                 break;
8550             }
8551         }
8552     }
8553
8554     if (!block)
8555         block = newOP(OP_NULL, 0);
8556     else if (cont || has_my) {
8557         block = op_scope(block);
8558     }
8559
8560     if (cont) {
8561         next = LINKLIST(cont);
8562     }
8563     if (expr) {
8564         OP * const unstack = newOP(OP_UNSTACK, 0);
8565         if (!next)
8566             next = unstack;
8567         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8568     }
8569
8570     assert(block);
8571     listop = op_append_list(OP_LINESEQ, block, cont);
8572     assert(listop);
8573     redo = LINKLIST(listop);
8574
8575     if (expr) {
8576         scalar(listop);
8577         o = new_logop(OP_AND, 0, &expr, &listop);
8578         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8579             op_free((OP*)loop);
8580             return expr;                /* listop already freed by new_logop */
8581         }
8582         if (listop)
8583             ((LISTOP*)listop)->op_last->op_next =
8584                 (o == listop ? redo : LINKLIST(o));
8585     }
8586     else
8587         o = listop;
8588
8589     if (!loop) {
8590         NewOp(1101,loop,1,LOOP);
8591         OpTYPE_set(loop, OP_ENTERLOOP);
8592         loop->op_private = 0;
8593         loop->op_next = (OP*)loop;
8594     }
8595
8596     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8597
8598     loop->op_redoop = redo;
8599     loop->op_lastop = o;
8600     o->op_private |= loopflags;
8601
8602     if (next)
8603         loop->op_nextop = next;
8604     else
8605         loop->op_nextop = o;
8606
8607     o->op_flags |= flags;
8608     o->op_private |= (flags >> 8);
8609     return o;
8610 }
8611
8612 /*
8613 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8614
8615 Constructs, checks, and returns an op tree expressing a C<foreach>
8616 loop (iteration through a list of values).  This is a heavyweight loop,
8617 with structure that allows exiting the loop by C<last> and suchlike.
8618
8619 C<sv> optionally supplies the variable that will be aliased to each
8620 item in turn; if null, it defaults to C<$_>.
8621 C<expr> supplies the list of values to iterate over.  C<block> supplies
8622 the main body of the loop, and C<cont> optionally supplies a C<continue>
8623 block that operates as a second half of the body.  All of these optree
8624 inputs are consumed by this function and become part of the constructed
8625 op tree.
8626
8627 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8628 op and, shifted up eight bits, the eight bits of C<op_private> for
8629 the C<leaveloop> op, except that (in both cases) some bits will be set
8630 automatically.
8631
8632 =cut
8633 */
8634
8635 OP *
8636 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8637 {
8638     dVAR;
8639     LOOP *loop;
8640     OP *wop;
8641     PADOFFSET padoff = 0;
8642     I32 iterflags = 0;
8643     I32 iterpflags = 0;
8644
8645     PERL_ARGS_ASSERT_NEWFOROP;
8646
8647     if (sv) {
8648         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8649             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8650             OpTYPE_set(sv, OP_RV2GV);
8651
8652             /* The op_type check is needed to prevent a possible segfault
8653              * if the loop variable is undeclared and 'strict vars' is in
8654              * effect. This is illegal but is nonetheless parsed, so we
8655              * may reach this point with an OP_CONST where we're expecting
8656              * an OP_GV.
8657              */
8658             if (cUNOPx(sv)->op_first->op_type == OP_GV
8659              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8660                 iterpflags |= OPpITER_DEF;
8661         }
8662         else if (sv->op_type == OP_PADSV) { /* private variable */
8663             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8664             padoff = sv->op_targ;
8665             sv->op_targ = 0;
8666             op_free(sv);
8667             sv = NULL;
8668             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8669         }
8670         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8671             NOOP;
8672         else
8673             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8674         if (padoff) {
8675             PADNAME * const pn = PAD_COMPNAME(padoff);
8676             const char * const name = PadnamePV(pn);
8677
8678             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8679                 iterpflags |= OPpITER_DEF;
8680         }
8681     }
8682     else {
8683         sv = newGVOP(OP_GV, 0, PL_defgv);
8684         iterpflags |= OPpITER_DEF;
8685     }
8686
8687     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8688         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8689         iterflags |= OPf_STACKED;
8690     }
8691     else if (expr->op_type == OP_NULL &&
8692              (expr->op_flags & OPf_KIDS) &&
8693              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8694     {
8695         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8696          * set the STACKED flag to indicate that these values are to be
8697          * treated as min/max values by 'pp_enteriter'.
8698          */
8699         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8700         LOGOP* const range = (LOGOP*) flip->op_first;
8701         OP* const left  = range->op_first;
8702         OP* const right = OpSIBLING(left);
8703         LISTOP* listop;
8704
8705         range->op_flags &= ~OPf_KIDS;
8706         /* detach range's children */
8707         op_sibling_splice((OP*)range, NULL, -1, NULL);
8708
8709         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8710         listop->op_first->op_next = range->op_next;
8711         left->op_next = range->op_other;
8712         right->op_next = (OP*)listop;
8713         listop->op_next = listop->op_first;
8714
8715         op_free(expr);
8716         expr = (OP*)(listop);
8717         op_null(expr);
8718         iterflags |= OPf_STACKED;
8719     }
8720     else {
8721         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8722     }
8723
8724     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8725                                   op_append_elem(OP_LIST, list(expr),
8726                                                  scalar(sv)));
8727     assert(!loop->op_next);
8728     /* for my  $x () sets OPpLVAL_INTRO;
8729      * for our $x () sets OPpOUR_INTRO */
8730     loop->op_private = (U8)iterpflags;
8731     if (loop->op_slabbed
8732      && DIFF(loop, OpSLOT(loop)->opslot_next)
8733          < SIZE_TO_PSIZE(sizeof(LOOP)))
8734     {
8735         LOOP *tmp;
8736         NewOp(1234,tmp,1,LOOP);
8737         Copy(loop,tmp,1,LISTOP);
8738 #ifdef PERL_OP_PARENT
8739         assert(loop->op_last->op_sibparent == (OP*)loop);
8740         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8741 #endif
8742         S_op_destroy(aTHX_ (OP*)loop);
8743         loop = tmp;
8744     }
8745     else if (!loop->op_slabbed)
8746     {
8747         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8748 #ifdef PERL_OP_PARENT
8749         OpLASTSIB_set(loop->op_last, (OP*)loop);
8750 #endif
8751     }
8752     loop->op_targ = padoff;
8753     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8754     return wop;
8755 }
8756
8757 /*
8758 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8759
8760 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8761 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8762 determining the target of the op; it is consumed by this function and
8763 becomes part of the constructed op tree.
8764
8765 =cut
8766 */
8767
8768 OP*
8769 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8770 {
8771     OP *o = NULL;
8772
8773     PERL_ARGS_ASSERT_NEWLOOPEX;
8774
8775     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8776         || type == OP_CUSTOM);
8777
8778     if (type != OP_GOTO) {
8779         /* "last()" means "last" */
8780         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8781             o = newOP(type, OPf_SPECIAL);
8782         }
8783     }
8784     else {
8785         /* Check whether it's going to be a goto &function */
8786         if (label->op_type == OP_ENTERSUB
8787                 && !(label->op_flags & OPf_STACKED))
8788             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8789     }
8790
8791     /* Check for a constant argument */
8792     if (label->op_type == OP_CONST) {
8793             SV * const sv = ((SVOP *)label)->op_sv;
8794             STRLEN l;
8795             const char *s = SvPV_const(sv,l);
8796             if (l == strlen(s)) {
8797                 o = newPVOP(type,
8798                             SvUTF8(((SVOP*)label)->op_sv),
8799                             savesharedpv(
8800                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8801             }
8802     }
8803
8804     /* If we have already created an op, we do not need the label. */
8805     if (o)
8806                 op_free(label);
8807     else o = newUNOP(type, OPf_STACKED, label);
8808
8809     PL_hints |= HINT_BLOCK_SCOPE;
8810     return o;
8811 }
8812
8813 /* if the condition is a literal array or hash
8814    (or @{ ... } etc), make a reference to it.
8815  */
8816 STATIC OP *
8817 S_ref_array_or_hash(pTHX_ OP *cond)
8818 {
8819     if (cond
8820     && (cond->op_type == OP_RV2AV
8821     ||  cond->op_type == OP_PADAV
8822     ||  cond->op_type == OP_RV2HV
8823     ||  cond->op_type == OP_PADHV))
8824
8825         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8826
8827     else if(cond
8828     && (cond->op_type == OP_ASLICE
8829     ||  cond->op_type == OP_KVASLICE
8830     ||  cond->op_type == OP_HSLICE
8831     ||  cond->op_type == OP_KVHSLICE)) {
8832
8833         /* anonlist now needs a list from this op, was previously used in
8834          * scalar context */
8835         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8836         cond->op_flags |= OPf_WANT_LIST;
8837
8838         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8839     }
8840
8841     else
8842         return cond;
8843 }
8844
8845 /* These construct the optree fragments representing given()
8846    and when() blocks.
8847
8848    entergiven and enterwhen are LOGOPs; the op_other pointer
8849    points up to the associated leave op. We need this so we
8850    can put it in the context and make break/continue work.
8851    (Also, of course, pp_enterwhen will jump straight to
8852    op_other if the match fails.)
8853  */
8854
8855 STATIC OP *
8856 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8857                    I32 enter_opcode, I32 leave_opcode,
8858                    PADOFFSET entertarg)
8859 {
8860     dVAR;
8861     LOGOP *enterop;
8862     OP *o;
8863
8864     PERL_ARGS_ASSERT_NEWGIVWHENOP;
8865     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8866
8867     enterop = alloc_LOGOP(enter_opcode, block, NULL);
8868     enterop->op_targ = 0;
8869     enterop->op_private = 0;
8870
8871     o = newUNOP(leave_opcode, 0, (OP *) enterop);
8872
8873     if (cond) {
8874         /* prepend cond if we have one */
8875         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8876
8877         o->op_next = LINKLIST(cond);
8878         cond->op_next = (OP *) enterop;
8879     }
8880     else {
8881         /* This is a default {} block */
8882         enterop->op_flags |= OPf_SPECIAL;
8883         o      ->op_flags |= OPf_SPECIAL;
8884
8885         o->op_next = (OP *) enterop;
8886     }
8887
8888     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
8889                                        entergiven and enterwhen both
8890                                        use ck_null() */
8891
8892     enterop->op_next = LINKLIST(block);
8893     block->op_next = enterop->op_other = o;
8894
8895     return o;
8896 }
8897
8898 /* Does this look like a boolean operation? For these purposes
8899    a boolean operation is:
8900      - a subroutine call [*]
8901      - a logical connective
8902      - a comparison operator
8903      - a filetest operator, with the exception of -s -M -A -C
8904      - defined(), exists() or eof()
8905      - /$re/ or $foo =~ /$re/
8906
8907    [*] possibly surprising
8908  */
8909 STATIC bool
8910 S_looks_like_bool(pTHX_ const OP *o)
8911 {
8912     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
8913
8914     switch(o->op_type) {
8915         case OP_OR:
8916         case OP_DOR:
8917             return looks_like_bool(cLOGOPo->op_first);
8918
8919         case OP_AND:
8920         {
8921             OP* sibl = OpSIBLING(cLOGOPo->op_first);
8922             ASSUME(sibl);
8923             return (
8924                 looks_like_bool(cLOGOPo->op_first)
8925              && looks_like_bool(sibl));
8926         }
8927
8928         case OP_NULL:
8929         case OP_SCALAR:
8930             return (
8931                 o->op_flags & OPf_KIDS
8932             && looks_like_bool(cUNOPo->op_first));
8933
8934         case OP_ENTERSUB:
8935
8936         case OP_NOT:    case OP_XOR:
8937
8938         case OP_EQ:     case OP_NE:     case OP_LT:
8939         case OP_GT:     case OP_LE:     case OP_GE:
8940
8941         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
8942         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
8943
8944         case OP_SEQ:    case OP_SNE:    case OP_SLT:
8945         case OP_SGT:    case OP_SLE:    case OP_SGE:
8946
8947         case OP_SMARTMATCH:
8948
8949         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
8950         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
8951         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
8952         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
8953         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
8954         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
8955         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
8956         case OP_FTTEXT:   case OP_FTBINARY:
8957
8958         case OP_DEFINED: case OP_EXISTS:
8959         case OP_MATCH:   case OP_EOF:
8960
8961         case OP_FLOP:
8962
8963             return TRUE;
8964
8965         case OP_CONST:
8966             /* Detect comparisons that have been optimized away */
8967             if (cSVOPo->op_sv == &PL_sv_yes
8968             ||  cSVOPo->op_sv == &PL_sv_no)
8969
8970                 return TRUE;
8971             else
8972                 return FALSE;
8973
8974         /* FALLTHROUGH */
8975         default:
8976             return FALSE;
8977     }
8978 }
8979
8980 /*
8981 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
8982
8983 Constructs, checks, and returns an op tree expressing a C<given> block.
8984 C<cond> supplies the expression to whose value C<$_> will be locally
8985 aliased, and C<block> supplies the body of the C<given> construct; they
8986 are consumed by this function and become part of the constructed op tree.
8987 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
8988
8989 =cut
8990 */
8991
8992 OP *
8993 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
8994 {
8995     PERL_ARGS_ASSERT_NEWGIVENOP;
8996     PERL_UNUSED_ARG(defsv_off);
8997
8998     assert(!defsv_off);
8999     return newGIVWHENOP(
9000         ref_array_or_hash(cond),
9001         block,
9002         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9003         0);
9004 }
9005
9006 /*
9007 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9008
9009 Constructs, checks, and returns an op tree expressing a C<when> block.
9010 C<cond> supplies the test expression, and C<block> supplies the block
9011 that will be executed if the test evaluates to true; they are consumed
9012 by this function and become part of the constructed op tree.  C<cond>
9013 will be interpreted DWIMically, often as a comparison against C<$_>,
9014 and may be null to generate a C<default> block.
9015
9016 =cut
9017 */
9018
9019 OP *
9020 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9021 {
9022     const bool cond_llb = (!cond || looks_like_bool(cond));
9023     OP *cond_op;
9024
9025     PERL_ARGS_ASSERT_NEWWHENOP;
9026
9027     if (cond_llb)
9028         cond_op = cond;
9029     else {
9030         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9031                 newDEFSVOP(),
9032                 scalar(ref_array_or_hash(cond)));
9033     }
9034
9035     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9036 }
9037
9038 /* must not conflict with SVf_UTF8 */
9039 #define CV_CKPROTO_CURSTASH     0x1
9040
9041 void
9042 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9043                     const STRLEN len, const U32 flags)
9044 {
9045     SV *name = NULL, *msg;
9046     const char * cvp = SvROK(cv)
9047                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9048                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9049                            : ""
9050                         : CvPROTO(cv);
9051     STRLEN clen = CvPROTOLEN(cv), plen = len;
9052
9053     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9054
9055     if (p == NULL && cvp == NULL)
9056         return;
9057
9058     if (!ckWARN_d(WARN_PROTOTYPE))
9059         return;
9060
9061     if (p && cvp) {
9062         p = S_strip_spaces(aTHX_ p, &plen);
9063         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9064         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9065             if (plen == clen && memEQ(cvp, p, plen))
9066                 return;
9067         } else {
9068             if (flags & SVf_UTF8) {
9069                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9070                     return;
9071             }
9072             else {
9073                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9074                     return;
9075             }
9076         }
9077     }
9078
9079     msg = sv_newmortal();
9080
9081     if (gv)
9082     {
9083         if (isGV(gv))
9084             gv_efullname3(name = sv_newmortal(), gv, NULL);
9085         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9086             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9087         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9088             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9089             sv_catpvs(name, "::");
9090             if (SvROK(gv)) {
9091                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9092                 assert (CvNAMED(SvRV_const(gv)));
9093                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9094             }
9095             else sv_catsv(name, (SV *)gv);
9096         }
9097         else name = (SV *)gv;
9098     }
9099     sv_setpvs(msg, "Prototype mismatch:");
9100     if (name)
9101         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9102     if (cvp)
9103         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9104             UTF8fARG(SvUTF8(cv),clen,cvp)
9105         );
9106     else
9107         sv_catpvs(msg, ": none");
9108     sv_catpvs(msg, " vs ");
9109     if (p)
9110         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9111     else
9112         sv_catpvs(msg, "none");
9113     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9114 }
9115
9116 static void const_sv_xsub(pTHX_ CV* cv);
9117 static void const_av_xsub(pTHX_ CV* cv);
9118
9119 /*
9120
9121 =head1 Optree Manipulation Functions
9122
9123 =for apidoc cv_const_sv
9124
9125 If C<cv> is a constant sub eligible for inlining, returns the constant
9126 value returned by the sub.  Otherwise, returns C<NULL>.
9127
9128 Constant subs can be created with C<newCONSTSUB> or as described in
9129 L<perlsub/"Constant Functions">.
9130
9131 =cut
9132 */
9133 SV *
9134 Perl_cv_const_sv(const CV *const cv)
9135 {
9136     SV *sv;
9137     if (!cv)
9138         return NULL;
9139     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9140         return NULL;
9141     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9142     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9143     return sv;
9144 }
9145
9146 SV *
9147 Perl_cv_const_sv_or_av(const CV * const cv)
9148 {
9149     if (!cv)
9150         return NULL;
9151     if (SvROK(cv)) return SvRV((SV *)cv);
9152     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9153     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9154 }
9155
9156 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9157  * Can be called in 2 ways:
9158  *
9159  * !allow_lex
9160  *      look for a single OP_CONST with attached value: return the value
9161  *
9162  * allow_lex && !CvCONST(cv);
9163  *
9164  *      examine the clone prototype, and if contains only a single
9165  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9166  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9167  *      a candidate for "constizing" at clone time, and return NULL.
9168  */
9169
9170 static SV *
9171 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9172 {
9173     SV *sv = NULL;
9174     bool padsv = FALSE;
9175
9176     assert(o);
9177     assert(cv);
9178
9179     for (; o; o = o->op_next) {
9180         const OPCODE type = o->op_type;
9181
9182         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9183              || type == OP_NULL
9184              || type == OP_PUSHMARK)
9185                 continue;
9186         if (type == OP_DBSTATE)
9187                 continue;
9188         if (type == OP_LEAVESUB)
9189             break;
9190         if (sv)
9191             return NULL;
9192         if (type == OP_CONST && cSVOPo->op_sv)
9193             sv = cSVOPo->op_sv;
9194         else if (type == OP_UNDEF && !o->op_private) {
9195             sv = newSV(0);
9196             SAVEFREESV(sv);
9197         }
9198         else if (allow_lex && type == OP_PADSV) {
9199                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9200                 {
9201                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9202                     padsv = TRUE;
9203                 }
9204                 else
9205                     return NULL;
9206         }
9207         else {
9208             return NULL;
9209         }
9210     }
9211     if (padsv) {
9212         CvCONST_on(cv);
9213         return NULL;
9214     }
9215     return sv;
9216 }
9217
9218 static void
9219 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9220                         PADNAME * const name, SV ** const const_svp)
9221 {
9222     assert (cv);
9223     assert (o || name);
9224     assert (const_svp);
9225     if (!block) {
9226         if (CvFLAGS(PL_compcv)) {
9227             /* might have had built-in attrs applied */
9228             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9229             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9230              && ckWARN(WARN_MISC))
9231             {
9232                 /* protect against fatal warnings leaking compcv */
9233                 SAVEFREESV(PL_compcv);
9234                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9235                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9236             }
9237             CvFLAGS(cv) |=
9238                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9239                   & ~(CVf_LVALUE * pureperl));
9240         }
9241         return;
9242     }
9243
9244     /* redundant check for speed: */
9245     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9246         const line_t oldline = CopLINE(PL_curcop);
9247         SV *namesv = o
9248             ? cSVOPo->op_sv
9249             : sv_2mortal(newSVpvn_utf8(
9250                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9251               ));
9252         if (PL_parser && PL_parser->copline != NOLINE)
9253             /* This ensures that warnings are reported at the first
9254                line of a redefinition, not the last.  */
9255             CopLINE_set(PL_curcop, PL_parser->copline);
9256         /* protect against fatal warnings leaking compcv */
9257         SAVEFREESV(PL_compcv);
9258         report_redefined_cv(namesv, cv, const_svp);
9259         SvREFCNT_inc_simple_void_NN(PL_compcv);
9260         CopLINE_set(PL_curcop, oldline);
9261     }
9262     SAVEFREESV(cv);
9263     return;
9264 }
9265
9266 CV *
9267 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9268 {
9269     CV **spot;
9270     SV **svspot;
9271     const char *ps;
9272     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9273     U32 ps_utf8 = 0;
9274     CV *cv = NULL;
9275     CV *compcv = PL_compcv;
9276     SV *const_sv;
9277     PADNAME *name;
9278     PADOFFSET pax = o->op_targ;
9279     CV *outcv = CvOUTSIDE(PL_compcv);
9280     CV *clonee = NULL;
9281     HEK *hek = NULL;
9282     bool reusable = FALSE;
9283     OP *start = NULL;
9284 #ifdef PERL_DEBUG_READONLY_OPS
9285     OPSLAB *slab = NULL;
9286 #endif
9287
9288     PERL_ARGS_ASSERT_NEWMYSUB;
9289
9290     PL_hints |= HINT_BLOCK_SCOPE;
9291
9292     /* Find the pad slot for storing the new sub.
9293        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9294        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9295        ing sub.  And then we need to dig deeper if this is a lexical from
9296        outside, as in:
9297            my sub foo; sub { sub foo { } }
9298      */
9299   redo:
9300     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9301     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9302         pax = PARENT_PAD_INDEX(name);
9303         outcv = CvOUTSIDE(outcv);
9304         assert(outcv);
9305         goto redo;
9306     }
9307     svspot =
9308         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9309                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9310     spot = (CV **)svspot;
9311
9312     if (!(PL_parser && PL_parser->error_count))
9313         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9314
9315     if (proto) {
9316         assert(proto->op_type == OP_CONST);
9317         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9318         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9319     }
9320     else
9321         ps = NULL;
9322
9323     if (proto)
9324         SAVEFREEOP(proto);
9325     if (attrs)
9326         SAVEFREEOP(attrs);
9327
9328     if (PL_parser && PL_parser->error_count) {
9329         op_free(block);
9330         SvREFCNT_dec(PL_compcv);
9331         PL_compcv = 0;
9332         goto done;
9333     }
9334
9335     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9336         cv = *spot;
9337         svspot = (SV **)(spot = &clonee);
9338     }
9339     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9340         cv = *spot;
9341     else {
9342         assert (SvTYPE(*spot) == SVt_PVCV);
9343         if (CvNAMED(*spot))
9344             hek = CvNAME_HEK(*spot);
9345         else {
9346             dVAR;
9347             U32 hash;
9348             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9349             CvNAME_HEK_set(*spot, hek =
9350                 share_hek(
9351                     PadnamePV(name)+1,
9352                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9353                     hash
9354                 )
9355             );
9356             CvLEXICAL_on(*spot);
9357         }
9358         cv = PadnamePROTOCV(name);
9359         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9360     }
9361
9362     if (block) {
9363         /* This makes sub {}; work as expected.  */
9364         if (block->op_type == OP_STUB) {
9365             const line_t l = PL_parser->copline;
9366             op_free(block);
9367             block = newSTATEOP(0, NULL, 0);
9368             PL_parser->copline = l;
9369         }
9370         block = CvLVALUE(compcv)
9371              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9372                    ? newUNOP(OP_LEAVESUBLV, 0,
9373                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9374                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9375         start = LINKLIST(block);
9376         block->op_next = 0;
9377         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9378             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9379         else
9380             const_sv = NULL;
9381     }
9382     else
9383         const_sv = NULL;
9384
9385     if (cv) {
9386         const bool exists = CvROOT(cv) || CvXSUB(cv);
9387
9388         /* if the subroutine doesn't exist and wasn't pre-declared
9389          * with a prototype, assume it will be AUTOLOADed,
9390          * skipping the prototype check
9391          */
9392         if (exists || SvPOK(cv))
9393             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9394                                  ps_utf8);
9395         /* already defined? */
9396         if (exists) {
9397             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9398             if (block)
9399                 cv = NULL;
9400             else {
9401                 if (attrs)
9402                     goto attrs;
9403                 /* just a "sub foo;" when &foo is already defined */
9404                 SAVEFREESV(compcv);
9405                 goto done;
9406             }
9407         }
9408         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9409             cv = NULL;
9410             reusable = TRUE;
9411         }
9412     }
9413
9414     if (const_sv) {
9415         SvREFCNT_inc_simple_void_NN(const_sv);
9416         SvFLAGS(const_sv) |= SVs_PADTMP;
9417         if (cv) {
9418             assert(!CvROOT(cv) && !CvCONST(cv));
9419             cv_forget_slab(cv);
9420         }
9421         else {
9422             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9423             CvFILE_set_from_cop(cv, PL_curcop);
9424             CvSTASH_set(cv, PL_curstash);
9425             *spot = cv;
9426         }
9427         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9428         CvXSUBANY(cv).any_ptr = const_sv;
9429         CvXSUB(cv) = const_sv_xsub;
9430         CvCONST_on(cv);
9431         CvISXSUB_on(cv);
9432         PoisonPADLIST(cv);
9433         CvFLAGS(cv) |= CvMETHOD(compcv);
9434         op_free(block);
9435         SvREFCNT_dec(compcv);
9436         PL_compcv = NULL;
9437         goto setname;
9438     }
9439
9440     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9441        determine whether this sub definition is in the same scope as its
9442        declaration.  If this sub definition is inside an inner named pack-
9443        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9444        the package sub.  So check PadnameOUTER(name) too.
9445      */
9446     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9447         assert(!CvWEAKOUTSIDE(compcv));
9448         SvREFCNT_dec(CvOUTSIDE(compcv));
9449         CvWEAKOUTSIDE_on(compcv);
9450     }
9451     /* XXX else do we have a circular reference? */
9452
9453     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9454         /* transfer PL_compcv to cv */
9455         if (block) {
9456             cv_flags_t preserved_flags =
9457                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9458             PADLIST *const temp_padl = CvPADLIST(cv);
9459             CV *const temp_cv = CvOUTSIDE(cv);
9460             const cv_flags_t other_flags =
9461                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9462             OP * const cvstart = CvSTART(cv);
9463
9464             SvPOK_off(cv);
9465             CvFLAGS(cv) =
9466                 CvFLAGS(compcv) | preserved_flags;
9467             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9468             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9469             CvPADLIST_set(cv, CvPADLIST(compcv));
9470             CvOUTSIDE(compcv) = temp_cv;
9471             CvPADLIST_set(compcv, temp_padl);
9472             CvSTART(cv) = CvSTART(compcv);
9473             CvSTART(compcv) = cvstart;
9474             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9475             CvFLAGS(compcv) |= other_flags;
9476
9477             if (CvFILE(cv) && CvDYNFILE(cv)) {
9478                 Safefree(CvFILE(cv));
9479             }
9480
9481             /* inner references to compcv must be fixed up ... */
9482             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9483             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9484                 ++PL_sub_generation;
9485         }
9486         else {
9487             /* Might have had built-in attributes applied -- propagate them. */
9488             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9489         }
9490         /* ... before we throw it away */
9491         SvREFCNT_dec(compcv);
9492         PL_compcv = compcv = cv;
9493     }
9494     else {
9495         cv = compcv;
9496         *spot = cv;
9497     }
9498
9499   setname:
9500     CvLEXICAL_on(cv);
9501     if (!CvNAME_HEK(cv)) {
9502         if (hek) (void)share_hek_hek(hek);
9503         else {
9504             dVAR;
9505             U32 hash;
9506             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9507             hek = share_hek(PadnamePV(name)+1,
9508                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9509                       hash);
9510         }
9511         CvNAME_HEK_set(cv, hek);
9512     }
9513
9514     if (const_sv)
9515         goto clone;
9516
9517     CvFILE_set_from_cop(cv, PL_curcop);
9518     CvSTASH_set(cv, PL_curstash);
9519
9520     if (ps) {
9521         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9522         if (ps_utf8)
9523             SvUTF8_on(MUTABLE_SV(cv));
9524     }
9525
9526     if (block) {
9527         /* If we assign an optree to a PVCV, then we've defined a
9528          * subroutine that the debugger could be able to set a breakpoint
9529          * in, so signal to pp_entereval that it should not throw away any
9530          * saved lines at scope exit.  */
9531
9532         PL_breakable_sub_gen++;
9533         CvROOT(cv) = block;
9534         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9535            itself has a refcount. */
9536         CvSLABBED_off(cv);
9537         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9538 #ifdef PERL_DEBUG_READONLY_OPS
9539         slab = (OPSLAB *)CvSTART(cv);
9540 #endif
9541         S_process_optree(aTHX_ cv, block, start);
9542     }
9543
9544   attrs:
9545     if (attrs) {
9546         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9547         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9548     }
9549
9550     if (block) {
9551         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9552             SV * const tmpstr = sv_newmortal();
9553             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9554                                                   GV_ADDMULTI, SVt_PVHV);
9555             HV *hv;
9556             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9557                                           CopFILE(PL_curcop),
9558                                           (long)PL_subline,
9559                                           (long)CopLINE(PL_curcop));
9560             if (HvNAME_HEK(PL_curstash)) {
9561                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9562                 sv_catpvs(tmpstr, "::");
9563             }
9564             else
9565                 sv_setpvs(tmpstr, "__ANON__::");
9566
9567             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9568                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9569             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9570                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9571             hv = GvHVn(db_postponed);
9572             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9573                 CV * const pcv = GvCV(db_postponed);
9574                 if (pcv) {
9575                     dSP;
9576                     PUSHMARK(SP);
9577                     XPUSHs(tmpstr);
9578                     PUTBACK;
9579                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9580                 }
9581             }
9582         }
9583     }
9584
9585   clone:
9586     if (clonee) {
9587         assert(CvDEPTH(outcv));
9588         spot = (CV **)
9589             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9590         if (reusable)
9591             cv_clone_into(clonee, *spot);
9592         else *spot = cv_clone(clonee);
9593         SvREFCNT_dec_NN(clonee);
9594         cv = *spot;
9595     }
9596
9597     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9598         PADOFFSET depth = CvDEPTH(outcv);
9599         while (--depth) {
9600             SV *oldcv;
9601             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9602             oldcv = *svspot;
9603             *svspot = SvREFCNT_inc_simple_NN(cv);
9604             SvREFCNT_dec(oldcv);
9605         }
9606     }
9607
9608   done:
9609     if (PL_parser)
9610         PL_parser->copline = NOLINE;
9611     LEAVE_SCOPE(floor);
9612 #ifdef PERL_DEBUG_READONLY_OPS
9613     if (slab)
9614         Slab_to_ro(slab);
9615 #endif
9616     op_free(o);
9617     return cv;
9618 }
9619
9620 /*
9621 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9622
9623 Construct a Perl subroutine, also performing some surrounding jobs.
9624
9625 This function is expected to be called in a Perl compilation context,
9626 and some aspects of the subroutine are taken from global variables
9627 associated with compilation.  In particular, C<PL_compcv> represents
9628 the subroutine that is currently being compiled.  It must be non-null
9629 when this function is called, and some aspects of the subroutine being
9630 constructed are taken from it.  The constructed subroutine may actually
9631 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9632
9633 If C<block> is null then the subroutine will have no body, and for the
9634 time being it will be an error to call it.  This represents a forward
9635 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9636 non-null then it provides the Perl code of the subroutine body, which
9637 will be executed when the subroutine is called.  This body includes
9638 any argument unwrapping code resulting from a subroutine signature or
9639 similar.  The pad use of the code must correspond to the pad attached
9640 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9641 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9642 by this function and will become part of the constructed subroutine.
9643
9644 C<proto> specifies the subroutine's prototype, unless one is supplied
9645 as an attribute (see below).  If C<proto> is null, then the subroutine
9646 will not have a prototype.  If C<proto> is non-null, it must point to a
9647 C<const> op whose value is a string, and the subroutine will have that
9648 string as its prototype.  If a prototype is supplied as an attribute, the
9649 attribute takes precedence over C<proto>, but in that case C<proto> should
9650 preferably be null.  In any case, C<proto> is consumed by this function.
9651
9652 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9653 attributes take effect by built-in means, being applied to C<PL_compcv>
9654 immediately when seen.  Other attributes are collected up and attached
9655 to the subroutine by this route.  C<attrs> may be null to supply no
9656 attributes, or point to a C<const> op for a single attribute, or point
9657 to a C<list> op whose children apart from the C<pushmark> are C<const>
9658 ops for one or more attributes.  Each C<const> op must be a string,
9659 giving the attribute name optionally followed by parenthesised arguments,
9660 in the manner in which attributes appear in Perl source.  The attributes
9661 will be applied to the sub by this function.  C<attrs> is consumed by
9662 this function.
9663
9664 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9665 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9666 must point to a C<const> op, which will be consumed by this function,
9667 and its string value supplies a name for the subroutine.  The name may
9668 be qualified or unqualified, and if it is unqualified then a default
9669 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9670 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9671 by which the subroutine will be named.
9672
9673 If there is already a subroutine of the specified name, then the new
9674 sub will either replace the existing one in the glob or be merged with
9675 the existing one.  A warning may be generated about redefinition.
9676
9677 If the subroutine has one of a few special names, such as C<BEGIN> or
9678 C<END>, then it will be claimed by the appropriate queue for automatic
9679 running of phase-related subroutines.  In this case the relevant glob will
9680 be left not containing any subroutine, even if it did contain one before.
9681 In the case of C<BEGIN>, the subroutine will be executed and the reference
9682 to it disposed of before this function returns.
9683
9684 The function returns a pointer to the constructed subroutine.  If the sub
9685 is anonymous then ownership of one counted reference to the subroutine
9686 is transferred to the caller.  If the sub is named then the caller does
9687 not get ownership of a reference.  In most such cases, where the sub
9688 has a non-phase name, the sub will be alive at the point it is returned
9689 by virtue of being contained in the glob that names it.  A phase-named
9690 subroutine will usually be alive by virtue of the reference owned by the
9691 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9692 been executed, will quite likely have been destroyed already by the
9693 time this function returns, making it erroneous for the caller to make
9694 any use of the returned pointer.  It is the caller's responsibility to
9695 ensure that it knows which of these situations applies.
9696
9697 =cut
9698 */
9699
9700 /* _x = extended */
9701 CV *
9702 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9703                             OP *block, bool o_is_gv)
9704 {
9705     GV *gv;
9706     const char *ps;
9707     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9708     U32 ps_utf8 = 0;
9709     CV *cv = NULL;     /* the previous CV with this name, if any */
9710     SV *const_sv;
9711     const bool ec = PL_parser && PL_parser->error_count;
9712     /* If the subroutine has no body, no attributes, and no builtin attributes
9713        then it's just a sub declaration, and we may be able to get away with
9714        storing with a placeholder scalar in the symbol table, rather than a
9715        full CV.  If anything is present then it will take a full CV to
9716        store it.  */
9717     const I32 gv_fetch_flags
9718         = ec ? GV_NOADD_NOINIT :
9719         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9720         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9721     STRLEN namlen = 0;
9722     const char * const name =
9723          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9724     bool has_name;
9725     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9726     bool evanescent = FALSE;
9727     OP *start = NULL;
9728 #ifdef PERL_DEBUG_READONLY_OPS
9729     OPSLAB *slab = NULL;
9730 #endif
9731
9732     if (o_is_gv) {
9733         gv = (GV*)o;
9734         o = NULL;
9735         has_name = TRUE;
9736     } else if (name) {
9737         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9738            hek and CvSTASH pointer together can imply the GV.  If the name
9739            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9740            CvSTASH, so forego the optimisation if we find any.
9741            Also, we may be called from load_module at run time, so
9742            PL_curstash (which sets CvSTASH) may not point to the stash the
9743            sub is stored in.  */
9744         const I32 flags =
9745            ec ? GV_NOADD_NOINIT
9746               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9747                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9748                     ? gv_fetch_flags
9749                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9750         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9751         has_name = TRUE;
9752     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9753         SV * const sv = sv_newmortal();
9754         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9755                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9756                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9757         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9758         has_name = TRUE;
9759     } else if (PL_curstash) {
9760         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9761         has_name = FALSE;
9762     } else {
9763         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9764         has_name = FALSE;
9765     }
9766
9767     if (!ec) {
9768         if (isGV(gv)) {
9769             move_proto_attr(&proto, &attrs, gv, 0);
9770         } else {
9771             assert(cSVOPo);
9772             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9773         }
9774     }
9775
9776     if (proto) {
9777         assert(proto->op_type == OP_CONST);
9778         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9779         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9780     }
9781     else
9782         ps = NULL;
9783
9784     if (o)
9785         SAVEFREEOP(o);
9786     if (proto)
9787         SAVEFREEOP(proto);
9788     if (attrs)
9789         SAVEFREEOP(attrs);
9790
9791     if (ec) {
9792         op_free(block);
9793
9794         if (name)
9795             SvREFCNT_dec(PL_compcv);
9796         else
9797             cv = PL_compcv;
9798
9799         PL_compcv = 0;
9800         if (name && block) {
9801             const char *s = (char *) my_memrchr(name, ':', namlen);
9802             s = s ? s+1 : name;
9803             if (strEQ(s, "BEGIN")) {
9804                 if (PL_in_eval & EVAL_KEEPERR)
9805                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9806                 else {
9807                     SV * const errsv = ERRSV;
9808                     /* force display of errors found but not reported */
9809                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9810                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9811                 }
9812             }
9813         }
9814         goto done;
9815     }
9816
9817     if (!block && SvTYPE(gv) != SVt_PVGV) {
9818         /* If we are not defining a new sub and the existing one is not a
9819            full GV + CV... */
9820         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9821             /* We are applying attributes to an existing sub, so we need it
9822                upgraded if it is a constant.  */
9823             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9824                 gv_init_pvn(gv, PL_curstash, name, namlen,
9825                             SVf_UTF8 * name_is_utf8);
9826         }
9827         else {                  /* Maybe prototype now, and had at maximum
9828                                    a prototype or const/sub ref before.  */
9829             if (SvTYPE(gv) > SVt_NULL) {
9830                 cv_ckproto_len_flags((const CV *)gv,
9831                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9832                                     ps_len, ps_utf8);
9833             }
9834
9835             if (!SvROK(gv)) {
9836                 if (ps) {
9837                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9838                     if (ps_utf8)
9839                         SvUTF8_on(MUTABLE_SV(gv));
9840                 }
9841                 else
9842                     sv_setiv(MUTABLE_SV(gv), -1);
9843             }
9844
9845             SvREFCNT_dec(PL_compcv);
9846             cv = PL_compcv = NULL;
9847             goto done;
9848         }
9849     }
9850
9851     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9852         ? NULL
9853         : isGV(gv)
9854             ? GvCV(gv)
9855             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9856                 ? (CV *)SvRV(gv)
9857                 : NULL;
9858
9859     if (block) {
9860         assert(PL_parser);
9861         /* This makes sub {}; work as expected.  */
9862         if (block->op_type == OP_STUB) {
9863             const line_t l = PL_parser->copline;
9864             op_free(block);
9865             block = newSTATEOP(0, NULL, 0);
9866             PL_parser->copline = l;
9867         }
9868         block = CvLVALUE(PL_compcv)
9869              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9870                     && (!isGV(gv) || !GvASSUMECV(gv)))
9871                    ? newUNOP(OP_LEAVESUBLV, 0,
9872                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9873                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9874         start = LINKLIST(block);
9875         block->op_next = 0;
9876         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9877             const_sv =
9878                 S_op_const_sv(aTHX_ start, PL_compcv,
9879                                         cBOOL(CvCLONE(PL_compcv)));
9880         else
9881             const_sv = NULL;
9882     }
9883     else
9884         const_sv = NULL;
9885
9886     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
9887         cv_ckproto_len_flags((const CV *)gv,
9888                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9889                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
9890         if (SvROK(gv)) {
9891             /* All the other code for sub redefinition warnings expects the
9892                clobbered sub to be a CV.  Instead of making all those code
9893                paths more complex, just inline the RV version here.  */
9894             const line_t oldline = CopLINE(PL_curcop);
9895             assert(IN_PERL_COMPILETIME);
9896             if (PL_parser && PL_parser->copline != NOLINE)
9897                 /* This ensures that warnings are reported at the first
9898                    line of a redefinition, not the last.  */
9899                 CopLINE_set(PL_curcop, PL_parser->copline);
9900             /* protect against fatal warnings leaking compcv */
9901             SAVEFREESV(PL_compcv);
9902
9903             if (ckWARN(WARN_REDEFINE)
9904              || (  ckWARN_d(WARN_REDEFINE)
9905                 && (  !const_sv || SvRV(gv) == const_sv
9906                    || sv_cmp(SvRV(gv), const_sv)  ))) {
9907                 assert(cSVOPo);
9908                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9909                           "Constant subroutine %" SVf " redefined",
9910                           SVfARG(cSVOPo->op_sv));
9911             }
9912
9913             SvREFCNT_inc_simple_void_NN(PL_compcv);
9914             CopLINE_set(PL_curcop, oldline);
9915             SvREFCNT_dec(SvRV(gv));
9916         }
9917     }
9918
9919     if (cv) {
9920         const bool exists = CvROOT(cv) || CvXSUB(cv);
9921
9922         /* if the subroutine doesn't exist and wasn't pre-declared
9923          * with a prototype, assume it will be AUTOLOADed,
9924          * skipping the prototype check
9925          */
9926         if (exists || SvPOK(cv))
9927             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
9928         /* already defined (or promised)? */
9929         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
9930             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
9931             if (block)
9932                 cv = NULL;
9933             else {
9934                 if (attrs)
9935                     goto attrs;
9936                 /* just a "sub foo;" when &foo is already defined */
9937                 SAVEFREESV(PL_compcv);
9938                 goto done;
9939             }
9940         }
9941     }
9942
9943     if (const_sv) {
9944         SvREFCNT_inc_simple_void_NN(const_sv);
9945         SvFLAGS(const_sv) |= SVs_PADTMP;
9946         if (cv) {
9947             assert(!CvROOT(cv) && !CvCONST(cv));
9948             cv_forget_slab(cv);
9949             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9950             CvXSUBANY(cv).any_ptr = const_sv;
9951             CvXSUB(cv) = const_sv_xsub;
9952             CvCONST_on(cv);
9953             CvISXSUB_on(cv);
9954             PoisonPADLIST(cv);
9955             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9956         }
9957         else {
9958             if (isGV(gv) || CvMETHOD(PL_compcv)) {
9959                 if (name && isGV(gv))
9960                     GvCV_set(gv, NULL);
9961                 cv = newCONSTSUB_flags(
9962                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9963                     const_sv
9964                 );
9965                 assert(cv);
9966                 assert(SvREFCNT((SV*)cv) != 0);
9967                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9968             }
9969             else {
9970                 if (!SvROK(gv)) {
9971                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
9972                     prepare_SV_for_RV((SV *)gv);
9973                     SvOK_off((SV *)gv);
9974                     SvROK_on(gv);
9975                 }
9976                 SvRV_set(gv, const_sv);
9977             }
9978         }
9979         op_free(block);
9980         SvREFCNT_dec(PL_compcv);
9981         PL_compcv = NULL;
9982         goto done;
9983     }
9984
9985     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
9986     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
9987         cv = NULL;
9988
9989     if (cv) {                           /* must reuse cv if autoloaded */
9990         /* transfer PL_compcv to cv */
9991         if (block) {
9992             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
9993             PADLIST *const temp_av = CvPADLIST(cv);
9994             CV *const temp_cv = CvOUTSIDE(cv);
9995             const cv_flags_t other_flags =
9996                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9997             OP * const cvstart = CvSTART(cv);
9998
9999             if (isGV(gv)) {
10000                 CvGV_set(cv,gv);
10001                 assert(!CvCVGV_RC(cv));
10002                 assert(CvGV(cv) == gv);
10003             }
10004             else {
10005                 dVAR;
10006                 U32 hash;
10007                 PERL_HASH(hash, name, namlen);
10008                 CvNAME_HEK_set(cv,
10009                                share_hek(name,
10010                                          name_is_utf8
10011                                             ? -(SSize_t)namlen
10012                                             :  (SSize_t)namlen,
10013                                          hash));
10014             }
10015
10016             SvPOK_off(cv);
10017             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10018                                              | CvNAMED(cv);
10019             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10020             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10021             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10022             CvOUTSIDE(PL_compcv) = temp_cv;
10023             CvPADLIST_set(PL_compcv, temp_av);
10024             CvSTART(cv) = CvSTART(PL_compcv);
10025             CvSTART(PL_compcv) = cvstart;
10026             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10027             CvFLAGS(PL_compcv) |= other_flags;
10028
10029             if (CvFILE(cv) && CvDYNFILE(cv)) {
10030                 Safefree(CvFILE(cv));
10031             }
10032             CvFILE_set_from_cop(cv, PL_curcop);
10033             CvSTASH_set(cv, PL_curstash);
10034
10035             /* inner references to PL_compcv must be fixed up ... */
10036             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10037             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10038                 ++PL_sub_generation;
10039         }
10040         else {
10041             /* Might have had built-in attributes applied -- propagate them. */
10042             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10043         }
10044         /* ... before we throw it away */
10045         SvREFCNT_dec(PL_compcv);
10046         PL_compcv = cv;
10047     }
10048     else {
10049         cv = PL_compcv;
10050         if (name && isGV(gv)) {
10051             GvCV_set(gv, cv);
10052             GvCVGEN(gv) = 0;
10053             if (HvENAME_HEK(GvSTASH(gv)))
10054                 /* sub Foo::bar { (shift)+1 } */
10055                 gv_method_changed(gv);
10056         }
10057         else if (name) {
10058             if (!SvROK(gv)) {
10059                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10060                 prepare_SV_for_RV((SV *)gv);
10061                 SvOK_off((SV *)gv);
10062                 SvROK_on(gv);
10063             }
10064             SvRV_set(gv, (SV *)cv);
10065             if (HvENAME_HEK(PL_curstash))
10066                 mro_method_changed_in(PL_curstash);
10067         }
10068     }
10069     assert(cv);
10070     assert(SvREFCNT((SV*)cv) != 0);
10071
10072     if (!CvHASGV(cv)) {
10073         if (isGV(gv))
10074             CvGV_set(cv, gv);
10075         else {
10076             dVAR;
10077             U32 hash;
10078             PERL_HASH(hash, name, namlen);
10079             CvNAME_HEK_set(cv, share_hek(name,
10080                                          name_is_utf8
10081                                             ? -(SSize_t)namlen
10082                                             :  (SSize_t)namlen,
10083                                          hash));
10084         }
10085         CvFILE_set_from_cop(cv, PL_curcop);
10086         CvSTASH_set(cv, PL_curstash);
10087     }
10088
10089     if (ps) {
10090         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10091         if ( ps_utf8 )
10092             SvUTF8_on(MUTABLE_SV(cv));
10093     }
10094
10095     if (block) {
10096         /* If we assign an optree to a PVCV, then we've defined a
10097          * subroutine that the debugger could be able to set a breakpoint
10098          * in, so signal to pp_entereval that it should not throw away any
10099          * saved lines at scope exit.  */
10100
10101         PL_breakable_sub_gen++;
10102         CvROOT(cv) = block;
10103         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10104            itself has a refcount. */
10105         CvSLABBED_off(cv);
10106         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10107 #ifdef PERL_DEBUG_READONLY_OPS
10108         slab = (OPSLAB *)CvSTART(cv);
10109 #endif
10110         S_process_optree(aTHX_ cv, block, start);
10111     }
10112
10113   attrs:
10114     if (attrs) {
10115         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10116         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10117                         ? GvSTASH(CvGV(cv))
10118                         : PL_curstash;
10119         if (!name)
10120             SAVEFREESV(cv);
10121         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10122         if (!name)
10123             SvREFCNT_inc_simple_void_NN(cv);
10124     }
10125
10126     if (block && has_name) {
10127         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10128             SV * const tmpstr = cv_name(cv,NULL,0);
10129             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10130                                                   GV_ADDMULTI, SVt_PVHV);
10131             HV *hv;
10132             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10133                                           CopFILE(PL_curcop),
10134                                           (long)PL_subline,
10135                                           (long)CopLINE(PL_curcop));
10136             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10137                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10138             hv = GvHVn(db_postponed);
10139             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10140                 CV * const pcv = GvCV(db_postponed);
10141                 if (pcv) {
10142                     dSP;
10143                     PUSHMARK(SP);
10144                     XPUSHs(tmpstr);
10145                     PUTBACK;
10146                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10147                 }
10148             }
10149         }
10150
10151         if (name) {
10152             if (PL_parser && PL_parser->error_count)
10153                 clear_special_blocks(name, gv, cv);
10154             else
10155                 evanescent =
10156                     process_special_blocks(floor, name, gv, cv);
10157         }
10158     }
10159     assert(cv);
10160
10161   done:
10162     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10163     if (PL_parser)
10164         PL_parser->copline = NOLINE;
10165     LEAVE_SCOPE(floor);
10166
10167     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10168     if (!evanescent) {
10169 #ifdef PERL_DEBUG_READONLY_OPS
10170     if (slab)
10171         Slab_to_ro(slab);
10172 #endif
10173     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10174         pad_add_weakref(cv);
10175     }
10176     return cv;
10177 }
10178
10179 STATIC void
10180 S_clear_special_blocks(pTHX_ const char *const fullname,
10181                        GV *const gv, CV *const cv) {
10182     const char *colon;
10183     const char *name;
10184
10185     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10186
10187     colon = strrchr(fullname,':');
10188     name = colon ? colon + 1 : fullname;
10189
10190     if ((*name == 'B' && strEQ(name, "BEGIN"))
10191         || (*name == 'E' && strEQ(name, "END"))
10192         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10193         || (*name == 'C' && strEQ(name, "CHECK"))
10194         || (*name == 'I' && strEQ(name, "INIT"))) {
10195         if (!isGV(gv)) {
10196             (void)CvGV(cv);
10197             assert(isGV(gv));
10198         }
10199         GvCV_set(gv, NULL);
10200         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10201     }
10202 }
10203
10204 /* Returns true if the sub has been freed.  */
10205 STATIC bool
10206 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10207                          GV *const gv,
10208                          CV *const cv)
10209 {
10210     const char *const colon = strrchr(fullname,':');
10211     const char *const name = colon ? colon + 1 : fullname;
10212
10213     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10214
10215     if (*name == 'B') {
10216         if (strEQ(name, "BEGIN")) {
10217             const I32 oldscope = PL_scopestack_ix;
10218             dSP;
10219             (void)CvGV(cv);
10220             if (floor) LEAVE_SCOPE(floor);
10221             ENTER;
10222             PUSHSTACKi(PERLSI_REQUIRE);
10223             SAVECOPFILE(&PL_compiling);
10224             SAVECOPLINE(&PL_compiling);
10225             SAVEVPTR(PL_curcop);
10226
10227             DEBUG_x( dump_sub(gv) );
10228             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10229             GvCV_set(gv,0);             /* cv has been hijacked */
10230             call_list(oldscope, PL_beginav);
10231
10232             POPSTACK;
10233             LEAVE;
10234             return !PL_savebegin;
10235         }
10236         else
10237             return FALSE;
10238     } else {
10239         if (*name == 'E') {
10240             if strEQ(name, "END") {
10241                 DEBUG_x( dump_sub(gv) );
10242                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10243             } else
10244                 return FALSE;
10245         } else if (*name == 'U') {
10246             if (strEQ(name, "UNITCHECK")) {
10247                 /* It's never too late to run a unitcheck block */
10248                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10249             }
10250             else
10251                 return FALSE;
10252         } else if (*name == 'C') {
10253             if (strEQ(name, "CHECK")) {
10254                 if (PL_main_start)
10255                     /* diag_listed_as: Too late to run %s block */
10256                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10257                                    "Too late to run CHECK block");
10258                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10259             }
10260             else
10261                 return FALSE;
10262         } else if (*name == 'I') {
10263             if (strEQ(name, "INIT")) {
10264                 if (PL_main_start)
10265                     /* diag_listed_as: Too late to run %s block */
10266                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10267                                    "Too late to run INIT block");
10268                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10269             }
10270             else
10271                 return FALSE;
10272         } else
10273             return FALSE;
10274         DEBUG_x( dump_sub(gv) );
10275         (void)CvGV(cv);
10276         GvCV_set(gv,0);         /* cv has been hijacked */
10277         return FALSE;
10278     }
10279 }
10280
10281 /*
10282 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10283
10284 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10285 rather than of counted length, and no flags are set.  (This means that
10286 C<name> is always interpreted as Latin-1.)
10287
10288 =cut
10289 */
10290
10291 CV *
10292 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10293 {
10294     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10295 }
10296
10297 /*
10298 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10299
10300 Construct a constant subroutine, also performing some surrounding
10301 jobs.  A scalar constant-valued subroutine is eligible for inlining
10302 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10303 123 }>>.  Other kinds of constant subroutine have other treatment.
10304
10305 The subroutine will have an empty prototype and will ignore any arguments
10306 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10307 is null, the subroutine will yield an empty list.  If C<sv> points to a
10308 scalar, the subroutine will always yield that scalar.  If C<sv> points
10309 to an array, the subroutine will always yield a list of the elements of
10310 that array in list context, or the number of elements in the array in
10311 scalar context.  This function takes ownership of one counted reference
10312 to the scalar or array, and will arrange for the object to live as long
10313 as the subroutine does.  If C<sv> points to a scalar then the inlining
10314 assumes that the value of the scalar will never change, so the caller
10315 must ensure that the scalar is not subsequently written to.  If C<sv>
10316 points to an array then no such assumption is made, so it is ostensibly
10317 safe to mutate the array or its elements, but whether this is really
10318 supported has not been determined.
10319
10320 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10321 Other aspects of the subroutine will be left in their default state.
10322 The caller is free to mutate the subroutine beyond its initial state
10323 after this function has returned.
10324
10325 If C<name> is null then the subroutine will be anonymous, with its
10326 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10327 subroutine will be named accordingly, referenced by the appropriate glob.
10328 C<name> is a string of length C<len> bytes giving a sigilless symbol
10329 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10330 otherwise.  The name may be either qualified or unqualified.  If the
10331 name is unqualified then it defaults to being in the stash specified by
10332 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10333 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10334 semantics.
10335
10336 C<flags> should not have bits set other than C<SVf_UTF8>.
10337
10338 If there is already a subroutine of the specified name, then the new sub
10339 will replace the existing one in the glob.  A warning may be generated
10340 about the redefinition.
10341
10342 If the subroutine has one of a few special names, such as C<BEGIN> or
10343 C<END>, then it will be claimed by the appropriate queue for automatic
10344 running of phase-related subroutines.  In this case the relevant glob will
10345 be left not containing any subroutine, even if it did contain one before.
10346 Execution of the subroutine will likely be a no-op, unless C<sv> was
10347 a tied array or the caller modified the subroutine in some interesting
10348 way before it was executed.  In the case of C<BEGIN>, the treatment is
10349 buggy: the sub will be executed when only half built, and may be deleted
10350 prematurely, possibly causing a crash.
10351
10352 The function returns a pointer to the constructed subroutine.  If the sub
10353 is anonymous then ownership of one counted reference to the subroutine
10354 is transferred to the caller.  If the sub is named then the caller does
10355 not get ownership of a reference.  In most such cases, where the sub
10356 has a non-phase name, the sub will be alive at the point it is returned
10357 by virtue of being contained in the glob that names it.  A phase-named
10358 subroutine will usually be alive by virtue of the reference owned by
10359 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10360 destroyed already by the time this function returns, but currently bugs
10361 occur in that case before the caller gets control.  It is the caller's
10362 responsibility to ensure that it knows which of these situations applies.
10363
10364 =cut
10365 */
10366
10367 CV *
10368 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10369                              U32 flags, SV *sv)
10370 {
10371     CV* cv;
10372     const char *const file = CopFILE(PL_curcop);
10373
10374     ENTER;
10375
10376     if (IN_PERL_RUNTIME) {
10377         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10378          * an op shared between threads. Use a non-shared COP for our
10379          * dirty work */
10380          SAVEVPTR(PL_curcop);
10381          SAVECOMPILEWARNINGS();
10382          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10383          PL_curcop = &PL_compiling;
10384     }
10385     SAVECOPLINE(PL_curcop);
10386     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10387
10388     SAVEHINTS();
10389     PL_hints &= ~HINT_BLOCK_SCOPE;
10390
10391     if (stash) {
10392         SAVEGENERICSV(PL_curstash);
10393         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10394     }
10395
10396     /* Protect sv against leakage caused by fatal warnings. */
10397     if (sv) SAVEFREESV(sv);
10398
10399     /* file becomes the CvFILE. For an XS, it's usually static storage,
10400        and so doesn't get free()d.  (It's expected to be from the C pre-
10401        processor __FILE__ directive). But we need a dynamically allocated one,
10402        and we need it to get freed.  */
10403     cv = newXS_len_flags(name, len,
10404                          sv && SvTYPE(sv) == SVt_PVAV
10405                              ? const_av_xsub
10406                              : const_sv_xsub,
10407                          file ? file : "", "",
10408                          &sv, XS_DYNAMIC_FILENAME | flags);
10409     assert(cv);
10410     assert(SvREFCNT((SV*)cv) != 0);
10411     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10412     CvCONST_on(cv);
10413
10414     LEAVE;
10415
10416     return cv;
10417 }
10418
10419 /*
10420 =for apidoc U||newXS
10421
10422 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10423 static storage, as it is used directly as CvFILE(), without a copy being made.
10424
10425 =cut
10426 */
10427
10428 CV *
10429 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10430 {
10431     PERL_ARGS_ASSERT_NEWXS;
10432     return newXS_len_flags(
10433         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10434     );
10435 }
10436
10437 CV *
10438 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10439                  const char *const filename, const char *const proto,
10440                  U32 flags)
10441 {
10442     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10443     return newXS_len_flags(
10444        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10445     );
10446 }
10447
10448 CV *
10449 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10450 {
10451     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10452     return newXS_len_flags(
10453         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10454     );
10455 }
10456
10457 /*
10458 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10459
10460 Construct an XS subroutine, also performing some surrounding jobs.
10461
10462 The subroutine will have the entry point C<subaddr>.  It will have
10463 the prototype specified by the nul-terminated string C<proto>, or
10464 no prototype if C<proto> is null.  The prototype string is copied;
10465 the caller can mutate the supplied string afterwards.  If C<filename>
10466 is non-null, it must be a nul-terminated filename, and the subroutine
10467 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10468 point directly to the supplied string, which must be static.  If C<flags>
10469 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10470 be taken instead.
10471
10472 Other aspects of the subroutine will be left in their default state.
10473 If anything else needs to be done to the subroutine for it to function
10474 correctly, it is the caller's responsibility to do that after this
10475 function has constructed it.  However, beware of the subroutine
10476 potentially being destroyed before this function returns, as described
10477 below.
10478
10479 If C<name> is null then the subroutine will be anonymous, with its
10480 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10481 subroutine will be named accordingly, referenced by the appropriate glob.
10482 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10483 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10484 The name may be either qualified or unqualified, with the stash defaulting
10485 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10486 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10487 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10488 the stash if necessary, with C<GV_ADDMULTI> semantics.
10489
10490 If there is already a subroutine of the specified name, then the new sub
10491 will replace the existing one in the glob.  A warning may be generated
10492 about the redefinition.  If the old subroutine was C<CvCONST> then the
10493 decision about whether to warn is influenced by an expectation about
10494 whether the new subroutine will become a constant of similar value.
10495 That expectation is determined by C<const_svp>.  (Note that the call to
10496 this function doesn't make the new subroutine C<CvCONST> in any case;
10497 that is left to the caller.)  If C<const_svp> is null then it indicates
10498 that the new subroutine will not become a constant.  If C<const_svp>
10499 is non-null then it indicates that the new subroutine will become a
10500 constant, and it points to an C<SV*> that provides the constant value
10501 that the subroutine will have.
10502
10503 If the subroutine has one of a few special names, such as C<BEGIN> or
10504 C<END>, then it will be claimed by the appropriate queue for automatic
10505 running of phase-related subroutines.  In this case the relevant glob will
10506 be left not containing any subroutine, even if it did contain one before.
10507 In the case of C<BEGIN>, the subroutine will be executed and the reference
10508 to it disposed of before this function returns, and also before its
10509 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10510 constructed by this function to be ready for execution then the caller
10511 must prevent this happening by giving the subroutine a different name.
10512
10513 The function returns a pointer to the constructed subroutine.  If the sub
10514 is anonymous then ownership of one counted reference to the subroutine
10515 is transferred to the caller.  If the sub is named then the caller does
10516 not get ownership of a reference.  In most such cases, where the sub
10517 has a non-phase name, the sub will be alive at the point it is returned
10518 by virtue of being contained in the glob that names it.  A phase-named
10519 subroutine will usually be alive by virtue of the reference owned by the
10520 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10521 been executed, will quite likely have been destroyed already by the
10522 time this function returns, making it erroneous for the caller to make
10523 any use of the returned pointer.  It is the caller's responsibility to
10524 ensure that it knows which of these situations applies.
10525
10526 =cut
10527 */
10528
10529 CV *
10530 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10531                            XSUBADDR_t subaddr, const char *const filename,
10532                            const char *const proto, SV **const_svp,
10533                            U32 flags)
10534 {
10535     CV *cv;
10536     bool interleave = FALSE;
10537     bool evanescent = FALSE;
10538
10539     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10540
10541     {
10542         GV * const gv = gv_fetchpvn(
10543                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10544                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10545                                 sizeof("__ANON__::__ANON__") - 1,
10546                             GV_ADDMULTI | flags, SVt_PVCV);
10547
10548         if ((cv = (name ? GvCV(gv) : NULL))) {
10549             if (GvCVGEN(gv)) {
10550                 /* just a cached method */
10551                 SvREFCNT_dec(cv);
10552                 cv = NULL;
10553             }
10554             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10555                 /* already defined (or promised) */
10556                 /* Redundant check that allows us to avoid creating an SV
10557                    most of the time: */
10558                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10559                     report_redefined_cv(newSVpvn_flags(
10560                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10561                                         ),
10562                                         cv, const_svp);
10563                 }
10564                 interleave = TRUE;
10565                 ENTER;
10566                 SAVEFREESV(cv);
10567                 cv = NULL;
10568             }
10569         }
10570
10571         if (cv)                         /* must reuse cv if autoloaded */
10572             cv_undef(cv);
10573         else {
10574             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10575             if (name) {
10576                 GvCV_set(gv,cv);
10577                 GvCVGEN(gv) = 0;
10578                 if (HvENAME_HEK(GvSTASH(gv)))
10579                     gv_method_changed(gv); /* newXS */
10580             }
10581         }
10582         assert(cv);
10583         assert(SvREFCNT((SV*)cv) != 0);
10584
10585         CvGV_set(cv, gv);
10586         if(filename) {
10587             /* XSUBs can't be perl lang/perl5db.pl debugged
10588             if (PERLDB_LINE_OR_SAVESRC)
10589                 (void)gv_fetchfile(filename); */
10590             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10591             if (flags & XS_DYNAMIC_FILENAME) {
10592                 CvDYNFILE_on(cv);
10593                 CvFILE(cv) = savepv(filename);
10594             } else {
10595             /* NOTE: not copied, as it is expected to be an external constant string */
10596                 CvFILE(cv) = (char *)filename;
10597             }
10598         } else {
10599             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10600             CvFILE(cv) = (char*)PL_xsubfilename;
10601         }
10602         CvISXSUB_on(cv);
10603         CvXSUB(cv) = subaddr;
10604 #ifndef PERL_IMPLICIT_CONTEXT
10605         CvHSCXT(cv) = &PL_stack_sp;
10606 #else
10607         PoisonPADLIST(cv);
10608 #endif
10609
10610         if (name)
10611             evanescent = process_special_blocks(0, name, gv, cv);
10612         else
10613             CvANON_on(cv);
10614     } /* <- not a conditional branch */
10615
10616     assert(cv);
10617     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10618
10619     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10620     if (interleave) LEAVE;
10621     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10622     return cv;
10623 }
10624
10625 CV *
10626 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10627 {
10628     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10629     GV *cvgv;
10630     PERL_ARGS_ASSERT_NEWSTUB;
10631     assert(!GvCVu(gv));
10632     GvCV_set(gv, cv);
10633     GvCVGEN(gv) = 0;
10634     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10635         gv_method_changed(gv);
10636     if (SvFAKE(gv)) {
10637         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10638         SvFAKE_off(cvgv);
10639     }
10640     else cvgv = gv;
10641     CvGV_set(cv, cvgv);
10642     CvFILE_set_from_cop(cv, PL_curcop);
10643     CvSTASH_set(cv, PL_curstash);
10644     GvMULTI_on(gv);
10645     return cv;
10646 }
10647
10648 void
10649 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10650 {
10651     CV *cv;
10652     GV *gv;
10653     OP *root;
10654     OP *start;
10655
10656     if (PL_parser && PL_parser->error_count) {
10657         op_free(block);
10658         goto finish;
10659     }
10660
10661     gv = o
10662         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10663         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10664
10665     GvMULTI_on(gv);
10666     if ((cv = GvFORM(gv))) {
10667         if (ckWARN(WARN_REDEFINE)) {
10668             const line_t oldline = CopLINE(PL_curcop);
10669             if (PL_parser && PL_parser->copline != NOLINE)
10670                 CopLINE_set(PL_curcop, PL_parser->copline);
10671             if (o) {
10672                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10673                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10674             } else {
10675                 /* diag_listed_as: Format %s redefined */
10676                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10677                             "Format STDOUT redefined");
10678             }
10679             CopLINE_set(PL_curcop, oldline);
10680         }
10681         SvREFCNT_dec(cv);
10682     }
10683     cv = PL_compcv;
10684     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10685     CvGV_set(cv, gv);
10686     CvFILE_set_from_cop(cv, PL_curcop);
10687
10688
10689     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10690     CvROOT(cv) = root;
10691     start = LINKLIST(root);
10692     root->op_next = 0;
10693     S_process_optree(aTHX_ cv, root, start);
10694     cv_forget_slab(cv);
10695
10696   finish:
10697     op_free(o);
10698     if (PL_parser)
10699         PL_parser->copline = NOLINE;
10700     LEAVE_SCOPE(floor);
10701     PL_compiling.cop_seq = 0;
10702 }
10703
10704 OP *
10705 Perl_newANONLIST(pTHX_ OP *o)
10706 {
10707     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10708 }
10709
10710 OP *
10711 Perl_newANONHASH(pTHX_ OP *o)
10712 {
10713     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10714 }
10715
10716 OP *
10717 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10718 {
10719     return newANONATTRSUB(floor, proto, NULL, block);
10720 }
10721
10722 OP *
10723 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10724 {
10725     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10726     OP * anoncode =
10727         newSVOP(OP_ANONCODE, 0,
10728                 cv);
10729     if (CvANONCONST(cv))
10730         anoncode = newUNOP(OP_ANONCONST, 0,
10731                            op_convert_list(OP_ENTERSUB,
10732                                            OPf_STACKED|OPf_WANT_SCALAR,
10733                                            anoncode));
10734     return newUNOP(OP_REFGEN, 0, anoncode);
10735 }
10736
10737 OP *
10738 Perl_oopsAV(pTHX_ OP *o)
10739 {
10740     dVAR;
10741
10742     PERL_ARGS_ASSERT_OOPSAV;
10743
10744     switch (o->op_type) {
10745     case OP_PADSV:
10746     case OP_PADHV:
10747         OpTYPE_set(o, OP_PADAV);
10748         return ref(o, OP_RV2AV);
10749
10750     case OP_RV2SV:
10751     case OP_RV2HV:
10752         OpTYPE_set(o, OP_RV2AV);
10753         ref(o, OP_RV2AV);
10754         break;
10755
10756     default:
10757         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10758         break;
10759     }
10760     return o;
10761 }
10762
10763 OP *
10764 Perl_oopsHV(pTHX_ OP *o)
10765 {
10766     dVAR;
10767
10768     PERL_ARGS_ASSERT_OOPSHV;
10769
10770     switch (o->op_type) {
10771     case OP_PADSV:
10772     case OP_PADAV:
10773         OpTYPE_set(o, OP_PADHV);
10774         return ref(o, OP_RV2HV);
10775
10776     case OP_RV2SV:
10777     case OP_RV2AV:
10778         OpTYPE_set(o, OP_RV2HV);
10779         /* rv2hv steals the bottom bit for its own uses */
10780         o->op_private &= ~OPpARG1_MASK;
10781         ref(o, OP_RV2HV);
10782         break;
10783
10784     default:
10785         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10786         break;
10787     }
10788     return o;
10789 }
10790
10791 OP *
10792 Perl_newAVREF(pTHX_ OP *o)
10793 {
10794     dVAR;
10795
10796     PERL_ARGS_ASSERT_NEWAVREF;
10797
10798     if (o->op_type == OP_PADANY) {
10799         OpTYPE_set(o, OP_PADAV);
10800         return o;
10801     }
10802     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10803         Perl_croak(aTHX_ "Can't use an array as a reference");
10804     }
10805     return newUNOP(OP_RV2AV, 0, scalar(o));
10806 }
10807
10808 OP *
10809 Perl_newGVREF(pTHX_ I32 type, OP *o)
10810 {
10811     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10812         return newUNOP(OP_NULL, 0, o);
10813     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10814 }
10815
10816 OP *
10817 Perl_newHVREF(pTHX_ OP *o)
10818 {
10819     dVAR;
10820
10821     PERL_ARGS_ASSERT_NEWHVREF;
10822
10823     if (o->op_type == OP_PADANY) {
10824         OpTYPE_set(o, OP_PADHV);
10825         return o;
10826     }
10827     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10828         Perl_croak(aTHX_ "Can't use a hash as a reference");
10829     }
10830     return newUNOP(OP_RV2HV, 0, scalar(o));
10831 }
10832
10833 OP *
10834 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10835 {
10836     if (o->op_type == OP_PADANY) {
10837         dVAR;
10838         OpTYPE_set(o, OP_PADCV);
10839     }
10840     return newUNOP(OP_RV2CV, flags, scalar(o));
10841 }
10842
10843 OP *
10844 Perl_newSVREF(pTHX_ OP *o)
10845 {
10846     dVAR;
10847
10848     PERL_ARGS_ASSERT_NEWSVREF;
10849
10850     if (o->op_type == OP_PADANY) {
10851         OpTYPE_set(o, OP_PADSV);
10852         scalar(o);
10853         return o;
10854     }
10855     return newUNOP(OP_RV2SV, 0, scalar(o));
10856 }
10857
10858 /* Check routines. See the comments at the top of this file for details
10859  * on when these are called */
10860
10861 OP *
10862 Perl_ck_anoncode(pTHX_ OP *o)
10863 {
10864     PERL_ARGS_ASSERT_CK_ANONCODE;
10865
10866     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10867     cSVOPo->op_sv = NULL;
10868     return o;
10869 }
10870
10871 static void
10872 S_io_hints(pTHX_ OP *o)
10873 {
10874 #if O_BINARY != 0 || O_TEXT != 0
10875     HV * const table =
10876         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10877     if (table) {
10878         SV **svp = hv_fetchs(table, "open_IN", FALSE);
10879         if (svp && *svp) {
10880             STRLEN len = 0;
10881             const char *d = SvPV_const(*svp, len);
10882             const I32 mode = mode_from_discipline(d, len);
10883             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10884 #  if O_BINARY != 0
10885             if (mode & O_BINARY)
10886                 o->op_private |= OPpOPEN_IN_RAW;
10887 #  endif
10888 #  if O_TEXT != 0
10889             if (mode & O_TEXT)
10890                 o->op_private |= OPpOPEN_IN_CRLF;
10891 #  endif
10892         }
10893
10894         svp = hv_fetchs(table, "open_OUT", FALSE);
10895         if (svp && *svp) {
10896             STRLEN len = 0;
10897             const char *d = SvPV_const(*svp, len);
10898             const I32 mode = mode_from_discipline(d, len);
10899             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10900 #  if O_BINARY != 0
10901             if (mode & O_BINARY)
10902                 o->op_private |= OPpOPEN_OUT_RAW;
10903 #  endif
10904 #  if O_TEXT != 0
10905             if (mode & O_TEXT)
10906                 o->op_private |= OPpOPEN_OUT_CRLF;
10907 #  endif
10908         }
10909     }
10910 #else
10911     PERL_UNUSED_CONTEXT;
10912     PERL_UNUSED_ARG(o);
10913 #endif
10914 }
10915
10916 OP *
10917 Perl_ck_backtick(pTHX_ OP *o)
10918 {
10919     GV *gv;
10920     OP *newop = NULL;
10921     OP *sibl;
10922     PERL_ARGS_ASSERT_CK_BACKTICK;
10923     o = ck_fun(o);
10924     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
10925     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
10926      && (gv = gv_override("readpipe",8)))
10927     {
10928         /* detach rest of siblings from o and its first child */
10929         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10930         newop = S_new_entersubop(aTHX_ gv, sibl);
10931     }
10932     else if (!(o->op_flags & OPf_KIDS))
10933         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
10934     if (newop) {
10935         op_free(o);
10936         return newop;
10937     }
10938     S_io_hints(aTHX_ o);
10939     return o;
10940 }
10941
10942 OP *
10943 Perl_ck_bitop(pTHX_ OP *o)
10944 {
10945     PERL_ARGS_ASSERT_CK_BITOP;
10946
10947     o->op_private = (U8)(PL_hints & HINT_INTEGER);
10948
10949     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
10950             && OP_IS_INFIX_BIT(o->op_type))
10951     {
10952         const OP * const left = cBINOPo->op_first;
10953         const OP * const right = OpSIBLING(left);
10954         if ((OP_IS_NUMCOMPARE(left->op_type) &&
10955                 (left->op_flags & OPf_PARENS) == 0) ||
10956             (OP_IS_NUMCOMPARE(right->op_type) &&
10957                 (right->op_flags & OPf_PARENS) == 0))
10958             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
10959                           "Possible precedence problem on bitwise %s operator",
10960                            o->op_type ==  OP_BIT_OR
10961                          ||o->op_type == OP_NBIT_OR  ? "|"
10962                         :  o->op_type ==  OP_BIT_AND
10963                          ||o->op_type == OP_NBIT_AND ? "&"
10964                         :  o->op_type ==  OP_BIT_XOR
10965                          ||o->op_type == OP_NBIT_XOR ? "^"
10966                         :  o->op_type == OP_SBIT_OR  ? "|."
10967                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
10968                            );
10969     }
10970     return o;
10971 }
10972
10973 PERL_STATIC_INLINE bool
10974 is_dollar_bracket(pTHX_ const OP * const o)
10975 {
10976     const OP *kid;
10977     PERL_UNUSED_CONTEXT;
10978     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
10979         && (kid = cUNOPx(o)->op_first)
10980         && kid->op_type == OP_GV
10981         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
10982 }
10983
10984 /* for lt, gt, le, ge, eq, ne and their i_ variants */
10985
10986 OP *
10987 Perl_ck_cmp(pTHX_ OP *o)
10988 {
10989     bool is_eq;
10990     bool neg;
10991     bool reverse;
10992     bool iv0;
10993     OP *indexop, *constop, *start;
10994     SV *sv;
10995     IV iv;
10996
10997     PERL_ARGS_ASSERT_CK_CMP;
10998
10999     is_eq = (   o->op_type == OP_EQ
11000              || o->op_type == OP_NE
11001              || o->op_type == OP_I_EQ
11002              || o->op_type == OP_I_NE);
11003
11004     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11005         const OP *kid = cUNOPo->op_first;
11006         if (kid &&
11007             (
11008                 (   is_dollar_bracket(aTHX_ kid)
11009                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11010                 )
11011              || (   kid->op_type == OP_CONST
11012                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11013                 )
11014            )
11015         )
11016             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11017                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11018     }
11019
11020     /* convert (index(...) == -1) and variations into
11021      *   (r)index/BOOL(,NEG)
11022      */
11023
11024     reverse = FALSE;
11025
11026     indexop = cUNOPo->op_first;
11027     constop = OpSIBLING(indexop);
11028     start = NULL;
11029     if (indexop->op_type == OP_CONST) {
11030         constop = indexop;
11031         indexop = OpSIBLING(constop);
11032         start = constop;
11033         reverse = TRUE;
11034     }
11035
11036     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11037         return o;
11038
11039     /* ($lex = index(....)) == -1 */
11040     if (indexop->op_private & OPpTARGET_MY)
11041         return o;
11042
11043     if (constop->op_type != OP_CONST)
11044         return o;
11045
11046     sv = cSVOPx_sv(constop);
11047     if (!(sv && SvIOK_notUV(sv)))
11048         return o;
11049
11050     iv = SvIVX(sv);
11051     if (iv != -1 && iv != 0)
11052         return o;
11053     iv0 = (iv == 0);
11054
11055     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11056         if (!(iv0 ^ reverse))
11057             return o;
11058         neg = iv0;
11059     }
11060     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11061         if (iv0 ^ reverse)
11062             return o;
11063         neg = !iv0;
11064     }
11065     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11066         if (!(iv0 ^ reverse))
11067             return o;
11068         neg = !iv0;
11069     }
11070     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11071         if (iv0 ^ reverse)
11072             return o;
11073         neg = iv0;
11074     }
11075     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11076         if (iv0)
11077             return o;
11078         neg = TRUE;
11079     }
11080     else {
11081         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11082         if (iv0)
11083             return o;
11084         neg = FALSE;
11085     }
11086
11087     indexop->op_flags &= ~OPf_PARENS;
11088     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11089     indexop->op_private |= OPpTRUEBOOL;
11090     if (neg)
11091         indexop->op_private |= OPpINDEX_BOOLNEG;
11092     /* cut out the index op and free the eq,const ops */
11093     (void)op_sibling_splice(o, start, 1, NULL);
11094     op_free(o);
11095
11096     return indexop;
11097 }
11098
11099
11100 OP *
11101 Perl_ck_concat(pTHX_ OP *o)
11102 {
11103     const OP * const kid = cUNOPo->op_first;
11104
11105     PERL_ARGS_ASSERT_CK_CONCAT;
11106     PERL_UNUSED_CONTEXT;
11107
11108     /* reuse the padtmp returned by the concat child */
11109     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11110             !(kUNOP->op_first->op_flags & OPf_MOD))
11111     {
11112         o->op_flags |= OPf_STACKED;
11113         o->op_private |= OPpCONCAT_NESTED;
11114     }
11115     return o;
11116 }
11117
11118 OP *
11119 Perl_ck_spair(pTHX_ OP *o)
11120 {
11121     dVAR;
11122
11123     PERL_ARGS_ASSERT_CK_SPAIR;
11124
11125     if (o->op_flags & OPf_KIDS) {
11126         OP* newop;
11127         OP* kid;
11128         OP* kidkid;
11129         const OPCODE type = o->op_type;
11130         o = modkids(ck_fun(o), type);
11131         kid    = cUNOPo->op_first;
11132         kidkid = kUNOP->op_first;
11133         newop = OpSIBLING(kidkid);
11134         if (newop) {
11135             const OPCODE type = newop->op_type;
11136             if (OpHAS_SIBLING(newop))
11137                 return o;
11138             if (o->op_type == OP_REFGEN
11139              && (  type == OP_RV2CV
11140                 || (  !(newop->op_flags & OPf_PARENS)
11141                    && (  type == OP_RV2AV || type == OP_PADAV
11142                       || type == OP_RV2HV || type == OP_PADHV))))
11143                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11144             else if (OP_GIMME(newop,0) != G_SCALAR)
11145                 return o;
11146         }
11147         /* excise first sibling */
11148         op_sibling_splice(kid, NULL, 1, NULL);
11149         op_free(kidkid);
11150     }
11151     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11152      * and OP_CHOMP into OP_SCHOMP */
11153     o->op_ppaddr = PL_ppaddr[++o->op_type];
11154     return ck_fun(o);
11155 }
11156
11157 OP *
11158 Perl_ck_delete(pTHX_ OP *o)
11159 {
11160     PERL_ARGS_ASSERT_CK_DELETE;
11161
11162     o = ck_fun(o);
11163     o->op_private = 0;
11164     if (o->op_flags & OPf_KIDS) {
11165         OP * const kid = cUNOPo->op_first;
11166         switch (kid->op_type) {
11167         case OP_ASLICE:
11168             o->op_flags |= OPf_SPECIAL;
11169             /* FALLTHROUGH */
11170         case OP_HSLICE:
11171             o->op_private |= OPpSLICE;
11172             break;
11173         case OP_AELEM:
11174             o->op_flags |= OPf_SPECIAL;
11175             /* FALLTHROUGH */
11176         case OP_HELEM:
11177             break;
11178         case OP_KVASLICE:
11179             o->op_flags |= OPf_SPECIAL;
11180             /* FALLTHROUGH */
11181         case OP_KVHSLICE:
11182             o->op_private |= OPpKVSLICE;
11183             break;
11184         default:
11185             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11186                              "element or slice");
11187         }
11188         if (kid->op_private & OPpLVAL_INTRO)
11189             o->op_private |= OPpLVAL_INTRO;
11190         op_null(kid);
11191     }
11192     return o;
11193 }
11194
11195 OP *
11196 Perl_ck_eof(pTHX_ OP *o)
11197 {
11198     PERL_ARGS_ASSERT_CK_EOF;
11199
11200     if (o->op_flags & OPf_KIDS) {
11201         OP *kid;
11202         if (cLISTOPo->op_first->op_type == OP_STUB) {
11203             OP * const newop
11204                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11205             op_free(o);
11206             o = newop;
11207         }
11208         o = ck_fun(o);
11209         kid = cLISTOPo->op_first;
11210         if (kid->op_type == OP_RV2GV)
11211             kid->op_private |= OPpALLOW_FAKE;
11212     }
11213     return o;
11214 }
11215
11216
11217 OP *
11218 Perl_ck_eval(pTHX_ OP *o)
11219 {
11220     dVAR;
11221
11222     PERL_ARGS_ASSERT_CK_EVAL;
11223
11224     PL_hints |= HINT_BLOCK_SCOPE;
11225     if (o->op_flags & OPf_KIDS) {
11226         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11227         assert(kid);
11228
11229         if (o->op_type == OP_ENTERTRY) {
11230             LOGOP *enter;
11231
11232             /* cut whole sibling chain free from o */
11233             op_sibling_splice(o, NULL, -1, NULL);
11234             op_free(o);
11235
11236             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11237
11238             /* establish postfix order */
11239             enter->op_next = (OP*)enter;
11240
11241             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11242             OpTYPE_set(o, OP_LEAVETRY);
11243             enter->op_other = o;
11244             return o;
11245         }
11246         else {
11247             scalar((OP*)kid);
11248             S_set_haseval(aTHX);
11249         }
11250     }
11251     else {
11252         const U8 priv = o->op_private;
11253         op_free(o);
11254         /* the newUNOP will recursively call ck_eval(), which will handle
11255          * all the stuff at the end of this function, like adding
11256          * OP_HINTSEVAL
11257          */
11258         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11259     }
11260     o->op_targ = (PADOFFSET)PL_hints;
11261     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11262     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11263      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11264         /* Store a copy of %^H that pp_entereval can pick up. */
11265         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11266                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11267         /* append hhop to only child  */
11268         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11269
11270         o->op_private |= OPpEVAL_HAS_HH;
11271     }
11272     if (!(o->op_private & OPpEVAL_BYTES)
11273          && FEATURE_UNIEVAL_IS_ENABLED)
11274             o->op_private |= OPpEVAL_UNICODE;
11275     return o;
11276 }
11277
11278 OP *
11279 Perl_ck_exec(pTHX_ OP *o)
11280 {
11281     PERL_ARGS_ASSERT_CK_EXEC;
11282
11283     if (o->op_flags & OPf_STACKED) {
11284         OP *kid;
11285         o = ck_fun(o);
11286         kid = OpSIBLING(cUNOPo->op_first);
11287         if (kid->op_type == OP_RV2GV)
11288             op_null(kid);
11289     }
11290     else
11291         o = listkids(o);
11292     return o;
11293 }
11294
11295 OP *
11296 Perl_ck_exists(pTHX_ OP *o)
11297 {
11298     PERL_ARGS_ASSERT_CK_EXISTS;
11299
11300     o = ck_fun(o);
11301     if (o->op_flags & OPf_KIDS) {
11302         OP * const kid = cUNOPo->op_first;
11303         if (kid->op_type == OP_ENTERSUB) {
11304             (void) ref(kid, o->op_type);
11305             if (kid->op_type != OP_RV2CV
11306                         && !(PL_parser && PL_parser->error_count))
11307                 Perl_croak(aTHX_
11308                           "exists argument is not a subroutine name");
11309             o->op_private |= OPpEXISTS_SUB;
11310         }
11311         else if (kid->op_type == OP_AELEM)
11312             o->op_flags |= OPf_SPECIAL;
11313         else if (kid->op_type != OP_HELEM)
11314             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11315                              "element or a subroutine");
11316         op_null(kid);
11317     }
11318     return o;
11319 }
11320
11321 OP *
11322 Perl_ck_rvconst(pTHX_ OP *o)
11323 {
11324     dVAR;
11325     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11326
11327     PERL_ARGS_ASSERT_CK_RVCONST;
11328
11329     if (o->op_type == OP_RV2HV)
11330         /* rv2hv steals the bottom bit for its own uses */
11331         o->op_private &= ~OPpARG1_MASK;
11332
11333     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11334
11335     if (kid->op_type == OP_CONST) {
11336         int iscv;
11337         GV *gv;
11338         SV * const kidsv = kid->op_sv;
11339
11340         /* Is it a constant from cv_const_sv()? */
11341         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11342             return o;
11343         }
11344         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11345         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11346             const char *badthing;
11347             switch (o->op_type) {
11348             case OP_RV2SV:
11349                 badthing = "a SCALAR";
11350                 break;
11351             case OP_RV2AV:
11352                 badthing = "an ARRAY";
11353                 break;
11354             case OP_RV2HV:
11355                 badthing = "a HASH";
11356                 break;
11357             default:
11358                 badthing = NULL;
11359                 break;
11360             }
11361             if (badthing)
11362                 Perl_croak(aTHX_
11363                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11364                            SVfARG(kidsv), badthing);
11365         }
11366         /*
11367          * This is a little tricky.  We only want to add the symbol if we
11368          * didn't add it in the lexer.  Otherwise we get duplicate strict
11369          * warnings.  But if we didn't add it in the lexer, we must at
11370          * least pretend like we wanted to add it even if it existed before,
11371          * or we get possible typo warnings.  OPpCONST_ENTERED says
11372          * whether the lexer already added THIS instance of this symbol.
11373          */
11374         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11375         gv = gv_fetchsv(kidsv,
11376                 o->op_type == OP_RV2CV
11377                         && o->op_private & OPpMAY_RETURN_CONSTANT
11378                     ? GV_NOEXPAND
11379                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11380                 iscv
11381                     ? SVt_PVCV
11382                     : o->op_type == OP_RV2SV
11383                         ? SVt_PV
11384                         : o->op_type == OP_RV2AV
11385                             ? SVt_PVAV
11386                             : o->op_type == OP_RV2HV
11387                                 ? SVt_PVHV
11388                                 : SVt_PVGV);
11389         if (gv) {
11390             if (!isGV(gv)) {
11391                 assert(iscv);
11392                 assert(SvROK(gv));
11393                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11394                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11395                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11396             }
11397             OpTYPE_set(kid, OP_GV);
11398             SvREFCNT_dec(kid->op_sv);
11399 #ifdef USE_ITHREADS
11400             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11401             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11402             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11403             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11404             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11405 #else
11406             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11407 #endif
11408             kid->op_private = 0;
11409             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11410             SvFAKE_off(gv);
11411         }
11412     }
11413     return o;
11414 }
11415
11416 OP *
11417 Perl_ck_ftst(pTHX_ OP *o)
11418 {
11419     dVAR;
11420     const I32 type = o->op_type;
11421
11422     PERL_ARGS_ASSERT_CK_FTST;
11423
11424     if (o->op_flags & OPf_REF) {
11425         NOOP;
11426     }
11427     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11428         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11429         const OPCODE kidtype = kid->op_type;
11430
11431         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11432          && !kid->op_folded) {
11433             OP * const newop = newGVOP(type, OPf_REF,
11434                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11435             op_free(o);
11436             return newop;
11437         }
11438
11439         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11440             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11441             if (name) {
11442                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11443                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11444                             array_passed_to_stat, name);
11445             }
11446             else {
11447                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11448                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11449             }
11450        }
11451         scalar((OP *) kid);
11452         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11453             o->op_private |= OPpFT_ACCESS;
11454         if (type != OP_STAT && type != OP_LSTAT
11455             && PL_check[kidtype] == Perl_ck_ftst
11456             && kidtype != OP_STAT && kidtype != OP_LSTAT
11457         ) {
11458             o->op_private |= OPpFT_STACKED;
11459             kid->op_private |= OPpFT_STACKING;
11460             if (kidtype == OP_FTTTY && (
11461                    !(kid->op_private & OPpFT_STACKED)
11462                 || kid->op_private & OPpFT_AFTER_t
11463                ))
11464                 o->op_private |= OPpFT_AFTER_t;
11465         }
11466     }
11467     else {
11468         op_free(o);
11469         if (type == OP_FTTTY)
11470             o = newGVOP(type, OPf_REF, PL_stdingv);
11471         else
11472             o = newUNOP(type, 0, newDEFSVOP());
11473     }
11474     return o;
11475 }
11476
11477 OP *
11478 Perl_ck_fun(pTHX_ OP *o)
11479 {
11480     const int type = o->op_type;
11481     I32 oa = PL_opargs[type] >> OASHIFT;
11482
11483     PERL_ARGS_ASSERT_CK_FUN;
11484
11485     if (o->op_flags & OPf_STACKED) {
11486         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11487             oa &= ~OA_OPTIONAL;
11488         else
11489             return no_fh_allowed(o);
11490     }
11491
11492     if (o->op_flags & OPf_KIDS) {
11493         OP *prev_kid = NULL;
11494         OP *kid = cLISTOPo->op_first;
11495         I32 numargs = 0;
11496         bool seen_optional = FALSE;
11497
11498         if (kid->op_type == OP_PUSHMARK ||
11499             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11500         {
11501             prev_kid = kid;
11502             kid = OpSIBLING(kid);
11503         }
11504         if (kid && kid->op_type == OP_COREARGS) {
11505             bool optional = FALSE;
11506             while (oa) {
11507                 numargs++;
11508                 if (oa & OA_OPTIONAL) optional = TRUE;
11509                 oa = oa >> 4;
11510             }
11511             if (optional) o->op_private |= numargs;
11512             return o;
11513         }
11514
11515         while (oa) {
11516             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11517                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11518                     kid = newDEFSVOP();
11519                     /* append kid to chain */
11520                     op_sibling_splice(o, prev_kid, 0, kid);
11521                 }
11522                 seen_optional = TRUE;
11523             }
11524             if (!kid) break;
11525
11526             numargs++;
11527             switch (oa & 7) {
11528             case OA_SCALAR:
11529                 /* list seen where single (scalar) arg expected? */
11530                 if (numargs == 1 && !(oa >> 4)
11531                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11532                 {
11533                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11534                 }
11535                 if (type != OP_DELETE) scalar(kid);
11536                 break;
11537             case OA_LIST:
11538                 if (oa < 16) {
11539                     kid = 0;
11540                     continue;
11541                 }
11542                 else
11543                     list(kid);
11544                 break;
11545             case OA_AVREF:
11546                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11547                     && !OpHAS_SIBLING(kid))
11548                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11549                                    "Useless use of %s with no values",
11550                                    PL_op_desc[type]);
11551
11552                 if (kid->op_type == OP_CONST
11553                       && (  !SvROK(cSVOPx_sv(kid))
11554                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11555                         )
11556                     bad_type_pv(numargs, "array", o, kid);
11557                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11558                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11559                                          PL_op_desc[type]), 0);
11560                 }
11561                 else {
11562                     op_lvalue(kid, type);
11563                 }
11564                 break;
11565             case OA_HVREF:
11566                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11567                     bad_type_pv(numargs, "hash", o, kid);
11568                 op_lvalue(kid, type);
11569                 break;
11570             case OA_CVREF:
11571                 {
11572                     /* replace kid with newop in chain */
11573                     OP * const newop =
11574                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11575                     newop->op_next = newop;
11576                     kid = newop;
11577                 }
11578                 break;
11579             case OA_FILEREF:
11580                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11581                     if (kid->op_type == OP_CONST &&
11582                         (kid->op_private & OPpCONST_BARE))
11583                     {
11584                         OP * const newop = newGVOP(OP_GV, 0,
11585                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11586                         /* replace kid with newop in chain */
11587                         op_sibling_splice(o, prev_kid, 1, newop);
11588                         op_free(kid);
11589                         kid = newop;
11590                     }
11591                     else if (kid->op_type == OP_READLINE) {
11592                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11593                         bad_type_pv(numargs, "HANDLE", o, kid);
11594                     }
11595                     else {
11596                         I32 flags = OPf_SPECIAL;
11597                         I32 priv = 0;
11598                         PADOFFSET targ = 0;
11599
11600                         /* is this op a FH constructor? */
11601                         if (is_handle_constructor(o,numargs)) {
11602                             const char *name = NULL;
11603                             STRLEN len = 0;
11604                             U32 name_utf8 = 0;
11605                             bool want_dollar = TRUE;
11606
11607                             flags = 0;
11608                             /* Set a flag to tell rv2gv to vivify
11609                              * need to "prove" flag does not mean something
11610                              * else already - NI-S 1999/05/07
11611                              */
11612                             priv = OPpDEREF;
11613                             if (kid->op_type == OP_PADSV) {
11614                                 PADNAME * const pn
11615                                     = PAD_COMPNAME_SV(kid->op_targ);
11616                                 name = PadnamePV (pn);
11617                                 len  = PadnameLEN(pn);
11618                                 name_utf8 = PadnameUTF8(pn);
11619                             }
11620                             else if (kid->op_type == OP_RV2SV
11621                                      && kUNOP->op_first->op_type == OP_GV)
11622                             {
11623                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11624                                 name = GvNAME(gv);
11625                                 len = GvNAMELEN(gv);
11626                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11627                             }
11628                             else if (kid->op_type == OP_AELEM
11629                                      || kid->op_type == OP_HELEM)
11630                             {
11631                                  OP *firstop;
11632                                  OP *op = ((BINOP*)kid)->op_first;
11633                                  name = NULL;
11634                                  if (op) {
11635                                       SV *tmpstr = NULL;
11636                                       const char * const a =
11637                                            kid->op_type == OP_AELEM ?
11638                                            "[]" : "{}";
11639                                       if (((op->op_type == OP_RV2AV) ||
11640                                            (op->op_type == OP_RV2HV)) &&
11641                                           (firstop = ((UNOP*)op)->op_first) &&
11642                                           (firstop->op_type == OP_GV)) {
11643                                            /* packagevar $a[] or $h{} */
11644                                            GV * const gv = cGVOPx_gv(firstop);
11645                                            if (gv)
11646                                                 tmpstr =
11647                                                      Perl_newSVpvf(aTHX_
11648                                                                    "%s%c...%c",
11649                                                                    GvNAME(gv),
11650                                                                    a[0], a[1]);
11651                                       }
11652                                       else if (op->op_type == OP_PADAV
11653                                                || op->op_type == OP_PADHV) {
11654                                            /* lexicalvar $a[] or $h{} */
11655                                            const char * const padname =
11656                                                 PAD_COMPNAME_PV(op->op_targ);
11657                                            if (padname)
11658                                                 tmpstr =
11659                                                      Perl_newSVpvf(aTHX_
11660                                                                    "%s%c...%c",
11661                                                                    padname + 1,
11662                                                                    a[0], a[1]);
11663                                       }
11664                                       if (tmpstr) {
11665                                            name = SvPV_const(tmpstr, len);
11666                                            name_utf8 = SvUTF8(tmpstr);
11667                                            sv_2mortal(tmpstr);
11668                                       }
11669                                  }
11670                                  if (!name) {
11671                                       name = "__ANONIO__";
11672                                       len = 10;
11673                                       want_dollar = FALSE;
11674                                  }
11675                                  op_lvalue(kid, type);
11676                             }
11677                             if (name) {
11678                                 SV *namesv;
11679                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11680                                 namesv = PAD_SVl(targ);
11681                                 if (want_dollar && *name != '$')
11682                                     sv_setpvs(namesv, "$");
11683                                 else
11684                                     SvPVCLEAR(namesv);
11685                                 sv_catpvn(namesv, name, len);
11686                                 if ( name_utf8 ) SvUTF8_on(namesv);
11687                             }
11688                         }
11689                         scalar(kid);
11690                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11691                                     OP_RV2GV, flags);
11692                         kid->op_targ = targ;
11693                         kid->op_private |= priv;
11694                     }
11695                 }
11696                 scalar(kid);
11697                 break;
11698             case OA_SCALARREF:
11699                 if ((type == OP_UNDEF || type == OP_POS)
11700                     && numargs == 1 && !(oa >> 4)
11701                     && kid->op_type == OP_LIST)
11702                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11703                 op_lvalue(scalar(kid), type);
11704                 break;
11705             }
11706             oa >>= 4;
11707             prev_kid = kid;
11708             kid = OpSIBLING(kid);
11709         }
11710         /* FIXME - should the numargs or-ing move after the too many
11711          * arguments check? */
11712         o->op_private |= numargs;
11713         if (kid)
11714             return too_many_arguments_pv(o,OP_DESC(o), 0);
11715         listkids(o);
11716     }
11717     else if (PL_opargs[type] & OA_DEFGV) {
11718         /* Ordering of these two is important to keep f_map.t passing.  */
11719         op_free(o);
11720         return newUNOP(type, 0, newDEFSVOP());
11721     }
11722
11723     if (oa) {
11724         while (oa & OA_OPTIONAL)
11725             oa >>= 4;
11726         if (oa && oa != OA_LIST)
11727             return too_few_arguments_pv(o,OP_DESC(o), 0);
11728     }
11729     return o;
11730 }
11731
11732 OP *
11733 Perl_ck_glob(pTHX_ OP *o)
11734 {
11735     GV *gv;
11736
11737     PERL_ARGS_ASSERT_CK_GLOB;
11738
11739     o = ck_fun(o);
11740     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11741         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11742
11743     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11744     {
11745         /* convert
11746          *     glob
11747          *       \ null - const(wildcard)
11748          * into
11749          *     null
11750          *       \ enter
11751          *            \ list
11752          *                 \ mark - glob - rv2cv
11753          *                             |        \ gv(CORE::GLOBAL::glob)
11754          *                             |
11755          *                              \ null - const(wildcard)
11756          */
11757         o->op_flags |= OPf_SPECIAL;
11758         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11759         o = S_new_entersubop(aTHX_ gv, o);
11760         o = newUNOP(OP_NULL, 0, o);
11761         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11762         return o;
11763     }
11764     else o->op_flags &= ~OPf_SPECIAL;
11765 #if !defined(PERL_EXTERNAL_GLOB)
11766     if (!PL_globhook) {
11767         ENTER;
11768         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11769                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11770         LEAVE;
11771     }
11772 #endif /* !PERL_EXTERNAL_GLOB */
11773     gv = (GV *)newSV(0);
11774     gv_init(gv, 0, "", 0, 0);
11775     gv_IOadd(gv);
11776     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11777     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11778     scalarkids(o);
11779     return o;
11780 }
11781
11782 OP *
11783 Perl_ck_grep(pTHX_ OP *o)
11784 {
11785     LOGOP *gwop;
11786     OP *kid;
11787     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11788
11789     PERL_ARGS_ASSERT_CK_GREP;
11790
11791     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11792
11793     if (o->op_flags & OPf_STACKED) {
11794         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11795         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11796             return no_fh_allowed(o);
11797         o->op_flags &= ~OPf_STACKED;
11798     }
11799     kid = OpSIBLING(cLISTOPo->op_first);
11800     if (type == OP_MAPWHILE)
11801         list(kid);
11802     else
11803         scalar(kid);
11804     o = ck_fun(o);
11805     if (PL_parser && PL_parser->error_count)
11806         return o;
11807     kid = OpSIBLING(cLISTOPo->op_first);
11808     if (kid->op_type != OP_NULL)
11809         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11810     kid = kUNOP->op_first;
11811
11812     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11813     kid->op_next = (OP*)gwop;
11814     o->op_private = gwop->op_private = 0;
11815     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11816
11817     kid = OpSIBLING(cLISTOPo->op_first);
11818     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11819         op_lvalue(kid, OP_GREPSTART);
11820
11821     return (OP*)gwop;
11822 }
11823
11824 OP *
11825 Perl_ck_index(pTHX_ OP *o)
11826 {
11827     PERL_ARGS_ASSERT_CK_INDEX;
11828
11829     if (o->op_flags & OPf_KIDS) {
11830         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11831         if (kid)
11832             kid = OpSIBLING(kid);                       /* get past "big" */
11833         if (kid && kid->op_type == OP_CONST) {
11834             const bool save_taint = TAINT_get;
11835             SV *sv = kSVOP->op_sv;
11836             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11837                 && SvOK(sv) && !SvROK(sv))
11838             {
11839                 sv = newSV(0);
11840                 sv_copypv(sv, kSVOP->op_sv);
11841                 SvREFCNT_dec_NN(kSVOP->op_sv);
11842                 kSVOP->op_sv = sv;
11843             }
11844             if (SvOK(sv)) fbm_compile(sv, 0);
11845             TAINT_set(save_taint);
11846 #ifdef NO_TAINT_SUPPORT
11847             PERL_UNUSED_VAR(save_taint);
11848 #endif
11849         }
11850     }
11851     return ck_fun(o);
11852 }
11853
11854 OP *
11855 Perl_ck_lfun(pTHX_ OP *o)
11856 {
11857     const OPCODE type = o->op_type;
11858
11859     PERL_ARGS_ASSERT_CK_LFUN;
11860
11861     return modkids(ck_fun(o), type);
11862 }
11863
11864 OP *
11865 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
11866 {
11867     PERL_ARGS_ASSERT_CK_DEFINED;
11868
11869     if ((o->op_flags & OPf_KIDS)) {
11870         switch (cUNOPo->op_first->op_type) {
11871         case OP_RV2AV:
11872         case OP_PADAV:
11873             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11874                              " (Maybe you should just omit the defined()?)");
11875             NOT_REACHED; /* NOTREACHED */
11876             break;
11877         case OP_RV2HV:
11878         case OP_PADHV:
11879             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11880                              " (Maybe you should just omit the defined()?)");
11881             NOT_REACHED; /* NOTREACHED */
11882             break;
11883         default:
11884             /* no warning */
11885             break;
11886         }
11887     }
11888     return ck_rfun(o);
11889 }
11890
11891 OP *
11892 Perl_ck_readline(pTHX_ OP *o)
11893 {
11894     PERL_ARGS_ASSERT_CK_READLINE;
11895
11896     if (o->op_flags & OPf_KIDS) {
11897          OP *kid = cLISTOPo->op_first;
11898          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11899     }
11900     else {
11901         OP * const newop
11902             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
11903         op_free(o);
11904         return newop;
11905     }
11906     return o;
11907 }
11908
11909 OP *
11910 Perl_ck_rfun(pTHX_ OP *o)
11911 {
11912     const OPCODE type = o->op_type;
11913
11914     PERL_ARGS_ASSERT_CK_RFUN;
11915
11916     return refkids(ck_fun(o), type);
11917 }
11918
11919 OP *
11920 Perl_ck_listiob(pTHX_ OP *o)
11921 {
11922     OP *kid;
11923
11924     PERL_ARGS_ASSERT_CK_LISTIOB;
11925
11926     kid = cLISTOPo->op_first;
11927     if (!kid) {
11928         o = force_list(o, 1);
11929         kid = cLISTOPo->op_first;
11930     }
11931     if (kid->op_type == OP_PUSHMARK)
11932         kid = OpSIBLING(kid);
11933     if (kid && o->op_flags & OPf_STACKED)
11934         kid = OpSIBLING(kid);
11935     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
11936         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
11937          && !kid->op_folded) {
11938             o->op_flags |= OPf_STACKED; /* make it a filehandle */
11939             scalar(kid);
11940             /* replace old const op with new OP_RV2GV parent */
11941             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
11942                                         OP_RV2GV, OPf_REF);
11943             kid = OpSIBLING(kid);
11944         }
11945     }
11946
11947     if (!kid)
11948         op_append_elem(o->op_type, o, newDEFSVOP());
11949
11950     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
11951     return listkids(o);
11952 }
11953
11954 OP *
11955 Perl_ck_smartmatch(pTHX_ OP *o)
11956 {
11957     dVAR;
11958     PERL_ARGS_ASSERT_CK_SMARTMATCH;
11959     if (0 == (o->op_flags & OPf_SPECIAL)) {
11960         OP *first  = cBINOPo->op_first;
11961         OP *second = OpSIBLING(first);
11962
11963         /* Implicitly take a reference to an array or hash */
11964
11965         /* remove the original two siblings, then add back the
11966          * (possibly different) first and second sibs.
11967          */
11968         op_sibling_splice(o, NULL, 1, NULL);
11969         op_sibling_splice(o, NULL, 1, NULL);
11970         first  = ref_array_or_hash(first);
11971         second = ref_array_or_hash(second);
11972         op_sibling_splice(o, NULL, 0, second);
11973         op_sibling_splice(o, NULL, 0, first);
11974
11975         /* Implicitly take a reference to a regular expression */
11976         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
11977             OpTYPE_set(first, OP_QR);
11978         }
11979         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
11980             OpTYPE_set(second, OP_QR);
11981         }
11982     }
11983
11984     return o;
11985 }
11986
11987
11988 static OP *
11989 S_maybe_targlex(pTHX_ OP *o)
11990 {
11991     OP * const kid = cLISTOPo->op_first;
11992     /* has a disposable target? */
11993     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
11994         && !(kid->op_flags & OPf_STACKED)
11995         /* Cannot steal the second time! */
11996         && !(kid->op_private & OPpTARGET_MY)
11997         )
11998     {
11999         OP * const kkid = OpSIBLING(kid);
12000
12001         /* Can just relocate the target. */
12002         if (kkid && kkid->op_type == OP_PADSV
12003             && (!(kkid->op_private & OPpLVAL_INTRO)
12004                || kkid->op_private & OPpPAD_STATE))
12005         {
12006             kid->op_targ = kkid->op_targ;
12007             kkid->op_targ = 0;
12008             /* Now we do not need PADSV and SASSIGN.
12009              * Detach kid and free the rest. */
12010             op_sibling_splice(o, NULL, 1, NULL);
12011             op_free(o);
12012             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12013             return kid;
12014         }
12015     }
12016     return o;
12017 }
12018
12019 OP *
12020 Perl_ck_sassign(pTHX_ OP *o)
12021 {
12022     dVAR;
12023     OP * const kid = cBINOPo->op_first;
12024
12025     PERL_ARGS_ASSERT_CK_SASSIGN;
12026
12027     if (OpHAS_SIBLING(kid)) {
12028         OP *kkid = OpSIBLING(kid);
12029         /* For state variable assignment with attributes, kkid is a list op
12030            whose op_last is a padsv. */
12031         if ((kkid->op_type == OP_PADSV ||
12032              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12033               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12034              )
12035             )
12036                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12037                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12038             return S_newONCEOP(aTHX_ o, kkid);
12039         }
12040     }
12041     return S_maybe_targlex(aTHX_ o);
12042 }
12043
12044
12045 OP *
12046 Perl_ck_match(pTHX_ OP *o)
12047 {
12048     PERL_UNUSED_CONTEXT;
12049     PERL_ARGS_ASSERT_CK_MATCH;
12050
12051     return o;
12052 }
12053
12054 OP *
12055 Perl_ck_method(pTHX_ OP *o)
12056 {
12057     SV *sv, *methsv, *rclass;
12058     const char* method;
12059     char* compatptr;
12060     int utf8;
12061     STRLEN len, nsplit = 0, i;
12062     OP* new_op;
12063     OP * const kid = cUNOPo->op_first;
12064
12065     PERL_ARGS_ASSERT_CK_METHOD;
12066     if (kid->op_type != OP_CONST) return o;
12067
12068     sv = kSVOP->op_sv;
12069
12070     /* replace ' with :: */
12071     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12072                                         SvEND(sv) - SvPVX(sv) )))
12073     {
12074         *compatptr = ':';
12075         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12076     }
12077
12078     method = SvPVX_const(sv);
12079     len = SvCUR(sv);
12080     utf8 = SvUTF8(sv) ? -1 : 1;
12081
12082     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12083         nsplit = i+1;
12084         break;
12085     }
12086
12087     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12088
12089     if (!nsplit) { /* $proto->method() */
12090         op_free(o);
12091         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12092     }
12093
12094     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12095         op_free(o);
12096         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12097     }
12098
12099     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12100     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12101         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12102         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12103     } else {
12104         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12105         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12106     }
12107 #ifdef USE_ITHREADS
12108     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12109 #else
12110     cMETHOPx(new_op)->op_rclass_sv = rclass;
12111 #endif
12112     op_free(o);
12113     return new_op;
12114 }
12115
12116 OP *
12117 Perl_ck_null(pTHX_ OP *o)
12118 {
12119     PERL_ARGS_ASSERT_CK_NULL;
12120     PERL_UNUSED_CONTEXT;
12121     return o;
12122 }
12123
12124 OP *
12125 Perl_ck_open(pTHX_ OP *o)
12126 {
12127     PERL_ARGS_ASSERT_CK_OPEN;
12128
12129     S_io_hints(aTHX_ o);
12130     {
12131          /* In case of three-arg dup open remove strictness
12132           * from the last arg if it is a bareword. */
12133          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12134          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12135          OP *oa;
12136          const char *mode;
12137
12138          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12139              (last->op_private & OPpCONST_BARE) &&
12140              (last->op_private & OPpCONST_STRICT) &&
12141              (oa = OpSIBLING(first)) &&         /* The fh. */
12142              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12143              (oa->op_type == OP_CONST) &&
12144              SvPOK(((SVOP*)oa)->op_sv) &&
12145              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12146              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12147              (last == OpSIBLING(oa)))                   /* The bareword. */
12148               last->op_private &= ~OPpCONST_STRICT;
12149     }
12150     return ck_fun(o);
12151 }
12152
12153 OP *
12154 Perl_ck_prototype(pTHX_ OP *o)
12155 {
12156     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12157     if (!(o->op_flags & OPf_KIDS)) {
12158         op_free(o);
12159         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12160     }
12161     return o;
12162 }
12163
12164 OP *
12165 Perl_ck_refassign(pTHX_ OP *o)
12166 {
12167     OP * const right = cLISTOPo->op_first;
12168     OP * const left = OpSIBLING(right);
12169     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12170     bool stacked = 0;
12171
12172     PERL_ARGS_ASSERT_CK_REFASSIGN;
12173     assert (left);
12174     assert (left->op_type == OP_SREFGEN);
12175
12176     o->op_private = 0;
12177     /* we use OPpPAD_STATE in refassign to mean either of those things,
12178      * and the code assumes the two flags occupy the same bit position
12179      * in the various ops below */
12180     assert(OPpPAD_STATE == OPpOUR_INTRO);
12181
12182     switch (varop->op_type) {
12183     case OP_PADAV:
12184         o->op_private |= OPpLVREF_AV;
12185         goto settarg;
12186     case OP_PADHV:
12187         o->op_private |= OPpLVREF_HV;
12188         /* FALLTHROUGH */
12189     case OP_PADSV:
12190       settarg:
12191         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12192         o->op_targ = varop->op_targ;
12193         varop->op_targ = 0;
12194         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12195         break;
12196
12197     case OP_RV2AV:
12198         o->op_private |= OPpLVREF_AV;
12199         goto checkgv;
12200         NOT_REACHED; /* NOTREACHED */
12201     case OP_RV2HV:
12202         o->op_private |= OPpLVREF_HV;
12203         /* FALLTHROUGH */
12204     case OP_RV2SV:
12205       checkgv:
12206         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12207         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12208       detach_and_stack:
12209         /* Point varop to its GV kid, detached.  */
12210         varop = op_sibling_splice(varop, NULL, -1, NULL);
12211         stacked = TRUE;
12212         break;
12213     case OP_RV2CV: {
12214         OP * const kidparent =
12215             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12216         OP * const kid = cUNOPx(kidparent)->op_first;
12217         o->op_private |= OPpLVREF_CV;
12218         if (kid->op_type == OP_GV) {
12219             varop = kidparent;
12220             goto detach_and_stack;
12221         }
12222         if (kid->op_type != OP_PADCV)   goto bad;
12223         o->op_targ = kid->op_targ;
12224         kid->op_targ = 0;
12225         break;
12226     }
12227     case OP_AELEM:
12228     case OP_HELEM:
12229         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12230         o->op_private |= OPpLVREF_ELEM;
12231         op_null(varop);
12232         stacked = TRUE;
12233         /* Detach varop.  */
12234         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12235         break;
12236     default:
12237       bad:
12238         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12239         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12240                                 "assignment",
12241                                  OP_DESC(varop)));
12242         return o;
12243     }
12244     if (!FEATURE_REFALIASING_IS_ENABLED)
12245         Perl_croak(aTHX_
12246                   "Experimental aliasing via reference not enabled");
12247     Perl_ck_warner_d(aTHX_
12248                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12249                     "Aliasing via reference is experimental");
12250     if (stacked) {
12251         o->op_flags |= OPf_STACKED;
12252         op_sibling_splice(o, right, 1, varop);
12253     }
12254     else {
12255         o->op_flags &=~ OPf_STACKED;
12256         op_sibling_splice(o, right, 1, NULL);
12257     }
12258     op_free(left);
12259     return o;
12260 }
12261
12262 OP *
12263 Perl_ck_repeat(pTHX_ OP *o)
12264 {
12265     PERL_ARGS_ASSERT_CK_REPEAT;
12266
12267     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12268         OP* kids;
12269         o->op_private |= OPpREPEAT_DOLIST;
12270         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12271         kids = force_list(kids, 1); /* promote it to a list */
12272         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12273     }
12274     else
12275         scalar(o);
12276     return o;
12277 }
12278
12279 OP *
12280 Perl_ck_require(pTHX_ OP *o)
12281 {
12282     GV* gv;
12283
12284     PERL_ARGS_ASSERT_CK_REQUIRE;
12285
12286     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12287         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12288         U32 hash;
12289         char *s;
12290         STRLEN len;
12291         if (kid->op_type == OP_CONST) {
12292           SV * const sv = kid->op_sv;
12293           U32 const was_readonly = SvREADONLY(sv);
12294           if (kid->op_private & OPpCONST_BARE) {
12295             dVAR;
12296             const char *end;
12297             HEK *hek;
12298
12299             if (was_readonly) {
12300                     SvREADONLY_off(sv);
12301             }
12302             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12303
12304             s = SvPVX(sv);
12305             len = SvCUR(sv);
12306             end = s + len;
12307             /* treat ::foo::bar as foo::bar */
12308             if (len >= 2 && s[0] == ':' && s[1] == ':')
12309                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12310             if (s == end)
12311                 DIE(aTHX_ "Bareword in require maps to empty filename");
12312
12313             for (; s < end; s++) {
12314                 if (*s == ':' && s[1] == ':') {
12315                     *s = '/';
12316                     Move(s+2, s+1, end - s - 1, char);
12317                     --end;
12318                 }
12319             }
12320             SvEND_set(sv, end);
12321             sv_catpvs(sv, ".pm");
12322             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12323             hek = share_hek(SvPVX(sv),
12324                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12325                             hash);
12326             sv_sethek(sv, hek);
12327             unshare_hek(hek);
12328             SvFLAGS(sv) |= was_readonly;
12329           }
12330           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12331                 && !SvVOK(sv)) {
12332             s = SvPV(sv, len);
12333             if (SvREFCNT(sv) > 1) {
12334                 kid->op_sv = newSVpvn_share(
12335                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12336                 SvREFCNT_dec_NN(sv);
12337             }
12338             else {
12339                 dVAR;
12340                 HEK *hek;
12341                 if (was_readonly) SvREADONLY_off(sv);
12342                 PERL_HASH(hash, s, len);
12343                 hek = share_hek(s,
12344                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12345                                 hash);
12346                 sv_sethek(sv, hek);
12347                 unshare_hek(hek);
12348                 SvFLAGS(sv) |= was_readonly;
12349             }
12350           }
12351         }
12352     }
12353
12354     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12355         /* handle override, if any */
12356      && (gv = gv_override("require", 7))) {
12357         OP *kid, *newop;
12358         if (o->op_flags & OPf_KIDS) {
12359             kid = cUNOPo->op_first;
12360             op_sibling_splice(o, NULL, -1, NULL);
12361         }
12362         else {
12363             kid = newDEFSVOP();
12364         }
12365         op_free(o);
12366         newop = S_new_entersubop(aTHX_ gv, kid);
12367         return newop;
12368     }
12369
12370     return ck_fun(o);
12371 }
12372
12373 OP *
12374 Perl_ck_return(pTHX_ OP *o)
12375 {
12376     OP *kid;
12377
12378     PERL_ARGS_ASSERT_CK_RETURN;
12379
12380     kid = OpSIBLING(cLISTOPo->op_first);
12381     if (PL_compcv && CvLVALUE(PL_compcv)) {
12382         for (; kid; kid = OpSIBLING(kid))
12383             op_lvalue(kid, OP_LEAVESUBLV);
12384     }
12385
12386     return o;
12387 }
12388
12389 OP *
12390 Perl_ck_select(pTHX_ OP *o)
12391 {
12392     dVAR;
12393     OP* kid;
12394
12395     PERL_ARGS_ASSERT_CK_SELECT;
12396
12397     if (o->op_flags & OPf_KIDS) {
12398         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12399         if (kid && OpHAS_SIBLING(kid)) {
12400             OpTYPE_set(o, OP_SSELECT);
12401             o = ck_fun(o);
12402             return fold_constants(op_integerize(op_std_init(o)));
12403         }
12404     }
12405     o = ck_fun(o);
12406     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12407     if (kid && kid->op_type == OP_RV2GV)
12408         kid->op_private &= ~HINT_STRICT_REFS;
12409     return o;
12410 }
12411
12412 OP *
12413 Perl_ck_shift(pTHX_ OP *o)
12414 {
12415     const I32 type = o->op_type;
12416
12417     PERL_ARGS_ASSERT_CK_SHIFT;
12418
12419     if (!(o->op_flags & OPf_KIDS)) {
12420         OP *argop;
12421
12422         if (!CvUNIQUE(PL_compcv)) {
12423             o->op_flags |= OPf_SPECIAL;
12424             return o;
12425         }
12426
12427         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12428         op_free(o);
12429         return newUNOP(type, 0, scalar(argop));
12430     }
12431     return scalar(ck_fun(o));
12432 }
12433
12434 OP *
12435 Perl_ck_sort(pTHX_ OP *o)
12436 {
12437     OP *firstkid;
12438     OP *kid;
12439     HV * const hinthv =
12440         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12441     U8 stacked;
12442
12443     PERL_ARGS_ASSERT_CK_SORT;
12444
12445     if (hinthv) {
12446             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12447             if (svp) {
12448                 const I32 sorthints = (I32)SvIV(*svp);
12449                 if ((sorthints & HINT_SORT_STABLE) != 0)
12450                     o->op_private |= OPpSORT_STABLE;
12451                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12452                     o->op_private |= OPpSORT_UNSTABLE;
12453             }
12454     }
12455
12456     if (o->op_flags & OPf_STACKED)
12457         simplify_sort(o);
12458     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12459
12460     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12461         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12462
12463         /* if the first arg is a code block, process it and mark sort as
12464          * OPf_SPECIAL */
12465         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12466             LINKLIST(kid);
12467             if (kid->op_type == OP_LEAVE)
12468                     op_null(kid);                       /* wipe out leave */
12469             /* Prevent execution from escaping out of the sort block. */
12470             kid->op_next = 0;
12471
12472             /* provide scalar context for comparison function/block */
12473             kid = scalar(firstkid);
12474             kid->op_next = kid;
12475             o->op_flags |= OPf_SPECIAL;
12476         }
12477         else if (kid->op_type == OP_CONST
12478               && kid->op_private & OPpCONST_BARE) {
12479             char tmpbuf[256];
12480             STRLEN len;
12481             PADOFFSET off;
12482             const char * const name = SvPV(kSVOP_sv, len);
12483             *tmpbuf = '&';
12484             assert (len < 256);
12485             Copy(name, tmpbuf+1, len, char);
12486             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12487             if (off != NOT_IN_PAD) {
12488                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12489                     SV * const fq =
12490                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12491                     sv_catpvs(fq, "::");
12492                     sv_catsv(fq, kSVOP_sv);
12493                     SvREFCNT_dec_NN(kSVOP_sv);
12494                     kSVOP->op_sv = fq;
12495                 }
12496                 else {
12497                     OP * const padop = newOP(OP_PADCV, 0);
12498                     padop->op_targ = off;
12499                     /* replace the const op with the pad op */
12500                     op_sibling_splice(firstkid, NULL, 1, padop);
12501                     op_free(kid);
12502                 }
12503             }
12504         }
12505
12506         firstkid = OpSIBLING(firstkid);
12507     }
12508
12509     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12510         /* provide list context for arguments */
12511         list(kid);
12512         if (stacked)
12513             op_lvalue(kid, OP_GREPSTART);
12514     }
12515
12516     return o;
12517 }
12518
12519 /* for sort { X } ..., where X is one of
12520  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12521  * elide the second child of the sort (the one containing X),
12522  * and set these flags as appropriate
12523         OPpSORT_NUMERIC;
12524         OPpSORT_INTEGER;
12525         OPpSORT_DESCEND;
12526  * Also, check and warn on lexical $a, $b.
12527  */
12528
12529 STATIC void
12530 S_simplify_sort(pTHX_ OP *o)
12531 {
12532     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12533     OP *k;
12534     int descending;
12535     GV *gv;
12536     const char *gvname;
12537     bool have_scopeop;
12538
12539     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12540
12541     kid = kUNOP->op_first;                              /* get past null */
12542     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12543      && kid->op_type != OP_LEAVE)
12544         return;
12545     kid = kLISTOP->op_last;                             /* get past scope */
12546     switch(kid->op_type) {
12547         case OP_NCMP:
12548         case OP_I_NCMP:
12549         case OP_SCMP:
12550             if (!have_scopeop) goto padkids;
12551             break;
12552         default:
12553             return;
12554     }
12555     k = kid;                                            /* remember this node*/
12556     if (kBINOP->op_first->op_type != OP_RV2SV
12557      || kBINOP->op_last ->op_type != OP_RV2SV)
12558     {
12559         /*
12560            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12561            then used in a comparison.  This catches most, but not
12562            all cases.  For instance, it catches
12563                sort { my($a); $a <=> $b }
12564            but not
12565                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12566            (although why you'd do that is anyone's guess).
12567         */
12568
12569        padkids:
12570         if (!ckWARN(WARN_SYNTAX)) return;
12571         kid = kBINOP->op_first;
12572         do {
12573             if (kid->op_type == OP_PADSV) {
12574                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12575                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12576                  && (  PadnamePV(name)[1] == 'a'
12577                     || PadnamePV(name)[1] == 'b'  ))
12578                     /* diag_listed_as: "my %s" used in sort comparison */
12579                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12580                                      "\"%s %s\" used in sort comparison",
12581                                       PadnameIsSTATE(name)
12582                                         ? "state"
12583                                         : "my",
12584                                       PadnamePV(name));
12585             }
12586         } while ((kid = OpSIBLING(kid)));
12587         return;
12588     }
12589     kid = kBINOP->op_first;                             /* get past cmp */
12590     if (kUNOP->op_first->op_type != OP_GV)
12591         return;
12592     kid = kUNOP->op_first;                              /* get past rv2sv */
12593     gv = kGVOP_gv;
12594     if (GvSTASH(gv) != PL_curstash)
12595         return;
12596     gvname = GvNAME(gv);
12597     if (*gvname == 'a' && gvname[1] == '\0')
12598         descending = 0;
12599     else if (*gvname == 'b' && gvname[1] == '\0')
12600         descending = 1;
12601     else
12602         return;
12603
12604     kid = k;                                            /* back to cmp */
12605     /* already checked above that it is rv2sv */
12606     kid = kBINOP->op_last;                              /* down to 2nd arg */
12607     if (kUNOP->op_first->op_type != OP_GV)
12608         return;
12609     kid = kUNOP->op_first;                              /* get past rv2sv */
12610     gv = kGVOP_gv;
12611     if (GvSTASH(gv) != PL_curstash)
12612         return;
12613     gvname = GvNAME(gv);
12614     if ( descending
12615          ? !(*gvname == 'a' && gvname[1] == '\0')
12616          : !(*gvname == 'b' && gvname[1] == '\0'))
12617         return;
12618     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12619     if (descending)
12620         o->op_private |= OPpSORT_DESCEND;
12621     if (k->op_type == OP_NCMP)
12622         o->op_private |= OPpSORT_NUMERIC;
12623     if (k->op_type == OP_I_NCMP)
12624         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12625     kid = OpSIBLING(cLISTOPo->op_first);
12626     /* cut out and delete old block (second sibling) */
12627     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12628     op_free(kid);
12629 }
12630
12631 OP *
12632 Perl_ck_split(pTHX_ OP *o)
12633 {
12634     dVAR;
12635     OP *kid;
12636     OP *sibs;
12637
12638     PERL_ARGS_ASSERT_CK_SPLIT;
12639
12640     assert(o->op_type == OP_LIST);
12641
12642     if (o->op_flags & OPf_STACKED)
12643         return no_fh_allowed(o);
12644
12645     kid = cLISTOPo->op_first;
12646     /* delete leading NULL node, then add a CONST if no other nodes */
12647     assert(kid->op_type == OP_NULL);
12648     op_sibling_splice(o, NULL, 1,
12649         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12650     op_free(kid);
12651     kid = cLISTOPo->op_first;
12652
12653     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12654         /* remove match expression, and replace with new optree with
12655          * a match op at its head */
12656         op_sibling_splice(o, NULL, 1, NULL);
12657         /* pmruntime will handle split " " behavior with flag==2 */
12658         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12659         op_sibling_splice(o, NULL, 0, kid);
12660     }
12661
12662     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12663
12664     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12665       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12666                      "Use of /g modifier is meaningless in split");
12667     }
12668
12669     /* eliminate the split op, and move the match op (plus any children)
12670      * into its place, then convert the match op into a split op. i.e.
12671      *
12672      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12673      *    |                        |                     |
12674      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12675      *    |                        |                     |
12676      *    R                        X - Y                 X - Y
12677      *    |
12678      *    X - Y
12679      *
12680      * (R, if it exists, will be a regcomp op)
12681      */
12682
12683     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12684     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12685     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12686     OpTYPE_set(kid, OP_SPLIT);
12687     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12688     kid->op_private = o->op_private;
12689     op_free(o);
12690     o = kid;
12691     kid = sibs; /* kid is now the string arg of the split */
12692
12693     if (!kid) {
12694         kid = newDEFSVOP();
12695         op_append_elem(OP_SPLIT, o, kid);
12696     }
12697     scalar(kid);
12698
12699     kid = OpSIBLING(kid);
12700     if (!kid) {
12701         kid = newSVOP(OP_CONST, 0, newSViv(0));
12702         op_append_elem(OP_SPLIT, o, kid);
12703         o->op_private |= OPpSPLIT_IMPLIM;
12704     }
12705     scalar(kid);
12706
12707     if (OpHAS_SIBLING(kid))
12708         return too_many_arguments_pv(o,OP_DESC(o), 0);
12709
12710     return o;
12711 }
12712
12713 OP *
12714 Perl_ck_stringify(pTHX_ OP *o)
12715 {
12716     OP * const kid = OpSIBLING(cUNOPo->op_first);
12717     PERL_ARGS_ASSERT_CK_STRINGIFY;
12718     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12719          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12720          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12721         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12722     {
12723         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12724         op_free(o);
12725         return kid;
12726     }
12727     return ck_fun(o);
12728 }
12729
12730 OP *
12731 Perl_ck_join(pTHX_ OP *o)
12732 {
12733     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12734
12735     PERL_ARGS_ASSERT_CK_JOIN;
12736
12737     if (kid && kid->op_type == OP_MATCH) {
12738         if (ckWARN(WARN_SYNTAX)) {
12739             const REGEXP *re = PM_GETRE(kPMOP);
12740             const SV *msg = re
12741                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12742                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12743                     : newSVpvs_flags( "STRING", SVs_TEMP );
12744             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12745                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12746                         SVfARG(msg), SVfARG(msg));
12747         }
12748     }
12749     if (kid
12750      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12751         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12752         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12753            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12754     {
12755         const OP * const bairn = OpSIBLING(kid); /* the list */
12756         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12757          && OP_GIMME(bairn,0) == G_SCALAR)
12758         {
12759             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12760                                      op_sibling_splice(o, kid, 1, NULL));
12761             op_free(o);
12762             return ret;
12763         }
12764     }
12765
12766     return ck_fun(o);
12767 }
12768
12769 /*
12770 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12771
12772 Examines an op, which is expected to identify a subroutine at runtime,
12773 and attempts to determine at compile time which subroutine it identifies.
12774 This is normally used during Perl compilation to determine whether
12775 a prototype can be applied to a function call.  C<cvop> is the op
12776 being considered, normally an C<rv2cv> op.  A pointer to the identified
12777 subroutine is returned, if it could be determined statically, and a null
12778 pointer is returned if it was not possible to determine statically.
12779
12780 Currently, the subroutine can be identified statically if the RV that the
12781 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12782 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12783 suitable if the constant value must be an RV pointing to a CV.  Details of
12784 this process may change in future versions of Perl.  If the C<rv2cv> op
12785 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12786 the subroutine statically: this flag is used to suppress compile-time
12787 magic on a subroutine call, forcing it to use default runtime behaviour.
12788
12789 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12790 of a GV reference is modified.  If a GV was examined and its CV slot was
12791 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12792 If the op is not optimised away, and the CV slot is later populated with
12793 a subroutine having a prototype, that flag eventually triggers the warning
12794 "called too early to check prototype".
12795
12796 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12797 of returning a pointer to the subroutine it returns a pointer to the
12798 GV giving the most appropriate name for the subroutine in this context.
12799 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12800 (C<CvANON>) subroutine that is referenced through a GV it will be the
12801 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12802 A null pointer is returned as usual if there is no statically-determinable
12803 subroutine.
12804
12805 =cut
12806 */
12807
12808 /* shared by toke.c:yylex */
12809 CV *
12810 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12811 {
12812     PADNAME *name = PAD_COMPNAME(off);
12813     CV *compcv = PL_compcv;
12814     while (PadnameOUTER(name)) {
12815         assert(PARENT_PAD_INDEX(name));
12816         compcv = CvOUTSIDE(compcv);
12817         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12818                 [off = PARENT_PAD_INDEX(name)];
12819     }
12820     assert(!PadnameIsOUR(name));
12821     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12822         return PadnamePROTOCV(name);
12823     }
12824     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12825 }
12826
12827 CV *
12828 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12829 {
12830     OP *rvop;
12831     CV *cv;
12832     GV *gv;
12833     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12834     if (flags & ~RV2CVOPCV_FLAG_MASK)
12835         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12836     if (cvop->op_type != OP_RV2CV)
12837         return NULL;
12838     if (cvop->op_private & OPpENTERSUB_AMPER)
12839         return NULL;
12840     if (!(cvop->op_flags & OPf_KIDS))
12841         return NULL;
12842     rvop = cUNOPx(cvop)->op_first;
12843     switch (rvop->op_type) {
12844         case OP_GV: {
12845             gv = cGVOPx_gv(rvop);
12846             if (!isGV(gv)) {
12847                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12848                     cv = MUTABLE_CV(SvRV(gv));
12849                     gv = NULL;
12850                     break;
12851                 }
12852                 if (flags & RV2CVOPCV_RETURN_STUB)
12853                     return (CV *)gv;
12854                 else return NULL;
12855             }
12856             cv = GvCVu(gv);
12857             if (!cv) {
12858                 if (flags & RV2CVOPCV_MARK_EARLY)
12859                     rvop->op_private |= OPpEARLY_CV;
12860                 return NULL;
12861             }
12862         } break;
12863         case OP_CONST: {
12864             SV *rv = cSVOPx_sv(rvop);
12865             if (!SvROK(rv))
12866                 return NULL;
12867             cv = (CV*)SvRV(rv);
12868             gv = NULL;
12869         } break;
12870         case OP_PADCV: {
12871             cv = find_lexical_cv(rvop->op_targ);
12872             gv = NULL;
12873         } break;
12874         default: {
12875             return NULL;
12876         } NOT_REACHED; /* NOTREACHED */
12877     }
12878     if (SvTYPE((SV*)cv) != SVt_PVCV)
12879         return NULL;
12880     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12881         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12882             gv = CvGV(cv);
12883         return (CV*)gv;
12884     }
12885     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
12886         if (CvLEXICAL(cv) || CvNAMED(cv))
12887             return NULL;
12888         if (!CvANON(cv) || !gv)
12889             gv = CvGV(cv);
12890         return (CV*)gv;
12891
12892     } else {
12893         return cv;
12894     }
12895 }
12896
12897 /*
12898 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
12899
12900 Performs the default fixup of the arguments part of an C<entersub>
12901 op tree.  This consists of applying list context to each of the
12902 argument ops.  This is the standard treatment used on a call marked
12903 with C<&>, or a method call, or a call through a subroutine reference,
12904 or any other call where the callee can't be identified at compile time,
12905 or a call where the callee has no prototype.
12906
12907 =cut
12908 */
12909
12910 OP *
12911 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
12912 {
12913     OP *aop;
12914
12915     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
12916
12917     aop = cUNOPx(entersubop)->op_first;
12918     if (!OpHAS_SIBLING(aop))
12919         aop = cUNOPx(aop)->op_first;
12920     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
12921         /* skip the extra attributes->import() call implicitly added in
12922          * something like foo(my $x : bar)
12923          */
12924         if (   aop->op_type == OP_ENTERSUB
12925             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
12926         )
12927             continue;
12928         list(aop);
12929         op_lvalue(aop, OP_ENTERSUB);
12930     }
12931     return entersubop;
12932 }
12933
12934 /*
12935 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
12936
12937 Performs the fixup of the arguments part of an C<entersub> op tree
12938 based on a subroutine prototype.  This makes various modifications to
12939 the argument ops, from applying context up to inserting C<refgen> ops,
12940 and checking the number and syntactic types of arguments, as directed by
12941 the prototype.  This is the standard treatment used on a subroutine call,
12942 not marked with C<&>, where the callee can be identified at compile time
12943 and has a prototype.
12944
12945 C<protosv> supplies the subroutine prototype to be applied to the call.
12946 It may be a normal defined scalar, of which the string value will be used.
12947 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
12948 that has been cast to C<SV*>) which has a prototype.  The prototype
12949 supplied, in whichever form, does not need to match the actual callee
12950 referenced by the op tree.
12951
12952 If the argument ops disagree with the prototype, for example by having
12953 an unacceptable number of arguments, a valid op tree is returned anyway.
12954 The error is reflected in the parser state, normally resulting in a single
12955 exception at the top level of parsing which covers all the compilation
12956 errors that occurred.  In the error message, the callee is referred to
12957 by the name defined by the C<namegv> parameter.
12958
12959 =cut
12960 */
12961
12962 OP *
12963 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
12964 {
12965     STRLEN proto_len;
12966     const char *proto, *proto_end;
12967     OP *aop, *prev, *cvop, *parent;
12968     int optional = 0;
12969     I32 arg = 0;
12970     I32 contextclass = 0;
12971     const char *e = NULL;
12972     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
12973     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
12974         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
12975                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
12976     if (SvTYPE(protosv) == SVt_PVCV)
12977          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
12978     else proto = SvPV(protosv, proto_len);
12979     proto = S_strip_spaces(aTHX_ proto, &proto_len);
12980     proto_end = proto + proto_len;
12981     parent = entersubop;
12982     aop = cUNOPx(entersubop)->op_first;
12983     if (!OpHAS_SIBLING(aop)) {
12984         parent = aop;
12985         aop = cUNOPx(aop)->op_first;
12986     }
12987     prev = aop;
12988     aop = OpSIBLING(aop);
12989     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12990     while (aop != cvop) {
12991         OP* o3 = aop;
12992
12993         if (proto >= proto_end)
12994         {
12995             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
12996             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12997                                         SVfARG(namesv)), SvUTF8(namesv));
12998             return entersubop;
12999         }
13000
13001         switch (*proto) {
13002             case ';':
13003                 optional = 1;
13004                 proto++;
13005                 continue;
13006             case '_':
13007                 /* _ must be at the end */
13008                 if (proto[1] && !strchr(";@%", proto[1]))
13009                     goto oops;
13010                 /* FALLTHROUGH */
13011             case '$':
13012                 proto++;
13013                 arg++;
13014                 scalar(aop);
13015                 break;
13016             case '%':
13017             case '@':
13018                 list(aop);
13019                 arg++;
13020                 break;
13021             case '&':
13022                 proto++;
13023                 arg++;
13024                 if (    o3->op_type != OP_UNDEF
13025                     && (o3->op_type != OP_SREFGEN
13026                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13027                                 != OP_ANONCODE
13028                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13029                                 != OP_RV2CV)))
13030                     bad_type_gv(arg, namegv, o3,
13031                             arg == 1 ? "block or sub {}" : "sub {}");
13032                 break;
13033             case '*':
13034                 /* '*' allows any scalar type, including bareword */
13035                 proto++;
13036                 arg++;
13037                 if (o3->op_type == OP_RV2GV)
13038                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13039                 else if (o3->op_type == OP_CONST)
13040                     o3->op_private &= ~OPpCONST_STRICT;
13041                 scalar(aop);
13042                 break;
13043             case '+':
13044                 proto++;
13045                 arg++;
13046                 if (o3->op_type == OP_RV2AV ||
13047                     o3->op_type == OP_PADAV ||
13048                     o3->op_type == OP_RV2HV ||
13049                     o3->op_type == OP_PADHV
13050                 ) {
13051                     goto wrapref;
13052                 }
13053                 scalar(aop);
13054                 break;
13055             case '[': case ']':
13056                 goto oops;
13057
13058             case '\\':
13059                 proto++;
13060                 arg++;
13061             again:
13062                 switch (*proto++) {
13063                     case '[':
13064                         if (contextclass++ == 0) {
13065                             e = (char *) memchr(proto, ']', proto_end - proto);
13066                             if (!e || e == proto)
13067                                 goto oops;
13068                         }
13069                         else
13070                             goto oops;
13071                         goto again;
13072
13073                     case ']':
13074                         if (contextclass) {
13075                             const char *p = proto;
13076                             const char *const end = proto;
13077                             contextclass = 0;
13078                             while (*--p != '[')
13079                                 /* \[$] accepts any scalar lvalue */
13080                                 if (*p == '$'
13081                                  && Perl_op_lvalue_flags(aTHX_
13082                                      scalar(o3),
13083                                      OP_READ, /* not entersub */
13084                                      OP_LVALUE_NO_CROAK
13085                                     )) goto wrapref;
13086                             bad_type_gv(arg, namegv, o3,
13087                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13088                         } else
13089                             goto oops;
13090                         break;
13091                     case '*':
13092                         if (o3->op_type == OP_RV2GV)
13093                             goto wrapref;
13094                         if (!contextclass)
13095                             bad_type_gv(arg, namegv, o3, "symbol");
13096                         break;
13097                     case '&':
13098                         if (o3->op_type == OP_ENTERSUB
13099                          && !(o3->op_flags & OPf_STACKED))
13100                             goto wrapref;
13101                         if (!contextclass)
13102                             bad_type_gv(arg, namegv, o3, "subroutine");
13103                         break;
13104                     case '$':
13105                         if (o3->op_type == OP_RV2SV ||
13106                                 o3->op_type == OP_PADSV ||
13107                                 o3->op_type == OP_HELEM ||
13108                                 o3->op_type == OP_AELEM)
13109                             goto wrapref;
13110                         if (!contextclass) {
13111                             /* \$ accepts any scalar lvalue */
13112                             if (Perl_op_lvalue_flags(aTHX_
13113                                     scalar(o3),
13114                                     OP_READ,  /* not entersub */
13115                                     OP_LVALUE_NO_CROAK
13116                                )) goto wrapref;
13117                             bad_type_gv(arg, namegv, o3, "scalar");
13118                         }
13119                         break;
13120                     case '@':
13121                         if (o3->op_type == OP_RV2AV ||
13122                                 o3->op_type == OP_PADAV)
13123                         {
13124                             o3->op_flags &=~ OPf_PARENS;
13125                             goto wrapref;
13126                         }
13127                         if (!contextclass)
13128                             bad_type_gv(arg, namegv, o3, "array");
13129                         break;
13130                     case '%':
13131                         if (o3->op_type == OP_RV2HV ||
13132                                 o3->op_type == OP_PADHV)
13133                         {
13134                             o3->op_flags &=~ OPf_PARENS;
13135                             goto wrapref;
13136                         }
13137                         if (!contextclass)
13138                             bad_type_gv(arg, namegv, o3, "hash");
13139                         break;
13140                     wrapref:
13141                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13142                                                 OP_REFGEN, 0);
13143                         if (contextclass && e) {
13144                             proto = e + 1;
13145                             contextclass = 0;
13146                         }
13147                         break;
13148                     default: goto oops;
13149                 }
13150                 if (contextclass)
13151                     goto again;
13152                 break;
13153             case ' ':
13154                 proto++;
13155                 continue;
13156             default:
13157             oops: {
13158                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13159                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13160                                   SVfARG(protosv));
13161             }
13162         }
13163
13164         op_lvalue(aop, OP_ENTERSUB);
13165         prev = aop;
13166         aop = OpSIBLING(aop);
13167     }
13168     if (aop == cvop && *proto == '_') {
13169         /* generate an access to $_ */
13170         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13171     }
13172     if (!optional && proto_end > proto &&
13173         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13174     {
13175         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13176         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13177                                     SVfARG(namesv)), SvUTF8(namesv));
13178     }
13179     return entersubop;
13180 }
13181
13182 /*
13183 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13184
13185 Performs the fixup of the arguments part of an C<entersub> op tree either
13186 based on a subroutine prototype or using default list-context processing.
13187 This is the standard treatment used on a subroutine call, not marked
13188 with C<&>, where the callee can be identified at compile time.
13189
13190 C<protosv> supplies the subroutine prototype to be applied to the call,
13191 or indicates that there is no prototype.  It may be a normal scalar,
13192 in which case if it is defined then the string value will be used
13193 as a prototype, and if it is undefined then there is no prototype.
13194 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13195 that has been cast to C<SV*>), of which the prototype will be used if it
13196 has one.  The prototype (or lack thereof) supplied, in whichever form,
13197 does not need to match the actual callee referenced by the op tree.
13198
13199 If the argument ops disagree with the prototype, for example by having
13200 an unacceptable number of arguments, a valid op tree is returned anyway.
13201 The error is reflected in the parser state, normally resulting in a single
13202 exception at the top level of parsing which covers all the compilation
13203 errors that occurred.  In the error message, the callee is referred to
13204 by the name defined by the C<namegv> parameter.
13205
13206 =cut
13207 */
13208
13209 OP *
13210 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13211         GV *namegv, SV *protosv)
13212 {
13213     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13214     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13215         return ck_entersub_args_proto(entersubop, namegv, protosv);
13216     else
13217         return ck_entersub_args_list(entersubop);
13218 }
13219
13220 OP *
13221 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13222 {
13223     IV cvflags = SvIVX(protosv);
13224     int opnum = cvflags & 0xffff;
13225     OP *aop = cUNOPx(entersubop)->op_first;
13226
13227     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13228
13229     if (!opnum) {
13230         OP *cvop;
13231         if (!OpHAS_SIBLING(aop))
13232             aop = cUNOPx(aop)->op_first;
13233         aop = OpSIBLING(aop);
13234         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13235         if (aop != cvop) {
13236             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13237             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13238                 SVfARG(namesv)), SvUTF8(namesv));
13239         }
13240
13241         op_free(entersubop);
13242         switch(cvflags >> 16) {
13243         case 'F': return newSVOP(OP_CONST, 0,
13244                                         newSVpv(CopFILE(PL_curcop),0));
13245         case 'L': return newSVOP(
13246                            OP_CONST, 0,
13247                            Perl_newSVpvf(aTHX_
13248                              "%" IVdf, (IV)CopLINE(PL_curcop)
13249                            )
13250                          );
13251         case 'P': return newSVOP(OP_CONST, 0,
13252                                    (PL_curstash
13253                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13254                                      : &PL_sv_undef
13255                                    )
13256                                 );
13257         }
13258         NOT_REACHED; /* NOTREACHED */
13259     }
13260     else {
13261         OP *prev, *cvop, *first, *parent;
13262         U32 flags = 0;
13263
13264         parent = entersubop;
13265         if (!OpHAS_SIBLING(aop)) {
13266             parent = aop;
13267             aop = cUNOPx(aop)->op_first;
13268         }
13269
13270         first = prev = aop;
13271         aop = OpSIBLING(aop);
13272         /* find last sibling */
13273         for (cvop = aop;
13274              OpHAS_SIBLING(cvop);
13275              prev = cvop, cvop = OpSIBLING(cvop))
13276             ;
13277         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13278             /* Usually, OPf_SPECIAL on an op with no args means that it had
13279              * parens, but these have their own meaning for that flag: */
13280             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13281             && opnum != OP_DELETE && opnum != OP_EXISTS)
13282                 flags |= OPf_SPECIAL;
13283         /* excise cvop from end of sibling chain */
13284         op_sibling_splice(parent, prev, 1, NULL);
13285         op_free(cvop);
13286         if (aop == cvop) aop = NULL;
13287
13288         /* detach remaining siblings from the first sibling, then
13289          * dispose of original optree */
13290
13291         if (aop)
13292             op_sibling_splice(parent, first, -1, NULL);
13293         op_free(entersubop);
13294
13295         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13296             flags |= OPpEVAL_BYTES <<8;
13297
13298         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13299         case OA_UNOP:
13300         case OA_BASEOP_OR_UNOP:
13301         case OA_FILESTATOP:
13302             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13303         case OA_BASEOP:
13304             if (aop) {
13305                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13306                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13307                     SVfARG(namesv)), SvUTF8(namesv));
13308                 op_free(aop);
13309             }
13310             return opnum == OP_RUNCV
13311                 ? newPVOP(OP_RUNCV,0,NULL)
13312                 : newOP(opnum,0);
13313         default:
13314             return op_convert_list(opnum,0,aop);
13315         }
13316     }
13317     NOT_REACHED; /* NOTREACHED */
13318     return entersubop;
13319 }
13320
13321 /*
13322 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13323
13324 Retrieves the function that will be used to fix up a call to C<cv>.
13325 Specifically, the function is applied to an C<entersub> op tree for a
13326 subroutine call, not marked with C<&>, where the callee can be identified
13327 at compile time as C<cv>.
13328
13329 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13330 for it is returned in C<*ckobj_p>, and control flags are returned in
13331 C<*ckflags_p>.  The function is intended to be called in this manner:
13332
13333  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13334
13335 In this call, C<entersubop> is a pointer to the C<entersub> op,
13336 which may be replaced by the check function, and C<namegv> supplies
13337 the name that should be used by the check function to refer
13338 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13339 It is permitted to apply the check function in non-standard situations,
13340 such as to a call to a different subroutine or to a method call.
13341
13342 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13343 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13344 instead, anything that can be used as the first argument to L</cv_name>.
13345 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13346 check function requires C<namegv> to be a genuine GV.
13347
13348 By default, the check function is
13349 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13350 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13351 flag is clear.  This implements standard prototype processing.  It can
13352 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13353
13354 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13355 indicates that the caller only knows about the genuine GV version of
13356 C<namegv>, and accordingly the corresponding bit will always be set in
13357 C<*ckflags_p>, regardless of the check function's recorded requirements.
13358 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13359 indicates the caller knows about the possibility of passing something
13360 other than a GV as C<namegv>, and accordingly the corresponding bit may
13361 be either set or clear in C<*ckflags_p>, indicating the check function's
13362 recorded requirements.
13363
13364 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13365 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13366 (for which see above).  All other bits should be clear.
13367
13368 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13369
13370 The original form of L</cv_get_call_checker_flags>, which does not return
13371 checker flags.  When using a checker function returned by this function,
13372 it is only safe to call it with a genuine GV as its C<namegv> argument.
13373
13374 =cut
13375 */
13376
13377 void
13378 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13379         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13380 {
13381     MAGIC *callmg;
13382     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13383     PERL_UNUSED_CONTEXT;
13384     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13385     if (callmg) {
13386         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13387         *ckobj_p = callmg->mg_obj;
13388         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13389     } else {
13390         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13391         *ckobj_p = (SV*)cv;
13392         *ckflags_p = gflags & MGf_REQUIRE_GV;
13393     }
13394 }
13395
13396 void
13397 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13398 {
13399     U32 ckflags;
13400     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13401     PERL_UNUSED_CONTEXT;
13402     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13403         &ckflags);
13404 }
13405
13406 /*
13407 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13408
13409 Sets the function that will be used to fix up a call to C<cv>.
13410 Specifically, the function is applied to an C<entersub> op tree for a
13411 subroutine call, not marked with C<&>, where the callee can be identified
13412 at compile time as C<cv>.
13413
13414 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13415 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13416 The function should be defined like this:
13417
13418     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13419
13420 It is intended to be called in this manner:
13421
13422     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13423
13424 In this call, C<entersubop> is a pointer to the C<entersub> op,
13425 which may be replaced by the check function, and C<namegv> supplies
13426 the name that should be used by the check function to refer
13427 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13428 It is permitted to apply the check function in non-standard situations,
13429 such as to a call to a different subroutine or to a method call.
13430
13431 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13432 CV or other SV instead.  Whatever is passed can be used as the first
13433 argument to L</cv_name>.  You can force perl to pass a GV by including
13434 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13435
13436 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13437 bit currently has a defined meaning (for which see above).  All other
13438 bits should be clear.
13439
13440 The current setting for a particular CV can be retrieved by
13441 L</cv_get_call_checker_flags>.
13442
13443 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13444
13445 The original form of L</cv_set_call_checker_flags>, which passes it the
13446 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13447 of that flag setting is that the check function is guaranteed to get a
13448 genuine GV as its C<namegv> argument.
13449
13450 =cut
13451 */
13452
13453 void
13454 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13455 {
13456     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13457     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13458 }
13459
13460 void
13461 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13462                                      SV *ckobj, U32 ckflags)
13463 {
13464     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13465     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13466         if (SvMAGICAL((SV*)cv))
13467             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13468     } else {
13469         MAGIC *callmg;
13470         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13471         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13472         assert(callmg);
13473         if (callmg->mg_flags & MGf_REFCOUNTED) {
13474             SvREFCNT_dec(callmg->mg_obj);
13475             callmg->mg_flags &= ~MGf_REFCOUNTED;
13476         }
13477         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13478         callmg->mg_obj = ckobj;
13479         if (ckobj != (SV*)cv) {
13480             SvREFCNT_inc_simple_void_NN(ckobj);
13481             callmg->mg_flags |= MGf_REFCOUNTED;
13482         }
13483         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13484                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13485     }
13486 }
13487
13488 static void
13489 S_entersub_alloc_targ(pTHX_ OP * const o)
13490 {
13491     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13492     o->op_private |= OPpENTERSUB_HASTARG;
13493 }
13494
13495 OP *
13496 Perl_ck_subr(pTHX_ OP *o)
13497 {
13498     OP *aop, *cvop;
13499     CV *cv;
13500     GV *namegv;
13501     SV **const_class = NULL;
13502
13503     PERL_ARGS_ASSERT_CK_SUBR;
13504
13505     aop = cUNOPx(o)->op_first;
13506     if (!OpHAS_SIBLING(aop))
13507         aop = cUNOPx(aop)->op_first;
13508     aop = OpSIBLING(aop);
13509     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13510     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13511     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13512
13513     o->op_private &= ~1;
13514     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13515     if (PERLDB_SUB && PL_curstash != PL_debstash)
13516         o->op_private |= OPpENTERSUB_DB;
13517     switch (cvop->op_type) {
13518         case OP_RV2CV:
13519             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13520             op_null(cvop);
13521             break;
13522         case OP_METHOD:
13523         case OP_METHOD_NAMED:
13524         case OP_METHOD_SUPER:
13525         case OP_METHOD_REDIR:
13526         case OP_METHOD_REDIR_SUPER:
13527             o->op_flags |= OPf_REF;
13528             if (aop->op_type == OP_CONST) {
13529                 aop->op_private &= ~OPpCONST_STRICT;
13530                 const_class = &cSVOPx(aop)->op_sv;
13531             }
13532             else if (aop->op_type == OP_LIST) {
13533                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13534                 if (sib && sib->op_type == OP_CONST) {
13535                     sib->op_private &= ~OPpCONST_STRICT;
13536                     const_class = &cSVOPx(sib)->op_sv;
13537                 }
13538             }
13539             /* make class name a shared cow string to speedup method calls */
13540             /* constant string might be replaced with object, f.e. bigint */
13541             if (const_class && SvPOK(*const_class)) {
13542                 STRLEN len;
13543                 const char* str = SvPV(*const_class, len);
13544                 if (len) {
13545                     SV* const shared = newSVpvn_share(
13546                         str, SvUTF8(*const_class)
13547                                     ? -(SSize_t)len : (SSize_t)len,
13548                         0
13549                     );
13550                     if (SvREADONLY(*const_class))
13551                         SvREADONLY_on(shared);
13552                     SvREFCNT_dec(*const_class);
13553                     *const_class = shared;
13554                 }
13555             }
13556             break;
13557     }
13558
13559     if (!cv) {
13560         S_entersub_alloc_targ(aTHX_ o);
13561         return ck_entersub_args_list(o);
13562     } else {
13563         Perl_call_checker ckfun;
13564         SV *ckobj;
13565         U32 ckflags;
13566         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13567         if (CvISXSUB(cv) || !CvROOT(cv))
13568             S_entersub_alloc_targ(aTHX_ o);
13569         if (!namegv) {
13570             /* The original call checker API guarantees that a GV will be
13571                be provided with the right name.  So, if the old API was
13572                used (or the REQUIRE_GV flag was passed), we have to reify
13573                the CV’s GV, unless this is an anonymous sub.  This is not
13574                ideal for lexical subs, as its stringification will include
13575                the package.  But it is the best we can do.  */
13576             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13577                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13578                     namegv = CvGV(cv);
13579             }
13580             else namegv = MUTABLE_GV(cv);
13581             /* After a syntax error in a lexical sub, the cv that
13582                rv2cv_op_cv returns may be a nameless stub. */
13583             if (!namegv) return ck_entersub_args_list(o);
13584
13585         }
13586         return ckfun(aTHX_ o, namegv, ckobj);
13587     }
13588 }
13589
13590 OP *
13591 Perl_ck_svconst(pTHX_ OP *o)
13592 {
13593     SV * const sv = cSVOPo->op_sv;
13594     PERL_ARGS_ASSERT_CK_SVCONST;
13595     PERL_UNUSED_CONTEXT;
13596 #ifdef PERL_COPY_ON_WRITE
13597     /* Since the read-only flag may be used to protect a string buffer, we
13598        cannot do copy-on-write with existing read-only scalars that are not
13599        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13600        that constant, mark the constant as COWable here, if it is not
13601        already read-only. */
13602     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13603         SvIsCOW_on(sv);
13604         CowREFCNT(sv) = 0;
13605 # ifdef PERL_DEBUG_READONLY_COW
13606         sv_buf_to_ro(sv);
13607 # endif
13608     }
13609 #endif
13610     SvREADONLY_on(sv);
13611     return o;
13612 }
13613
13614 OP *
13615 Perl_ck_trunc(pTHX_ OP *o)
13616 {
13617     PERL_ARGS_ASSERT_CK_TRUNC;
13618
13619     if (o->op_flags & OPf_KIDS) {
13620         SVOP *kid = (SVOP*)cUNOPo->op_first;
13621
13622         if (kid->op_type == OP_NULL)
13623             kid = (SVOP*)OpSIBLING(kid);
13624         if (kid && kid->op_type == OP_CONST &&
13625             (kid->op_private & OPpCONST_BARE) &&
13626             !kid->op_folded)
13627         {
13628             o->op_flags |= OPf_SPECIAL;
13629             kid->op_private &= ~OPpCONST_STRICT;
13630         }
13631     }
13632     return ck_fun(o);
13633 }
13634
13635 OP *
13636 Perl_ck_substr(pTHX_ OP *o)
13637 {
13638     PERL_ARGS_ASSERT_CK_SUBSTR;
13639
13640     o = ck_fun(o);
13641     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13642         OP *kid = cLISTOPo->op_first;
13643
13644         if (kid->op_type == OP_NULL)
13645             kid = OpSIBLING(kid);
13646         if (kid)
13647             /* Historically, substr(delete $foo{bar},...) has been allowed
13648                with 4-arg substr.  Keep it working by applying entersub
13649                lvalue context.  */
13650             op_lvalue(kid, OP_ENTERSUB);
13651
13652     }
13653     return o;
13654 }
13655
13656 OP *
13657 Perl_ck_tell(pTHX_ OP *o)
13658 {
13659     PERL_ARGS_ASSERT_CK_TELL;
13660     o = ck_fun(o);
13661     if (o->op_flags & OPf_KIDS) {
13662      OP *kid = cLISTOPo->op_first;
13663      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13664      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13665     }
13666     return o;
13667 }
13668
13669 OP *
13670 Perl_ck_each(pTHX_ OP *o)
13671 {
13672     dVAR;
13673     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13674     const unsigned orig_type  = o->op_type;
13675
13676     PERL_ARGS_ASSERT_CK_EACH;
13677
13678     if (kid) {
13679         switch (kid->op_type) {
13680             case OP_PADHV:
13681             case OP_RV2HV:
13682                 break;
13683             case OP_PADAV:
13684             case OP_RV2AV:
13685                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13686                             : orig_type == OP_KEYS ? OP_AKEYS
13687                             :                        OP_AVALUES);
13688                 break;
13689             case OP_CONST:
13690                 if (kid->op_private == OPpCONST_BARE
13691                  || !SvROK(cSVOPx_sv(kid))
13692                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13693                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13694                    )
13695                     goto bad;
13696                 /* FALLTHROUGH */
13697             default:
13698                 qerror(Perl_mess(aTHX_
13699                     "Experimental %s on scalar is now forbidden",
13700                      PL_op_desc[orig_type]));
13701                bad:
13702                 bad_type_pv(1, "hash or array", o, kid);
13703                 return o;
13704         }
13705     }
13706     return ck_fun(o);
13707 }
13708
13709 OP *
13710 Perl_ck_length(pTHX_ OP *o)
13711 {
13712     PERL_ARGS_ASSERT_CK_LENGTH;
13713
13714     o = ck_fun(o);
13715
13716     if (ckWARN(WARN_SYNTAX)) {
13717         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13718
13719         if (kid) {
13720             SV *name = NULL;
13721             const bool hash = kid->op_type == OP_PADHV
13722                            || kid->op_type == OP_RV2HV;
13723             switch (kid->op_type) {
13724                 case OP_PADHV:
13725                 case OP_PADAV:
13726                 case OP_RV2HV:
13727                 case OP_RV2AV:
13728                     name = S_op_varname(aTHX_ kid);
13729                     break;
13730                 default:
13731                     return o;
13732             }
13733             if (name)
13734                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13735                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13736                     ")\"?)",
13737                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13738                 );
13739             else if (hash)
13740      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13741                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13742                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13743             else
13744      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13745                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13746                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13747         }
13748     }
13749
13750     return o;
13751 }
13752
13753
13754
13755 /*
13756    ---------------------------------------------------------
13757
13758    Common vars in list assignment
13759
13760    There now follows some enums and static functions for detecting
13761    common variables in list assignments. Here is a little essay I wrote
13762    for myself when trying to get my head around this. DAPM.
13763
13764    ----
13765
13766    First some random observations:
13767
13768    * If a lexical var is an alias of something else, e.g.
13769        for my $x ($lex, $pkg, $a[0]) {...}
13770      then the act of aliasing will increase the reference count of the SV
13771
13772    * If a package var is an alias of something else, it may still have a
13773      reference count of 1, depending on how the alias was created, e.g.
13774      in *a = *b, $a may have a refcount of 1 since the GP is shared
13775      with a single GvSV pointer to the SV. So If it's an alias of another
13776      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13777      a lexical var or an array element, then it will have RC > 1.
13778
13779    * There are many ways to create a package alias; ultimately, XS code
13780      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13781      run-time tracing mechanisms are unlikely to be able to catch all cases.
13782
13783    * When the LHS is all my declarations, the same vars can't appear directly
13784      on the RHS, but they can indirectly via closures, aliasing and lvalue
13785      subs. But those techniques all involve an increase in the lexical
13786      scalar's ref count.
13787
13788    * When the LHS is all lexical vars (but not necessarily my declarations),
13789      it is possible for the same lexicals to appear directly on the RHS, and
13790      without an increased ref count, since the stack isn't refcounted.
13791      This case can be detected at compile time by scanning for common lex
13792      vars with PL_generation.
13793
13794    * lvalue subs defeat common var detection, but they do at least
13795      return vars with a temporary ref count increment. Also, you can't
13796      tell at compile time whether a sub call is lvalue.
13797
13798
13799    So...
13800
13801    A: There are a few circumstances where there definitely can't be any
13802      commonality:
13803
13804        LHS empty:  () = (...);
13805        RHS empty:  (....) = ();
13806        RHS contains only constants or other 'can't possibly be shared'
13807            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13808            i.e. they only contain ops not marked as dangerous, whose children
13809            are also not dangerous;
13810        LHS ditto;
13811        LHS contains a single scalar element: e.g. ($x) = (....); because
13812            after $x has been modified, it won't be used again on the RHS;
13813        RHS contains a single element with no aggregate on LHS: e.g.
13814            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13815            won't be used again.
13816
13817    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13818      we can ignore):
13819
13820        my ($a, $b, @c) = ...;
13821
13822        Due to closure and goto tricks, these vars may already have content.
13823        For the same reason, an element on the RHS may be a lexical or package
13824        alias of one of the vars on the left, or share common elements, for
13825        example:
13826
13827            my ($x,$y) = f(); # $x and $y on both sides
13828            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13829
13830        and
13831
13832            my $ra = f();
13833            my @a = @$ra;  # elements of @a on both sides
13834            sub f { @a = 1..4; \@a }
13835
13836
13837        First, just consider scalar vars on LHS:
13838
13839            RHS is safe only if (A), or in addition,
13840                * contains only lexical *scalar* vars, where neither side's
13841                  lexicals have been flagged as aliases
13842
13843            If RHS is not safe, then it's always legal to check LHS vars for
13844            RC==1, since the only RHS aliases will always be associated
13845            with an RC bump.
13846
13847            Note that in particular, RHS is not safe if:
13848
13849                * it contains package scalar vars; e.g.:
13850
13851                    f();
13852                    my ($x, $y) = (2, $x_alias);
13853                    sub f { $x = 1; *x_alias = \$x; }
13854
13855                * It contains other general elements, such as flattened or
13856                * spliced or single array or hash elements, e.g.
13857
13858                    f();
13859                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13860
13861                    sub f {
13862                        ($x, $y) = (1,2);
13863                        use feature 'refaliasing';
13864                        \($a[0], $a[1]) = \($y,$x);
13865                    }
13866
13867                  It doesn't matter if the array/hash is lexical or package.
13868
13869                * it contains a function call that happens to be an lvalue
13870                  sub which returns one or more of the above, e.g.
13871
13872                    f();
13873                    my ($x,$y) = f();
13874
13875                    sub f : lvalue {
13876                        ($x, $y) = (1,2);
13877                        *x1 = \$x;
13878                        $y, $x1;
13879                    }
13880
13881                    (so a sub call on the RHS should be treated the same
13882                    as having a package var on the RHS).
13883
13884                * any other "dangerous" thing, such an op or built-in that
13885                  returns one of the above, e.g. pp_preinc
13886
13887
13888            If RHS is not safe, what we can do however is at compile time flag
13889            that the LHS are all my declarations, and at run time check whether
13890            all the LHS have RC == 1, and if so skip the full scan.
13891
13892        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
13893
13894            Here the issue is whether there can be elements of @a on the RHS
13895            which will get prematurely freed when @a is cleared prior to
13896            assignment. This is only a problem if the aliasing mechanism
13897            is one which doesn't increase the refcount - only if RC == 1
13898            will the RHS element be prematurely freed.
13899
13900            Because the array/hash is being INTROed, it or its elements
13901            can't directly appear on the RHS:
13902
13903                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
13904
13905            but can indirectly, e.g.:
13906
13907                my $r = f();
13908                my (@a) = @$r;
13909                sub f { @a = 1..3; \@a }
13910
13911            So if the RHS isn't safe as defined by (A), we must always
13912            mortalise and bump the ref count of any remaining RHS elements
13913            when assigning to a non-empty LHS aggregate.
13914
13915            Lexical scalars on the RHS aren't safe if they've been involved in
13916            aliasing, e.g.
13917
13918                use feature 'refaliasing';
13919
13920                f();
13921                \(my $lex) = \$pkg;
13922                my @a = ($lex,3); # equivalent to ($a[0],3)
13923
13924                sub f {
13925                    @a = (1,2);
13926                    \$pkg = \$a[0];
13927                }
13928
13929            Similarly with lexical arrays and hashes on the RHS:
13930
13931                f();
13932                my @b;
13933                my @a = (@b);
13934
13935                sub f {
13936                    @a = (1,2);
13937                    \$b[0] = \$a[1];
13938                    \$b[1] = \$a[0];
13939                }
13940
13941
13942
13943    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
13944        my $a; ($a, my $b) = (....);
13945
13946        The difference between (B) and (C) is that it is now physically
13947        possible for the LHS vars to appear on the RHS too, where they
13948        are not reference counted; but in this case, the compile-time
13949        PL_generation sweep will detect such common vars.
13950
13951        So the rules for (C) differ from (B) in that if common vars are
13952        detected, the runtime "test RC==1" optimisation can no longer be used,
13953        and a full mark and sweep is required
13954
13955    D: As (C), but in addition the LHS may contain package vars.
13956
13957        Since package vars can be aliased without a corresponding refcount
13958        increase, all bets are off. It's only safe if (A). E.g.
13959
13960            my ($x, $y) = (1,2);
13961
13962            for $x_alias ($x) {
13963                ($x_alias, $y) = (3, $x); # whoops
13964            }
13965
13966        Ditto for LHS aggregate package vars.
13967
13968    E: Any other dangerous ops on LHS, e.g.
13969            (f(), $a[0], @$r) = (...);
13970
13971        this is similar to (E) in that all bets are off. In addition, it's
13972        impossible to determine at compile time whether the LHS
13973        contains a scalar or an aggregate, e.g.
13974
13975            sub f : lvalue { @a }
13976            (f()) = 1..3;
13977
13978 * ---------------------------------------------------------
13979 */
13980
13981
13982 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
13983  * that at least one of the things flagged was seen.
13984  */
13985
13986 enum {
13987     AAS_MY_SCALAR       = 0x001, /* my $scalar */
13988     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
13989     AAS_LEX_SCALAR      = 0x004, /* $lexical */
13990     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
13991     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
13992     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
13993     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
13994     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
13995                                          that's flagged OA_DANGEROUS */
13996     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
13997                                         not in any of the categories above */
13998     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
13999 };
14000
14001
14002
14003 /* helper function for S_aassign_scan().
14004  * check a PAD-related op for commonality and/or set its generation number.
14005  * Returns a boolean indicating whether its shared */
14006
14007 static bool
14008 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14009 {
14010     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14011         /* lexical used in aliasing */
14012         return TRUE;
14013
14014     if (rhs)
14015         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14016     else
14017         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14018
14019     return FALSE;
14020 }
14021
14022
14023 /*
14024   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14025   It scans the left or right hand subtree of the aassign op, and returns a
14026   set of flags indicating what sorts of things it found there.
14027   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14028   set PL_generation on lexical vars; if the latter, we see if
14029   PL_generation matches.
14030   'top' indicates whether we're recursing or at the top level.
14031   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14032   This fn will increment it by the number seen. It's not intended to
14033   be an accurate count (especially as many ops can push a variable
14034   number of SVs onto the stack); rather it's used as to test whether there
14035   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14036 */
14037
14038 static int
14039 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14040 {
14041     int flags = 0;
14042     bool kid_top = FALSE;
14043
14044     /* first, look for a solitary @_ on the RHS */
14045     if (   rhs
14046         && top
14047         && (o->op_flags & OPf_KIDS)
14048         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14049     ) {
14050         OP *kid = cUNOPo->op_first;
14051         if (   (   kid->op_type == OP_PUSHMARK
14052                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14053             && ((kid = OpSIBLING(kid)))
14054             && !OpHAS_SIBLING(kid)
14055             && kid->op_type == OP_RV2AV
14056             && !(kid->op_flags & OPf_REF)
14057             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14058             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14059             && ((kid = cUNOPx(kid)->op_first))
14060             && kid->op_type == OP_GV
14061             && cGVOPx_gv(kid) == PL_defgv
14062         )
14063             flags |= AAS_DEFAV;
14064     }
14065
14066     switch (o->op_type) {
14067     case OP_GVSV:
14068         (*scalars_p)++;
14069         return AAS_PKG_SCALAR;
14070
14071     case OP_PADAV:
14072     case OP_PADHV:
14073         (*scalars_p) += 2;
14074         /* if !top, could be e.g. @a[0,1] */
14075         if (top && (o->op_flags & OPf_REF))
14076             return (o->op_private & OPpLVAL_INTRO)
14077                 ? AAS_MY_AGG : AAS_LEX_AGG;
14078         return AAS_DANGEROUS;
14079
14080     case OP_PADSV:
14081         {
14082             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14083                         ?  AAS_LEX_SCALAR_COMM : 0;
14084             (*scalars_p)++;
14085             return (o->op_private & OPpLVAL_INTRO)
14086                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14087         }
14088
14089     case OP_RV2AV:
14090     case OP_RV2HV:
14091         (*scalars_p) += 2;
14092         if (cUNOPx(o)->op_first->op_type != OP_GV)
14093             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14094         /* @pkg, %pkg */
14095         /* if !top, could be e.g. @a[0,1] */
14096         if (top && (o->op_flags & OPf_REF))
14097             return AAS_PKG_AGG;
14098         return AAS_DANGEROUS;
14099
14100     case OP_RV2SV:
14101         (*scalars_p)++;
14102         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14103             (*scalars_p) += 2;
14104             return AAS_DANGEROUS; /* ${expr} */
14105         }
14106         return AAS_PKG_SCALAR; /* $pkg */
14107
14108     case OP_SPLIT:
14109         if (o->op_private & OPpSPLIT_ASSIGN) {
14110             /* the assign in @a = split() has been optimised away
14111              * and the @a attached directly to the split op
14112              * Treat the array as appearing on the RHS, i.e.
14113              *    ... = (@a = split)
14114              * is treated like
14115              *    ... = @a;
14116              */
14117
14118             if (o->op_flags & OPf_STACKED)
14119                 /* @{expr} = split() - the array expression is tacked
14120                  * on as an extra child to split - process kid */
14121                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14122                                         top, scalars_p);
14123
14124             /* ... else array is directly attached to split op */
14125             (*scalars_p) += 2;
14126             if (PL_op->op_private & OPpSPLIT_LEX)
14127                 return (o->op_private & OPpLVAL_INTRO)
14128                     ? AAS_MY_AGG : AAS_LEX_AGG;
14129             else
14130                 return AAS_PKG_AGG;
14131         }
14132         (*scalars_p)++;
14133         /* other args of split can't be returned */
14134         return AAS_SAFE_SCALAR;
14135
14136     case OP_UNDEF:
14137         /* undef counts as a scalar on the RHS:
14138          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14139          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14140          */
14141         if (rhs)
14142             (*scalars_p)++;
14143         flags = AAS_SAFE_SCALAR;
14144         break;
14145
14146     case OP_PUSHMARK:
14147     case OP_STUB:
14148         /* these are all no-ops; they don't push a potentially common SV
14149          * onto the stack, so they are neither AAS_DANGEROUS nor
14150          * AAS_SAFE_SCALAR */
14151         return 0;
14152
14153     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14154         break;
14155
14156     case OP_NULL:
14157     case OP_LIST:
14158         /* these do nothing but may have children; but their children
14159          * should also be treated as top-level */
14160         kid_top = top;
14161         break;
14162
14163     default:
14164         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14165             (*scalars_p) += 2;
14166             flags = AAS_DANGEROUS;
14167             break;
14168         }
14169
14170         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14171             && (o->op_private & OPpTARGET_MY))
14172         {
14173             (*scalars_p)++;
14174             return S_aassign_padcheck(aTHX_ o, rhs)
14175                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14176         }
14177
14178         /* if its an unrecognised, non-dangerous op, assume that it
14179          * it the cause of at least one safe scalar */
14180         (*scalars_p)++;
14181         flags = AAS_SAFE_SCALAR;
14182         break;
14183     }
14184
14185     /* XXX this assumes that all other ops are "transparent" - i.e. that
14186      * they can return some of their children. While this true for e.g.
14187      * sort and grep, it's not true for e.g. map. We really need a
14188      * 'transparent' flag added to regen/opcodes
14189      */
14190     if (o->op_flags & OPf_KIDS) {
14191         OP *kid;
14192         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14193             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14194     }
14195     return flags;
14196 }
14197
14198
14199 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14200    and modify the optree to make them work inplace */
14201
14202 STATIC void
14203 S_inplace_aassign(pTHX_ OP *o) {
14204
14205     OP *modop, *modop_pushmark;
14206     OP *oright;
14207     OP *oleft, *oleft_pushmark;
14208
14209     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14210
14211     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14212
14213     assert(cUNOPo->op_first->op_type == OP_NULL);
14214     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14215     assert(modop_pushmark->op_type == OP_PUSHMARK);
14216     modop = OpSIBLING(modop_pushmark);
14217
14218     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14219         return;
14220
14221     /* no other operation except sort/reverse */
14222     if (OpHAS_SIBLING(modop))
14223         return;
14224
14225     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14226     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14227
14228     if (modop->op_flags & OPf_STACKED) {
14229         /* skip sort subroutine/block */
14230         assert(oright->op_type == OP_NULL);
14231         oright = OpSIBLING(oright);
14232     }
14233
14234     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14235     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14236     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14237     oleft = OpSIBLING(oleft_pushmark);
14238
14239     /* Check the lhs is an array */
14240     if (!oleft ||
14241         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14242         || OpHAS_SIBLING(oleft)
14243         || (oleft->op_private & OPpLVAL_INTRO)
14244     )
14245         return;
14246
14247     /* Only one thing on the rhs */
14248     if (OpHAS_SIBLING(oright))
14249         return;
14250
14251     /* check the array is the same on both sides */
14252     if (oleft->op_type == OP_RV2AV) {
14253         if (oright->op_type != OP_RV2AV
14254             || !cUNOPx(oright)->op_first
14255             || cUNOPx(oright)->op_first->op_type != OP_GV
14256             || cUNOPx(oleft )->op_first->op_type != OP_GV
14257             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14258                cGVOPx_gv(cUNOPx(oright)->op_first)
14259         )
14260             return;
14261     }
14262     else if (oright->op_type != OP_PADAV
14263         || oright->op_targ != oleft->op_targ
14264     )
14265         return;
14266
14267     /* This actually is an inplace assignment */
14268
14269     modop->op_private |= OPpSORT_INPLACE;
14270
14271     /* transfer MODishness etc from LHS arg to RHS arg */
14272     oright->op_flags = oleft->op_flags;
14273
14274     /* remove the aassign op and the lhs */
14275     op_null(o);
14276     op_null(oleft_pushmark);
14277     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14278         op_null(cUNOPx(oleft)->op_first);
14279     op_null(oleft);
14280 }
14281
14282
14283
14284 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14285  * that potentially represent a series of one or more aggregate derefs
14286  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14287  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14288  * additional ops left in too).
14289  *
14290  * The caller will have already verified that the first few ops in the
14291  * chain following 'start' indicate a multideref candidate, and will have
14292  * set 'orig_o' to the point further on in the chain where the first index
14293  * expression (if any) begins.  'orig_action' specifies what type of
14294  * beginning has already been determined by the ops between start..orig_o
14295  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14296  *
14297  * 'hints' contains any hints flags that need adding (currently just
14298  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14299  */
14300
14301 STATIC void
14302 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14303 {
14304     dVAR;
14305     int pass;
14306     UNOP_AUX_item *arg_buf = NULL;
14307     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14308     int index_skip         = -1;    /* don't output index arg on this action */
14309
14310     /* similar to regex compiling, do two passes; the first pass
14311      * determines whether the op chain is convertible and calculates the
14312      * buffer size; the second pass populates the buffer and makes any
14313      * changes necessary to ops (such as moving consts to the pad on
14314      * threaded builds).
14315      *
14316      * NB: for things like Coverity, note that both passes take the same
14317      * path through the logic tree (except for 'if (pass)' bits), since
14318      * both passes are following the same op_next chain; and in
14319      * particular, if it would return early on the second pass, it would
14320      * already have returned early on the first pass.
14321      */
14322     for (pass = 0; pass < 2; pass++) {
14323         OP *o                = orig_o;
14324         UV action            = orig_action;
14325         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14326         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14327         int action_count     = 0;     /* number of actions seen so far */
14328         int action_ix        = 0;     /* action_count % (actions per IV) */
14329         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14330         bool is_last         = FALSE; /* no more derefs to follow */
14331         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14332         UNOP_AUX_item *arg     = arg_buf;
14333         UNOP_AUX_item *action_ptr = arg_buf;
14334
14335         if (pass)
14336             action_ptr->uv = 0;
14337         arg++;
14338
14339         switch (action) {
14340         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14341         case MDEREF_HV_gvhv_helem:
14342             next_is_hash = TRUE;
14343             /* FALLTHROUGH */
14344         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14345         case MDEREF_AV_gvav_aelem:
14346             if (pass) {
14347 #ifdef USE_ITHREADS
14348                 arg->pad_offset = cPADOPx(start)->op_padix;
14349                 /* stop it being swiped when nulled */
14350                 cPADOPx(start)->op_padix = 0;
14351 #else
14352                 arg->sv = cSVOPx(start)->op_sv;
14353                 cSVOPx(start)->op_sv = NULL;
14354 #endif
14355             }
14356             arg++;
14357             break;
14358
14359         case MDEREF_HV_padhv_helem:
14360         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14361             next_is_hash = TRUE;
14362             /* FALLTHROUGH */
14363         case MDEREF_AV_padav_aelem:
14364         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14365             if (pass) {
14366                 arg->pad_offset = start->op_targ;
14367                 /* we skip setting op_targ = 0 for now, since the intact
14368                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14369                 reset_start_targ = TRUE;
14370             }
14371             arg++;
14372             break;
14373
14374         case MDEREF_HV_pop_rv2hv_helem:
14375             next_is_hash = TRUE;
14376             /* FALLTHROUGH */
14377         case MDEREF_AV_pop_rv2av_aelem:
14378             break;
14379
14380         default:
14381             NOT_REACHED; /* NOTREACHED */
14382             return;
14383         }
14384
14385         while (!is_last) {
14386             /* look for another (rv2av/hv; get index;
14387              * aelem/helem/exists/delele) sequence */
14388
14389             OP *kid;
14390             bool is_deref;
14391             bool ok;
14392             UV index_type = MDEREF_INDEX_none;
14393
14394             if (action_count) {
14395                 /* if this is not the first lookup, consume the rv2av/hv  */
14396
14397                 /* for N levels of aggregate lookup, we normally expect
14398                  * that the first N-1 [ah]elem ops will be flagged as
14399                  * /DEREF (so they autovivifiy if necessary), and the last
14400                  * lookup op not to be.
14401                  * For other things (like @{$h{k1}{k2}}) extra scope or
14402                  * leave ops can appear, so abandon the effort in that
14403                  * case */
14404                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14405                     return;
14406
14407                 /* rv2av or rv2hv sKR/1 */
14408
14409                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14410                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14411                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14412                     return;
14413
14414                 /* at this point, we wouldn't expect any of these
14415                  * possible private flags:
14416                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14417                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14418                  */
14419                 ASSUME(!(o->op_private &
14420                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14421
14422                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14423
14424                 /* make sure the type of the previous /DEREF matches the
14425                  * type of the next lookup */
14426                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14427                 top_op = o;
14428
14429                 action = next_is_hash
14430                             ? MDEREF_HV_vivify_rv2hv_helem
14431                             : MDEREF_AV_vivify_rv2av_aelem;
14432                 o = o->op_next;
14433             }
14434
14435             /* if this is the second pass, and we're at the depth where
14436              * previously we encountered a non-simple index expression,
14437              * stop processing the index at this point */
14438             if (action_count != index_skip) {
14439
14440                 /* look for one or more simple ops that return an array
14441                  * index or hash key */
14442
14443                 switch (o->op_type) {
14444                 case OP_PADSV:
14445                     /* it may be a lexical var index */
14446                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14447                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14448                     ASSUME(!(o->op_private &
14449                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14450
14451                     if (   OP_GIMME(o,0) == G_SCALAR
14452                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14453                         && o->op_private == 0)
14454                     {
14455                         if (pass)
14456                             arg->pad_offset = o->op_targ;
14457                         arg++;
14458                         index_type = MDEREF_INDEX_padsv;
14459                         o = o->op_next;
14460                     }
14461                     break;
14462
14463                 case OP_CONST:
14464                     if (next_is_hash) {
14465                         /* it's a constant hash index */
14466                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14467                             /* "use constant foo => FOO; $h{+foo}" for
14468                              * some weird FOO, can leave you with constants
14469                              * that aren't simple strings. It's not worth
14470                              * the extra hassle for those edge cases */
14471                             break;
14472
14473                         if (pass) {
14474                             UNOP *rop = NULL;
14475                             OP * helem_op = o->op_next;
14476
14477                             ASSUME(   helem_op->op_type == OP_HELEM
14478                                    || helem_op->op_type == OP_NULL);
14479                             if (helem_op->op_type == OP_HELEM) {
14480                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14481                                 if (   helem_op->op_private & OPpLVAL_INTRO
14482                                     || rop->op_type != OP_RV2HV
14483                                 )
14484                                     rop = NULL;
14485                             }
14486                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14487
14488 #ifdef USE_ITHREADS
14489                             /* Relocate sv to the pad for thread safety */
14490                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14491                             arg->pad_offset = o->op_targ;
14492                             o->op_targ = 0;
14493 #else
14494                             arg->sv = cSVOPx_sv(o);
14495 #endif
14496                         }
14497                     }
14498                     else {
14499                         /* it's a constant array index */
14500                         IV iv;
14501                         SV *ix_sv = cSVOPo->op_sv;
14502                         if (!SvIOK(ix_sv))
14503                             break;
14504                         iv = SvIV(ix_sv);
14505
14506                         if (   action_count == 0
14507                             && iv >= -128
14508                             && iv <= 127
14509                             && (   action == MDEREF_AV_padav_aelem
14510                                 || action == MDEREF_AV_gvav_aelem)
14511                         )
14512                             maybe_aelemfast = TRUE;
14513
14514                         if (pass) {
14515                             arg->iv = iv;
14516                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14517                         }
14518                     }
14519                     if (pass)
14520                         /* we've taken ownership of the SV */
14521                         cSVOPo->op_sv = NULL;
14522                     arg++;
14523                     index_type = MDEREF_INDEX_const;
14524                     o = o->op_next;
14525                     break;
14526
14527                 case OP_GV:
14528                     /* it may be a package var index */
14529
14530                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14531                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14532                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14533                         || o->op_private != 0
14534                     )
14535                         break;
14536
14537                     kid = o->op_next;
14538                     if (kid->op_type != OP_RV2SV)
14539                         break;
14540
14541                     ASSUME(!(kid->op_flags &
14542                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14543                              |OPf_SPECIAL|OPf_PARENS)));
14544                     ASSUME(!(kid->op_private &
14545                                     ~(OPpARG1_MASK
14546                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14547                                      |OPpDEREF|OPpLVAL_INTRO)));
14548                     if(   (kid->op_flags &~ OPf_PARENS)
14549                             != (OPf_WANT_SCALAR|OPf_KIDS)
14550                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14551                     )
14552                         break;
14553
14554                     if (pass) {
14555 #ifdef USE_ITHREADS
14556                         arg->pad_offset = cPADOPx(o)->op_padix;
14557                         /* stop it being swiped when nulled */
14558                         cPADOPx(o)->op_padix = 0;
14559 #else
14560                         arg->sv = cSVOPx(o)->op_sv;
14561                         cSVOPo->op_sv = NULL;
14562 #endif
14563                     }
14564                     arg++;
14565                     index_type = MDEREF_INDEX_gvsv;
14566                     o = kid->op_next;
14567                     break;
14568
14569                 } /* switch */
14570             } /* action_count != index_skip */
14571
14572             action |= index_type;
14573
14574
14575             /* at this point we have either:
14576              *   * detected what looks like a simple index expression,
14577              *     and expect the next op to be an [ah]elem, or
14578              *     an nulled  [ah]elem followed by a delete or exists;
14579              *  * found a more complex expression, so something other
14580              *    than the above follows.
14581              */
14582
14583             /* possibly an optimised away [ah]elem (where op_next is
14584              * exists or delete) */
14585             if (o->op_type == OP_NULL)
14586                 o = o->op_next;
14587
14588             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14589              * OP_EXISTS or OP_DELETE */
14590
14591             /* if something like arybase (a.k.a $[ ) is in scope,
14592              * abandon optimisation attempt */
14593             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14594                && PL_check[o->op_type] != Perl_ck_null)
14595                 return;
14596             /* similarly for customised exists and delete */
14597             if (  (o->op_type == OP_EXISTS)
14598                && PL_check[o->op_type] != Perl_ck_exists)
14599                 return;
14600             if (  (o->op_type == OP_DELETE)
14601                && PL_check[o->op_type] != Perl_ck_delete)
14602                 return;
14603
14604             if (   o->op_type != OP_AELEM
14605                 || (o->op_private &
14606                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14607                 )
14608                 maybe_aelemfast = FALSE;
14609
14610             /* look for aelem/helem/exists/delete. If it's not the last elem
14611              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14612              * flags; if it's the last, then it mustn't have
14613              * OPpDEREF_AV/HV, but may have lots of other flags, like
14614              * OPpLVAL_INTRO etc
14615              */
14616
14617             if (   index_type == MDEREF_INDEX_none
14618                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14619                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14620             )
14621                 ok = FALSE;
14622             else {
14623                 /* we have aelem/helem/exists/delete with valid simple index */
14624
14625                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14626                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14627                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14628
14629                 /* This doesn't make much sense but is legal:
14630                  *    @{ local $x[0][0] } = 1
14631                  * Since scope exit will undo the autovivification,
14632                  * don't bother in the first place. The OP_LEAVE
14633                  * assertion is in case there are other cases of both
14634                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14635                  * exit that would undo the local - in which case this
14636                  * block of code would need rethinking.
14637                  */
14638                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14639 #ifdef DEBUGGING
14640                     OP *n = o->op_next;
14641                     while (n && (  n->op_type == OP_NULL
14642                                 || n->op_type == OP_LIST))
14643                         n = n->op_next;
14644                     assert(n && n->op_type == OP_LEAVE);
14645 #endif
14646                     o->op_private &= ~OPpDEREF;
14647                     is_deref = FALSE;
14648                 }
14649
14650                 if (is_deref) {
14651                     ASSUME(!(o->op_flags &
14652                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14653                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14654
14655                     ok =    (o->op_flags &~ OPf_PARENS)
14656                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14657                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14658                 }
14659                 else if (o->op_type == OP_EXISTS) {
14660                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14661                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14662                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14663                     ok =  !(o->op_private & ~OPpARG1_MASK);
14664                 }
14665                 else if (o->op_type == OP_DELETE) {
14666                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14667                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14668                     ASSUME(!(o->op_private &
14669                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14670                     /* don't handle slices or 'local delete'; the latter
14671                      * is fairly rare, and has a complex runtime */
14672                     ok =  !(o->op_private & ~OPpARG1_MASK);
14673                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14674                         /* skip handling run-tome error */
14675                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14676                 }
14677                 else {
14678                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14679                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14680                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14681                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14682                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14683                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14684                 }
14685             }
14686
14687             if (ok) {
14688                 if (!first_elem_op)
14689                     first_elem_op = o;
14690                 top_op = o;
14691                 if (is_deref) {
14692                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14693                     o = o->op_next;
14694                 }
14695                 else {
14696                     is_last = TRUE;
14697                     action |= MDEREF_FLAG_last;
14698                 }
14699             }
14700             else {
14701                 /* at this point we have something that started
14702                  * promisingly enough (with rv2av or whatever), but failed
14703                  * to find a simple index followed by an
14704                  * aelem/helem/exists/delete. If this is the first action,
14705                  * give up; but if we've already seen at least one
14706                  * aelem/helem, then keep them and add a new action with
14707                  * MDEREF_INDEX_none, which causes it to do the vivify
14708                  * from the end of the previous lookup, and do the deref,
14709                  * but stop at that point. So $a[0][expr] will do one
14710                  * av_fetch, vivify and deref, then continue executing at
14711                  * expr */
14712                 if (!action_count)
14713                     return;
14714                 is_last = TRUE;
14715                 index_skip = action_count;
14716                 action |= MDEREF_FLAG_last;
14717                 if (index_type != MDEREF_INDEX_none)
14718                     arg--;
14719             }
14720
14721             if (pass)
14722                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14723             action_ix++;
14724             action_count++;
14725             /* if there's no space for the next action, create a new slot
14726              * for it *before* we start adding args for that action */
14727             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14728                 action_ptr = arg;
14729                 if (pass)
14730                     arg->uv = 0;
14731                 arg++;
14732                 action_ix = 0;
14733             }
14734         } /* while !is_last */
14735
14736         /* success! */
14737
14738         if (pass) {
14739             OP *mderef;
14740             OP *p, *q;
14741
14742             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14743             if (index_skip == -1) {
14744                 mderef->op_flags = o->op_flags
14745                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14746                 if (o->op_type == OP_EXISTS)
14747                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14748                 else if (o->op_type == OP_DELETE)
14749                     mderef->op_private = OPpMULTIDEREF_DELETE;
14750                 else
14751                     mderef->op_private = o->op_private
14752                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14753             }
14754             /* accumulate strictness from every level (although I don't think
14755              * they can actually vary) */
14756             mderef->op_private |= hints;
14757
14758             /* integrate the new multideref op into the optree and the
14759              * op_next chain.
14760              *
14761              * In general an op like aelem or helem has two child
14762              * sub-trees: the aggregate expression (a_expr) and the
14763              * index expression (i_expr):
14764              *
14765              *     aelem
14766              *       |
14767              *     a_expr - i_expr
14768              *
14769              * The a_expr returns an AV or HV, while the i-expr returns an
14770              * index. In general a multideref replaces most or all of a
14771              * multi-level tree, e.g.
14772              *
14773              *     exists
14774              *       |
14775              *     ex-aelem
14776              *       |
14777              *     rv2av  - i_expr1
14778              *       |
14779              *     helem
14780              *       |
14781              *     rv2hv  - i_expr2
14782              *       |
14783              *     aelem
14784              *       |
14785              *     a_expr - i_expr3
14786              *
14787              * With multideref, all the i_exprs will be simple vars or
14788              * constants, except that i_expr1 may be arbitrary in the case
14789              * of MDEREF_INDEX_none.
14790              *
14791              * The bottom-most a_expr will be either:
14792              *   1) a simple var (so padXv or gv+rv2Xv);
14793              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14794              *      so a simple var with an extra rv2Xv;
14795              *   3) or an arbitrary expression.
14796              *
14797              * 'start', the first op in the execution chain, will point to
14798              *   1),2): the padXv or gv op;
14799              *   3):    the rv2Xv which forms the last op in the a_expr
14800              *          execution chain, and the top-most op in the a_expr
14801              *          subtree.
14802              *
14803              * For all cases, the 'start' node is no longer required,
14804              * but we can't free it since one or more external nodes
14805              * may point to it. E.g. consider
14806              *     $h{foo} = $a ? $b : $c
14807              * Here, both the op_next and op_other branches of the
14808              * cond_expr point to the gv[*h] of the hash expression, so
14809              * we can't free the 'start' op.
14810              *
14811              * For expr->[...], we need to save the subtree containing the
14812              * expression; for the other cases, we just need to save the
14813              * start node.
14814              * So in all cases, we null the start op and keep it around by
14815              * making it the child of the multideref op; for the expr->
14816              * case, the expr will be a subtree of the start node.
14817              *
14818              * So in the simple 1,2 case the  optree above changes to
14819              *
14820              *     ex-exists
14821              *       |
14822              *     multideref
14823              *       |
14824              *     ex-gv (or ex-padxv)
14825              *
14826              *  with the op_next chain being
14827              *
14828              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14829              *
14830              *  In the 3 case, we have
14831              *
14832              *     ex-exists
14833              *       |
14834              *     multideref
14835              *       |
14836              *     ex-rv2xv
14837              *       |
14838              *    rest-of-a_expr
14839              *      subtree
14840              *
14841              *  and
14842              *
14843              *  -> rest-of-a_expr subtree ->
14844              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
14845              *
14846              *
14847              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14848              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14849              * multideref attached as the child, e.g.
14850              *
14851              *     exists
14852              *       |
14853              *     ex-aelem
14854              *       |
14855              *     ex-rv2av  - i_expr1
14856              *       |
14857              *     multideref
14858              *       |
14859              *     ex-whatever
14860              *
14861              */
14862
14863             /* if we free this op, don't free the pad entry */
14864             if (reset_start_targ)
14865                 start->op_targ = 0;
14866
14867
14868             /* Cut the bit we need to save out of the tree and attach to
14869              * the multideref op, then free the rest of the tree */
14870
14871             /* find parent of node to be detached (for use by splice) */
14872             p = first_elem_op;
14873             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
14874                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14875             {
14876                 /* there is an arbitrary expression preceding us, e.g.
14877                  * expr->[..]? so we need to save the 'expr' subtree */
14878                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14879                     p = cUNOPx(p)->op_first;
14880                 ASSUME(   start->op_type == OP_RV2AV
14881                        || start->op_type == OP_RV2HV);
14882             }
14883             else {
14884                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
14885                  * above for exists/delete. */
14886                 while (   (p->op_flags & OPf_KIDS)
14887                        && cUNOPx(p)->op_first != start
14888                 )
14889                     p = cUNOPx(p)->op_first;
14890             }
14891             ASSUME(cUNOPx(p)->op_first == start);
14892
14893             /* detach from main tree, and re-attach under the multideref */
14894             op_sibling_splice(mderef, NULL, 0,
14895                     op_sibling_splice(p, NULL, 1, NULL));
14896             op_null(start);
14897
14898             start->op_next = mderef;
14899
14900             mderef->op_next = index_skip == -1 ? o->op_next : o;
14901
14902             /* excise and free the original tree, and replace with
14903              * the multideref op */
14904             p = op_sibling_splice(top_op, NULL, -1, mderef);
14905             while (p) {
14906                 q = OpSIBLING(p);
14907                 op_free(p);
14908                 p = q;
14909             }
14910             op_null(top_op);
14911         }
14912         else {
14913             Size_t size = arg - arg_buf;
14914
14915             if (maybe_aelemfast && action_count == 1)
14916                 return;
14917
14918             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
14919                                 sizeof(UNOP_AUX_item) * (size + 1));
14920             /* for dumping etc: store the length in a hidden first slot;
14921              * we set the op_aux pointer to the second slot */
14922             arg_buf->uv = size;
14923             arg_buf++;
14924         }
14925     } /* for (pass = ...) */
14926 }
14927
14928 /* See if the ops following o are such that o will always be executed in
14929  * boolean context: that is, the SV which o pushes onto the stack will
14930  * only ever be consumed by later ops via SvTRUE(sv) or similar.
14931  * If so, set a suitable private flag on o. Normally this will be
14932  * bool_flag; but see below why maybe_flag is needed too.
14933  *
14934  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
14935  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
14936  * already be taken, so you'll have to give that op two different flags.
14937  *
14938  * More explanation of 'maybe_flag' and 'safe_and' parameters.
14939  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
14940  * those underlying ops) short-circuit, which means that rather than
14941  * necessarily returning a truth value, they may return the LH argument,
14942  * which may not be boolean. For example in $x = (keys %h || -1), keys
14943  * should return a key count rather than a boolean, even though its
14944  * sort-of being used in boolean context.
14945  *
14946  * So we only consider such logical ops to provide boolean context to
14947  * their LH argument if they themselves are in void or boolean context.
14948  * However, sometimes the context isn't known until run-time. In this
14949  * case the op is marked with the maybe_flag flag it.
14950  *
14951  * Consider the following.
14952  *
14953  *     sub f { ....;  if (%h) { .... } }
14954  *
14955  * This is actually compiled as
14956  *
14957  *     sub f { ....;  %h && do { .... } }
14958  *
14959  * Here we won't know until runtime whether the final statement (and hence
14960  * the &&) is in void context and so is safe to return a boolean value.
14961  * So mark o with maybe_flag rather than the bool_flag.
14962  * Note that there is cost associated with determining context at runtime
14963  * (e.g. a call to block_gimme()), so it may not be worth setting (at
14964  * compile time) and testing (at runtime) maybe_flag if the scalar verses
14965  * boolean costs savings are marginal.
14966  *
14967  * However, we can do slightly better with && (compared to || and //):
14968  * this op only returns its LH argument when that argument is false. In
14969  * this case, as long as the op promises to return a false value which is
14970  * valid in both boolean and scalar contexts, we can mark an op consumed
14971  * by && with bool_flag rather than maybe_flag.
14972  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
14973  * than &PL_sv_no for a false result in boolean context, then it's safe. An
14974  * op which promises to handle this case is indicated by setting safe_and
14975  * to true.
14976  */
14977
14978 static void
14979 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
14980 {
14981     OP *lop;
14982     U8 flag = 0;
14983
14984     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
14985
14986     /* OPpTARGET_MY and boolean context probably don't mix well.
14987      * If someone finds a valid use case, maybe add an extra flag to this
14988      * function which indicates its safe to do so for this op? */
14989     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
14990              && (o->op_private & OPpTARGET_MY)));
14991
14992     lop = o->op_next;
14993
14994     while (lop) {
14995         switch (lop->op_type) {
14996         case OP_NULL:
14997         case OP_SCALAR:
14998             break;
14999
15000         /* these two consume the stack argument in the scalar case,
15001          * and treat it as a boolean in the non linenumber case */
15002         case OP_FLIP:
15003         case OP_FLOP:
15004             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15005                 || (lop->op_private & OPpFLIP_LINENUM))
15006             {
15007                 lop = NULL;
15008                 break;
15009             }
15010             /* FALLTHROUGH */
15011         /* these never leave the original value on the stack */
15012         case OP_NOT:
15013         case OP_XOR:
15014         case OP_COND_EXPR:
15015         case OP_GREPWHILE:
15016             flag = bool_flag;
15017             lop = NULL;
15018             break;
15019
15020         /* OR DOR and AND evaluate their arg as a boolean, but then may
15021          * leave the original scalar value on the stack when following the
15022          * op_next route. If not in void context, we need to ensure
15023          * that whatever follows consumes the arg only in boolean context
15024          * too.
15025          */
15026         case OP_AND:
15027             if (safe_and) {
15028                 flag = bool_flag;
15029                 lop = NULL;
15030                 break;
15031             }
15032             /* FALLTHROUGH */
15033         case OP_OR:
15034         case OP_DOR:
15035             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15036                 flag = bool_flag;
15037                 lop = NULL;
15038             }
15039             else if (!(lop->op_flags & OPf_WANT)) {
15040                 /* unknown context - decide at runtime */
15041                 flag = maybe_flag;
15042                 lop = NULL;
15043             }
15044             break;
15045
15046         default:
15047             lop = NULL;
15048             break;
15049         }
15050
15051         if (lop)
15052             lop = lop->op_next;
15053     }
15054
15055     o->op_private |= flag;
15056 }
15057
15058
15059
15060 /* mechanism for deferring recursion in rpeep() */
15061
15062 #define MAX_DEFERRED 4
15063
15064 #define DEFER(o) \
15065   STMT_START { \
15066     if (defer_ix == (MAX_DEFERRED-1)) { \
15067         OP **defer = defer_queue[defer_base]; \
15068         CALL_RPEEP(*defer); \
15069         S_prune_chain_head(defer); \
15070         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15071         defer_ix--; \
15072     } \
15073     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15074   } STMT_END
15075
15076 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15077 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15078
15079
15080 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15081  * See the comments at the top of this file for more details about when
15082  * peep() is called */
15083
15084 void
15085 Perl_rpeep(pTHX_ OP *o)
15086 {
15087     dVAR;
15088     OP* oldop = NULL;
15089     OP* oldoldop = NULL;
15090     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15091     int defer_base = 0;
15092     int defer_ix = -1;
15093
15094     if (!o || o->op_opt)
15095         return;
15096
15097     assert(o->op_type != OP_FREED);
15098
15099     ENTER;
15100     SAVEOP();
15101     SAVEVPTR(PL_curcop);
15102     for (;; o = o->op_next) {
15103         if (o && o->op_opt)
15104             o = NULL;
15105         if (!o) {
15106             while (defer_ix >= 0) {
15107                 OP **defer =
15108                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15109                 CALL_RPEEP(*defer);
15110                 S_prune_chain_head(defer);
15111             }
15112             break;
15113         }
15114
15115       redo:
15116
15117         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15118         assert(!oldoldop || oldoldop->op_next == oldop);
15119         assert(!oldop    || oldop->op_next    == o);
15120
15121         /* By default, this op has now been optimised. A couple of cases below
15122            clear this again.  */
15123         o->op_opt = 1;
15124         PL_op = o;
15125
15126         /* look for a series of 1 or more aggregate derefs, e.g.
15127          *   $a[1]{foo}[$i]{$k}
15128          * and replace with a single OP_MULTIDEREF op.
15129          * Each index must be either a const, or a simple variable,
15130          *
15131          * First, look for likely combinations of starting ops,
15132          * corresponding to (global and lexical variants of)
15133          *     $a[...]   $h{...}
15134          *     $r->[...] $r->{...}
15135          *     (preceding expression)->[...]
15136          *     (preceding expression)->{...}
15137          * and if so, call maybe_multideref() to do a full inspection
15138          * of the op chain and if appropriate, replace with an
15139          * OP_MULTIDEREF
15140          */
15141         {
15142             UV action;
15143             OP *o2 = o;
15144             U8 hints = 0;
15145
15146             switch (o2->op_type) {
15147             case OP_GV:
15148                 /* $pkg[..]   :   gv[*pkg]
15149                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15150
15151                 /* Fail if there are new op flag combinations that we're
15152                  * not aware of, rather than:
15153                  *  * silently failing to optimise, or
15154                  *  * silently optimising the flag away.
15155                  * If this ASSUME starts failing, examine what new flag
15156                  * has been added to the op, and decide whether the
15157                  * optimisation should still occur with that flag, then
15158                  * update the code accordingly. This applies to all the
15159                  * other ASSUMEs in the block of code too.
15160                  */
15161                 ASSUME(!(o2->op_flags &
15162                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15163                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15164
15165                 o2 = o2->op_next;
15166
15167                 if (o2->op_type == OP_RV2AV) {
15168                     action = MDEREF_AV_gvav_aelem;
15169                     goto do_deref;
15170                 }
15171
15172                 if (o2->op_type == OP_RV2HV) {
15173                     action = MDEREF_HV_gvhv_helem;
15174                     goto do_deref;
15175                 }
15176
15177                 if (o2->op_type != OP_RV2SV)
15178                     break;
15179
15180                 /* at this point we've seen gv,rv2sv, so the only valid
15181                  * construct left is $pkg->[] or $pkg->{} */
15182
15183                 ASSUME(!(o2->op_flags & OPf_STACKED));
15184                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15185                             != (OPf_WANT_SCALAR|OPf_MOD))
15186                     break;
15187
15188                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15189                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15190                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15191                     break;
15192                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15193                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15194                     break;
15195
15196                 o2 = o2->op_next;
15197                 if (o2->op_type == OP_RV2AV) {
15198                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15199                     goto do_deref;
15200                 }
15201                 if (o2->op_type == OP_RV2HV) {
15202                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15203                     goto do_deref;
15204                 }
15205                 break;
15206
15207             case OP_PADSV:
15208                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15209
15210                 ASSUME(!(o2->op_flags &
15211                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15212                 if ((o2->op_flags &
15213                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15214                      != (OPf_WANT_SCALAR|OPf_MOD))
15215                     break;
15216
15217                 ASSUME(!(o2->op_private &
15218                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15219                 /* skip if state or intro, or not a deref */
15220                 if (      o2->op_private != OPpDEREF_AV
15221                        && o2->op_private != OPpDEREF_HV)
15222                     break;
15223
15224                 o2 = o2->op_next;
15225                 if (o2->op_type == OP_RV2AV) {
15226                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15227                     goto do_deref;
15228                 }
15229                 if (o2->op_type == OP_RV2HV) {
15230                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15231                     goto do_deref;
15232                 }
15233                 break;
15234
15235             case OP_PADAV:
15236             case OP_PADHV:
15237                 /*    $lex[..]:  padav[@lex:1,2] sR *
15238                  * or $lex{..}:  padhv[%lex:1,2] sR */
15239                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15240                                             OPf_REF|OPf_SPECIAL)));
15241                 if ((o2->op_flags &
15242                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15243                      != (OPf_WANT_SCALAR|OPf_REF))
15244                     break;
15245                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15246                     break;
15247                 /* OPf_PARENS isn't currently used in this case;
15248                  * if that changes, let us know! */
15249                 ASSUME(!(o2->op_flags & OPf_PARENS));
15250
15251                 /* at this point, we wouldn't expect any of the remaining
15252                  * possible private flags:
15253                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15254                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15255                  *
15256                  * OPpSLICEWARNING shouldn't affect runtime
15257                  */
15258                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15259
15260                 action = o2->op_type == OP_PADAV
15261                             ? MDEREF_AV_padav_aelem
15262                             : MDEREF_HV_padhv_helem;
15263                 o2 = o2->op_next;
15264                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15265                 break;
15266
15267
15268             case OP_RV2AV:
15269             case OP_RV2HV:
15270                 action = o2->op_type == OP_RV2AV
15271                             ? MDEREF_AV_pop_rv2av_aelem
15272                             : MDEREF_HV_pop_rv2hv_helem;
15273                 /* FALLTHROUGH */
15274             do_deref:
15275                 /* (expr)->[...]:  rv2av sKR/1;
15276                  * (expr)->{...}:  rv2hv sKR/1; */
15277
15278                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15279
15280                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15281                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15282                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15283                     break;
15284
15285                 /* at this point, we wouldn't expect any of these
15286                  * possible private flags:
15287                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15288                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15289                  */
15290                 ASSUME(!(o2->op_private &
15291                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15292                      |OPpOUR_INTRO)));
15293                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15294
15295                 o2 = o2->op_next;
15296
15297                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15298                 break;
15299
15300             default:
15301                 break;
15302             }
15303         }
15304
15305
15306         switch (o->op_type) {
15307         case OP_DBSTATE:
15308             PL_curcop = ((COP*)o);              /* for warnings */
15309             break;
15310         case OP_NEXTSTATE:
15311             PL_curcop = ((COP*)o);              /* for warnings */
15312
15313             /* Optimise a "return ..." at the end of a sub to just be "...".
15314              * This saves 2 ops. Before:
15315              * 1  <;> nextstate(main 1 -e:1) v ->2
15316              * 4  <@> return K ->5
15317              * 2    <0> pushmark s ->3
15318              * -    <1> ex-rv2sv sK/1 ->4
15319              * 3      <#> gvsv[*cat] s ->4
15320              *
15321              * After:
15322              * -  <@> return K ->-
15323              * -    <0> pushmark s ->2
15324              * -    <1> ex-rv2sv sK/1 ->-
15325              * 2      <$> gvsv(*cat) s ->3
15326              */
15327             {
15328                 OP *next = o->op_next;
15329                 OP *sibling = OpSIBLING(o);
15330                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15331                     && OP_TYPE_IS(sibling, OP_RETURN)
15332                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15333                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15334                        ||OP_TYPE_IS(sibling->op_next->op_next,
15335                                     OP_LEAVESUBLV))
15336                     && cUNOPx(sibling)->op_first == next
15337                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15338                     && next->op_next
15339                 ) {
15340                     /* Look through the PUSHMARK's siblings for one that
15341                      * points to the RETURN */
15342                     OP *top = OpSIBLING(next);
15343                     while (top && top->op_next) {
15344                         if (top->op_next == sibling) {
15345                             top->op_next = sibling->op_next;
15346                             o->op_next = next->op_next;
15347                             break;
15348                         }
15349                         top = OpSIBLING(top);
15350                     }
15351                 }
15352             }
15353
15354             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15355              *
15356              * This latter form is then suitable for conversion into padrange
15357              * later on. Convert:
15358              *
15359              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15360              *
15361              * into:
15362              *
15363              *   nextstate1 ->     listop     -> nextstate3
15364              *                 /            \
15365              *         pushmark -> padop1 -> padop2
15366              */
15367             if (o->op_next && (
15368                     o->op_next->op_type == OP_PADSV
15369                  || o->op_next->op_type == OP_PADAV
15370                  || o->op_next->op_type == OP_PADHV
15371                 )
15372                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15373                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15374                 && o->op_next->op_next->op_next && (
15375                     o->op_next->op_next->op_next->op_type == OP_PADSV
15376                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15377                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15378                 )
15379                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15380                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15381                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15382                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15383             ) {
15384                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15385
15386                 pad1 =    o->op_next;
15387                 ns2  = pad1->op_next;
15388                 pad2 =  ns2->op_next;
15389                 ns3  = pad2->op_next;
15390
15391                 /* we assume here that the op_next chain is the same as
15392                  * the op_sibling chain */
15393                 assert(OpSIBLING(o)    == pad1);
15394                 assert(OpSIBLING(pad1) == ns2);
15395                 assert(OpSIBLING(ns2)  == pad2);
15396                 assert(OpSIBLING(pad2) == ns3);
15397
15398                 /* excise and delete ns2 */
15399                 op_sibling_splice(NULL, pad1, 1, NULL);
15400                 op_free(ns2);
15401
15402                 /* excise pad1 and pad2 */
15403                 op_sibling_splice(NULL, o, 2, NULL);
15404
15405                 /* create new listop, with children consisting of:
15406                  * a new pushmark, pad1, pad2. */
15407                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15408                 newop->op_flags |= OPf_PARENS;
15409                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15410
15411                 /* insert newop between o and ns3 */
15412                 op_sibling_splice(NULL, o, 0, newop);
15413
15414                 /*fixup op_next chain */
15415                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15416                 o    ->op_next = newpm;
15417                 newpm->op_next = pad1;
15418                 pad1 ->op_next = pad2;
15419                 pad2 ->op_next = newop; /* listop */
15420                 newop->op_next = ns3;
15421
15422                 /* Ensure pushmark has this flag if padops do */
15423                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15424                     newpm->op_flags |= OPf_MOD;
15425                 }
15426
15427                 break;
15428             }
15429
15430             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15431                to carry two labels. For now, take the easier option, and skip
15432                this optimisation if the first NEXTSTATE has a label.  */
15433             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15434                 OP *nextop = o->op_next;
15435                 while (nextop && nextop->op_type == OP_NULL)
15436                     nextop = nextop->op_next;
15437
15438                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15439                     op_null(o);
15440                     if (oldop)
15441                         oldop->op_next = nextop;
15442                     o = nextop;
15443                     /* Skip (old)oldop assignment since the current oldop's
15444                        op_next already points to the next op.  */
15445                     goto redo;
15446                 }
15447             }
15448             break;
15449
15450         case OP_CONCAT:
15451             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15452                 if (o->op_next->op_private & OPpTARGET_MY) {
15453                     if (o->op_flags & OPf_STACKED) /* chained concats */
15454                         break; /* ignore_optimization */
15455                     else {
15456                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15457                         o->op_targ = o->op_next->op_targ;
15458                         o->op_next->op_targ = 0;
15459                         o->op_private |= OPpTARGET_MY;
15460                     }
15461                 }
15462                 op_null(o->op_next);
15463             }
15464             break;
15465         case OP_STUB:
15466             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15467                 break; /* Scalar stub must produce undef.  List stub is noop */
15468             }
15469             goto nothin;
15470         case OP_NULL:
15471             if (o->op_targ == OP_NEXTSTATE
15472                 || o->op_targ == OP_DBSTATE)
15473             {
15474                 PL_curcop = ((COP*)o);
15475             }
15476             /* XXX: We avoid setting op_seq here to prevent later calls
15477                to rpeep() from mistakenly concluding that optimisation
15478                has already occurred. This doesn't fix the real problem,
15479                though (See 20010220.007 (#5874)). AMS 20010719 */
15480             /* op_seq functionality is now replaced by op_opt */
15481             o->op_opt = 0;
15482             /* FALLTHROUGH */
15483         case OP_SCALAR:
15484         case OP_LINESEQ:
15485         case OP_SCOPE:
15486         nothin:
15487             if (oldop) {
15488                 oldop->op_next = o->op_next;
15489                 o->op_opt = 0;
15490                 continue;
15491             }
15492             break;
15493
15494         case OP_PUSHMARK:
15495
15496             /* Given
15497                  5 repeat/DOLIST
15498                  3   ex-list
15499                  1     pushmark
15500                  2     scalar or const
15501                  4   const[0]
15502                convert repeat into a stub with no kids.
15503              */
15504             if (o->op_next->op_type == OP_CONST
15505              || (  o->op_next->op_type == OP_PADSV
15506                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15507              || (  o->op_next->op_type == OP_GV
15508                 && o->op_next->op_next->op_type == OP_RV2SV
15509                 && !(o->op_next->op_next->op_private
15510                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15511             {
15512                 const OP *kid = o->op_next->op_next;
15513                 if (o->op_next->op_type == OP_GV)
15514                    kid = kid->op_next;
15515                 /* kid is now the ex-list.  */
15516                 if (kid->op_type == OP_NULL
15517                  && (kid = kid->op_next)->op_type == OP_CONST
15518                     /* kid is now the repeat count.  */
15519                  && kid->op_next->op_type == OP_REPEAT
15520                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15521                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15522                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15523                  && oldop)
15524                 {
15525                     o = kid->op_next; /* repeat */
15526                     oldop->op_next = o;
15527                     op_free(cBINOPo->op_first);
15528                     op_free(cBINOPo->op_last );
15529                     o->op_flags &=~ OPf_KIDS;
15530                     /* stub is a baseop; repeat is a binop */
15531                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15532                     OpTYPE_set(o, OP_STUB);
15533                     o->op_private = 0;
15534                     break;
15535                 }
15536             }
15537
15538             /* Convert a series of PAD ops for my vars plus support into a
15539              * single padrange op. Basically
15540              *
15541              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15542              *
15543              * becomes, depending on circumstances, one of
15544              *
15545              *    padrange  ----------------------------------> (list) -> rest
15546              *    padrange  --------------------------------------------> rest
15547              *
15548              * where all the pad indexes are sequential and of the same type
15549              * (INTRO or not).
15550              * We convert the pushmark into a padrange op, then skip
15551              * any other pad ops, and possibly some trailing ops.
15552              * Note that we don't null() the skipped ops, to make it
15553              * easier for Deparse to undo this optimisation (and none of
15554              * the skipped ops are holding any resourses). It also makes
15555              * it easier for find_uninit_var(), as it can just ignore
15556              * padrange, and examine the original pad ops.
15557              */
15558         {
15559             OP *p;
15560             OP *followop = NULL; /* the op that will follow the padrange op */
15561             U8 count = 0;
15562             U8 intro = 0;
15563             PADOFFSET base = 0; /* init only to stop compiler whining */
15564             bool gvoid = 0;     /* init only to stop compiler whining */
15565             bool defav = 0;  /* seen (...) = @_ */
15566             bool reuse = 0;  /* reuse an existing padrange op */
15567
15568             /* look for a pushmark -> gv[_] -> rv2av */
15569
15570             {
15571                 OP *rv2av, *q;
15572                 p = o->op_next;
15573                 if (   p->op_type == OP_GV
15574                     && cGVOPx_gv(p) == PL_defgv
15575                     && (rv2av = p->op_next)
15576                     && rv2av->op_type == OP_RV2AV
15577                     && !(rv2av->op_flags & OPf_REF)
15578                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15579                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15580                 ) {
15581                     q = rv2av->op_next;
15582                     if (q->op_type == OP_NULL)
15583                         q = q->op_next;
15584                     if (q->op_type == OP_PUSHMARK) {
15585                         defav = 1;
15586                         p = q;
15587                     }
15588                 }
15589             }
15590             if (!defav) {
15591                 p = o;
15592             }
15593
15594             /* scan for PAD ops */
15595
15596             for (p = p->op_next; p; p = p->op_next) {
15597                 if (p->op_type == OP_NULL)
15598                     continue;
15599
15600                 if ((     p->op_type != OP_PADSV
15601                        && p->op_type != OP_PADAV
15602                        && p->op_type != OP_PADHV
15603                     )
15604                       /* any private flag other than INTRO? e.g. STATE */
15605                    || (p->op_private & ~OPpLVAL_INTRO)
15606                 )
15607                     break;
15608
15609                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15610                  * instead */
15611                 if (   p->op_type == OP_PADAV
15612                     && p->op_next
15613                     && p->op_next->op_type == OP_CONST
15614                     && p->op_next->op_next
15615                     && p->op_next->op_next->op_type == OP_AELEM
15616                 )
15617                     break;
15618
15619                 /* for 1st padop, note what type it is and the range
15620                  * start; for the others, check that it's the same type
15621                  * and that the targs are contiguous */
15622                 if (count == 0) {
15623                     intro = (p->op_private & OPpLVAL_INTRO);
15624                     base = p->op_targ;
15625                     gvoid = OP_GIMME(p,0) == G_VOID;
15626                 }
15627                 else {
15628                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15629                         break;
15630                     /* Note that you'd normally  expect targs to be
15631                      * contiguous in my($a,$b,$c), but that's not the case
15632                      * when external modules start doing things, e.g.
15633                      * Function::Parameters */
15634                     if (p->op_targ != base + count)
15635                         break;
15636                     assert(p->op_targ == base + count);
15637                     /* Either all the padops or none of the padops should
15638                        be in void context.  Since we only do the optimisa-
15639                        tion for av/hv when the aggregate itself is pushed
15640                        on to the stack (one item), there is no need to dis-
15641                        tinguish list from scalar context.  */
15642                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15643                         break;
15644                 }
15645
15646                 /* for AV, HV, only when we're not flattening */
15647                 if (   p->op_type != OP_PADSV
15648                     && !gvoid
15649                     && !(p->op_flags & OPf_REF)
15650                 )
15651                     break;
15652
15653                 if (count >= OPpPADRANGE_COUNTMASK)
15654                     break;
15655
15656                 /* there's a biggest base we can fit into a
15657                  * SAVEt_CLEARPADRANGE in pp_padrange.
15658                  * (The sizeof() stuff will be constant-folded, and is
15659                  * intended to avoid getting "comparison is always false"
15660                  * compiler warnings. See the comments above
15661                  * MEM_WRAP_CHECK for more explanation on why we do this
15662                  * in a weird way to avoid compiler warnings.)
15663                  */
15664                 if (   intro
15665                     && (8*sizeof(base) >
15666                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15667                         ? (Size_t)base
15668                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15669                         ) >
15670                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15671                 )
15672                     break;
15673
15674                 /* Success! We've got another valid pad op to optimise away */
15675                 count++;
15676                 followop = p->op_next;
15677             }
15678
15679             if (count < 1 || (count == 1 && !defav))
15680                 break;
15681
15682             /* pp_padrange in specifically compile-time void context
15683              * skips pushing a mark and lexicals; in all other contexts
15684              * (including unknown till runtime) it pushes a mark and the
15685              * lexicals. We must be very careful then, that the ops we
15686              * optimise away would have exactly the same effect as the
15687              * padrange.
15688              * In particular in void context, we can only optimise to
15689              * a padrange if we see the complete sequence
15690              *     pushmark, pad*v, ...., list
15691              * which has the net effect of leaving the markstack as it
15692              * was.  Not pushing onto the stack (whereas padsv does touch
15693              * the stack) makes no difference in void context.
15694              */
15695             assert(followop);
15696             if (gvoid) {
15697                 if (followop->op_type == OP_LIST
15698                         && OP_GIMME(followop,0) == G_VOID
15699                    )
15700                 {
15701                     followop = followop->op_next; /* skip OP_LIST */
15702
15703                     /* consolidate two successive my(...);'s */
15704
15705                     if (   oldoldop
15706                         && oldoldop->op_type == OP_PADRANGE
15707                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15708                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15709                         && !(oldoldop->op_flags & OPf_SPECIAL)
15710                     ) {
15711                         U8 old_count;
15712                         assert(oldoldop->op_next == oldop);
15713                         assert(   oldop->op_type == OP_NEXTSTATE
15714                                || oldop->op_type == OP_DBSTATE);
15715                         assert(oldop->op_next == o);
15716
15717                         old_count
15718                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15719
15720                        /* Do not assume pad offsets for $c and $d are con-
15721                           tiguous in
15722                             my ($a,$b,$c);
15723                             my ($d,$e,$f);
15724                         */
15725                         if (  oldoldop->op_targ + old_count == base
15726                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15727                             base = oldoldop->op_targ;
15728                             count += old_count;
15729                             reuse = 1;
15730                         }
15731                     }
15732
15733                     /* if there's any immediately following singleton
15734                      * my var's; then swallow them and the associated
15735                      * nextstates; i.e.
15736                      *    my ($a,$b); my $c; my $d;
15737                      * is treated as
15738                      *    my ($a,$b,$c,$d);
15739                      */
15740
15741                     while (    ((p = followop->op_next))
15742                             && (  p->op_type == OP_PADSV
15743                                || p->op_type == OP_PADAV
15744                                || p->op_type == OP_PADHV)
15745                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15746                             && (p->op_private & OPpLVAL_INTRO) == intro
15747                             && !(p->op_private & ~OPpLVAL_INTRO)
15748                             && p->op_next
15749                             && (   p->op_next->op_type == OP_NEXTSTATE
15750                                 || p->op_next->op_type == OP_DBSTATE)
15751                             && count < OPpPADRANGE_COUNTMASK
15752                             && base + count == p->op_targ
15753                     ) {
15754                         count++;
15755                         followop = p->op_next;
15756                     }
15757                 }
15758                 else
15759                     break;
15760             }
15761
15762             if (reuse) {
15763                 assert(oldoldop->op_type == OP_PADRANGE);
15764                 oldoldop->op_next = followop;
15765                 oldoldop->op_private = (intro | count);
15766                 o = oldoldop;
15767                 oldop = NULL;
15768                 oldoldop = NULL;
15769             }
15770             else {
15771                 /* Convert the pushmark into a padrange.
15772                  * To make Deparse easier, we guarantee that a padrange was
15773                  * *always* formerly a pushmark */
15774                 assert(o->op_type == OP_PUSHMARK);
15775                 o->op_next = followop;
15776                 OpTYPE_set(o, OP_PADRANGE);
15777                 o->op_targ = base;
15778                 /* bit 7: INTRO; bit 6..0: count */
15779                 o->op_private = (intro | count);
15780                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15781                               | gvoid * OPf_WANT_VOID
15782                               | (defav ? OPf_SPECIAL : 0));
15783             }
15784             break;
15785         }
15786
15787         case OP_RV2AV:
15788             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15789                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15790             break;
15791
15792         case OP_RV2HV:
15793         case OP_PADHV:
15794             /*'keys %h' in void or scalar context: skip the OP_KEYS
15795              * and perform the functionality directly in the RV2HV/PADHV
15796              * op
15797              */
15798             if (o->op_flags & OPf_REF) {
15799                 OP *k = o->op_next;
15800                 U8 want = (k->op_flags & OPf_WANT);
15801                 if (   k
15802                     && k->op_type == OP_KEYS
15803                     && (   want == OPf_WANT_VOID
15804                         || want == OPf_WANT_SCALAR)
15805                     && !(k->op_private & OPpMAYBE_LVSUB)
15806                     && !(k->op_flags & OPf_MOD)
15807                 ) {
15808                     o->op_next     = k->op_next;
15809                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15810                     o->op_flags   |= want;
15811                     o->op_private |= (o->op_type == OP_PADHV ?
15812                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15813                     /* for keys(%lex), hold onto the OP_KEYS's targ
15814                      * since padhv doesn't have its own targ to return
15815                      * an int with */
15816                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15817                         op_null(k);
15818                 }
15819             }
15820
15821             /* see if %h is used in boolean context */
15822             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15823                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15824
15825
15826             if (o->op_type != OP_PADHV)
15827                 break;
15828             /* FALLTHROUGH */
15829         case OP_PADAV:
15830             if (   o->op_type == OP_PADAV
15831                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15832             )
15833                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15834             /* FALLTHROUGH */
15835         case OP_PADSV:
15836             /* Skip over state($x) in void context.  */
15837             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15838              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15839             {
15840                 oldop->op_next = o->op_next;
15841                 goto redo_nextstate;
15842             }
15843             if (o->op_type != OP_PADAV)
15844                 break;
15845             /* FALLTHROUGH */
15846         case OP_GV:
15847             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15848                 OP* const pop = (o->op_type == OP_PADAV) ?
15849                             o->op_next : o->op_next->op_next;
15850                 IV i;
15851                 if (pop && pop->op_type == OP_CONST &&
15852                     ((PL_op = pop->op_next)) &&
15853                     pop->op_next->op_type == OP_AELEM &&
15854                     !(pop->op_next->op_private &
15855                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15856                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15857                 {
15858                     GV *gv;
15859                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15860                         no_bareword_allowed(pop);
15861                     if (o->op_type == OP_GV)
15862                         op_null(o->op_next);
15863                     op_null(pop->op_next);
15864                     op_null(pop);
15865                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15866                     o->op_next = pop->op_next->op_next;
15867                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15868                     o->op_private = (U8)i;
15869                     if (o->op_type == OP_GV) {
15870                         gv = cGVOPo_gv;
15871                         GvAVn(gv);
15872                         o->op_type = OP_AELEMFAST;
15873                     }
15874                     else
15875                         o->op_type = OP_AELEMFAST_LEX;
15876                 }
15877                 if (o->op_type != OP_GV)
15878                     break;
15879             }
15880
15881             /* Remove $foo from the op_next chain in void context.  */
15882             if (oldop
15883              && (  o->op_next->op_type == OP_RV2SV
15884                 || o->op_next->op_type == OP_RV2AV
15885                 || o->op_next->op_type == OP_RV2HV  )
15886              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15887              && !(o->op_next->op_private & OPpLVAL_INTRO))
15888             {
15889                 oldop->op_next = o->op_next->op_next;
15890                 /* Reprocess the previous op if it is a nextstate, to
15891                    allow double-nextstate optimisation.  */
15892               redo_nextstate:
15893                 if (oldop->op_type == OP_NEXTSTATE) {
15894                     oldop->op_opt = 0;
15895                     o = oldop;
15896                     oldop = oldoldop;
15897                     oldoldop = NULL;
15898                     goto redo;
15899                 }
15900                 o = oldop->op_next;
15901                 goto redo;
15902             }
15903             else if (o->op_next->op_type == OP_RV2SV) {
15904                 if (!(o->op_next->op_private & OPpDEREF)) {
15905                     op_null(o->op_next);
15906                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
15907                                                                | OPpOUR_INTRO);
15908                     o->op_next = o->op_next->op_next;
15909                     OpTYPE_set(o, OP_GVSV);
15910                 }
15911             }
15912             else if (o->op_next->op_type == OP_READLINE
15913                     && o->op_next->op_next->op_type == OP_CONCAT
15914                     && (o->op_next->op_next->op_flags & OPf_STACKED))
15915             {
15916                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
15917                 OpTYPE_set(o, OP_RCATLINE);
15918                 o->op_flags |= OPf_STACKED;
15919                 op_null(o->op_next->op_next);
15920                 op_null(o->op_next);
15921             }
15922
15923             break;
15924
15925         case OP_NOT:
15926             break;
15927
15928         case OP_AND:
15929         case OP_OR:
15930         case OP_DOR:
15931             while (cLOGOP->op_other->op_type == OP_NULL)
15932                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15933             while (o->op_next && (   o->op_type == o->op_next->op_type
15934                                   || o->op_next->op_type == OP_NULL))
15935                 o->op_next = o->op_next->op_next;
15936
15937             /* If we're an OR and our next is an AND in void context, we'll
15938                follow its op_other on short circuit, same for reverse.
15939                We can't do this with OP_DOR since if it's true, its return
15940                value is the underlying value which must be evaluated
15941                by the next op. */
15942             if (o->op_next &&
15943                 (
15944                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
15945                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
15946                 )
15947                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15948             ) {
15949                 o->op_next = ((LOGOP*)o->op_next)->op_other;
15950             }
15951             DEFER(cLOGOP->op_other);
15952             o->op_opt = 1;
15953             break;
15954
15955         case OP_GREPWHILE:
15956             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15957                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15958             /* FALLTHROUGH */
15959         case OP_COND_EXPR:
15960         case OP_MAPWHILE:
15961         case OP_ANDASSIGN:
15962         case OP_ORASSIGN:
15963         case OP_DORASSIGN:
15964         case OP_RANGE:
15965         case OP_ONCE:
15966         case OP_ARGDEFELEM:
15967             while (cLOGOP->op_other->op_type == OP_NULL)
15968                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15969             DEFER(cLOGOP->op_other);
15970             break;
15971
15972         case OP_ENTERLOOP:
15973         case OP_ENTERITER:
15974             while (cLOOP->op_redoop->op_type == OP_NULL)
15975                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
15976             while (cLOOP->op_nextop->op_type == OP_NULL)
15977                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
15978             while (cLOOP->op_lastop->op_type == OP_NULL)
15979                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
15980             /* a while(1) loop doesn't have an op_next that escapes the
15981              * loop, so we have to explicitly follow the op_lastop to
15982              * process the rest of the code */
15983             DEFER(cLOOP->op_lastop);
15984             break;
15985
15986         case OP_ENTERTRY:
15987             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
15988             DEFER(cLOGOPo->op_other);
15989             break;
15990
15991         case OP_SUBST:
15992             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15993                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15994             assert(!(cPMOP->op_pmflags & PMf_ONCE));
15995             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
15996                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
15997                 cPMOP->op_pmstashstartu.op_pmreplstart
15998                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
15999             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16000             break;
16001
16002         case OP_SORT: {
16003             OP *oright;
16004
16005             if (o->op_flags & OPf_SPECIAL) {
16006                 /* first arg is a code block */
16007                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16008                 OP * kid          = cUNOPx(nullop)->op_first;
16009
16010                 assert(nullop->op_type == OP_NULL);
16011                 assert(kid->op_type == OP_SCOPE
16012                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16013                 /* since OP_SORT doesn't have a handy op_other-style
16014                  * field that can point directly to the start of the code
16015                  * block, store it in the otherwise-unused op_next field
16016                  * of the top-level OP_NULL. This will be quicker at
16017                  * run-time, and it will also allow us to remove leading
16018                  * OP_NULLs by just messing with op_nexts without
16019                  * altering the basic op_first/op_sibling layout. */
16020                 kid = kLISTOP->op_first;
16021                 assert(
16022                       (kid->op_type == OP_NULL
16023                       && (  kid->op_targ == OP_NEXTSTATE
16024                          || kid->op_targ == OP_DBSTATE  ))
16025                     || kid->op_type == OP_STUB
16026                     || kid->op_type == OP_ENTER
16027                     || (PL_parser && PL_parser->error_count));
16028                 nullop->op_next = kid->op_next;
16029                 DEFER(nullop->op_next);
16030             }
16031
16032             /* check that RHS of sort is a single plain array */
16033             oright = cUNOPo->op_first;
16034             if (!oright || oright->op_type != OP_PUSHMARK)
16035                 break;
16036
16037             if (o->op_private & OPpSORT_INPLACE)
16038                 break;
16039
16040             /* reverse sort ... can be optimised.  */
16041             if (!OpHAS_SIBLING(cUNOPo)) {
16042                 /* Nothing follows us on the list. */
16043                 OP * const reverse = o->op_next;
16044
16045                 if (reverse->op_type == OP_REVERSE &&
16046                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16047                     OP * const pushmark = cUNOPx(reverse)->op_first;
16048                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16049                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16050                         /* reverse -> pushmark -> sort */
16051                         o->op_private |= OPpSORT_REVERSE;
16052                         op_null(reverse);
16053                         pushmark->op_next = oright->op_next;
16054                         op_null(oright);
16055                     }
16056                 }
16057             }
16058
16059             break;
16060         }
16061
16062         case OP_REVERSE: {
16063             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16064             OP *gvop = NULL;
16065             LISTOP *enter, *exlist;
16066
16067             if (o->op_private & OPpSORT_INPLACE)
16068                 break;
16069
16070             enter = (LISTOP *) o->op_next;
16071             if (!enter)
16072                 break;
16073             if (enter->op_type == OP_NULL) {
16074                 enter = (LISTOP *) enter->op_next;
16075                 if (!enter)
16076                     break;
16077             }
16078             /* for $a (...) will have OP_GV then OP_RV2GV here.
16079                for (...) just has an OP_GV.  */
16080             if (enter->op_type == OP_GV) {
16081                 gvop = (OP *) enter;
16082                 enter = (LISTOP *) enter->op_next;
16083                 if (!enter)
16084                     break;
16085                 if (enter->op_type == OP_RV2GV) {
16086                   enter = (LISTOP *) enter->op_next;
16087                   if (!enter)
16088                     break;
16089                 }
16090             }
16091
16092             if (enter->op_type != OP_ENTERITER)
16093                 break;
16094
16095             iter = enter->op_next;
16096             if (!iter || iter->op_type != OP_ITER)
16097                 break;
16098
16099             expushmark = enter->op_first;
16100             if (!expushmark || expushmark->op_type != OP_NULL
16101                 || expushmark->op_targ != OP_PUSHMARK)
16102                 break;
16103
16104             exlist = (LISTOP *) OpSIBLING(expushmark);
16105             if (!exlist || exlist->op_type != OP_NULL
16106                 || exlist->op_targ != OP_LIST)
16107                 break;
16108
16109             if (exlist->op_last != o) {
16110                 /* Mmm. Was expecting to point back to this op.  */
16111                 break;
16112             }
16113             theirmark = exlist->op_first;
16114             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16115                 break;
16116
16117             if (OpSIBLING(theirmark) != o) {
16118                 /* There's something between the mark and the reverse, eg
16119                    for (1, reverse (...))
16120                    so no go.  */
16121                 break;
16122             }
16123
16124             ourmark = ((LISTOP *)o)->op_first;
16125             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16126                 break;
16127
16128             ourlast = ((LISTOP *)o)->op_last;
16129             if (!ourlast || ourlast->op_next != o)
16130                 break;
16131
16132             rv2av = OpSIBLING(ourmark);
16133             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16134                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16135                 /* We're just reversing a single array.  */
16136                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16137                 enter->op_flags |= OPf_STACKED;
16138             }
16139
16140             /* We don't have control over who points to theirmark, so sacrifice
16141                ours.  */
16142             theirmark->op_next = ourmark->op_next;
16143             theirmark->op_flags = ourmark->op_flags;
16144             ourlast->op_next = gvop ? gvop : (OP *) enter;
16145             op_null(ourmark);
16146             op_null(o);
16147             enter->op_private |= OPpITER_REVERSED;
16148             iter->op_private |= OPpITER_REVERSED;
16149
16150             oldoldop = NULL;
16151             oldop    = ourlast;
16152             o        = oldop->op_next;
16153             goto redo;
16154             NOT_REACHED; /* NOTREACHED */
16155             break;
16156         }
16157
16158         case OP_QR:
16159         case OP_MATCH:
16160             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16161                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16162             }
16163             break;
16164
16165         case OP_RUNCV:
16166             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16167              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16168             {
16169                 SV *sv;
16170                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16171                 else {
16172                     sv = newRV((SV *)PL_compcv);
16173                     sv_rvweaken(sv);
16174                     SvREADONLY_on(sv);
16175                 }
16176                 OpTYPE_set(o, OP_CONST);
16177                 o->op_flags |= OPf_SPECIAL;
16178                 cSVOPo->op_sv = sv;
16179             }
16180             break;
16181
16182         case OP_SASSIGN:
16183             if (OP_GIMME(o,0) == G_VOID
16184              || (  o->op_next->op_type == OP_LINESEQ
16185                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16186                    || (  o->op_next->op_next->op_type == OP_RETURN
16187                       && !CvLVALUE(PL_compcv)))))
16188             {
16189                 OP *right = cBINOP->op_first;
16190                 if (right) {
16191                     /*   sassign
16192                     *      RIGHT
16193                     *      substr
16194                     *         pushmark
16195                     *         arg1
16196                     *         arg2
16197                     *         ...
16198                     * becomes
16199                     *
16200                     *  ex-sassign
16201                     *     substr
16202                     *        pushmark
16203                     *        RIGHT
16204                     *        arg1
16205                     *        arg2
16206                     *        ...
16207                     */
16208                     OP *left = OpSIBLING(right);
16209                     if (left->op_type == OP_SUBSTR
16210                          && (left->op_private & 7) < 4) {
16211                         op_null(o);
16212                         /* cut out right */
16213                         op_sibling_splice(o, NULL, 1, NULL);
16214                         /* and insert it as second child of OP_SUBSTR */
16215                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16216                                     right);
16217                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16218                         left->op_flags =
16219                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16220                     }
16221                 }
16222             }
16223             break;
16224
16225         case OP_AASSIGN: {
16226             int l, r, lr, lscalars, rscalars;
16227
16228             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16229                Note that we do this now rather than in newASSIGNOP(),
16230                since only by now are aliased lexicals flagged as such
16231
16232                See the essay "Common vars in list assignment" above for
16233                the full details of the rationale behind all the conditions
16234                below.
16235
16236                PL_generation sorcery:
16237                To detect whether there are common vars, the global var
16238                PL_generation is incremented for each assign op we scan.
16239                Then we run through all the lexical variables on the LHS,
16240                of the assignment, setting a spare slot in each of them to
16241                PL_generation.  Then we scan the RHS, and if any lexicals
16242                already have that value, we know we've got commonality.
16243                Also, if the generation number is already set to
16244                PERL_INT_MAX, then the variable is involved in aliasing, so
16245                we also have potential commonality in that case.
16246              */
16247
16248             PL_generation++;
16249             /* scan LHS */
16250             lscalars = 0;
16251             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16252             /* scan RHS */
16253             rscalars = 0;
16254             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16255             lr = (l|r);
16256
16257
16258             /* After looking for things which are *always* safe, this main
16259              * if/else chain selects primarily based on the type of the
16260              * LHS, gradually working its way down from the more dangerous
16261              * to the more restrictive and thus safer cases */
16262
16263             if (   !l                      /* () = ....; */
16264                 || !r                      /* .... = (); */
16265                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16266                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16267                 || (lscalars < 2)          /* ($x, undef) = ... */
16268             ) {
16269                 NOOP; /* always safe */
16270             }
16271             else if (l & AAS_DANGEROUS) {
16272                 /* always dangerous */
16273                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16274                 o->op_private |= OPpASSIGN_COMMON_AGG;
16275             }
16276             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16277                 /* package vars are always dangerous - too many
16278                  * aliasing possibilities */
16279                 if (l & AAS_PKG_SCALAR)
16280                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16281                 if (l & AAS_PKG_AGG)
16282                     o->op_private |= OPpASSIGN_COMMON_AGG;
16283             }
16284             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16285                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16286             {
16287                 /* LHS contains only lexicals and safe ops */
16288
16289                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16290                     o->op_private |= OPpASSIGN_COMMON_AGG;
16291
16292                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16293                     if (lr & AAS_LEX_SCALAR_COMM)
16294                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16295                     else if (   !(l & AAS_LEX_SCALAR)
16296                              && (r & AAS_DEFAV))
16297                     {
16298                         /* falsely mark
16299                          *    my (...) = @_
16300                          * as scalar-safe for performance reasons.
16301                          * (it will still have been marked _AGG if necessary */
16302                         NOOP;
16303                     }
16304                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16305                         /* if there are only lexicals on the LHS and no
16306                          * common ones on the RHS, then we assume that the
16307                          * only way those lexicals could also get
16308                          * on the RHS is via some sort of dereffing or
16309                          * closure, e.g.
16310                          *    $r = \$lex;
16311                          *    ($lex, $x) = (1, $$r)
16312                          * and in this case we assume the var must have
16313                          *  a bumped ref count. So if its ref count is 1,
16314                          *  it must only be on the LHS.
16315                          */
16316                         o->op_private |= OPpASSIGN_COMMON_RC1;
16317                 }
16318             }
16319
16320             /* ... = ($x)
16321              * may have to handle aggregate on LHS, but we can't
16322              * have common scalars. */
16323             if (rscalars < 2)
16324                 o->op_private &=
16325                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16326
16327             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16328                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16329             break;
16330         }
16331
16332         case OP_REF:
16333             /* see if ref() is used in boolean context */
16334             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16335                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16336             break;
16337
16338         case OP_LENGTH:
16339             /* see if the op is used in known boolean context,
16340              * but not if OA_TARGLEX optimisation is enabled */
16341             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16342                 && !(o->op_private & OPpTARGET_MY)
16343             )
16344                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16345             break;
16346
16347         case OP_POS:
16348             /* see if the op is used in known boolean context */
16349             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16350                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16351             break;
16352
16353         case OP_CUSTOM: {
16354             Perl_cpeep_t cpeep =
16355                 XopENTRYCUSTOM(o, xop_peep);
16356             if (cpeep)
16357                 cpeep(aTHX_ o, oldop);
16358             break;
16359         }
16360
16361         }
16362         /* did we just null the current op? If so, re-process it to handle
16363          * eliding "empty" ops from the chain */
16364         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16365             o->op_opt = 0;
16366             o = oldop;
16367         }
16368         else {
16369             oldoldop = oldop;
16370             oldop = o;
16371         }
16372     }
16373     LEAVE;
16374 }
16375
16376 void
16377 Perl_peep(pTHX_ OP *o)
16378 {
16379     CALL_RPEEP(o);
16380 }
16381
16382 /*
16383 =head1 Custom Operators
16384
16385 =for apidoc Ao||custom_op_xop
16386 Return the XOP structure for a given custom op.  This macro should be
16387 considered internal to C<OP_NAME> and the other access macros: use them instead.
16388 This macro does call a function.  Prior
16389 to 5.19.6, this was implemented as a
16390 function.
16391
16392 =cut
16393 */
16394
16395 XOPRETANY
16396 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16397 {
16398     SV *keysv;
16399     HE *he = NULL;
16400     XOP *xop;
16401
16402     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16403
16404     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16405     assert(o->op_type == OP_CUSTOM);
16406
16407     /* This is wrong. It assumes a function pointer can be cast to IV,
16408      * which isn't guaranteed, but this is what the old custom OP code
16409      * did. In principle it should be safer to Copy the bytes of the
16410      * pointer into a PV: since the new interface is hidden behind
16411      * functions, this can be changed later if necessary.  */
16412     /* Change custom_op_xop if this ever happens */
16413     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16414
16415     if (PL_custom_ops)
16416         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16417
16418     /* assume noone will have just registered a desc */
16419     if (!he && PL_custom_op_names &&
16420         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16421     ) {
16422         const char *pv;
16423         STRLEN l;
16424
16425         /* XXX does all this need to be shared mem? */
16426         Newxz(xop, 1, XOP);
16427         pv = SvPV(HeVAL(he), l);
16428         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16429         if (PL_custom_op_descs &&
16430             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16431         ) {
16432             pv = SvPV(HeVAL(he), l);
16433             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16434         }
16435         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16436     }
16437     else {
16438         if (!he)
16439             xop = (XOP *)&xop_null;
16440         else
16441             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16442     }
16443     {
16444         XOPRETANY any;
16445         if(field == XOPe_xop_ptr) {
16446             any.xop_ptr = xop;
16447         } else {
16448             const U32 flags = XopFLAGS(xop);
16449             if(flags & field) {
16450                 switch(field) {
16451                 case XOPe_xop_name:
16452                     any.xop_name = xop->xop_name;
16453                     break;
16454                 case XOPe_xop_desc:
16455                     any.xop_desc = xop->xop_desc;
16456                     break;
16457                 case XOPe_xop_class:
16458                     any.xop_class = xop->xop_class;
16459                     break;
16460                 case XOPe_xop_peep:
16461                     any.xop_peep = xop->xop_peep;
16462                     break;
16463                 default:
16464                     NOT_REACHED; /* NOTREACHED */
16465                     break;
16466                 }
16467             } else {
16468                 switch(field) {
16469                 case XOPe_xop_name:
16470                     any.xop_name = XOPd_xop_name;
16471                     break;
16472                 case XOPe_xop_desc:
16473                     any.xop_desc = XOPd_xop_desc;
16474                     break;
16475                 case XOPe_xop_class:
16476                     any.xop_class = XOPd_xop_class;
16477                     break;
16478                 case XOPe_xop_peep:
16479                     any.xop_peep = XOPd_xop_peep;
16480                     break;
16481                 default:
16482                     NOT_REACHED; /* NOTREACHED */
16483                     break;
16484                 }
16485             }
16486         }
16487         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16488          * op.c: In function 'Perl_custom_op_get_field':
16489          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16490          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16491          * expands to assert(0), which expands to ((0) ? (void)0 :
16492          * __assert(...)), and gcc doesn't know that __assert can never return. */
16493         return any;
16494     }
16495 }
16496
16497 /*
16498 =for apidoc Ao||custom_op_register
16499 Register a custom op.  See L<perlguts/"Custom Operators">.
16500
16501 =cut
16502 */
16503
16504 void
16505 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16506 {
16507     SV *keysv;
16508
16509     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16510
16511     /* see the comment in custom_op_xop */
16512     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16513
16514     if (!PL_custom_ops)
16515         PL_custom_ops = newHV();
16516
16517     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16518         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16519 }
16520
16521 /*
16522
16523 =for apidoc core_prototype
16524
16525 This function assigns the prototype of the named core function to C<sv>, or
16526 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16527 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16528 by C<keyword()>.  It must not be equal to 0.
16529
16530 =cut
16531 */
16532
16533 SV *
16534 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16535                           int * const opnum)
16536 {
16537     int i = 0, n = 0, seen_question = 0, defgv = 0;
16538     I32 oa;
16539 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16540     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16541     bool nullret = FALSE;
16542
16543     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16544
16545     assert (code);
16546
16547     if (!sv) sv = sv_newmortal();
16548
16549 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16550
16551     switch (code < 0 ? -code : code) {
16552     case KEY_and   : case KEY_chop: case KEY_chomp:
16553     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16554     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16555     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16556     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16557     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16558     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16559     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16560     case KEY_x     : case KEY_xor    :
16561         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16562     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16563     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16564     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16565     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16566     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16567     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16568         retsetpvs("", 0);
16569     case KEY_evalbytes:
16570         name = "entereval"; break;
16571     case KEY_readpipe:
16572         name = "backtick";
16573     }
16574
16575 #undef retsetpvs
16576
16577   findopnum:
16578     while (i < MAXO) {  /* The slow way. */
16579         if (strEQ(name, PL_op_name[i])
16580             || strEQ(name, PL_op_desc[i]))
16581         {
16582             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16583             goto found;
16584         }
16585         i++;
16586     }
16587     return NULL;
16588   found:
16589     defgv = PL_opargs[i] & OA_DEFGV;
16590     oa = PL_opargs[i] >> OASHIFT;
16591     while (oa) {
16592         if (oa & OA_OPTIONAL && !seen_question && (
16593               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16594         )) {
16595             seen_question = 1;
16596             str[n++] = ';';
16597         }
16598         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16599             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16600             /* But globs are already references (kinda) */
16601             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16602         ) {
16603             str[n++] = '\\';
16604         }
16605         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16606          && !scalar_mod_type(NULL, i)) {
16607             str[n++] = '[';
16608             str[n++] = '$';
16609             str[n++] = '@';
16610             str[n++] = '%';
16611             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16612             str[n++] = '*';
16613             str[n++] = ']';
16614         }
16615         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16616         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16617             str[n-1] = '_'; defgv = 0;
16618         }
16619         oa = oa >> 4;
16620     }
16621     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16622     str[n++] = '\0';
16623     sv_setpvn(sv, str, n - 1);
16624     if (opnum) *opnum = i;
16625     return sv;
16626 }
16627
16628 OP *
16629 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16630                       const int opnum)
16631 {
16632     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16633     OP *o;
16634
16635     PERL_ARGS_ASSERT_CORESUB_OP;
16636
16637     switch(opnum) {
16638     case 0:
16639         return op_append_elem(OP_LINESEQ,
16640                        argop,
16641                        newSLICEOP(0,
16642                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16643                                   newOP(OP_CALLER,0)
16644                        )
16645                );
16646     case OP_EACH:
16647     case OP_KEYS:
16648     case OP_VALUES:
16649         o = newUNOP(OP_AVHVSWITCH,0,argop);
16650         o->op_private = opnum-OP_EACH;
16651         return o;
16652     case OP_SELECT: /* which represents OP_SSELECT as well */
16653         if (code)
16654             return newCONDOP(
16655                          0,
16656                          newBINOP(OP_GT, 0,
16657                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16658                                   newSVOP(OP_CONST, 0, newSVuv(1))
16659                                  ),
16660                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16661                                     OP_SSELECT),
16662                          coresub_op(coreargssv, 0, OP_SELECT)
16663                    );
16664         /* FALLTHROUGH */
16665     default:
16666         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16667         case OA_BASEOP:
16668             return op_append_elem(
16669                         OP_LINESEQ, argop,
16670                         newOP(opnum,
16671                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16672                                 ? OPpOFFBYONE << 8 : 0)
16673                    );
16674         case OA_BASEOP_OR_UNOP:
16675             if (opnum == OP_ENTEREVAL) {
16676                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16677                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16678             }
16679             else o = newUNOP(opnum,0,argop);
16680             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16681             else {
16682           onearg:
16683               if (is_handle_constructor(o, 1))
16684                 argop->op_private |= OPpCOREARGS_DEREF1;
16685               if (scalar_mod_type(NULL, opnum))
16686                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16687             }
16688             return o;
16689         default:
16690             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16691             if (is_handle_constructor(o, 2))
16692                 argop->op_private |= OPpCOREARGS_DEREF2;
16693             if (opnum == OP_SUBSTR) {
16694                 o->op_private |= OPpMAYBE_LVSUB;
16695                 return o;
16696             }
16697             else goto onearg;
16698         }
16699     }
16700 }
16701
16702 void
16703 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16704                                SV * const *new_const_svp)
16705 {
16706     const char *hvname;
16707     bool is_const = !!CvCONST(old_cv);
16708     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16709
16710     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16711
16712     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16713         return;
16714         /* They are 2 constant subroutines generated from
16715            the same constant. This probably means that
16716            they are really the "same" proxy subroutine
16717            instantiated in 2 places. Most likely this is
16718            when a constant is exported twice.  Don't warn.
16719         */
16720     if (
16721         (ckWARN(WARN_REDEFINE)
16722          && !(
16723                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16724              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16725              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16726                  strEQ(hvname, "autouse"))
16727              )
16728         )
16729      || (is_const
16730          && ckWARN_d(WARN_REDEFINE)
16731          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16732         )
16733     )
16734         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16735                           is_const
16736                             ? "Constant subroutine %" SVf " redefined"
16737                             : "Subroutine %" SVf " redefined",
16738                           SVfARG(name));
16739 }
16740
16741 /*
16742 =head1 Hook manipulation
16743
16744 These functions provide convenient and thread-safe means of manipulating
16745 hook variables.
16746
16747 =cut
16748 */
16749
16750 /*
16751 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16752
16753 Puts a C function into the chain of check functions for a specified op
16754 type.  This is the preferred way to manipulate the L</PL_check> array.
16755 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16756 is a pointer to the C function that is to be added to that opcode's
16757 check chain, and C<old_checker_p> points to the storage location where a
16758 pointer to the next function in the chain will be stored.  The value of
16759 C<new_checker> is written into the L</PL_check> array, while the value
16760 previously stored there is written to C<*old_checker_p>.
16761
16762 L</PL_check> is global to an entire process, and a module wishing to
16763 hook op checking may find itself invoked more than once per process,
16764 typically in different threads.  To handle that situation, this function
16765 is idempotent.  The location C<*old_checker_p> must initially (once
16766 per process) contain a null pointer.  A C variable of static duration
16767 (declared at file scope, typically also marked C<static> to give
16768 it internal linkage) will be implicitly initialised appropriately,
16769 if it does not have an explicit initialiser.  This function will only
16770 actually modify the check chain if it finds C<*old_checker_p> to be null.
16771 This function is also thread safe on the small scale.  It uses appropriate
16772 locking to avoid race conditions in accessing L</PL_check>.
16773
16774 When this function is called, the function referenced by C<new_checker>
16775 must be ready to be called, except for C<*old_checker_p> being unfilled.
16776 In a threading situation, C<new_checker> may be called immediately,
16777 even before this function has returned.  C<*old_checker_p> will always
16778 be appropriately set before C<new_checker> is called.  If C<new_checker>
16779 decides not to do anything special with an op that it is given (which
16780 is the usual case for most uses of op check hooking), it must chain the
16781 check function referenced by C<*old_checker_p>.
16782
16783 Taken all together, XS code to hook an op checker should typically look
16784 something like this:
16785
16786     static Perl_check_t nxck_frob;
16787     static OP *myck_frob(pTHX_ OP *op) {
16788         ...
16789         op = nxck_frob(aTHX_ op);
16790         ...
16791         return op;
16792     }
16793     BOOT:
16794         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16795
16796 If you want to influence compilation of calls to a specific subroutine,
16797 then use L</cv_set_call_checker_flags> rather than hooking checking of
16798 all C<entersub> ops.
16799
16800 =cut
16801 */
16802
16803 void
16804 Perl_wrap_op_checker(pTHX_ Optype opcode,
16805     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16806 {
16807     dVAR;
16808
16809     PERL_UNUSED_CONTEXT;
16810     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16811     if (*old_checker_p) return;
16812     OP_CHECK_MUTEX_LOCK;
16813     if (!*old_checker_p) {
16814         *old_checker_p = PL_check[opcode];
16815         PL_check[opcode] = new_checker;
16816     }
16817     OP_CHECK_MUTEX_UNLOCK;
16818 }
16819
16820 #include "XSUB.h"
16821
16822 /* Efficient sub that returns a constant scalar value. */
16823 static void
16824 const_sv_xsub(pTHX_ CV* cv)
16825 {
16826     dXSARGS;
16827     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16828     PERL_UNUSED_ARG(items);
16829     if (!sv) {
16830         XSRETURN(0);
16831     }
16832     EXTEND(sp, 1);
16833     ST(0) = sv;
16834     XSRETURN(1);
16835 }
16836
16837 static void
16838 const_av_xsub(pTHX_ CV* cv)
16839 {
16840     dXSARGS;
16841     AV * const av = MUTABLE_AV(XSANY.any_ptr);
16842     SP -= items;
16843     assert(av);
16844 #ifndef DEBUGGING
16845     if (!av) {
16846         XSRETURN(0);
16847     }
16848 #endif
16849     if (SvRMAGICAL(av))
16850         Perl_croak(aTHX_ "Magical list constants are not supported");
16851     if (GIMME_V != G_ARRAY) {
16852         EXTEND(SP, 1);
16853         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16854         XSRETURN(1);
16855     }
16856     EXTEND(SP, AvFILLp(av)+1);
16857     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16858     XSRETURN(AvFILLp(av)+1);
16859 }
16860
16861
16862 /*
16863  * ex: set ts=8 sts=4 sw=4 et:
16864  */