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     if (first)
1549         logop->op_flags = OPf_KIDS;
1550     while (kid && OpHAS_SIBLING(kid))
1551         kid = OpSIBLING(kid);
1552     if (kid)
1553         OpLASTSIB_set(kid, (OP*)logop);
1554     return logop;
1555 }
1556
1557
1558 /* Contextualizers */
1559
1560 /*
1561 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1562
1563 Applies a syntactic context to an op tree representing an expression.
1564 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1565 or C<G_VOID> to specify the context to apply.  The modified op tree
1566 is returned.
1567
1568 =cut
1569 */
1570
1571 OP *
1572 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1573 {
1574     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1575     switch (context) {
1576         case G_SCALAR: return scalar(o);
1577         case G_ARRAY:  return list(o);
1578         case G_VOID:   return scalarvoid(o);
1579         default:
1580             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1581                        (long) context);
1582     }
1583 }
1584
1585 /*
1586
1587 =for apidoc Am|OP*|op_linklist|OP *o
1588 This function is the implementation of the L</LINKLIST> macro.  It should
1589 not be called directly.
1590
1591 =cut
1592 */
1593
1594 OP *
1595 Perl_op_linklist(pTHX_ OP *o)
1596 {
1597     OP *first;
1598
1599     PERL_ARGS_ASSERT_OP_LINKLIST;
1600
1601     if (o->op_next)
1602         return o->op_next;
1603
1604     /* establish postfix order */
1605     first = cUNOPo->op_first;
1606     if (first) {
1607         OP *kid;
1608         o->op_next = LINKLIST(first);
1609         kid = first;
1610         for (;;) {
1611             OP *sibl = OpSIBLING(kid);
1612             if (sibl) {
1613                 kid->op_next = LINKLIST(sibl);
1614                 kid = sibl;
1615             } else {
1616                 kid->op_next = o;
1617                 break;
1618             }
1619         }
1620     }
1621     else
1622         o->op_next = o;
1623
1624     return o->op_next;
1625 }
1626
1627 static OP *
1628 S_scalarkids(pTHX_ OP *o)
1629 {
1630     if (o && o->op_flags & OPf_KIDS) {
1631         OP *kid;
1632         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1633             scalar(kid);
1634     }
1635     return o;
1636 }
1637
1638 STATIC OP *
1639 S_scalarboolean(pTHX_ OP *o)
1640 {
1641     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1642
1643     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1644          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1645         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1646          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1647          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1648         if (ckWARN(WARN_SYNTAX)) {
1649             const line_t oldline = CopLINE(PL_curcop);
1650
1651             if (PL_parser && PL_parser->copline != NOLINE) {
1652                 /* This ensures that warnings are reported at the first line
1653                    of the conditional, not the last.  */
1654                 CopLINE_set(PL_curcop, PL_parser->copline);
1655             }
1656             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1657             CopLINE_set(PL_curcop, oldline);
1658         }
1659     }
1660     return scalar(o);
1661 }
1662
1663 static SV *
1664 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1665 {
1666     assert(o);
1667     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1668            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1669     {
1670         const char funny  = o->op_type == OP_PADAV
1671                          || o->op_type == OP_RV2AV ? '@' : '%';
1672         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1673             GV *gv;
1674             if (cUNOPo->op_first->op_type != OP_GV
1675              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1676                 return NULL;
1677             return varname(gv, funny, 0, NULL, 0, subscript_type);
1678         }
1679         return
1680             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1681     }
1682 }
1683
1684 static SV *
1685 S_op_varname(pTHX_ const OP *o)
1686 {
1687     return S_op_varname_subscript(aTHX_ o, 1);
1688 }
1689
1690 static void
1691 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1692 { /* or not so pretty :-) */
1693     if (o->op_type == OP_CONST) {
1694         *retsv = cSVOPo_sv;
1695         if (SvPOK(*retsv)) {
1696             SV *sv = *retsv;
1697             *retsv = sv_newmortal();
1698             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1699                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1700         }
1701         else if (!SvOK(*retsv))
1702             *retpv = "undef";
1703     }
1704     else *retpv = "...";
1705 }
1706
1707 static void
1708 S_scalar_slice_warning(pTHX_ const OP *o)
1709 {
1710     OP *kid;
1711     const bool h = o->op_type == OP_HSLICE
1712                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1713     const char lbrack =
1714         h ? '{' : '[';
1715     const char rbrack =
1716         h ? '}' : ']';
1717     SV *name;
1718     SV *keysv = NULL; /* just to silence compiler warnings */
1719     const char *key = NULL;
1720
1721     if (!(o->op_private & OPpSLICEWARNING))
1722         return;
1723     if (PL_parser && PL_parser->error_count)
1724         /* This warning can be nonsensical when there is a syntax error. */
1725         return;
1726
1727     kid = cLISTOPo->op_first;
1728     kid = OpSIBLING(kid); /* get past pushmark */
1729     /* weed out false positives: any ops that can return lists */
1730     switch (kid->op_type) {
1731     case OP_BACKTICK:
1732     case OP_GLOB:
1733     case OP_READLINE:
1734     case OP_MATCH:
1735     case OP_RV2AV:
1736     case OP_EACH:
1737     case OP_VALUES:
1738     case OP_KEYS:
1739     case OP_SPLIT:
1740     case OP_LIST:
1741     case OP_SORT:
1742     case OP_REVERSE:
1743     case OP_ENTERSUB:
1744     case OP_CALLER:
1745     case OP_LSTAT:
1746     case OP_STAT:
1747     case OP_READDIR:
1748     case OP_SYSTEM:
1749     case OP_TMS:
1750     case OP_LOCALTIME:
1751     case OP_GMTIME:
1752     case OP_ENTEREVAL:
1753         return;
1754     }
1755
1756     /* Don't warn if we have a nulled list either. */
1757     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1758         return;
1759
1760     assert(OpSIBLING(kid));
1761     name = S_op_varname(aTHX_ OpSIBLING(kid));
1762     if (!name) /* XS module fiddling with the op tree */
1763         return;
1764     S_op_pretty(aTHX_ kid, &keysv, &key);
1765     assert(SvPOK(name));
1766     sv_chop(name,SvPVX(name)+1);
1767     if (key)
1768        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1769         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1771                    "%c%s%c",
1772                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1773                     lbrack, key, rbrack);
1774     else
1775        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1776         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1777                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1778                     SVf "%c%" SVf "%c",
1779                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1780                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1781 }
1782
1783 OP *
1784 Perl_scalar(pTHX_ OP *o)
1785 {
1786     OP *kid;
1787
1788     /* assumes no premature commitment */
1789     if (!o || (PL_parser && PL_parser->error_count)
1790          || (o->op_flags & OPf_WANT)
1791          || o->op_type == OP_RETURN)
1792     {
1793         return o;
1794     }
1795
1796     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1797
1798     switch (o->op_type) {
1799     case OP_REPEAT:
1800         scalar(cBINOPo->op_first);
1801         if (o->op_private & OPpREPEAT_DOLIST) {
1802             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1803             assert(kid->op_type == OP_PUSHMARK);
1804             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1805                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1806                 o->op_private &=~ OPpREPEAT_DOLIST;
1807             }
1808         }
1809         break;
1810     case OP_OR:
1811     case OP_AND:
1812     case OP_COND_EXPR:
1813         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1814             scalar(kid);
1815         break;
1816         /* FALLTHROUGH */
1817     case OP_SPLIT:
1818     case OP_MATCH:
1819     case OP_QR:
1820     case OP_SUBST:
1821     case OP_NULL:
1822     default:
1823         if (o->op_flags & OPf_KIDS) {
1824             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1825                 scalar(kid);
1826         }
1827         break;
1828     case OP_LEAVE:
1829     case OP_LEAVETRY:
1830         kid = cLISTOPo->op_first;
1831         scalar(kid);
1832         kid = OpSIBLING(kid);
1833     do_kids:
1834         while (kid) {
1835             OP *sib = OpSIBLING(kid);
1836             if (sib && kid->op_type != OP_LEAVEWHEN
1837              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1838                 || (  sib->op_targ != OP_NEXTSTATE
1839                    && sib->op_targ != OP_DBSTATE  )))
1840                 scalarvoid(kid);
1841             else
1842                 scalar(kid);
1843             kid = sib;
1844         }
1845         PL_curcop = &PL_compiling;
1846         break;
1847     case OP_SCOPE:
1848     case OP_LINESEQ:
1849     case OP_LIST:
1850         kid = cLISTOPo->op_first;
1851         goto do_kids;
1852     case OP_SORT:
1853         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1854         break;
1855     case OP_KVHSLICE:
1856     case OP_KVASLICE:
1857     {
1858         /* Warn about scalar context */
1859         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1860         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1861         SV *name;
1862         SV *keysv;
1863         const char *key = NULL;
1864
1865         /* This warning can be nonsensical when there is a syntax error. */
1866         if (PL_parser && PL_parser->error_count)
1867             break;
1868
1869         if (!ckWARN(WARN_SYNTAX)) break;
1870
1871         kid = cLISTOPo->op_first;
1872         kid = OpSIBLING(kid); /* get past pushmark */
1873         assert(OpSIBLING(kid));
1874         name = S_op_varname(aTHX_ OpSIBLING(kid));
1875         if (!name) /* XS module fiddling with the op tree */
1876             break;
1877         S_op_pretty(aTHX_ kid, &keysv, &key);
1878         assert(SvPOK(name));
1879         sv_chop(name,SvPVX(name)+1);
1880         if (key)
1881   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1882             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1883                        "%%%" SVf "%c%s%c in scalar context better written "
1884                        "as $%" SVf "%c%s%c",
1885                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1886                         lbrack, key, rbrack);
1887         else
1888   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1889             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1890                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1891                        "written as $%" SVf "%c%" SVf "%c",
1892                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1893                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1894     }
1895     }
1896     return o;
1897 }
1898
1899 OP *
1900 Perl_scalarvoid(pTHX_ OP *arg)
1901 {
1902     dVAR;
1903     OP *kid;
1904     SV* sv;
1905     SSize_t defer_stack_alloc = 0;
1906     SSize_t defer_ix = -1;
1907     OP **defer_stack = NULL;
1908     OP *o = arg;
1909
1910     PERL_ARGS_ASSERT_SCALARVOID;
1911
1912     do {
1913         U8 want;
1914         SV *useless_sv = NULL;
1915         const char* useless = NULL;
1916
1917         if (o->op_type == OP_NEXTSTATE
1918             || o->op_type == OP_DBSTATE
1919             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1920                                           || o->op_targ == OP_DBSTATE)))
1921             PL_curcop = (COP*)o;                /* for warning below */
1922
1923         /* assumes no premature commitment */
1924         want = o->op_flags & OPf_WANT;
1925         if ((want && want != OPf_WANT_SCALAR)
1926             || (PL_parser && PL_parser->error_count)
1927             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1928         {
1929             continue;
1930         }
1931
1932         if ((o->op_private & OPpTARGET_MY)
1933             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1934         {
1935             /* newASSIGNOP has already applied scalar context, which we
1936                leave, as if this op is inside SASSIGN.  */
1937             continue;
1938         }
1939
1940         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1941
1942         switch (o->op_type) {
1943         default:
1944             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1945                 break;
1946             /* FALLTHROUGH */
1947         case OP_REPEAT:
1948             if (o->op_flags & OPf_STACKED)
1949                 break;
1950             if (o->op_type == OP_REPEAT)
1951                 scalar(cBINOPo->op_first);
1952             goto func_ops;
1953         case OP_CONCAT:
1954             if ((o->op_flags & OPf_STACKED) &&
1955                     !(o->op_private & OPpCONCAT_NESTED))
1956                 break;
1957             goto func_ops;
1958         case OP_SUBSTR:
1959             if (o->op_private == 4)
1960                 break;
1961             /* FALLTHROUGH */
1962         case OP_WANTARRAY:
1963         case OP_GV:
1964         case OP_SMARTMATCH:
1965         case OP_AV2ARYLEN:
1966         case OP_REF:
1967         case OP_REFGEN:
1968         case OP_SREFGEN:
1969         case OP_DEFINED:
1970         case OP_HEX:
1971         case OP_OCT:
1972         case OP_LENGTH:
1973         case OP_VEC:
1974         case OP_INDEX:
1975         case OP_RINDEX:
1976         case OP_SPRINTF:
1977         case OP_KVASLICE:
1978         case OP_KVHSLICE:
1979         case OP_UNPACK:
1980         case OP_PACK:
1981         case OP_JOIN:
1982         case OP_LSLICE:
1983         case OP_ANONLIST:
1984         case OP_ANONHASH:
1985         case OP_SORT:
1986         case OP_REVERSE:
1987         case OP_RANGE:
1988         case OP_FLIP:
1989         case OP_FLOP:
1990         case OP_CALLER:
1991         case OP_FILENO:
1992         case OP_EOF:
1993         case OP_TELL:
1994         case OP_GETSOCKNAME:
1995         case OP_GETPEERNAME:
1996         case OP_READLINK:
1997         case OP_TELLDIR:
1998         case OP_GETPPID:
1999         case OP_GETPGRP:
2000         case OP_GETPRIORITY:
2001         case OP_TIME:
2002         case OP_TMS:
2003         case OP_LOCALTIME:
2004         case OP_GMTIME:
2005         case OP_GHBYNAME:
2006         case OP_GHBYADDR:
2007         case OP_GHOSTENT:
2008         case OP_GNBYNAME:
2009         case OP_GNBYADDR:
2010         case OP_GNETENT:
2011         case OP_GPBYNAME:
2012         case OP_GPBYNUMBER:
2013         case OP_GPROTOENT:
2014         case OP_GSBYNAME:
2015         case OP_GSBYPORT:
2016         case OP_GSERVENT:
2017         case OP_GPWNAM:
2018         case OP_GPWUID:
2019         case OP_GGRNAM:
2020         case OP_GGRGID:
2021         case OP_GETLOGIN:
2022         case OP_PROTOTYPE:
2023         case OP_RUNCV:
2024         func_ops:
2025             useless = OP_DESC(o);
2026             break;
2027
2028         case OP_GVSV:
2029         case OP_PADSV:
2030         case OP_PADAV:
2031         case OP_PADHV:
2032         case OP_PADANY:
2033         case OP_AELEM:
2034         case OP_AELEMFAST:
2035         case OP_AELEMFAST_LEX:
2036         case OP_ASLICE:
2037         case OP_HELEM:
2038         case OP_HSLICE:
2039             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2040                 /* Otherwise it's "Useless use of grep iterator" */
2041                 useless = OP_DESC(o);
2042             break;
2043
2044         case OP_SPLIT:
2045             if (!(o->op_private & OPpSPLIT_ASSIGN))
2046                 useless = OP_DESC(o);
2047             break;
2048
2049         case OP_NOT:
2050             kid = cUNOPo->op_first;
2051             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2052                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2053                 goto func_ops;
2054             }
2055             useless = "negative pattern binding (!~)";
2056             break;
2057
2058         case OP_SUBST:
2059             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2060                 useless = "non-destructive substitution (s///r)";
2061             break;
2062
2063         case OP_TRANSR:
2064             useless = "non-destructive transliteration (tr///r)";
2065             break;
2066
2067         case OP_RV2GV:
2068         case OP_RV2SV:
2069         case OP_RV2AV:
2070         case OP_RV2HV:
2071             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2072                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2073                 useless = "a variable";
2074             break;
2075
2076         case OP_CONST:
2077             sv = cSVOPo_sv;
2078             if (cSVOPo->op_private & OPpCONST_STRICT)
2079                 no_bareword_allowed(o);
2080             else {
2081                 if (ckWARN(WARN_VOID)) {
2082                     NV nv;
2083                     /* don't warn on optimised away booleans, eg
2084                      * use constant Foo, 5; Foo || print; */
2085                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2086                         useless = NULL;
2087                     /* the constants 0 and 1 are permitted as they are
2088                        conventionally used as dummies in constructs like
2089                        1 while some_condition_with_side_effects;  */
2090                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2091                         useless = NULL;
2092                     else if (SvPOK(sv)) {
2093                         SV * const dsv = newSVpvs("");
2094                         useless_sv
2095                             = Perl_newSVpvf(aTHX_
2096                                             "a constant (%s)",
2097                                             pv_pretty(dsv, SvPVX_const(sv),
2098                                                       SvCUR(sv), 32, NULL, NULL,
2099                                                       PERL_PV_PRETTY_DUMP
2100                                                       | PERL_PV_ESCAPE_NOCLEAR
2101                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2102                         SvREFCNT_dec_NN(dsv);
2103                     }
2104                     else if (SvOK(sv)) {
2105                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2106                     }
2107                     else
2108                         useless = "a constant (undef)";
2109                 }
2110             }
2111             op_null(o);         /* don't execute or even remember it */
2112             break;
2113
2114         case OP_POSTINC:
2115             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2116             break;
2117
2118         case OP_POSTDEC:
2119             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2120             break;
2121
2122         case OP_I_POSTINC:
2123             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2124             break;
2125
2126         case OP_I_POSTDEC:
2127             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2128             break;
2129
2130         case OP_SASSIGN: {
2131             OP *rv2gv;
2132             UNOP *refgen, *rv2cv;
2133             LISTOP *exlist;
2134
2135             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2136                 break;
2137
2138             rv2gv = ((BINOP *)o)->op_last;
2139             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2140                 break;
2141
2142             refgen = (UNOP *)((BINOP *)o)->op_first;
2143
2144             if (!refgen || (refgen->op_type != OP_REFGEN
2145                             && refgen->op_type != OP_SREFGEN))
2146                 break;
2147
2148             exlist = (LISTOP *)refgen->op_first;
2149             if (!exlist || exlist->op_type != OP_NULL
2150                 || exlist->op_targ != OP_LIST)
2151                 break;
2152
2153             if (exlist->op_first->op_type != OP_PUSHMARK
2154                 && exlist->op_first != exlist->op_last)
2155                 break;
2156
2157             rv2cv = (UNOP*)exlist->op_last;
2158
2159             if (rv2cv->op_type != OP_RV2CV)
2160                 break;
2161
2162             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2163             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2164             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2165
2166             o->op_private |= OPpASSIGN_CV_TO_GV;
2167             rv2gv->op_private |= OPpDONT_INIT_GV;
2168             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2169
2170             break;
2171         }
2172
2173         case OP_AASSIGN: {
2174             inplace_aassign(o);
2175             break;
2176         }
2177
2178         case OP_OR:
2179         case OP_AND:
2180             kid = cLOGOPo->op_first;
2181             if (kid->op_type == OP_NOT
2182                 && (kid->op_flags & OPf_KIDS)) {
2183                 if (o->op_type == OP_AND) {
2184                     OpTYPE_set(o, OP_OR);
2185                 } else {
2186                     OpTYPE_set(o, OP_AND);
2187                 }
2188                 op_null(kid);
2189             }
2190             /* FALLTHROUGH */
2191
2192         case OP_DOR:
2193         case OP_COND_EXPR:
2194         case OP_ENTERGIVEN:
2195         case OP_ENTERWHEN:
2196             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2197                 if (!(kid->op_flags & OPf_KIDS))
2198                     scalarvoid(kid);
2199                 else
2200                     DEFER_OP(kid);
2201         break;
2202
2203         case OP_NULL:
2204             if (o->op_flags & OPf_STACKED)
2205                 break;
2206             /* FALLTHROUGH */
2207         case OP_NEXTSTATE:
2208         case OP_DBSTATE:
2209         case OP_ENTERTRY:
2210         case OP_ENTER:
2211             if (!(o->op_flags & OPf_KIDS))
2212                 break;
2213             /* FALLTHROUGH */
2214         case OP_SCOPE:
2215         case OP_LEAVE:
2216         case OP_LEAVETRY:
2217         case OP_LEAVELOOP:
2218         case OP_LINESEQ:
2219         case OP_LEAVEGIVEN:
2220         case OP_LEAVEWHEN:
2221         kids:
2222             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2223                 if (!(kid->op_flags & OPf_KIDS))
2224                     scalarvoid(kid);
2225                 else
2226                     DEFER_OP(kid);
2227             break;
2228         case OP_LIST:
2229             /* If the first kid after pushmark is something that the padrange
2230                optimisation would reject, then null the list and the pushmark.
2231             */
2232             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2233                 && (  !(kid = OpSIBLING(kid))
2234                       || (  kid->op_type != OP_PADSV
2235                             && kid->op_type != OP_PADAV
2236                             && kid->op_type != OP_PADHV)
2237                       || kid->op_private & ~OPpLVAL_INTRO
2238                       || !(kid = OpSIBLING(kid))
2239                       || (  kid->op_type != OP_PADSV
2240                             && kid->op_type != OP_PADAV
2241                             && kid->op_type != OP_PADHV)
2242                       || kid->op_private & ~OPpLVAL_INTRO)
2243             ) {
2244                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2245                 op_null(o); /* NULL the list */
2246             }
2247             goto kids;
2248         case OP_ENTEREVAL:
2249             scalarkids(o);
2250             break;
2251         case OP_SCALAR:
2252             scalar(o);
2253             break;
2254         }
2255
2256         if (useless_sv) {
2257             /* mortalise it, in case warnings are fatal.  */
2258             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2259                            "Useless use of %" SVf " in void context",
2260                            SVfARG(sv_2mortal(useless_sv)));
2261         }
2262         else if (useless) {
2263             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2264                            "Useless use of %s in void context",
2265                            useless);
2266         }
2267     } while ( (o = POP_DEFERRED_OP()) );
2268
2269     Safefree(defer_stack);
2270
2271     return arg;
2272 }
2273
2274 static OP *
2275 S_listkids(pTHX_ OP *o)
2276 {
2277     if (o && o->op_flags & OPf_KIDS) {
2278         OP *kid;
2279         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2280             list(kid);
2281     }
2282     return o;
2283 }
2284
2285 OP *
2286 Perl_list(pTHX_ OP *o)
2287 {
2288     OP *kid;
2289
2290     /* assumes no premature commitment */
2291     if (!o || (o->op_flags & OPf_WANT)
2292          || (PL_parser && PL_parser->error_count)
2293          || o->op_type == OP_RETURN)
2294     {
2295         return o;
2296     }
2297
2298     if ((o->op_private & OPpTARGET_MY)
2299         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2300     {
2301         return o;                               /* As if inside SASSIGN */
2302     }
2303
2304     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2305
2306     switch (o->op_type) {
2307     case OP_FLOP:
2308         list(cBINOPo->op_first);
2309         break;
2310     case OP_REPEAT:
2311         if (o->op_private & OPpREPEAT_DOLIST
2312          && !(o->op_flags & OPf_STACKED))
2313         {
2314             list(cBINOPo->op_first);
2315             kid = cBINOPo->op_last;
2316             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2317              && SvIVX(kSVOP_sv) == 1)
2318             {
2319                 op_null(o); /* repeat */
2320                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2321                 /* const (rhs): */
2322                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2323             }
2324         }
2325         break;
2326     case OP_OR:
2327     case OP_AND:
2328     case OP_COND_EXPR:
2329         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2330             list(kid);
2331         break;
2332     default:
2333     case OP_MATCH:
2334     case OP_QR:
2335     case OP_SUBST:
2336     case OP_NULL:
2337         if (!(o->op_flags & OPf_KIDS))
2338             break;
2339         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2340             list(cBINOPo->op_first);
2341             return gen_constant_list(o);
2342         }
2343         listkids(o);
2344         break;
2345     case OP_LIST:
2346         listkids(o);
2347         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2348             op_null(cUNOPo->op_first); /* NULL the pushmark */
2349             op_null(o); /* NULL the list */
2350         }
2351         break;
2352     case OP_LEAVE:
2353     case OP_LEAVETRY:
2354         kid = cLISTOPo->op_first;
2355         list(kid);
2356         kid = OpSIBLING(kid);
2357     do_kids:
2358         while (kid) {
2359             OP *sib = OpSIBLING(kid);
2360             if (sib && kid->op_type != OP_LEAVEWHEN)
2361                 scalarvoid(kid);
2362             else
2363                 list(kid);
2364             kid = sib;
2365         }
2366         PL_curcop = &PL_compiling;
2367         break;
2368     case OP_SCOPE:
2369     case OP_LINESEQ:
2370         kid = cLISTOPo->op_first;
2371         goto do_kids;
2372     }
2373     return o;
2374 }
2375
2376 static OP *
2377 S_scalarseq(pTHX_ OP *o)
2378 {
2379     if (o) {
2380         const OPCODE type = o->op_type;
2381
2382         if (type == OP_LINESEQ || type == OP_SCOPE ||
2383             type == OP_LEAVE || type == OP_LEAVETRY)
2384         {
2385             OP *kid, *sib;
2386             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2387                 if ((sib = OpSIBLING(kid))
2388                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2389                     || (  sib->op_targ != OP_NEXTSTATE
2390                        && sib->op_targ != OP_DBSTATE  )))
2391                 {
2392                     scalarvoid(kid);
2393                 }
2394             }
2395             PL_curcop = &PL_compiling;
2396         }
2397         o->op_flags &= ~OPf_PARENS;
2398         if (PL_hints & HINT_BLOCK_SCOPE)
2399             o->op_flags |= OPf_PARENS;
2400     }
2401     else
2402         o = newOP(OP_STUB, 0);
2403     return o;
2404 }
2405
2406 STATIC OP *
2407 S_modkids(pTHX_ OP *o, I32 type)
2408 {
2409     if (o && o->op_flags & OPf_KIDS) {
2410         OP *kid;
2411         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2412             op_lvalue(kid, type);
2413     }
2414     return o;
2415 }
2416
2417
2418 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2419  * const fields. Also, convert CONST keys to HEK-in-SVs.
2420  * rop is the op that retrieves the hash;
2421  * key_op is the first key
2422  */
2423
2424 STATIC void
2425 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2426 {
2427     PADNAME *lexname;
2428     GV **fields;
2429     bool check_fields;
2430
2431     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2432     if (rop) {
2433         if (rop->op_first->op_type == OP_PADSV)
2434             /* @$hash{qw(keys here)} */
2435             rop = (UNOP*)rop->op_first;
2436         else {
2437             /* @{$hash}{qw(keys here)} */
2438             if (rop->op_first->op_type == OP_SCOPE
2439                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2440                 {
2441                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2442                 }
2443             else
2444                 rop = NULL;
2445         }
2446     }
2447
2448     lexname = NULL; /* just to silence compiler warnings */
2449     fields  = NULL; /* just to silence compiler warnings */
2450
2451     check_fields =
2452             rop
2453          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2454              SvPAD_TYPED(lexname))
2455          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2456          && isGV(*fields) && GvHV(*fields);
2457
2458     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2459         SV **svp, *sv;
2460         if (key_op->op_type != OP_CONST)
2461             continue;
2462         svp = cSVOPx_svp(key_op);
2463
2464         /* make sure it's not a bareword under strict subs */
2465         if (key_op->op_private & OPpCONST_BARE &&
2466             key_op->op_private & OPpCONST_STRICT)
2467         {
2468             no_bareword_allowed((OP*)key_op);
2469         }
2470
2471         /* Make the CONST have a shared SV */
2472         if (   !SvIsCOW_shared_hash(sv = *svp)
2473             && SvTYPE(sv) < SVt_PVMG
2474             && SvOK(sv)
2475             && !SvROK(sv))
2476         {
2477             SSize_t keylen;
2478             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2479             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2480             SvREFCNT_dec_NN(sv);
2481             *svp = nsv;
2482         }
2483
2484         if (   check_fields
2485             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2486         {
2487             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2488                         "in variable %" PNf " of type %" HEKf,
2489                         SVfARG(*svp), PNfARG(lexname),
2490                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2491         }
2492     }
2493 }
2494
2495 /* info returned by S_sprintf_is_multiconcatable() */
2496
2497 struct sprintf_ismc_info {
2498     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2499     char  *start;     /* start of raw format string */
2500     char  *end;       /* bytes after end of raw format string */
2501     STRLEN total_len; /* total length (in bytes) of format string, not
2502                          including '%s' and  half of '%%' */
2503     STRLEN variant;   /* number of bytes by which total_len_p would grow
2504                          if upgraded to utf8 */
2505     bool   utf8;      /* whether the format is utf8 */
2506 };
2507
2508
2509 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2510  * i.e. its format argument is a const string with only '%s' and '%%'
2511  * formats, and the number of args is known, e.g.
2512  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2513  * but not
2514  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2515  *
2516  * If successful, the sprintf_ismc_info struct pointed to by info will be
2517  * populated.
2518  */
2519
2520 STATIC bool
2521 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2522 {
2523     OP    *pm, *constop, *kid;
2524     SV    *sv;
2525     char  *s, *e, *p;
2526     SSize_t nargs, nformats;
2527     STRLEN cur, total_len, variant;
2528     bool   utf8;
2529
2530     /* if sprintf's behaviour changes, die here so that someone
2531      * can decide whether to enhance this function or skip optimising
2532      * under those new circumstances */
2533     assert(!(o->op_flags & OPf_STACKED));
2534     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2535     assert(!(o->op_private & ~OPpARG4_MASK));
2536
2537     pm = cUNOPo->op_first;
2538     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2539         return FALSE;
2540     constop = OpSIBLING(pm);
2541     if (!constop || constop->op_type != OP_CONST)
2542         return FALSE;
2543     sv = cSVOPx_sv(constop);
2544     if (SvMAGICAL(sv) || !SvPOK(sv))
2545         return FALSE;
2546
2547     s = SvPV(sv, cur);
2548     e = s + cur;
2549
2550     /* Scan format for %% and %s and work out how many %s there are.
2551      * Abandon if other format types are found.
2552      */
2553
2554     nformats  = 0;
2555     total_len = 0;
2556     variant   = 0;
2557
2558     for (p = s; p < e; p++) {
2559         if (*p != '%') {
2560             total_len++;
2561             if (!UTF8_IS_INVARIANT(*p))
2562                 variant++;
2563             continue;
2564         }
2565         p++;
2566         if (p >= e)
2567             return FALSE; /* lone % at end gives "Invalid conversion" */
2568         if (*p == '%')
2569             total_len++;
2570         else if (*p == 's')
2571             nformats++;
2572         else
2573             return FALSE;
2574     }
2575
2576     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2577         return FALSE;
2578
2579     utf8 = cBOOL(SvUTF8(sv));
2580     if (utf8)
2581         variant = 0;
2582
2583     /* scan args; they must all be in scalar cxt */
2584
2585     nargs = 0;
2586     kid = OpSIBLING(constop);
2587
2588     while (kid) {
2589         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2590             return FALSE;
2591         nargs++;
2592         kid = OpSIBLING(kid);
2593     }
2594
2595     if (nargs != nformats)
2596         return FALSE; /* e.g. sprintf("%s%s", $a); */
2597
2598
2599     info->nargs      = nargs;
2600     info->start      = s;
2601     info->end        = e;
2602     info->total_len  = total_len;
2603     info->variant    = variant;
2604     info->utf8       = utf8;
2605
2606     return TRUE;
2607 }
2608
2609
2610
2611 /* S_maybe_multiconcat():
2612  *
2613  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2614  * convert it (and its children) into an OP_MULTICONCAT. See the code
2615  * comments just before pp_multiconcat() for the full details of what
2616  * OP_MULTICONCAT supports.
2617  *
2618  * Basically we're looking for an optree with a chain of OP_CONCATS down
2619  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2620  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2621  *
2622  *      $x = "$a$b-$c"
2623  *
2624  *  looks like
2625  *
2626  *      SASSIGN
2627  *         |
2628  *      STRINGIFY   -- PADSV[$x]
2629  *         |
2630  *         |
2631  *      ex-PUSHMARK -- CONCAT/S
2632  *                        |
2633  *                     CONCAT/S  -- PADSV[$d]
2634  *                        |
2635  *                     CONCAT    -- CONST["-"]
2636  *                        |
2637  *                     PADSV[$a] -- PADSV[$b]
2638  *
2639  * Note that at this stage the OP_SASSIGN may have already been optimised
2640  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2641  */
2642
2643 STATIC void
2644 S_maybe_multiconcat(pTHX_ OP *o)
2645 {
2646     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2647     OP *topop;       /* the top-most op in the concat tree (often equals o,
2648                         unless there are assign/stringify ops above it */
2649     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2650     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2651     OP *targetop;    /* the op corresponding to target=... or target.=... */
2652     OP *stringop;    /* the OP_STRINGIFY op, if any */
2653     OP *nextop;      /* used for recreating the op_next chain without consts */
2654     OP *kid;         /* general-purpose op pointer */
2655     UNOP_AUX_item *aux;
2656     UNOP_AUX_item *lenp;
2657     char *const_str, *p;
2658     struct sprintf_ismc_info sprintf_info;
2659
2660                      /* store info about each arg in args[];
2661                       * toparg is the highest used slot; argp is a general
2662                       * pointer to args[] slots */
2663     struct {
2664         void *p;      /* initially points to const sv (or null for op);
2665                          later, set to SvPV(constsv), with ... */
2666         STRLEN len;   /* ... len set to SvPV(..., len) */
2667     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2668
2669     SSize_t nargs  = 0;
2670     SSize_t nconst = 0;
2671     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2672     STRLEN variant;
2673     bool utf8 = FALSE;
2674     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2675                                  the last-processed arg will the LHS of one,
2676                                  as args are processed in reverse order */
2677     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2678     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2679     U8 flags          = 0;   /* what will become the op_flags and ... */
2680     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2681     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2682     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2683     bool prev_was_const = FALSE; /* previous arg was a const */
2684
2685     /* -----------------------------------------------------------------
2686      * Phase 1:
2687      *
2688      * Examine the optree non-destructively to determine whether it's
2689      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2690      * information about the optree in args[].
2691      */
2692
2693     argp     = args;
2694     targmyop = NULL;
2695     targetop = NULL;
2696     stringop = NULL;
2697     topop    = o;
2698     parentop = o;
2699
2700     assert(   o->op_type == OP_SASSIGN
2701            || o->op_type == OP_CONCAT
2702            || o->op_type == OP_SPRINTF
2703            || o->op_type == OP_STRINGIFY);
2704
2705     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2706
2707     /* first see if, at the top of the tree, there is an assign,
2708      * append and/or stringify */
2709
2710     if (topop->op_type == OP_SASSIGN) {
2711         /* expr = ..... */
2712         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2713             return;
2714         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2715             return;
2716         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2717
2718         parentop = topop;
2719         topop = cBINOPo->op_first;
2720         targetop = OpSIBLING(topop);
2721         if (!targetop) /* probably some sort of syntax error */
2722             return;
2723     }
2724     else if (   topop->op_type == OP_CONCAT
2725              && (topop->op_flags & OPf_STACKED)
2726              && (cUNOPo->op_first->op_flags & OPf_MOD)
2727              && (!(topop->op_private & OPpCONCAT_NESTED))
2728             )
2729     {
2730         /* expr .= ..... */
2731
2732         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2733          * decide what to do about it */
2734         assert(!(o->op_private & OPpTARGET_MY));
2735
2736         /* barf on unknown flags */
2737         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2738         private_flags |= OPpMULTICONCAT_APPEND;
2739         targetop = cBINOPo->op_first;
2740         parentop = topop;
2741         topop    = OpSIBLING(targetop);
2742
2743         /* $x .= <FOO> gets optimised to rcatline instead */
2744         if (topop->op_type == OP_READLINE)
2745             return;
2746     }
2747
2748     if (targetop) {
2749         /* Can targetop (the LHS) if it's a padsv, be be optimised
2750          * away and use OPpTARGET_MY instead?
2751          */
2752         if (    (targetop->op_type == OP_PADSV)
2753             && !(targetop->op_private & OPpDEREF)
2754             && !(targetop->op_private & OPpPAD_STATE)
2755                /* we don't support 'my $x .= ...' */
2756             && (   o->op_type == OP_SASSIGN
2757                 || !(targetop->op_private & OPpLVAL_INTRO))
2758         )
2759             is_targable = TRUE;
2760     }
2761
2762     if (topop->op_type == OP_STRINGIFY) {
2763         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2764             return;
2765         stringop = topop;
2766
2767         /* barf on unknown flags */
2768         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2769
2770         if ((topop->op_private & OPpTARGET_MY)) {
2771             if (o->op_type == OP_SASSIGN)
2772                 return; /* can't have two assigns */
2773             targmyop = topop;
2774         }
2775
2776         private_flags |= OPpMULTICONCAT_STRINGIFY;
2777         parentop = topop;
2778         topop = cBINOPx(topop)->op_first;
2779         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2780         topop = OpSIBLING(topop);
2781     }
2782
2783     if (topop->op_type == OP_SPRINTF) {
2784         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2785             return;
2786         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2787             nargs     = sprintf_info.nargs;
2788             total_len = sprintf_info.total_len;
2789             variant   = sprintf_info.variant;
2790             utf8      = sprintf_info.utf8;
2791             is_sprintf = TRUE;
2792             private_flags |= OPpMULTICONCAT_FAKE;
2793             toparg = argp;
2794             /* we have an sprintf op rather than a concat optree.
2795              * Skip most of the code below which is associated with
2796              * processing that optree. We also skip phase 2, determining
2797              * whether its cost effective to optimise, since for sprintf,
2798              * multiconcat is *always* faster */
2799             goto create_aux;
2800         }
2801         /* note that even if the sprintf itself isn't multiconcatable,
2802          * the expression as a whole may be, e.g. in
2803          *    $x .= sprintf("%d",...)
2804          * the sprintf op will be left as-is, but the concat/S op may
2805          * be upgraded to multiconcat
2806          */
2807     }
2808     else if (topop->op_type == OP_CONCAT) {
2809         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2810             return;
2811
2812         if ((topop->op_private & OPpTARGET_MY)) {
2813             if (o->op_type == OP_SASSIGN || targmyop)
2814                 return; /* can't have two assigns */
2815             targmyop = topop;
2816         }
2817     }
2818
2819     /* Is it safe to convert a sassign/stringify/concat op into
2820      * a multiconcat? */
2821     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2822     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2823     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2824     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2825     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2826                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2827     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2828                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2829
2830     /* Now scan the down the tree looking for a series of
2831      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2832      * stacked). For example this tree:
2833      *
2834      *     |
2835      *   CONCAT/STACKED
2836      *     |
2837      *   CONCAT/STACKED -- EXPR5
2838      *     |
2839      *   CONCAT/STACKED -- EXPR4
2840      *     |
2841      *   CONCAT -- EXPR3
2842      *     |
2843      *   EXPR1  -- EXPR2
2844      *
2845      * corresponds to an expression like
2846      *
2847      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2848      *
2849      * Record info about each EXPR in args[]: in particular, whether it is
2850      * a stringifiable OP_CONST and if so what the const sv is.
2851      *
2852      * The reason why the last concat can't be STACKED is the difference
2853      * between
2854      *
2855      *    ((($a .= $a) .= $a) .= $a) .= $a
2856      *
2857      * and
2858      *    $a . $a . $a . $a . $a
2859      *
2860      * The main difference between the optrees for those two constructs
2861      * is the presence of the last STACKED. As well as modifying $a,
2862      * the former sees the changed $a between each concat, so if $s is
2863      * initially 'a', the first returns 'a' x 16, while the latter returns
2864      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2865      */
2866
2867     kid = topop;
2868
2869     for (;;) {
2870         OP *argop;
2871         SV *sv;
2872         bool last = FALSE;
2873
2874         if (    kid->op_type == OP_CONCAT
2875             && !kid_is_last
2876         ) {
2877             OP *k1, *k2;
2878             k1 = cUNOPx(kid)->op_first;
2879             k2 = OpSIBLING(k1);
2880             /* shouldn't happen except maybe after compile err? */
2881             if (!k2)
2882                 return;
2883
2884             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2885             if (kid->op_private & OPpTARGET_MY)
2886                 kid_is_last = TRUE;
2887
2888             stacked_last = (kid->op_flags & OPf_STACKED);
2889             if (!stacked_last)
2890                 kid_is_last = TRUE;
2891
2892             kid   = k1;
2893             argop = k2;
2894         }
2895         else {
2896             argop = kid;
2897             last = TRUE;
2898         }
2899
2900         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2901             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2902         {
2903             /* At least two spare slots are needed to decompose both
2904              * concat args. If there are no slots left, continue to
2905              * examine the rest of the optree, but don't push new values
2906              * on args[]. If the optree as a whole is legal for conversion
2907              * (in particular that the last concat isn't STACKED), then
2908              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2909              * can be converted into an OP_MULTICONCAT now, with the first
2910              * child of that op being the remainder of the optree -
2911              * which may itself later be converted to a multiconcat op
2912              * too.
2913              */
2914             if (last) {
2915                 /* the last arg is the rest of the optree */
2916                 argp++->p = NULL;
2917                 nargs++;
2918             }
2919         }
2920         else if (   argop->op_type == OP_CONST
2921             && ((sv = cSVOPx_sv(argop)))
2922             /* defer stringification until runtime of 'constant'
2923              * things that might stringify variantly, e.g. the radix
2924              * point of NVs, or overloaded RVs */
2925             && (SvPOK(sv) || SvIOK(sv))
2926             && (!SvGMAGICAL(sv))
2927         ) {
2928             argp++->p = sv;
2929             utf8   |= cBOOL(SvUTF8(sv));
2930             nconst++;
2931             if (prev_was_const)
2932                 /* this const may be demoted back to a plain arg later;
2933                  * make sure we have enough arg slots left */
2934                 nadjconst++;
2935             prev_was_const = !prev_was_const;
2936         }
2937         else {
2938             argp++->p = NULL;
2939             nargs++;
2940             prev_was_const = FALSE;
2941         }
2942
2943         if (last)
2944             break;
2945     }
2946
2947     toparg = argp - 1;
2948
2949     if (stacked_last)
2950         return; /* we don't support ((A.=B).=C)...) */
2951
2952     /* look for two adjacent consts and don't fold them together:
2953      *     $o . "a" . "b"
2954      * should do
2955      *     $o->concat("a")->concat("b")
2956      * rather than
2957      *     $o->concat("ab")
2958      * (but $o .=  "a" . "b" should still fold)
2959      */
2960     {
2961         bool seen_nonconst = FALSE;
2962         for (argp = toparg; argp >= args; argp--) {
2963             if (argp->p == NULL) {
2964                 seen_nonconst = TRUE;
2965                 continue;
2966             }
2967             if (!seen_nonconst)
2968                 continue;
2969             if (argp[1].p) {
2970                 /* both previous and current arg were constants;
2971                  * leave the current OP_CONST as-is */
2972                 argp->p = NULL;
2973                 nconst--;
2974                 nargs++;
2975             }
2976         }
2977     }
2978
2979     /* -----------------------------------------------------------------
2980      * Phase 2:
2981      *
2982      * At this point we have determined that the optree *can* be converted
2983      * into a multiconcat. Having gathered all the evidence, we now decide
2984      * whether it *should*.
2985      */
2986
2987
2988     /* we need at least one concat action, e.g.:
2989      *
2990      *  Y . Z
2991      *  X = Y . Z
2992      *  X .= Y
2993      *
2994      * otherwise we could be doing something like $x = "foo", which
2995      * if treated as as a concat, would fail to COW.
2996      */
2997     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2998         return;
2999
3000     /* Benchmarking seems to indicate that we gain if:
3001      * * we optimise at least two actions into a single multiconcat
3002      *    (e.g concat+concat, sassign+concat);
3003      * * or if we can eliminate at least 1 OP_CONST;
3004      * * or if we can eliminate a padsv via OPpTARGET_MY
3005      */
3006
3007     if (
3008            /* eliminated at least one OP_CONST */
3009            nconst >= 1
3010            /* eliminated an OP_SASSIGN */
3011         || o->op_type == OP_SASSIGN
3012            /* eliminated an OP_PADSV */
3013         || (!targmyop && is_targable)
3014     )
3015         /* definitely a net gain to optimise */
3016         goto optimise;
3017
3018     /* ... if not, what else? */
3019
3020     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3021      * multiconcat is faster (due to not creating a temporary copy of
3022      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3023      * faster.
3024      */
3025     if (   nconst == 0
3026          && nargs == 2
3027          && targmyop
3028          && topop->op_type == OP_CONCAT
3029     ) {
3030         PADOFFSET t = targmyop->op_targ;
3031         OP *k1 = cBINOPx(topop)->op_first;
3032         OP *k2 = cBINOPx(topop)->op_last;
3033         if (   k2->op_type == OP_PADSV
3034             && k2->op_targ == t
3035             && (   k1->op_type != OP_PADSV
3036                 || k1->op_targ != t)
3037         )
3038             goto optimise;
3039     }
3040
3041     /* need at least two concats */
3042     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3043         return;
3044
3045
3046
3047     /* -----------------------------------------------------------------
3048      * Phase 3:
3049      *
3050      * At this point the optree has been verified as ok to be optimised
3051      * into an OP_MULTICONCAT. Now start changing things.
3052      */
3053
3054    optimise:
3055
3056     /* stringify all const args and determine utf8ness */
3057
3058     variant = 0;
3059     for (argp = args; argp <= toparg; argp++) {
3060         SV *sv = (SV*)argp->p;
3061         if (!sv)
3062             continue; /* not a const op */
3063         if (utf8 && !SvUTF8(sv))
3064             sv_utf8_upgrade_nomg(sv);
3065         argp->p = SvPV_nomg(sv, argp->len);
3066         total_len += argp->len;
3067
3068         /* see if any strings would grow if converted to utf8 */
3069         if (!utf8) {
3070             char *p    = (char*)argp->p;
3071             STRLEN len = argp->len;
3072             while (len--) {
3073                 U8 c = *p++;
3074                 if (!UTF8_IS_INVARIANT(c))
3075                     variant++;
3076             }
3077         }
3078     }
3079
3080     /* create and populate aux struct */
3081
3082   create_aux:
3083
3084     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3085                     sizeof(UNOP_AUX_item)
3086                     *  (
3087                            PERL_MULTICONCAT_HEADER_SIZE
3088                          + ((nargs + 1) * (variant ? 2 : 1))
3089                         )
3090                     );
3091     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3092
3093     /* Extract all the non-const expressions from the concat tree then
3094      * dispose of the old tree, e.g. convert the tree from this:
3095      *
3096      *  o => SASSIGN
3097      *         |
3098      *       STRINGIFY   -- TARGET
3099      *         |
3100      *       ex-PUSHMARK -- CONCAT
3101      *                        |
3102      *                      CONCAT -- EXPR5
3103      *                        |
3104      *                      CONCAT -- EXPR4
3105      *                        |
3106      *                      CONCAT -- EXPR3
3107      *                        |
3108      *                      EXPR1  -- EXPR2
3109      *
3110      *
3111      * to:
3112      *
3113      *  o => MULTICONCAT
3114      *         |
3115      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3116      *
3117      * except that if EXPRi is an OP_CONST, it's discarded.
3118      *
3119      * During the conversion process, EXPR ops are stripped from the tree
3120      * and unshifted onto o. Finally, any of o's remaining original
3121      * childen are discarded and o is converted into an OP_MULTICONCAT.
3122      *
3123      * In this middle of this, o may contain both: unshifted args on the
3124      * left, and some remaining original args on the right. lastkidop
3125      * is set to point to the right-most unshifted arg to delineate
3126      * between the two sets.
3127      */
3128
3129
3130     if (is_sprintf) {
3131         /* create a copy of the format with the %'s removed, and record
3132          * the sizes of the const string segments in the aux struct */
3133         char *q, *oldq;
3134         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3135
3136         p    = sprintf_info.start;
3137         q    = const_str;
3138         oldq = q;
3139         for (; p < sprintf_info.end; p++) {
3140             if (*p == '%') {
3141                 p++;
3142                 if (*p != '%') {
3143                     (lenp++)->ssize = q - oldq;
3144                     oldq = q;
3145                     continue;
3146                 }
3147             }
3148             *q++ = *p;
3149         }
3150         lenp->ssize = q - oldq;
3151         assert((STRLEN)(q - const_str) == total_len);
3152
3153         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3154          * may or may not be topop) The pushmark and const ops need to be
3155          * kept in case they're an op_next entry point.
3156          */
3157         lastkidop = cLISTOPx(topop)->op_last;
3158         kid = cUNOPx(topop)->op_first; /* pushmark */
3159         op_null(kid);
3160         op_null(OpSIBLING(kid));       /* const */
3161         if (o != topop) {
3162             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3163             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3164             lastkidop->op_next = o;
3165         }
3166     }
3167     else {
3168         p = const_str;
3169         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3170
3171         lenp->ssize = -1;
3172
3173         /* Concatenate all const strings into const_str.
3174          * Note that args[] contains the RHS args in reverse order, so
3175          * we scan args[] from top to bottom to get constant strings
3176          * in L-R order
3177          */
3178         for (argp = toparg; argp >= args; argp--) {
3179             if (!argp->p)
3180                 /* not a const op */
3181                 (++lenp)->ssize = -1;
3182             else {
3183                 STRLEN l = argp->len;
3184                 Copy(argp->p, p, l, char);
3185                 p += l;
3186                 if (lenp->ssize == -1)
3187                     lenp->ssize = l;
3188                 else
3189                     lenp->ssize += l;
3190             }
3191         }
3192
3193         kid = topop;
3194         nextop = o;
3195         lastkidop = NULL;
3196
3197         for (argp = args; argp <= toparg; argp++) {
3198             /* only keep non-const args, except keep the first-in-next-chain
3199              * arg no matter what it is (but nulled if OP_CONST), because it
3200              * may be the entry point to this subtree from the previous
3201              * op_next.
3202              */
3203             bool last = (argp == toparg);
3204             OP *prev;
3205
3206             /* set prev to the sibling *before* the arg to be cut out,
3207              * e.g.:
3208              *
3209              *         |
3210              * kid=  CONST
3211              *         |
3212              * prev= CONST -- EXPR
3213              *         |
3214              */
3215             if (argp == args && kid->op_type != OP_CONCAT) {
3216                 /* in e.g. '$x . = f(1)' there's no RHS concat tree
3217                  * so the expression to be cut isn't kid->op_last but
3218                  * kid itself */
3219                 OP *o1, *o2;
3220                 /* find the op before kid */
3221                 o1 = NULL;
3222                 o2 = cUNOPx(parentop)->op_first;
3223                 while (o2 && o2 != kid) {
3224                     o1 = o2;
3225                     o2 = OpSIBLING(o2);
3226                 }
3227                 assert(o2 == kid);
3228                 prev = o1;
3229                 kid  = parentop;
3230             }
3231             else if (kid == o && lastkidop)
3232                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3233             else
3234                 prev = last ? NULL : cUNOPx(kid)->op_first;
3235
3236             if (!argp->p || last) {
3237                 /* cut RH op */
3238                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3239                 /* and unshift to front of o */
3240                 op_sibling_splice(o, NULL, 0, aop);
3241                 /* record the right-most op added to o: later we will
3242                  * free anything to the right of it */
3243                 if (!lastkidop)
3244                     lastkidop = aop;
3245                 aop->op_next = nextop;
3246                 if (last) {
3247                     if (argp->p)
3248                         /* null the const at start of op_next chain */
3249                         op_null(aop);
3250                 }
3251                 else if (prev)
3252                     nextop = prev->op_next;
3253             }
3254
3255             /* the last two arguments are both attached to the same concat op */
3256             if (argp < toparg - 1)
3257                 kid = prev;
3258         }
3259     }
3260
3261     /* Populate the aux struct */
3262
3263     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3264     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3265     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3266     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3267     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3268
3269     /* if variant > 0, calculate a variant const string and lengths where
3270      * the utf8 version of the string will take 'variant' more bytes than
3271      * the plain one. */
3272
3273     if (variant) {
3274         char              *p = const_str;
3275         STRLEN          ulen = total_len + variant;
3276         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3277         UNOP_AUX_item *ulens = lens + (nargs + 1);
3278         char             *up = (char*)PerlMemShared_malloc(ulen);
3279         SSize_t            n;
3280
3281         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3282         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3283
3284         for (n = 0; n < (nargs + 1); n++) {
3285             SSize_t i;
3286             char * orig_up = up;
3287             for (i = (lens++)->ssize; i > 0; i--) {
3288                 U8 c = *p++;
3289                 append_utf8_from_native_byte(c, (U8**)&up);
3290             }
3291             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3292         }
3293     }
3294
3295     if (stringop) {
3296         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3297          * that op's first child - an ex-PUSHMARK - because the op_next of
3298          * the previous op may point to it (i.e. it's the entry point for
3299          * the o optree)
3300          */
3301         OP *pmop =
3302             (stringop == o)
3303                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3304                 : op_sibling_splice(stringop, NULL, 1, NULL);
3305         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3306         op_sibling_splice(o, NULL, 0, pmop);
3307         if (!lastkidop)
3308             lastkidop = pmop;
3309     }
3310
3311     /* Optimise
3312      *    target  = A.B.C...
3313      *    target .= A.B.C...
3314      */
3315
3316     if (targetop) {
3317         assert(!targmyop);
3318
3319         if (o->op_type == OP_SASSIGN) {
3320             /* Move the target subtree from being the last of o's children
3321              * to being the last of o's preserved children.
3322              * Note the difference between 'target = ...' and 'target .= ...':
3323              * for the former, target is executed last; for the latter,
3324              * first.
3325              */
3326             kid = OpSIBLING(lastkidop);
3327             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3328             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3329             lastkidop->op_next = kid->op_next;
3330             lastkidop = targetop;
3331         }
3332         else {
3333             /* Move the target subtree from being the first of o's
3334              * original children to being the first of *all* o's children.
3335              */
3336             if (lastkidop) {
3337                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3338                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3339             }
3340             else {
3341                 /* if the RHS of .= doesn't contain a concat (e.g.
3342                  * $x .= "foo"), it gets missed by the "strip ops from the
3343                  * tree and add to o" loop earlier */
3344                 assert(topop->op_type != OP_CONCAT);
3345                 if (stringop) {
3346                     /* in e.g. $x .= "$y", move the $y expression
3347                      * from being a child of OP_STRINGIFY to being the
3348                      * second child of the OP_CONCAT
3349                      */
3350                     assert(cUNOPx(stringop)->op_first == topop);
3351                     op_sibling_splice(stringop, NULL, 1, NULL);
3352                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3353                 }
3354                 assert(topop == OpSIBLING(cBINOPo->op_first));
3355                 if (toparg->p)
3356                     op_null(topop);
3357                 lastkidop = topop;
3358             }
3359         }
3360
3361         if (is_targable) {
3362             /* optimise
3363              *  my $lex  = A.B.C...
3364              *     $lex  = A.B.C...
3365              *     $lex .= A.B.C...
3366              * The original padsv op is kept but nulled in case it's the
3367              * entry point for the optree (which it will be for
3368              * '$lex .=  ... '
3369              */
3370             private_flags |= OPpTARGET_MY;
3371             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3372             o->op_targ = targetop->op_targ;
3373             targetop->op_targ = 0;
3374             op_null(targetop);
3375         }
3376         else
3377             flags |= OPf_STACKED;
3378     }
3379     else if (targmyop) {
3380         private_flags |= OPpTARGET_MY;
3381         if (o != targmyop) {
3382             o->op_targ = targmyop->op_targ;
3383             targmyop->op_targ = 0;
3384         }
3385     }
3386
3387     /* detach the emaciated husk of the sprintf/concat optree and free it */
3388     for (;;) {
3389         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3390         if (!kid)
3391             break;
3392         op_free(kid);
3393     }
3394
3395     /* and convert o into a multiconcat */
3396
3397     o->op_flags        = (flags|OPf_KIDS|stacked_last
3398                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3399     o->op_private      = private_flags;
3400     o->op_type         = OP_MULTICONCAT;
3401     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3402     cUNOP_AUXo->op_aux = aux;
3403 }
3404
3405
3406 /* do all the final processing on an optree (e.g. running the peephole
3407  * optimiser on it), then attach it to cv (if cv is non-null)
3408  */
3409
3410 static void
3411 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3412 {
3413     OP **startp;
3414
3415     /* XXX for some reason, evals, require and main optrees are
3416      * never attached to their CV; instead they just hang off
3417      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3418      * and get manually freed when appropriate */
3419     if (cv)
3420         startp = &CvSTART(cv);
3421     else
3422         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3423
3424     *startp = start;
3425     optree->op_private |= OPpREFCOUNTED;
3426     OpREFCNT_set(optree, 1);
3427     optimize_optree(optree);
3428     CALL_PEEP(*startp);
3429     finalize_optree(optree);
3430     S_prune_chain_head(startp);
3431
3432     if (cv) {
3433         /* now that optimizer has done its work, adjust pad values */
3434         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3435                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3436     }
3437 }
3438
3439
3440 /*
3441 =for apidoc optimize_optree
3442
3443 This function applies some optimisations to the optree in top-down order.
3444 It is called before the peephole optimizer, which processes ops in
3445 execution order. Note that finalize_optree() also does a top-down scan,
3446 but is called *after* the peephole optimizer.
3447
3448 =cut
3449 */
3450
3451 void
3452 Perl_optimize_optree(pTHX_ OP* o)
3453 {
3454     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3455
3456     ENTER;
3457     SAVEVPTR(PL_curcop);
3458
3459     optimize_op(o);
3460
3461     LEAVE;
3462 }
3463
3464
3465 /* helper for optimize_optree() which optimises on op then recurses
3466  * to optimise any children.
3467  */
3468
3469 STATIC void
3470 S_optimize_op(pTHX_ OP* o)
3471 {
3472     OP *kid;
3473
3474     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3475     assert(o->op_type != OP_FREED);
3476
3477     switch (o->op_type) {
3478     case OP_NEXTSTATE:
3479     case OP_DBSTATE:
3480         PL_curcop = ((COP*)o);          /* for warnings */
3481         break;
3482
3483
3484     case OP_CONCAT:
3485     case OP_SASSIGN:
3486     case OP_STRINGIFY:
3487     case OP_SPRINTF:
3488         S_maybe_multiconcat(aTHX_ o);
3489         break;
3490
3491     case OP_SUBST:
3492         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3493             optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3494         break;
3495
3496     default:
3497         break;
3498     }
3499
3500     if (!(o->op_flags & OPf_KIDS))
3501         return;
3502
3503     for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3504         optimize_op(kid);
3505 }
3506
3507
3508 /*
3509 =for apidoc finalize_optree
3510
3511 This function finalizes the optree.  Should be called directly after
3512 the complete optree is built.  It does some additional
3513 checking which can't be done in the normal C<ck_>xxx functions and makes
3514 the tree thread-safe.
3515
3516 =cut
3517 */
3518 void
3519 Perl_finalize_optree(pTHX_ OP* o)
3520 {
3521     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3522
3523     ENTER;
3524     SAVEVPTR(PL_curcop);
3525
3526     finalize_op(o);
3527
3528     LEAVE;
3529 }
3530
3531 #ifdef USE_ITHREADS
3532 /* Relocate sv to the pad for thread safety.
3533  * Despite being a "constant", the SV is written to,
3534  * for reference counts, sv_upgrade() etc. */
3535 PERL_STATIC_INLINE void
3536 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3537 {
3538     PADOFFSET ix;
3539     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3540     if (!*svp) return;
3541     ix = pad_alloc(OP_CONST, SVf_READONLY);
3542     SvREFCNT_dec(PAD_SVl(ix));
3543     PAD_SETSV(ix, *svp);
3544     /* XXX I don't know how this isn't readonly already. */
3545     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3546     *svp = NULL;
3547     *targp = ix;
3548 }
3549 #endif
3550
3551
3552 STATIC void
3553 S_finalize_op(pTHX_ OP* o)
3554 {
3555     PERL_ARGS_ASSERT_FINALIZE_OP;
3556
3557     assert(o->op_type != OP_FREED);
3558
3559     switch (o->op_type) {
3560     case OP_NEXTSTATE:
3561     case OP_DBSTATE:
3562         PL_curcop = ((COP*)o);          /* for warnings */
3563         break;
3564     case OP_EXEC:
3565         if (OpHAS_SIBLING(o)) {
3566             OP *sib = OpSIBLING(o);
3567             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3568                 && ckWARN(WARN_EXEC)
3569                 && OpHAS_SIBLING(sib))
3570             {
3571                     const OPCODE type = OpSIBLING(sib)->op_type;
3572                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3573                         const line_t oldline = CopLINE(PL_curcop);
3574                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3575                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3576                             "Statement unlikely to be reached");
3577                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3578                             "\t(Maybe you meant system() when you said exec()?)\n");
3579                         CopLINE_set(PL_curcop, oldline);
3580                     }
3581             }
3582         }
3583         break;
3584
3585     case OP_GV:
3586         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3587             GV * const gv = cGVOPo_gv;
3588             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3589                 /* XXX could check prototype here instead of just carping */
3590                 SV * const sv = sv_newmortal();
3591                 gv_efullname3(sv, gv, NULL);
3592                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3593                     "%" SVf "() called too early to check prototype",
3594                     SVfARG(sv));
3595             }
3596         }
3597         break;
3598
3599     case OP_CONST:
3600         if (cSVOPo->op_private & OPpCONST_STRICT)
3601             no_bareword_allowed(o);
3602 #ifdef USE_ITHREADS
3603         /* FALLTHROUGH */
3604     case OP_HINTSEVAL:
3605         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3606 #endif
3607         break;
3608
3609 #ifdef USE_ITHREADS
3610     /* Relocate all the METHOP's SVs to the pad for thread safety. */
3611     case OP_METHOD_NAMED:
3612     case OP_METHOD_SUPER:
3613     case OP_METHOD_REDIR:
3614     case OP_METHOD_REDIR_SUPER:
3615         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3616         break;
3617 #endif
3618
3619     case OP_HELEM: {
3620         UNOP *rop;
3621         SVOP *key_op;
3622         OP *kid;
3623
3624         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3625             break;
3626
3627         rop = (UNOP*)((BINOP*)o)->op_first;
3628
3629         goto check_keys;
3630
3631     case OP_HSLICE:
3632         S_scalar_slice_warning(aTHX_ o);
3633         /* FALLTHROUGH */
3634
3635     case OP_KVHSLICE:
3636         kid = OpSIBLING(cLISTOPo->op_first);
3637         if (/* I bet there's always a pushmark... */
3638             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3639             && OP_TYPE_ISNT_NN(kid, OP_CONST))
3640         {
3641             break;
3642         }
3643
3644         key_op = (SVOP*)(kid->op_type == OP_CONST
3645                                 ? kid
3646                                 : OpSIBLING(kLISTOP->op_first));
3647
3648         rop = (UNOP*)((LISTOP*)o)->op_last;
3649
3650       check_keys:
3651         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3652             rop = NULL;
3653         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3654         break;
3655     }
3656     case OP_NULL:
3657         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3658             break;
3659         /* FALLTHROUGH */
3660     case OP_ASLICE:
3661         S_scalar_slice_warning(aTHX_ o);
3662         break;
3663
3664     case OP_SUBST: {
3665         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3666             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3667         break;
3668     }
3669     default:
3670         break;
3671     }
3672
3673     if (o->op_flags & OPf_KIDS) {
3674         OP *kid;
3675
3676 #ifdef DEBUGGING
3677         /* check that op_last points to the last sibling, and that
3678          * the last op_sibling/op_sibparent field points back to the
3679          * parent, and that the only ops with KIDS are those which are
3680          * entitled to them */
3681         U32 type = o->op_type;
3682         U32 family;
3683         bool has_last;
3684
3685         if (type == OP_NULL) {
3686             type = o->op_targ;
3687             /* ck_glob creates a null UNOP with ex-type GLOB
3688              * (which is a list op. So pretend it wasn't a listop */
3689             if (type == OP_GLOB)
3690                 type = OP_NULL;
3691         }
3692         family = PL_opargs[type] & OA_CLASS_MASK;
3693
3694         has_last = (   family == OA_BINOP
3695                     || family == OA_LISTOP
3696                     || family == OA_PMOP
3697                     || family == OA_LOOP
3698                    );
3699         assert(  has_last /* has op_first and op_last, or ...
3700               ... has (or may have) op_first: */
3701               || family == OA_UNOP
3702               || family == OA_UNOP_AUX
3703               || family == OA_LOGOP
3704               || family == OA_BASEOP_OR_UNOP
3705               || family == OA_FILESTATOP
3706               || family == OA_LOOPEXOP
3707               || family == OA_METHOP
3708               || type == OP_CUSTOM
3709               || type == OP_NULL /* new_logop does this */
3710               );
3711
3712         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3713 #  ifdef PERL_OP_PARENT
3714             if (!OpHAS_SIBLING(kid)) {
3715                 if (has_last)
3716                     assert(kid == cLISTOPo->op_last);
3717                 assert(kid->op_sibparent == o);
3718             }
3719 #  else
3720             if (has_last && !OpHAS_SIBLING(kid))
3721                 assert(kid == cLISTOPo->op_last);
3722 #  endif
3723         }
3724 #endif
3725
3726         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3727             finalize_op(kid);
3728     }
3729 }
3730
3731 /*
3732 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3733
3734 Propagate lvalue ("modifiable") context to an op and its children.
3735 C<type> represents the context type, roughly based on the type of op that
3736 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3737 because it has no op type of its own (it is signalled by a flag on
3738 the lvalue op).
3739
3740 This function detects things that can't be modified, such as C<$x+1>, and
3741 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3742 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3743
3744 It also flags things that need to behave specially in an lvalue context,
3745 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3746
3747 =cut
3748 */
3749
3750 static void
3751 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3752 {
3753     CV *cv = PL_compcv;
3754     PadnameLVALUE_on(pn);
3755     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3756         cv = CvOUTSIDE(cv);
3757         /* RT #127786: cv can be NULL due to an eval within the DB package
3758          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3759          * unless they contain an eval, but calling eval within DB
3760          * pretends the eval was done in the caller's scope.
3761          */
3762         if (!cv)
3763             break;
3764         assert(CvPADLIST(cv));
3765         pn =
3766            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3767         assert(PadnameLEN(pn));
3768         PadnameLVALUE_on(pn);
3769     }
3770 }
3771
3772 static bool
3773 S_vivifies(const OPCODE type)
3774 {
3775     switch(type) {
3776     case OP_RV2AV:     case   OP_ASLICE:
3777     case OP_RV2HV:     case OP_KVASLICE:
3778     case OP_RV2SV:     case   OP_HSLICE:
3779     case OP_AELEMFAST: case OP_KVHSLICE:
3780     case OP_HELEM:
3781     case OP_AELEM:
3782         return 1;
3783     }
3784     return 0;
3785 }
3786
3787 static void
3788 S_lvref(pTHX_ OP *o, I32 type)
3789 {
3790     dVAR;
3791     OP *kid;
3792     switch (o->op_type) {
3793     case OP_COND_EXPR:
3794         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3795              kid = OpSIBLING(kid))
3796             S_lvref(aTHX_ kid, type);
3797         /* FALLTHROUGH */
3798     case OP_PUSHMARK:
3799         return;
3800     case OP_RV2AV:
3801         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3802         o->op_flags |= OPf_STACKED;
3803         if (o->op_flags & OPf_PARENS) {
3804             if (o->op_private & OPpLVAL_INTRO) {
3805                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3806                       "localized parenthesized array in list assignment"));
3807                 return;
3808             }
3809           slurpy:
3810             OpTYPE_set(o, OP_LVAVREF);
3811             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3812             o->op_flags |= OPf_MOD|OPf_REF;
3813             return;
3814         }
3815         o->op_private |= OPpLVREF_AV;
3816         goto checkgv;
3817     case OP_RV2CV:
3818         kid = cUNOPo->op_first;
3819         if (kid->op_type == OP_NULL)
3820             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3821                 ->op_first;
3822         o->op_private = OPpLVREF_CV;
3823         if (kid->op_type == OP_GV)
3824             o->op_flags |= OPf_STACKED;
3825         else if (kid->op_type == OP_PADCV) {
3826             o->op_targ = kid->op_targ;
3827             kid->op_targ = 0;
3828             op_free(cUNOPo->op_first);
3829             cUNOPo->op_first = NULL;
3830             o->op_flags &=~ OPf_KIDS;
3831         }
3832         else goto badref;
3833         break;
3834     case OP_RV2HV:
3835         if (o->op_flags & OPf_PARENS) {
3836           parenhash:
3837             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3838                                  "parenthesized hash in list assignment"));
3839                 return;
3840         }
3841         o->op_private |= OPpLVREF_HV;
3842         /* FALLTHROUGH */
3843     case OP_RV2SV:
3844       checkgv:
3845         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3846         o->op_flags |= OPf_STACKED;
3847         break;
3848     case OP_PADHV:
3849         if (o->op_flags & OPf_PARENS) goto parenhash;
3850         o->op_private |= OPpLVREF_HV;
3851         /* FALLTHROUGH */
3852     case OP_PADSV:
3853         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3854         break;
3855     case OP_PADAV:
3856         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3857         if (o->op_flags & OPf_PARENS) goto slurpy;
3858         o->op_private |= OPpLVREF_AV;
3859         break;
3860     case OP_AELEM:
3861     case OP_HELEM:
3862         o->op_private |= OPpLVREF_ELEM;
3863         o->op_flags   |= OPf_STACKED;
3864         break;
3865     case OP_ASLICE:
3866     case OP_HSLICE:
3867         OpTYPE_set(o, OP_LVREFSLICE);
3868         o->op_private &= OPpLVAL_INTRO;
3869         return;
3870     case OP_NULL:
3871         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3872             goto badref;
3873         else if (!(o->op_flags & OPf_KIDS))
3874             return;
3875         if (o->op_targ != OP_LIST) {
3876             S_lvref(aTHX_ cBINOPo->op_first, type);
3877             return;
3878         }
3879         /* FALLTHROUGH */
3880     case OP_LIST:
3881         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3882             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3883             S_lvref(aTHX_ kid, type);
3884         }
3885         return;
3886     case OP_STUB:
3887         if (o->op_flags & OPf_PARENS)
3888             return;
3889         /* FALLTHROUGH */
3890     default:
3891       badref:
3892         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3893         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3894                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3895                       ? "do block"
3896                       : OP_DESC(o),
3897                      PL_op_desc[type]));
3898         return;
3899     }
3900     OpTYPE_set(o, OP_LVREF);
3901     o->op_private &=
3902         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3903     if (type == OP_ENTERLOOP)
3904         o->op_private |= OPpLVREF_ITER;
3905 }
3906
3907 PERL_STATIC_INLINE bool
3908 S_potential_mod_type(I32 type)
3909 {
3910     /* Types that only potentially result in modification.  */
3911     return type == OP_GREPSTART || type == OP_ENTERSUB
3912         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3913 }
3914
3915 OP *
3916 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3917 {
3918     dVAR;
3919     OP *kid;
3920     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3921     int localize = -1;
3922
3923     if (!o || (PL_parser && PL_parser->error_count))
3924         return o;
3925
3926     if ((o->op_private & OPpTARGET_MY)
3927         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3928     {
3929         return o;
3930     }
3931
3932     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3933
3934     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3935
3936     switch (o->op_type) {
3937     case OP_UNDEF:
3938         PL_modcount++;
3939         return o;
3940     case OP_STUB:
3941         if ((o->op_flags & OPf_PARENS))
3942             break;
3943         goto nomod;
3944     case OP_ENTERSUB:
3945         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3946             !(o->op_flags & OPf_STACKED)) {
3947             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3948             assert(cUNOPo->op_first->op_type == OP_NULL);
3949             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3950             break;
3951         }
3952         else {                          /* lvalue subroutine call */
3953             o->op_private |= OPpLVAL_INTRO;
3954             PL_modcount = RETURN_UNLIMITED_NUMBER;
3955             if (S_potential_mod_type(type)) {
3956                 o->op_private |= OPpENTERSUB_INARGS;
3957                 break;
3958             }
3959             else {                      /* Compile-time error message: */
3960                 OP *kid = cUNOPo->op_first;
3961                 CV *cv;
3962                 GV *gv;
3963                 SV *namesv;
3964
3965                 if (kid->op_type != OP_PUSHMARK) {
3966                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3967                         Perl_croak(aTHX_
3968                                 "panic: unexpected lvalue entersub "
3969                                 "args: type/targ %ld:%" UVuf,
3970                                 (long)kid->op_type, (UV)kid->op_targ);
3971                     kid = kLISTOP->op_first;
3972                 }
3973                 while (OpHAS_SIBLING(kid))
3974                     kid = OpSIBLING(kid);
3975                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3976                     break;      /* Postpone until runtime */
3977                 }
3978
3979                 kid = kUNOP->op_first;
3980                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3981                     kid = kUNOP->op_first;
3982                 if (kid->op_type == OP_NULL)
3983                     Perl_croak(aTHX_
3984                                "Unexpected constant lvalue entersub "
3985                                "entry via type/targ %ld:%" UVuf,
3986                                (long)kid->op_type, (UV)kid->op_targ);
3987                 if (kid->op_type != OP_GV) {
3988                     break;
3989                 }
3990
3991                 gv = kGVOP_gv;
3992                 cv = isGV(gv)
3993                     ? GvCV(gv)
3994                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3995                         ? MUTABLE_CV(SvRV(gv))
3996                         : NULL;
3997                 if (!cv)
3998                     break;
3999                 if (CvLVALUE(cv))
4000                     break;
4001                 if (flags & OP_LVALUE_NO_CROAK)
4002                     return NULL;
4003
4004                 namesv = cv_name(cv, NULL, 0);
4005                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4006                                      "subroutine call of &%" SVf " in %s",
4007                                      SVfARG(namesv), PL_op_desc[type]),
4008                            SvUTF8(namesv));
4009                 return o;
4010             }
4011         }
4012         /* FALLTHROUGH */
4013     default:
4014       nomod:
4015         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4016         /* grep, foreach, subcalls, refgen */
4017         if (S_potential_mod_type(type))
4018             break;
4019         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4020                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4021                       ? "do block"
4022                       : OP_DESC(o)),
4023                      type ? PL_op_desc[type] : "local"));
4024         return o;
4025
4026     case OP_PREINC:
4027     case OP_PREDEC:
4028     case OP_POW:
4029     case OP_MULTIPLY:
4030     case OP_DIVIDE:
4031     case OP_MODULO:
4032     case OP_ADD:
4033     case OP_SUBTRACT:
4034     case OP_CONCAT:
4035     case OP_LEFT_SHIFT:
4036     case OP_RIGHT_SHIFT:
4037     case OP_BIT_AND:
4038     case OP_BIT_XOR:
4039     case OP_BIT_OR:
4040     case OP_I_MULTIPLY:
4041     case OP_I_DIVIDE:
4042     case OP_I_MODULO:
4043     case OP_I_ADD:
4044     case OP_I_SUBTRACT:
4045         if (!(o->op_flags & OPf_STACKED))
4046             goto nomod;
4047         PL_modcount++;
4048         break;
4049
4050     case OP_REPEAT:
4051         if (o->op_flags & OPf_STACKED) {
4052             PL_modcount++;
4053             break;
4054         }
4055         if (!(o->op_private & OPpREPEAT_DOLIST))
4056             goto nomod;
4057         else {
4058             const I32 mods = PL_modcount;
4059             modkids(cBINOPo->op_first, type);
4060             if (type != OP_AASSIGN)
4061                 goto nomod;
4062             kid = cBINOPo->op_last;
4063             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4064                 const IV iv = SvIV(kSVOP_sv);
4065                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4066                     PL_modcount =
4067                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4068             }
4069             else
4070                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4071         }
4072         break;
4073
4074     case OP_COND_EXPR:
4075         localize = 1;
4076         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4077             op_lvalue(kid, type);
4078         break;
4079
4080     case OP_RV2AV:
4081     case OP_RV2HV:
4082         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4083            PL_modcount = RETURN_UNLIMITED_NUMBER;
4084             return o;           /* Treat \(@foo) like ordinary list. */
4085         }
4086         /* FALLTHROUGH */
4087     case OP_RV2GV:
4088         if (scalar_mod_type(o, type))
4089             goto nomod;
4090         ref(cUNOPo->op_first, o->op_type);
4091         /* FALLTHROUGH */
4092     case OP_ASLICE:
4093     case OP_HSLICE:
4094         localize = 1;
4095         /* FALLTHROUGH */
4096     case OP_AASSIGN:
4097         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4098         if (type == OP_LEAVESUBLV && (
4099                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4100              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4101            ))
4102             o->op_private |= OPpMAYBE_LVSUB;
4103         /* FALLTHROUGH */
4104     case OP_NEXTSTATE:
4105     case OP_DBSTATE:
4106        PL_modcount = RETURN_UNLIMITED_NUMBER;
4107         break;
4108     case OP_KVHSLICE:
4109     case OP_KVASLICE:
4110     case OP_AKEYS:
4111         if (type == OP_LEAVESUBLV)
4112             o->op_private |= OPpMAYBE_LVSUB;
4113         goto nomod;
4114     case OP_AVHVSWITCH:
4115         if (type == OP_LEAVESUBLV
4116          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4117             o->op_private |= OPpMAYBE_LVSUB;
4118         goto nomod;
4119     case OP_AV2ARYLEN:
4120         PL_hints |= HINT_BLOCK_SCOPE;
4121         if (type == OP_LEAVESUBLV)
4122             o->op_private |= OPpMAYBE_LVSUB;
4123         PL_modcount++;
4124         break;
4125     case OP_RV2SV:
4126         ref(cUNOPo->op_first, o->op_type);
4127         localize = 1;
4128         /* FALLTHROUGH */
4129     case OP_GV:
4130         PL_hints |= HINT_BLOCK_SCOPE;
4131         /* FALLTHROUGH */
4132     case OP_SASSIGN:
4133     case OP_ANDASSIGN:
4134     case OP_ORASSIGN:
4135     case OP_DORASSIGN:
4136         PL_modcount++;
4137         break;
4138
4139     case OP_AELEMFAST:
4140     case OP_AELEMFAST_LEX:
4141         localize = -1;
4142         PL_modcount++;
4143         break;
4144
4145     case OP_PADAV:
4146     case OP_PADHV:
4147        PL_modcount = RETURN_UNLIMITED_NUMBER;
4148         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4149             return o;           /* Treat \(@foo) like ordinary list. */
4150         if (scalar_mod_type(o, type))
4151             goto nomod;
4152         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4153           && type == OP_LEAVESUBLV)
4154             o->op_private |= OPpMAYBE_LVSUB;
4155         /* FALLTHROUGH */
4156     case OP_PADSV:
4157         PL_modcount++;
4158         if (!type) /* local() */
4159             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4160                               PNfARG(PAD_COMPNAME(o->op_targ)));
4161         if (!(o->op_private & OPpLVAL_INTRO)
4162          || (  type != OP_SASSIGN && type != OP_AASSIGN
4163             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4164             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4165         break;
4166
4167     case OP_PUSHMARK:
4168         localize = 0;
4169         break;
4170
4171     case OP_KEYS:
4172         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4173             goto nomod;
4174         goto lvalue_func;
4175     case OP_SUBSTR:
4176         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4177             goto nomod;
4178         /* FALLTHROUGH */
4179     case OP_POS:
4180     case OP_VEC:
4181       lvalue_func:
4182         if (type == OP_LEAVESUBLV)
4183             o->op_private |= OPpMAYBE_LVSUB;
4184         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4185             /* substr and vec */
4186             /* If this op is in merely potential (non-fatal) modifiable
4187                context, then apply OP_ENTERSUB context to
4188                the kid op (to avoid croaking).  Other-
4189                wise pass this op’s own type so the correct op is mentioned
4190                in error messages.  */
4191             op_lvalue(OpSIBLING(cBINOPo->op_first),
4192                       S_potential_mod_type(type)
4193                         ? (I32)OP_ENTERSUB
4194                         : o->op_type);
4195         }
4196         break;
4197
4198     case OP_AELEM:
4199     case OP_HELEM:
4200         ref(cBINOPo->op_first, o->op_type);
4201         if (type == OP_ENTERSUB &&
4202              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4203             o->op_private |= OPpLVAL_DEFER;
4204         if (type == OP_LEAVESUBLV)
4205             o->op_private |= OPpMAYBE_LVSUB;
4206         localize = 1;
4207         PL_modcount++;
4208         break;
4209
4210     case OP_LEAVE:
4211     case OP_LEAVELOOP:
4212         o->op_private |= OPpLVALUE;
4213         /* FALLTHROUGH */
4214     case OP_SCOPE:
4215     case OP_ENTER:
4216     case OP_LINESEQ:
4217         localize = 0;
4218         if (o->op_flags & OPf_KIDS)
4219             op_lvalue(cLISTOPo->op_last, type);
4220         break;
4221
4222     case OP_NULL:
4223         localize = 0;
4224         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4225             goto nomod;
4226         else if (!(o->op_flags & OPf_KIDS))
4227             break;
4228
4229         if (o->op_targ != OP_LIST) {
4230             OP *sib = OpSIBLING(cLISTOPo->op_first);
4231             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4232              * that looks like
4233              *
4234              *   null
4235              *      arg
4236              *      trans
4237              *
4238              * compared with things like OP_MATCH which have the argument
4239              * as a child:
4240              *
4241              *   match
4242              *      arg
4243              *
4244              * so handle specially to correctly get "Can't modify" croaks etc
4245              */
4246
4247             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4248             {
4249                 /* this should trigger a "Can't modify transliteration" err */
4250                 op_lvalue(sib, type);
4251             }
4252             op_lvalue(cBINOPo->op_first, type);
4253             break;
4254         }
4255         /* FALLTHROUGH */
4256     case OP_LIST:
4257         localize = 0;
4258         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4259             /* elements might be in void context because the list is
4260                in scalar context or because they are attribute sub calls */
4261             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4262                 op_lvalue(kid, type);
4263         break;
4264
4265     case OP_COREARGS:
4266         return o;
4267
4268     case OP_AND:
4269     case OP_OR:
4270         if (type == OP_LEAVESUBLV
4271          || !S_vivifies(cLOGOPo->op_first->op_type))
4272             op_lvalue(cLOGOPo->op_first, type);
4273         if (type == OP_LEAVESUBLV
4274          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4275             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4276         goto nomod;
4277
4278     case OP_SREFGEN:
4279         if (type == OP_NULL) { /* local */
4280           local_refgen:
4281             if (!FEATURE_MYREF_IS_ENABLED)
4282                 Perl_croak(aTHX_ "The experimental declared_refs "
4283                                  "feature is not enabled");
4284             Perl_ck_warner_d(aTHX_
4285                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4286                     "Declaring references is experimental");
4287             op_lvalue(cUNOPo->op_first, OP_NULL);
4288             return o;
4289         }
4290         if (type != OP_AASSIGN && type != OP_SASSIGN
4291          && type != OP_ENTERLOOP)
4292             goto nomod;
4293         /* Don’t bother applying lvalue context to the ex-list.  */
4294         kid = cUNOPx(cUNOPo->op_first)->op_first;
4295         assert (!OpHAS_SIBLING(kid));
4296         goto kid_2lvref;
4297     case OP_REFGEN:
4298         if (type == OP_NULL) /* local */
4299             goto local_refgen;
4300         if (type != OP_AASSIGN) goto nomod;
4301         kid = cUNOPo->op_first;
4302       kid_2lvref:
4303         {
4304             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4305             S_lvref(aTHX_ kid, type);
4306             if (!PL_parser || PL_parser->error_count == ec) {
4307                 if (!FEATURE_REFALIASING_IS_ENABLED)
4308                     Perl_croak(aTHX_
4309                        "Experimental aliasing via reference not enabled");
4310                 Perl_ck_warner_d(aTHX_
4311                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4312                                 "Aliasing via reference is experimental");
4313             }
4314         }
4315         if (o->op_type == OP_REFGEN)
4316             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4317         op_null(o);
4318         return o;
4319
4320     case OP_SPLIT:
4321         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4322             /* This is actually @array = split.  */
4323             PL_modcount = RETURN_UNLIMITED_NUMBER;
4324             break;
4325         }
4326         goto nomod;
4327
4328     case OP_SCALAR:
4329         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4330         goto nomod;
4331     }
4332
4333     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4334        their argument is a filehandle; thus \stat(".") should not set
4335        it. AMS 20011102 */
4336     if (type == OP_REFGEN &&
4337         PL_check[o->op_type] == Perl_ck_ftst)
4338         return o;
4339
4340     if (type != OP_LEAVESUBLV)
4341         o->op_flags |= OPf_MOD;
4342
4343     if (type == OP_AASSIGN || type == OP_SASSIGN)
4344         o->op_flags |= OPf_SPECIAL
4345                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4346     else if (!type) { /* local() */
4347         switch (localize) {
4348         case 1:
4349             o->op_private |= OPpLVAL_INTRO;
4350             o->op_flags &= ~OPf_SPECIAL;
4351             PL_hints |= HINT_BLOCK_SCOPE;
4352             break;
4353         case 0:
4354             break;
4355         case -1:
4356             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4357                            "Useless localization of %s", OP_DESC(o));
4358         }
4359     }
4360     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4361              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4362         o->op_flags |= OPf_REF;
4363     return o;
4364 }
4365
4366 STATIC bool
4367 S_scalar_mod_type(const OP *o, I32 type)
4368 {
4369     switch (type) {
4370     case OP_POS:
4371     case OP_SASSIGN:
4372         if (o && o->op_type == OP_RV2GV)
4373             return FALSE;
4374         /* FALLTHROUGH */
4375     case OP_PREINC:
4376     case OP_PREDEC:
4377     case OP_POSTINC:
4378     case OP_POSTDEC:
4379     case OP_I_PREINC:
4380     case OP_I_PREDEC:
4381     case OP_I_POSTINC:
4382     case OP_I_POSTDEC:
4383     case OP_POW:
4384     case OP_MULTIPLY:
4385     case OP_DIVIDE:
4386     case OP_MODULO:
4387     case OP_REPEAT:
4388     case OP_ADD:
4389     case OP_SUBTRACT:
4390     case OP_I_MULTIPLY:
4391     case OP_I_DIVIDE:
4392     case OP_I_MODULO:
4393     case OP_I_ADD:
4394     case OP_I_SUBTRACT:
4395     case OP_LEFT_SHIFT:
4396     case OP_RIGHT_SHIFT:
4397     case OP_BIT_AND:
4398     case OP_BIT_XOR:
4399     case OP_BIT_OR:
4400     case OP_NBIT_AND:
4401     case OP_NBIT_XOR:
4402     case OP_NBIT_OR:
4403     case OP_SBIT_AND:
4404     case OP_SBIT_XOR:
4405     case OP_SBIT_OR:
4406     case OP_CONCAT:
4407     case OP_SUBST:
4408     case OP_TRANS:
4409     case OP_TRANSR:
4410     case OP_READ:
4411     case OP_SYSREAD:
4412     case OP_RECV:
4413     case OP_ANDASSIGN:
4414     case OP_ORASSIGN:
4415     case OP_DORASSIGN:
4416     case OP_VEC:
4417     case OP_SUBSTR:
4418         return TRUE;
4419     default:
4420         return FALSE;
4421     }
4422 }
4423
4424 STATIC bool
4425 S_is_handle_constructor(const OP *o, I32 numargs)
4426 {
4427     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4428
4429     switch (o->op_type) {
4430     case OP_PIPE_OP:
4431     case OP_SOCKPAIR:
4432         if (numargs == 2)
4433             return TRUE;
4434         /* FALLTHROUGH */
4435     case OP_SYSOPEN:
4436     case OP_OPEN:
4437     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4438     case OP_SOCKET:
4439     case OP_OPEN_DIR:
4440     case OP_ACCEPT:
4441         if (numargs == 1)
4442             return TRUE;
4443         /* FALLTHROUGH */
4444     default:
4445         return FALSE;
4446     }
4447 }
4448
4449 static OP *
4450 S_refkids(pTHX_ OP *o, I32 type)
4451 {
4452     if (o && o->op_flags & OPf_KIDS) {
4453         OP *kid;
4454         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4455             ref(kid, type);
4456     }
4457     return o;
4458 }
4459
4460 OP *
4461 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4462 {
4463     dVAR;
4464     OP *kid;
4465
4466     PERL_ARGS_ASSERT_DOREF;
4467
4468     if (PL_parser && PL_parser->error_count)
4469         return o;
4470
4471     switch (o->op_type) {
4472     case OP_ENTERSUB:
4473         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4474             !(o->op_flags & OPf_STACKED)) {
4475             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4476             assert(cUNOPo->op_first->op_type == OP_NULL);
4477             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4478             o->op_flags |= OPf_SPECIAL;
4479         }
4480         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4481             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4482                               : type == OP_RV2HV ? OPpDEREF_HV
4483                               : OPpDEREF_SV);
4484             o->op_flags |= OPf_MOD;
4485         }
4486
4487         break;
4488
4489     case OP_COND_EXPR:
4490         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4491             doref(kid, type, set_op_ref);
4492         break;
4493     case OP_RV2SV:
4494         if (type == OP_DEFINED)
4495             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4496         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4497         /* FALLTHROUGH */
4498     case OP_PADSV:
4499         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4500             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4501                               : type == OP_RV2HV ? OPpDEREF_HV
4502                               : OPpDEREF_SV);
4503             o->op_flags |= OPf_MOD;
4504         }
4505         break;
4506
4507     case OP_RV2AV:
4508     case OP_RV2HV:
4509         if (set_op_ref)
4510             o->op_flags |= OPf_REF;
4511         /* FALLTHROUGH */
4512     case OP_RV2GV:
4513         if (type == OP_DEFINED)
4514             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4515         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4516         break;
4517
4518     case OP_PADAV:
4519     case OP_PADHV:
4520         if (set_op_ref)
4521             o->op_flags |= OPf_REF;
4522         break;
4523
4524     case OP_SCALAR:
4525     case OP_NULL:
4526         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4527             break;
4528         doref(cBINOPo->op_first, type, set_op_ref);
4529         break;
4530     case OP_AELEM:
4531     case OP_HELEM:
4532         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4533         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4534             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4535                               : type == OP_RV2HV ? OPpDEREF_HV
4536                               : OPpDEREF_SV);
4537             o->op_flags |= OPf_MOD;
4538         }
4539         break;
4540
4541     case OP_SCOPE:
4542     case OP_LEAVE:
4543         set_op_ref = FALSE;
4544         /* FALLTHROUGH */
4545     case OP_ENTER:
4546     case OP_LIST:
4547         if (!(o->op_flags & OPf_KIDS))
4548             break;
4549         doref(cLISTOPo->op_last, type, set_op_ref);
4550         break;
4551     default:
4552         break;
4553     }
4554     return scalar(o);
4555
4556 }
4557
4558 STATIC OP *
4559 S_dup_attrlist(pTHX_ OP *o)
4560 {
4561     OP *rop;
4562
4563     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4564
4565     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4566      * where the first kid is OP_PUSHMARK and the remaining ones
4567      * are OP_CONST.  We need to push the OP_CONST values.
4568      */
4569     if (o->op_type == OP_CONST)
4570         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4571     else {
4572         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4573         rop = NULL;
4574         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4575             if (o->op_type == OP_CONST)
4576                 rop = op_append_elem(OP_LIST, rop,
4577                                   newSVOP(OP_CONST, o->op_flags,
4578                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4579         }
4580     }
4581     return rop;
4582 }
4583
4584 STATIC void
4585 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4586 {
4587     PERL_ARGS_ASSERT_APPLY_ATTRS;
4588     {
4589         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4590
4591         /* fake up C<use attributes $pkg,$rv,@attrs> */
4592
4593 #define ATTRSMODULE "attributes"
4594 #define ATTRSMODULE_PM "attributes.pm"
4595
4596         Perl_load_module(
4597           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4598           newSVpvs(ATTRSMODULE),
4599           NULL,
4600           op_prepend_elem(OP_LIST,
4601                           newSVOP(OP_CONST, 0, stashsv),
4602                           op_prepend_elem(OP_LIST,
4603                                           newSVOP(OP_CONST, 0,
4604                                                   newRV(target)),
4605                                           dup_attrlist(attrs))));
4606     }
4607 }
4608
4609 STATIC void
4610 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4611 {
4612     OP *pack, *imop, *arg;
4613     SV *meth, *stashsv, **svp;
4614
4615     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4616
4617     if (!attrs)
4618         return;
4619
4620     assert(target->op_type == OP_PADSV ||
4621            target->op_type == OP_PADHV ||
4622            target->op_type == OP_PADAV);
4623
4624     /* Ensure that attributes.pm is loaded. */
4625     /* Don't force the C<use> if we don't need it. */
4626     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4627     if (svp && *svp != &PL_sv_undef)
4628         NOOP;   /* already in %INC */
4629     else
4630         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4631                                newSVpvs(ATTRSMODULE), NULL);
4632
4633     /* Need package name for method call. */
4634     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4635
4636     /* Build up the real arg-list. */
4637     stashsv = newSVhek(HvNAME_HEK(stash));
4638
4639     arg = newOP(OP_PADSV, 0);
4640     arg->op_targ = target->op_targ;
4641     arg = op_prepend_elem(OP_LIST,
4642                        newSVOP(OP_CONST, 0, stashsv),
4643                        op_prepend_elem(OP_LIST,
4644                                     newUNOP(OP_REFGEN, 0,
4645                                             arg),
4646                                     dup_attrlist(attrs)));
4647
4648     /* Fake up a method call to import */
4649     meth = newSVpvs_share("import");
4650     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4651                    op_append_elem(OP_LIST,
4652                                op_prepend_elem(OP_LIST, pack, arg),
4653                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4654
4655     /* Combine the ops. */
4656     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4657 }
4658
4659 /*
4660 =notfor apidoc apply_attrs_string
4661
4662 Attempts to apply a list of attributes specified by the C<attrstr> and
4663 C<len> arguments to the subroutine identified by the C<cv> argument which
4664 is expected to be associated with the package identified by the C<stashpv>
4665 argument (see L<attributes>).  It gets this wrong, though, in that it
4666 does not correctly identify the boundaries of the individual attribute
4667 specifications within C<attrstr>.  This is not really intended for the
4668 public API, but has to be listed here for systems such as AIX which
4669 need an explicit export list for symbols.  (It's called from XS code
4670 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4671 to respect attribute syntax properly would be welcome.
4672
4673 =cut
4674 */
4675
4676 void
4677 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4678                         const char *attrstr, STRLEN len)
4679 {
4680     OP *attrs = NULL;
4681
4682     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4683
4684     if (!len) {
4685         len = strlen(attrstr);
4686     }
4687
4688     while (len) {
4689         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4690         if (len) {
4691             const char * const sstr = attrstr;
4692             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4693             attrs = op_append_elem(OP_LIST, attrs,
4694                                 newSVOP(OP_CONST, 0,
4695                                         newSVpvn(sstr, attrstr-sstr)));
4696         }
4697     }
4698
4699     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4700                      newSVpvs(ATTRSMODULE),
4701                      NULL, op_prepend_elem(OP_LIST,
4702                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4703                                   op_prepend_elem(OP_LIST,
4704                                                newSVOP(OP_CONST, 0,
4705                                                        newRV(MUTABLE_SV(cv))),
4706                                                attrs)));
4707 }
4708
4709 STATIC void
4710 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4711                         bool curstash)
4712 {
4713     OP *new_proto = NULL;
4714     STRLEN pvlen;
4715     char *pv;
4716     OP *o;
4717
4718     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4719
4720     if (!*attrs)
4721         return;
4722
4723     o = *attrs;
4724     if (o->op_type == OP_CONST) {
4725         pv = SvPV(cSVOPo_sv, pvlen);
4726         if (memBEGINs(pv, pvlen, "prototype(")) {
4727             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4728             SV ** const tmpo = cSVOPx_svp(o);
4729             SvREFCNT_dec(cSVOPo_sv);
4730             *tmpo = tmpsv;
4731             new_proto = o;
4732             *attrs = NULL;
4733         }
4734     } else if (o->op_type == OP_LIST) {
4735         OP * lasto;
4736         assert(o->op_flags & OPf_KIDS);
4737         lasto = cLISTOPo->op_first;
4738         assert(lasto->op_type == OP_PUSHMARK);
4739         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4740             if (o->op_type == OP_CONST) {
4741                 pv = SvPV(cSVOPo_sv, pvlen);
4742                 if (memBEGINs(pv, pvlen, "prototype(")) {
4743                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4744                     SV ** const tmpo = cSVOPx_svp(o);
4745                     SvREFCNT_dec(cSVOPo_sv);
4746                     *tmpo = tmpsv;
4747                     if (new_proto && ckWARN(WARN_MISC)) {
4748                         STRLEN new_len;
4749                         const char * newp = SvPV(cSVOPo_sv, new_len);
4750                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4751                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4752                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4753                         op_free(new_proto);
4754                     }
4755                     else if (new_proto)
4756                         op_free(new_proto);
4757                     new_proto = o;
4758                     /* excise new_proto from the list */
4759                     op_sibling_splice(*attrs, lasto, 1, NULL);
4760                     o = lasto;
4761                     continue;
4762                 }
4763             }
4764             lasto = o;
4765         }
4766         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4767            would get pulled in with no real need */
4768         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4769             op_free(*attrs);
4770             *attrs = NULL;
4771         }
4772     }
4773
4774     if (new_proto) {
4775         SV *svname;
4776         if (isGV(name)) {
4777             svname = sv_newmortal();
4778             gv_efullname3(svname, name, NULL);
4779         }
4780         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4781             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4782         else
4783             svname = (SV *)name;
4784         if (ckWARN(WARN_ILLEGALPROTO))
4785             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4786                                  curstash);
4787         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4788             STRLEN old_len, new_len;
4789             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4790             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4791
4792             if (curstash && svname == (SV *)name
4793              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4794                 svname = sv_2mortal(newSVsv(PL_curstname));
4795                 sv_catpvs(svname, "::");
4796                 sv_catsv(svname, (SV *)name);
4797             }
4798
4799             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4800                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4801                 " in %" SVf,
4802                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4803                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4804                 SVfARG(svname));
4805         }
4806         if (*proto)
4807             op_free(*proto);
4808         *proto = new_proto;
4809     }
4810 }
4811
4812 static void
4813 S_cant_declare(pTHX_ OP *o)
4814 {
4815     if (o->op_type == OP_NULL
4816      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4817         o = cUNOPo->op_first;
4818     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4819                              o->op_type == OP_NULL
4820                                && o->op_flags & OPf_SPECIAL
4821                                  ? "do block"
4822                                  : OP_DESC(o),
4823                              PL_parser->in_my == KEY_our   ? "our"   :
4824                              PL_parser->in_my == KEY_state ? "state" :
4825                                                              "my"));
4826 }
4827
4828 STATIC OP *
4829 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4830 {
4831     I32 type;
4832     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4833
4834     PERL_ARGS_ASSERT_MY_KID;
4835
4836     if (!o || (PL_parser && PL_parser->error_count))
4837         return o;
4838
4839     type = o->op_type;
4840
4841     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4842         OP *kid;
4843         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4844             my_kid(kid, attrs, imopsp);
4845         return o;
4846     } else if (type == OP_UNDEF || type == OP_STUB) {
4847         return o;
4848     } else if (type == OP_RV2SV ||      /* "our" declaration */
4849                type == OP_RV2AV ||
4850                type == OP_RV2HV) {
4851         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4852             S_cant_declare(aTHX_ o);
4853         } else if (attrs) {
4854             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4855             assert(PL_parser);
4856             PL_parser->in_my = FALSE;
4857             PL_parser->in_my_stash = NULL;
4858             apply_attrs(GvSTASH(gv),
4859                         (type == OP_RV2SV ? GvSVn(gv) :
4860                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4861                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4862                         attrs);
4863         }
4864         o->op_private |= OPpOUR_INTRO;
4865         return o;
4866     }
4867     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4868         if (!FEATURE_MYREF_IS_ENABLED)
4869             Perl_croak(aTHX_ "The experimental declared_refs "
4870                              "feature is not enabled");
4871         Perl_ck_warner_d(aTHX_
4872              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4873             "Declaring references is experimental");
4874         /* Kid is a nulled OP_LIST, handled above.  */
4875         my_kid(cUNOPo->op_first, attrs, imopsp);
4876         return o;
4877     }
4878     else if (type != OP_PADSV &&
4879              type != OP_PADAV &&
4880              type != OP_PADHV &&
4881              type != OP_PUSHMARK)
4882     {
4883         S_cant_declare(aTHX_ o);
4884         return o;
4885     }
4886     else if (attrs && type != OP_PUSHMARK) {
4887         HV *stash;
4888
4889         assert(PL_parser);
4890         PL_parser->in_my = FALSE;
4891         PL_parser->in_my_stash = NULL;
4892
4893         /* check for C<my Dog $spot> when deciding package */
4894         stash = PAD_COMPNAME_TYPE(o->op_targ);
4895         if (!stash)
4896             stash = PL_curstash;
4897         apply_attrs_my(stash, o, attrs, imopsp);
4898     }
4899     o->op_flags |= OPf_MOD;
4900     o->op_private |= OPpLVAL_INTRO;
4901     if (stately)
4902         o->op_private |= OPpPAD_STATE;
4903     return o;
4904 }
4905
4906 OP *
4907 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4908 {
4909     OP *rops;
4910     int maybe_scalar = 0;
4911
4912     PERL_ARGS_ASSERT_MY_ATTRS;
4913
4914 /* [perl #17376]: this appears to be premature, and results in code such as
4915    C< our(%x); > executing in list mode rather than void mode */
4916 #if 0
4917     if (o->op_flags & OPf_PARENS)
4918         list(o);
4919     else
4920         maybe_scalar = 1;
4921 #else
4922     maybe_scalar = 1;
4923 #endif
4924     if (attrs)
4925         SAVEFREEOP(attrs);
4926     rops = NULL;
4927     o = my_kid(o, attrs, &rops);
4928     if (rops) {
4929         if (maybe_scalar && o->op_type == OP_PADSV) {
4930             o = scalar(op_append_list(OP_LIST, rops, o));
4931             o->op_private |= OPpLVAL_INTRO;
4932         }
4933         else {
4934             /* The listop in rops might have a pushmark at the beginning,
4935                which will mess up list assignment. */
4936             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4937             if (rops->op_type == OP_LIST &&
4938                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4939             {
4940                 OP * const pushmark = lrops->op_first;
4941                 /* excise pushmark */
4942                 op_sibling_splice(rops, NULL, 1, NULL);
4943                 op_free(pushmark);
4944             }
4945             o = op_append_list(OP_LIST, o, rops);
4946         }
4947     }
4948     PL_parser->in_my = FALSE;
4949     PL_parser->in_my_stash = NULL;
4950     return o;
4951 }
4952
4953 OP *
4954 Perl_sawparens(pTHX_ OP *o)
4955 {
4956     PERL_UNUSED_CONTEXT;
4957     if (o)
4958         o->op_flags |= OPf_PARENS;
4959     return o;
4960 }
4961
4962 OP *
4963 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4964 {
4965     OP *o;
4966     bool ismatchop = 0;
4967     const OPCODE ltype = left->op_type;
4968     const OPCODE rtype = right->op_type;
4969
4970     PERL_ARGS_ASSERT_BIND_MATCH;
4971
4972     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4973           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4974     {
4975       const char * const desc
4976           = PL_op_desc[(
4977                           rtype == OP_SUBST || rtype == OP_TRANS
4978                        || rtype == OP_TRANSR
4979                        )
4980                        ? (int)rtype : OP_MATCH];
4981       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4982       SV * const name =
4983         S_op_varname(aTHX_ left);
4984       if (name)
4985         Perl_warner(aTHX_ packWARN(WARN_MISC),
4986              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4987              desc, SVfARG(name), SVfARG(name));
4988       else {
4989         const char * const sample = (isary
4990              ? "@array" : "%hash");
4991         Perl_warner(aTHX_ packWARN(WARN_MISC),
4992              "Applying %s to %s will act on scalar(%s)",
4993              desc, sample, sample);
4994       }
4995     }
4996
4997     if (rtype == OP_CONST &&
4998         cSVOPx(right)->op_private & OPpCONST_BARE &&
4999         cSVOPx(right)->op_private & OPpCONST_STRICT)
5000     {
5001         no_bareword_allowed(right);
5002     }
5003
5004     /* !~ doesn't make sense with /r, so error on it for now */
5005     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5006         type == OP_NOT)
5007         /* diag_listed_as: Using !~ with %s doesn't make sense */
5008         yyerror("Using !~ with s///r doesn't make sense");
5009     if (rtype == OP_TRANSR && type == OP_NOT)
5010         /* diag_listed_as: Using !~ with %s doesn't make sense */
5011         yyerror("Using !~ with tr///r doesn't make sense");
5012
5013     ismatchop = (rtype == OP_MATCH ||
5014                  rtype == OP_SUBST ||
5015                  rtype == OP_TRANS || rtype == OP_TRANSR)
5016              && !(right->op_flags & OPf_SPECIAL);
5017     if (ismatchop && right->op_private & OPpTARGET_MY) {
5018         right->op_targ = 0;
5019         right->op_private &= ~OPpTARGET_MY;
5020     }
5021     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5022         if (left->op_type == OP_PADSV
5023          && !(left->op_private & OPpLVAL_INTRO))
5024         {
5025             right->op_targ = left->op_targ;
5026             op_free(left);
5027             o = right;
5028         }
5029         else {
5030             right->op_flags |= OPf_STACKED;
5031             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5032             ! (rtype == OP_TRANS &&
5033                right->op_private & OPpTRANS_IDENTICAL) &&
5034             ! (rtype == OP_SUBST &&
5035                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5036                 left = op_lvalue(left, rtype);
5037             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5038                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5039             else
5040                 o = op_prepend_elem(rtype, scalar(left), right);
5041         }
5042         if (type == OP_NOT)
5043             return newUNOP(OP_NOT, 0, scalar(o));
5044         return o;
5045     }
5046     else
5047         return bind_match(type, left,
5048                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5049 }
5050
5051 OP *
5052 Perl_invert(pTHX_ OP *o)
5053 {
5054     if (!o)
5055         return NULL;
5056     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5057 }
5058
5059 /*
5060 =for apidoc Amx|OP *|op_scope|OP *o
5061
5062 Wraps up an op tree with some additional ops so that at runtime a dynamic
5063 scope will be created.  The original ops run in the new dynamic scope,
5064 and then, provided that they exit normally, the scope will be unwound.
5065 The additional ops used to create and unwind the dynamic scope will
5066 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5067 instead if the ops are simple enough to not need the full dynamic scope
5068 structure.
5069
5070 =cut
5071 */
5072
5073 OP *
5074 Perl_op_scope(pTHX_ OP *o)
5075 {
5076     dVAR;
5077     if (o) {
5078         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5079             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5080             OpTYPE_set(o, OP_LEAVE);
5081         }
5082         else if (o->op_type == OP_LINESEQ) {
5083             OP *kid;
5084             OpTYPE_set(o, OP_SCOPE);
5085             kid = ((LISTOP*)o)->op_first;
5086             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5087                 op_null(kid);
5088
5089                 /* The following deals with things like 'do {1 for 1}' */
5090                 kid = OpSIBLING(kid);
5091                 if (kid &&
5092                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5093                     op_null(kid);
5094             }
5095         }
5096         else
5097             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5098     }
5099     return o;
5100 }
5101
5102 OP *
5103 Perl_op_unscope(pTHX_ OP *o)
5104 {
5105     if (o && o->op_type == OP_LINESEQ) {
5106         OP *kid = cLISTOPo->op_first;
5107         for(; kid; kid = OpSIBLING(kid))
5108             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5109                 op_null(kid);
5110     }
5111     return o;
5112 }
5113
5114 /*
5115 =for apidoc Am|int|block_start|int full
5116
5117 Handles compile-time scope entry.
5118 Arranges for hints to be restored on block
5119 exit and also handles pad sequence numbers to make lexical variables scope
5120 right.  Returns a savestack index for use with C<block_end>.
5121
5122 =cut
5123 */
5124
5125 int
5126 Perl_block_start(pTHX_ int full)
5127 {
5128     const int retval = PL_savestack_ix;
5129
5130     PL_compiling.cop_seq = PL_cop_seqmax;
5131     COP_SEQMAX_INC;
5132     pad_block_start(full);
5133     SAVEHINTS();
5134     PL_hints &= ~HINT_BLOCK_SCOPE;
5135     SAVECOMPILEWARNINGS();
5136     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5137     SAVEI32(PL_compiling.cop_seq);
5138     PL_compiling.cop_seq = 0;
5139
5140     CALL_BLOCK_HOOKS(bhk_start, full);
5141
5142     return retval;
5143 }
5144
5145 /*
5146 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5147
5148 Handles compile-time scope exit.  C<floor>
5149 is the savestack index returned by
5150 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5151 possibly modified.
5152
5153 =cut
5154 */
5155
5156 OP*
5157 Perl_block_end(pTHX_ I32 floor, OP *seq)
5158 {
5159     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5160     OP* retval = scalarseq(seq);
5161     OP *o;
5162
5163     /* XXX Is the null PL_parser check necessary here? */
5164     assert(PL_parser); /* Let’s find out under debugging builds.  */
5165     if (PL_parser && PL_parser->parsed_sub) {
5166         o = newSTATEOP(0, NULL, NULL);
5167         op_null(o);
5168         retval = op_append_elem(OP_LINESEQ, retval, o);
5169     }
5170
5171     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5172
5173     LEAVE_SCOPE(floor);
5174     if (needblockscope)
5175         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5176     o = pad_leavemy();
5177
5178     if (o) {
5179         /* pad_leavemy has created a sequence of introcv ops for all my
5180            subs declared in the block.  We have to replicate that list with
5181            clonecv ops, to deal with this situation:
5182
5183                sub {
5184                    my sub s1;
5185                    my sub s2;
5186                    sub s1 { state sub foo { \&s2 } }
5187                }->()
5188
5189            Originally, I was going to have introcv clone the CV and turn
5190            off the stale flag.  Since &s1 is declared before &s2, the
5191            introcv op for &s1 is executed (on sub entry) before the one for
5192            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5193            cloned, since it is a state sub) closes over &s2 and expects
5194            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5195            then &s2 is still marked stale.  Since &s1 is not active, and
5196            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5197            ble will not stay shared’ warning.  Because it is the same stub
5198            that will be used when the introcv op for &s2 is executed, clos-
5199            ing over it is safe.  Hence, we have to turn off the stale flag
5200            on all lexical subs in the block before we clone any of them.
5201            Hence, having introcv clone the sub cannot work.  So we create a
5202            list of ops like this:
5203
5204                lineseq
5205                   |
5206                   +-- introcv
5207                   |
5208                   +-- introcv
5209                   |
5210                   +-- introcv
5211                   |
5212                   .
5213                   .
5214                   .
5215                   |
5216                   +-- clonecv
5217                   |
5218                   +-- clonecv
5219                   |
5220                   +-- clonecv
5221                   |
5222                   .
5223                   .
5224                   .
5225          */
5226         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5227         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5228         for (;; kid = OpSIBLING(kid)) {
5229             OP *newkid = newOP(OP_CLONECV, 0);
5230             newkid->op_targ = kid->op_targ;
5231             o = op_append_elem(OP_LINESEQ, o, newkid);
5232             if (kid == last) break;
5233         }
5234         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5235     }
5236
5237     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5238
5239     return retval;
5240 }
5241
5242 /*
5243 =head1 Compile-time scope hooks
5244
5245 =for apidoc Aox||blockhook_register
5246
5247 Register a set of hooks to be called when the Perl lexical scope changes
5248 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5249
5250 =cut
5251 */
5252
5253 void
5254 Perl_blockhook_register(pTHX_ BHK *hk)
5255 {
5256     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5257
5258     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5259 }
5260
5261 void
5262 Perl_newPROG(pTHX_ OP *o)
5263 {
5264     OP *start;
5265
5266     PERL_ARGS_ASSERT_NEWPROG;
5267
5268     if (PL_in_eval) {
5269         PERL_CONTEXT *cx;
5270         I32 i;
5271         if (PL_eval_root)
5272                 return;
5273         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5274                                ((PL_in_eval & EVAL_KEEPERR)
5275                                 ? OPf_SPECIAL : 0), o);
5276
5277         cx = CX_CUR();
5278         assert(CxTYPE(cx) == CXt_EVAL);
5279
5280         if ((cx->blk_gimme & G_WANT) == G_VOID)
5281             scalarvoid(PL_eval_root);
5282         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5283             list(PL_eval_root);
5284         else
5285             scalar(PL_eval_root);
5286
5287         start = op_linklist(PL_eval_root);
5288         PL_eval_root->op_next = 0;
5289         i = PL_savestack_ix;
5290         SAVEFREEOP(o);
5291         ENTER;
5292         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5293         LEAVE;
5294         PL_savestack_ix = i;
5295     }
5296     else {
5297         if (o->op_type == OP_STUB) {
5298             /* This block is entered if nothing is compiled for the main
5299                program. This will be the case for an genuinely empty main
5300                program, or one which only has BEGIN blocks etc, so already
5301                run and freed.
5302
5303                Historically (5.000) the guard above was !o. However, commit
5304                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5305                c71fccf11fde0068, changed perly.y so that newPROG() is now
5306                called with the output of block_end(), which returns a new
5307                OP_STUB for the case of an empty optree. ByteLoader (and
5308                maybe other things) also take this path, because they set up
5309                PL_main_start and PL_main_root directly, without generating an
5310                optree.
5311
5312                If the parsing the main program aborts (due to parse errors,
5313                or due to BEGIN or similar calling exit), then newPROG()
5314                isn't even called, and hence this code path and its cleanups
5315                are skipped. This shouldn't make a make a difference:
5316                * a non-zero return from perl_parse is a failure, and
5317                  perl_destruct() should be called immediately.
5318                * however, if exit(0) is called during the parse, then
5319                  perl_parse() returns 0, and perl_run() is called. As
5320                  PL_main_start will be NULL, perl_run() will return
5321                  promptly, and the exit code will remain 0.
5322             */
5323
5324             PL_comppad_name = 0;
5325             PL_compcv = 0;
5326             S_op_destroy(aTHX_ o);
5327             return;
5328         }
5329         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5330         PL_curcop = &PL_compiling;
5331         start = LINKLIST(PL_main_root);
5332         PL_main_root->op_next = 0;
5333         S_process_optree(aTHX_ NULL, PL_main_root, start);
5334         cv_forget_slab(PL_compcv);
5335         PL_compcv = 0;
5336
5337         /* Register with debugger */
5338         if (PERLDB_INTER) {
5339             CV * const cv = get_cvs("DB::postponed", 0);
5340             if (cv) {
5341                 dSP;
5342                 PUSHMARK(SP);
5343                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5344                 PUTBACK;
5345                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5346             }
5347         }
5348     }
5349 }
5350
5351 OP *
5352 Perl_localize(pTHX_ OP *o, I32 lex)
5353 {
5354     PERL_ARGS_ASSERT_LOCALIZE;
5355
5356     if (o->op_flags & OPf_PARENS)
5357 /* [perl #17376]: this appears to be premature, and results in code such as
5358    C< our(%x); > executing in list mode rather than void mode */
5359 #if 0
5360         list(o);
5361 #else
5362         NOOP;
5363 #endif
5364     else {
5365         if ( PL_parser->bufptr > PL_parser->oldbufptr
5366             && PL_parser->bufptr[-1] == ','
5367             && ckWARN(WARN_PARENTHESIS))
5368         {
5369             char *s = PL_parser->bufptr;
5370             bool sigil = FALSE;
5371
5372             /* some heuristics to detect a potential error */
5373             while (*s && (strchr(", \t\n", *s)))
5374                 s++;
5375
5376             while (1) {
5377                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5378                        && *++s
5379                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5380                     s++;
5381                     sigil = TRUE;
5382                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5383                         s++;
5384                     while (*s && (strchr(", \t\n", *s)))
5385                         s++;
5386                 }
5387                 else
5388                     break;
5389             }
5390             if (sigil && (*s == ';' || *s == '=')) {
5391                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5392                                 "Parentheses missing around \"%s\" list",
5393                                 lex
5394                                     ? (PL_parser->in_my == KEY_our
5395                                         ? "our"
5396                                         : PL_parser->in_my == KEY_state
5397                                             ? "state"
5398                                             : "my")
5399                                     : "local");
5400             }
5401         }
5402     }
5403     if (lex)
5404         o = my(o);
5405     else
5406         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5407     PL_parser->in_my = FALSE;
5408     PL_parser->in_my_stash = NULL;
5409     return o;
5410 }
5411
5412 OP *
5413 Perl_jmaybe(pTHX_ OP *o)
5414 {
5415     PERL_ARGS_ASSERT_JMAYBE;
5416
5417     if (o->op_type == OP_LIST) {
5418         OP * const o2
5419             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5420         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5421     }
5422     return o;
5423 }
5424
5425 PERL_STATIC_INLINE OP *
5426 S_op_std_init(pTHX_ OP *o)
5427 {
5428     I32 type = o->op_type;
5429
5430     PERL_ARGS_ASSERT_OP_STD_INIT;
5431
5432     if (PL_opargs[type] & OA_RETSCALAR)
5433         scalar(o);
5434     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5435         o->op_targ = pad_alloc(type, SVs_PADTMP);
5436
5437     return o;
5438 }
5439
5440 PERL_STATIC_INLINE OP *
5441 S_op_integerize(pTHX_ OP *o)
5442 {
5443     I32 type = o->op_type;
5444
5445     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5446
5447     /* integerize op. */
5448     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5449     {
5450         dVAR;
5451         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5452     }
5453
5454     if (type == OP_NEGATE)
5455         /* XXX might want a ck_negate() for this */
5456         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5457
5458     return o;
5459 }
5460
5461 static OP *
5462 S_fold_constants(pTHX_ OP *const o)
5463 {
5464     dVAR;
5465     OP * volatile curop;
5466     OP *newop;
5467     volatile I32 type = o->op_type;
5468     bool is_stringify;
5469     SV * volatile sv = NULL;
5470     int ret = 0;
5471     OP *old_next;
5472     SV * const oldwarnhook = PL_warnhook;
5473     SV * const olddiehook  = PL_diehook;
5474     COP not_compiling;
5475     U8 oldwarn = PL_dowarn;
5476     I32 old_cxix;
5477     dJMPENV;
5478
5479     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5480
5481     if (!(PL_opargs[type] & OA_FOLDCONST))
5482         goto nope;
5483
5484     switch (type) {
5485     case OP_UCFIRST:
5486     case OP_LCFIRST:
5487     case OP_UC:
5488     case OP_LC:
5489     case OP_FC:
5490 #ifdef USE_LOCALE_CTYPE
5491         if (IN_LC_COMPILETIME(LC_CTYPE))
5492             goto nope;
5493 #endif
5494         break;
5495     case OP_SLT:
5496     case OP_SGT:
5497     case OP_SLE:
5498     case OP_SGE:
5499     case OP_SCMP:
5500 #ifdef USE_LOCALE_COLLATE
5501         if (IN_LC_COMPILETIME(LC_COLLATE))
5502             goto nope;
5503 #endif
5504         break;
5505     case OP_SPRINTF:
5506         /* XXX what about the numeric ops? */
5507 #ifdef USE_LOCALE_NUMERIC
5508         if (IN_LC_COMPILETIME(LC_NUMERIC))
5509             goto nope;
5510 #endif
5511         break;
5512     case OP_PACK:
5513         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5514           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5515             goto nope;
5516         {
5517             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5518             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5519             {
5520                 const char *s = SvPVX_const(sv);
5521                 while (s < SvEND(sv)) {
5522                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5523                     s++;
5524                 }
5525             }
5526         }
5527         break;
5528     case OP_REPEAT:
5529         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5530         break;
5531     case OP_SREFGEN:
5532         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5533          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5534             goto nope;
5535     }
5536
5537     if (PL_parser && PL_parser->error_count)
5538         goto nope;              /* Don't try to run w/ errors */
5539
5540     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5541         switch (curop->op_type) {
5542         case OP_CONST:
5543             if (   (curop->op_private & OPpCONST_BARE)
5544                 && (curop->op_private & OPpCONST_STRICT)) {
5545                 no_bareword_allowed(curop);
5546                 goto nope;
5547             }
5548             /* FALLTHROUGH */
5549         case OP_LIST:
5550         case OP_SCALAR:
5551         case OP_NULL:
5552         case OP_PUSHMARK:
5553             /* Foldable; move to next op in list */
5554             break;
5555
5556         default:
5557             /* No other op types are considered foldable */
5558             goto nope;
5559         }
5560     }
5561
5562     curop = LINKLIST(o);
5563     old_next = o->op_next;
5564     o->op_next = 0;
5565     PL_op = curop;
5566
5567     old_cxix = cxstack_ix;
5568     create_eval_scope(NULL, G_FAKINGEVAL);
5569
5570     /* Verify that we don't need to save it:  */
5571     assert(PL_curcop == &PL_compiling);
5572     StructCopy(&PL_compiling, &not_compiling, COP);
5573     PL_curcop = &not_compiling;
5574     /* The above ensures that we run with all the correct hints of the
5575        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5576     assert(IN_PERL_RUNTIME);
5577     PL_warnhook = PERL_WARNHOOK_FATAL;
5578     PL_diehook  = NULL;
5579     JMPENV_PUSH(ret);
5580
5581     /* Effective $^W=1.  */
5582     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5583         PL_dowarn |= G_WARN_ON;
5584
5585     switch (ret) {
5586     case 0:
5587         CALLRUNOPS(aTHX);
5588         sv = *(PL_stack_sp--);
5589         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5590             pad_swipe(o->op_targ,  FALSE);
5591         }
5592         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5593             SvREFCNT_inc_simple_void(sv);
5594             SvTEMP_off(sv);
5595         }
5596         else { assert(SvIMMORTAL(sv)); }
5597         break;
5598     case 3:
5599         /* Something tried to die.  Abandon constant folding.  */
5600         /* Pretend the error never happened.  */
5601         CLEAR_ERRSV();
5602         o->op_next = old_next;
5603         break;
5604     default:
5605         JMPENV_POP;
5606         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5607         PL_warnhook = oldwarnhook;
5608         PL_diehook  = olddiehook;
5609         /* XXX note that this croak may fail as we've already blown away
5610          * the stack - eg any nested evals */
5611         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5612     }
5613     JMPENV_POP;
5614     PL_dowarn   = oldwarn;
5615     PL_warnhook = oldwarnhook;
5616     PL_diehook  = olddiehook;
5617     PL_curcop = &PL_compiling;
5618
5619     /* if we croaked, depending on how we croaked the eval scope
5620      * may or may not have already been popped */
5621     if (cxstack_ix > old_cxix) {
5622         assert(cxstack_ix == old_cxix + 1);
5623         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5624         delete_eval_scope();
5625     }
5626     if (ret)
5627         goto nope;
5628
5629     /* OP_STRINGIFY and constant folding are used to implement qq.
5630        Here the constant folding is an implementation detail that we
5631        want to hide.  If the stringify op is itself already marked
5632        folded, however, then it is actually a folded join.  */
5633     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5634     op_free(o);
5635     assert(sv);
5636     if (is_stringify)
5637         SvPADTMP_off(sv);
5638     else if (!SvIMMORTAL(sv)) {
5639         SvPADTMP_on(sv);
5640         SvREADONLY_on(sv);
5641     }
5642     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5643     if (!is_stringify) newop->op_folded = 1;
5644     return newop;
5645
5646  nope:
5647     return o;
5648 }
5649
5650 static OP *
5651 S_gen_constant_list(pTHX_ OP *o)
5652 {
5653     dVAR;
5654     OP *curop, *old_next;
5655     SV * const oldwarnhook = PL_warnhook;
5656     SV * const olddiehook  = PL_diehook;
5657     COP *old_curcop;
5658     U8 oldwarn = PL_dowarn;
5659     SV **svp;
5660     AV *av;
5661     I32 old_cxix;
5662     COP not_compiling;
5663     int ret = 0;
5664     dJMPENV;
5665     bool op_was_null;
5666
5667     list(o);
5668     if (PL_parser && PL_parser->error_count)
5669         return o;               /* Don't attempt to run with errors */
5670
5671     curop = LINKLIST(o);
5672     old_next = o->op_next;
5673     o->op_next = 0;
5674     op_was_null = o->op_type == OP_NULL;
5675     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5676         o->op_type = OP_CUSTOM;
5677     CALL_PEEP(curop);
5678     if (op_was_null)
5679         o->op_type = OP_NULL;
5680     S_prune_chain_head(&curop);
5681     PL_op = curop;
5682
5683     old_cxix = cxstack_ix;
5684     create_eval_scope(NULL, G_FAKINGEVAL);
5685
5686     old_curcop = PL_curcop;
5687     StructCopy(old_curcop, &not_compiling, COP);
5688     PL_curcop = &not_compiling;
5689     /* The above ensures that we run with all the correct hints of the
5690        current COP, but that IN_PERL_RUNTIME is true. */
5691     assert(IN_PERL_RUNTIME);
5692     PL_warnhook = PERL_WARNHOOK_FATAL;
5693     PL_diehook  = NULL;
5694     JMPENV_PUSH(ret);
5695
5696     /* Effective $^W=1.  */
5697     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5698         PL_dowarn |= G_WARN_ON;
5699
5700     switch (ret) {
5701     case 0:
5702 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5703         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5704 #endif
5705         Perl_pp_pushmark(aTHX);
5706         CALLRUNOPS(aTHX);
5707         PL_op = curop;
5708         assert (!(curop->op_flags & OPf_SPECIAL));
5709         assert(curop->op_type == OP_RANGE);
5710         Perl_pp_anonlist(aTHX);
5711         break;
5712     case 3:
5713         CLEAR_ERRSV();
5714         o->op_next = old_next;
5715         break;
5716     default:
5717         JMPENV_POP;
5718         PL_warnhook = oldwarnhook;
5719         PL_diehook = olddiehook;
5720         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5721             ret);
5722     }
5723
5724     JMPENV_POP;
5725     PL_dowarn = oldwarn;
5726     PL_warnhook = oldwarnhook;
5727     PL_diehook = olddiehook;
5728     PL_curcop = old_curcop;
5729
5730     if (cxstack_ix > old_cxix) {
5731         assert(cxstack_ix == old_cxix + 1);
5732         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5733         delete_eval_scope();
5734     }
5735     if (ret)
5736         return o;
5737
5738     OpTYPE_set(o, OP_RV2AV);
5739     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5740     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5741     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5742     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5743
5744     /* replace subtree with an OP_CONST */
5745     curop = ((UNOP*)o)->op_first;
5746     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5747     op_free(curop);
5748
5749     if (AvFILLp(av) != -1)
5750         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5751         {
5752             SvPADTMP_on(*svp);
5753             SvREADONLY_on(*svp);
5754         }
5755     LINKLIST(o);
5756     return list(o);
5757 }
5758
5759 /*
5760 =head1 Optree Manipulation Functions
5761 */
5762
5763 /* List constructors */
5764
5765 /*
5766 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5767
5768 Append an item to the list of ops contained directly within a list-type
5769 op, returning the lengthened list.  C<first> is the list-type op,
5770 and C<last> is the op to append to the list.  C<optype> specifies the
5771 intended opcode for the list.  If C<first> is not already a list of the
5772 right type, it will be upgraded into one.  If either C<first> or C<last>
5773 is null, the other is returned unchanged.
5774
5775 =cut
5776 */
5777
5778 OP *
5779 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5780 {
5781     if (!first)
5782         return last;
5783
5784     if (!last)
5785         return first;
5786
5787     if (first->op_type != (unsigned)type
5788         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5789     {
5790         return newLISTOP(type, 0, first, last);
5791     }
5792
5793     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5794     first->op_flags |= OPf_KIDS;
5795     return first;
5796 }
5797
5798 /*
5799 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5800
5801 Concatenate the lists of ops contained directly within two list-type ops,
5802 returning the combined list.  C<first> and C<last> are the list-type ops
5803 to concatenate.  C<optype> specifies the intended opcode for the list.
5804 If either C<first> or C<last> is not already a list of the right type,
5805 it will be upgraded into one.  If either C<first> or C<last> is null,
5806 the other is returned unchanged.
5807
5808 =cut
5809 */
5810
5811 OP *
5812 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5813 {
5814     if (!first)
5815         return last;
5816
5817     if (!last)
5818         return first;
5819
5820     if (first->op_type != (unsigned)type)
5821         return op_prepend_elem(type, first, last);
5822
5823     if (last->op_type != (unsigned)type)
5824         return op_append_elem(type, first, last);
5825
5826     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5827     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5828     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5829     first->op_flags |= (last->op_flags & OPf_KIDS);
5830
5831     S_op_destroy(aTHX_ last);
5832
5833     return first;
5834 }
5835
5836 /*
5837 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5838
5839 Prepend an item to the list of ops contained directly within a list-type
5840 op, returning the lengthened list.  C<first> is the op to prepend to the
5841 list, and C<last> is the list-type op.  C<optype> specifies the intended
5842 opcode for the list.  If C<last> is not already a list of the right type,
5843 it will be upgraded into one.  If either C<first> or C<last> is null,
5844 the other is returned unchanged.
5845
5846 =cut
5847 */
5848
5849 OP *
5850 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5851 {
5852     if (!first)
5853         return last;
5854
5855     if (!last)
5856         return first;
5857
5858     if (last->op_type == (unsigned)type) {
5859         if (type == OP_LIST) {  /* already a PUSHMARK there */
5860             /* insert 'first' after pushmark */
5861             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5862             if (!(first->op_flags & OPf_PARENS))
5863                 last->op_flags &= ~OPf_PARENS;
5864         }
5865         else
5866             op_sibling_splice(last, NULL, 0, first);
5867         last->op_flags |= OPf_KIDS;
5868         return last;
5869     }
5870
5871     return newLISTOP(type, 0, first, last);
5872 }
5873
5874 /*
5875 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5876
5877 Converts C<o> into a list op if it is not one already, and then converts it
5878 into the specified C<type>, calling its check function, allocating a target if
5879 it needs one, and folding constants.
5880
5881 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5882 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5883 C<op_convert_list> to make it the right type.
5884
5885 =cut
5886 */
5887
5888 OP *
5889 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5890 {
5891     dVAR;
5892     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5893     if (!o || o->op_type != OP_LIST)
5894         o = force_list(o, 0);
5895     else
5896     {
5897         o->op_flags &= ~OPf_WANT;
5898         o->op_private &= ~OPpLVAL_INTRO;
5899     }
5900
5901     if (!(PL_opargs[type] & OA_MARK))
5902         op_null(cLISTOPo->op_first);
5903     else {
5904         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5905         if (kid2 && kid2->op_type == OP_COREARGS) {
5906             op_null(cLISTOPo->op_first);
5907             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5908         }
5909     }
5910
5911     if (type != OP_SPLIT)
5912         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5913          * ck_split() create a real PMOP and leave the op's type as listop
5914          * for now. Otherwise op_free() etc will crash.
5915          */
5916         OpTYPE_set(o, type);
5917
5918     o->op_flags |= flags;
5919     if (flags & OPf_FOLDED)
5920         o->op_folded = 1;
5921
5922     o = CHECKOP(type, o);
5923     if (o->op_type != (unsigned)type)
5924         return o;
5925
5926     return fold_constants(op_integerize(op_std_init(o)));
5927 }
5928
5929 /* Constructors */
5930
5931
5932 /*
5933 =head1 Optree construction
5934
5935 =for apidoc Am|OP *|newNULLLIST
5936
5937 Constructs, checks, and returns a new C<stub> op, which represents an
5938 empty list expression.
5939
5940 =cut
5941 */
5942
5943 OP *
5944 Perl_newNULLLIST(pTHX)
5945 {
5946     return newOP(OP_STUB, 0);
5947 }
5948
5949 /* promote o and any siblings to be a list if its not already; i.e.
5950  *
5951  *  o - A - B
5952  *
5953  * becomes
5954  *
5955  *  list
5956  *    |
5957  *  pushmark - o - A - B
5958  *
5959  * If nullit it true, the list op is nulled.
5960  */
5961
5962 static OP *
5963 S_force_list(pTHX_ OP *o, bool nullit)
5964 {
5965     if (!o || o->op_type != OP_LIST) {
5966         OP *rest = NULL;
5967         if (o) {
5968             /* manually detach any siblings then add them back later */
5969             rest = OpSIBLING(o);
5970             OpLASTSIB_set(o, NULL);
5971         }
5972         o = newLISTOP(OP_LIST, 0, o, NULL);
5973         if (rest)
5974             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5975     }
5976     if (nullit)
5977         op_null(o);
5978     return o;
5979 }
5980
5981 /*
5982 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5983
5984 Constructs, checks, and returns an op of any list type.  C<type> is
5985 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5986 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5987 supply up to two ops to be direct children of the list op; they are
5988 consumed by this function and become part of the constructed op tree.
5989
5990 For most list operators, the check function expects all the kid ops to be
5991 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5992 appropriate.  What you want to do in that case is create an op of type
5993 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5994 See L</op_convert_list> for more information.
5995
5996
5997 =cut
5998 */
5999
6000 OP *
6001 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6002 {
6003     dVAR;
6004     LISTOP *listop;
6005
6006     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6007         || type == OP_CUSTOM);
6008
6009     NewOp(1101, listop, 1, LISTOP);
6010
6011     OpTYPE_set(listop, type);
6012     if (first || last)
6013         flags |= OPf_KIDS;
6014     listop->op_flags = (U8)flags;
6015
6016     if (!last && first)
6017         last = first;
6018     else if (!first && last)
6019         first = last;
6020     else if (first)
6021         OpMORESIB_set(first, last);
6022     listop->op_first = first;
6023     listop->op_last = last;
6024     if (type == OP_LIST) {
6025         OP* const pushop = newOP(OP_PUSHMARK, 0);
6026         OpMORESIB_set(pushop, first);
6027         listop->op_first = pushop;
6028         listop->op_flags |= OPf_KIDS;
6029         if (!last)
6030             listop->op_last = pushop;
6031     }
6032     if (listop->op_last)
6033         OpLASTSIB_set(listop->op_last, (OP*)listop);
6034
6035     return CHECKOP(type, listop);
6036 }
6037
6038 /*
6039 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6040
6041 Constructs, checks, and returns an op of any base type (any type that
6042 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6043 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6044 of C<op_private>.
6045
6046 =cut
6047 */
6048
6049 OP *
6050 Perl_newOP(pTHX_ I32 type, I32 flags)
6051 {
6052     dVAR;
6053     OP *o;
6054
6055     if (type == -OP_ENTEREVAL) {
6056         type = OP_ENTEREVAL;
6057         flags |= OPpEVAL_BYTES<<8;
6058     }
6059
6060     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6061         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6062         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6063         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6064
6065     NewOp(1101, o, 1, OP);
6066     OpTYPE_set(o, type);
6067     o->op_flags = (U8)flags;
6068
6069     o->op_next = o;
6070     o->op_private = (U8)(0 | (flags >> 8));
6071     if (PL_opargs[type] & OA_RETSCALAR)
6072         scalar(o);
6073     if (PL_opargs[type] & OA_TARGET)
6074         o->op_targ = pad_alloc(type, SVs_PADTMP);
6075     return CHECKOP(type, o);
6076 }
6077
6078 /*
6079 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6080
6081 Constructs, checks, and returns an op of any unary type.  C<type> is
6082 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6083 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6084 bits, the eight bits of C<op_private>, except that the bit with value 1
6085 is automatically set.  C<first> supplies an optional op to be the direct
6086 child of the unary op; it is consumed by this function and become part
6087 of the constructed op tree.
6088
6089 =cut
6090 */
6091
6092 OP *
6093 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6094 {
6095     dVAR;
6096     UNOP *unop;
6097
6098     if (type == -OP_ENTEREVAL) {
6099         type = OP_ENTEREVAL;
6100         flags |= OPpEVAL_BYTES<<8;
6101     }
6102
6103     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6104         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6105         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6106         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6107         || type == OP_SASSIGN
6108         || type == OP_ENTERTRY
6109         || type == OP_CUSTOM
6110         || type == OP_NULL );
6111
6112     if (!first)
6113         first = newOP(OP_STUB, 0);
6114     if (PL_opargs[type] & OA_MARK)
6115         first = force_list(first, 1);
6116
6117     NewOp(1101, unop, 1, UNOP);
6118     OpTYPE_set(unop, type);
6119     unop->op_first = first;
6120     unop->op_flags = (U8)(flags | OPf_KIDS);
6121     unop->op_private = (U8)(1 | (flags >> 8));
6122
6123     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6124         OpLASTSIB_set(first, (OP*)unop);
6125
6126     unop = (UNOP*) CHECKOP(type, unop);
6127     if (unop->op_next)
6128         return (OP*)unop;
6129
6130     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6131 }
6132
6133 /*
6134 =for apidoc newUNOP_AUX
6135
6136 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6137 initialised to C<aux>
6138
6139 =cut
6140 */
6141
6142 OP *
6143 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6144 {
6145     dVAR;
6146     UNOP_AUX *unop;
6147
6148     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6149         || type == OP_CUSTOM);
6150
6151     NewOp(1101, unop, 1, UNOP_AUX);
6152     unop->op_type = (OPCODE)type;
6153     unop->op_ppaddr = PL_ppaddr[type];
6154     unop->op_first = first;
6155     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6156     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6157     unop->op_aux = aux;
6158
6159     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6160         OpLASTSIB_set(first, (OP*)unop);
6161
6162     unop = (UNOP_AUX*) CHECKOP(type, unop);
6163
6164     return op_std_init((OP *) unop);
6165 }
6166
6167 /*
6168 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6169
6170 Constructs, checks, and returns an op of method type with a method name
6171 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6172 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6173 and, shifted up eight bits, the eight bits of C<op_private>, except that
6174 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6175 op which evaluates method name; it is consumed by this function and
6176 become part of the constructed op tree.
6177 Supported optypes: C<OP_METHOD>.
6178
6179 =cut
6180 */
6181
6182 static OP*
6183 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6184     dVAR;
6185     METHOP *methop;
6186
6187     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6188         || type == OP_CUSTOM);
6189
6190     NewOp(1101, methop, 1, METHOP);
6191     if (dynamic_meth) {
6192         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6193         methop->op_flags = (U8)(flags | OPf_KIDS);
6194         methop->op_u.op_first = dynamic_meth;
6195         methop->op_private = (U8)(1 | (flags >> 8));
6196
6197         if (!OpHAS_SIBLING(dynamic_meth))
6198             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6199     }
6200     else {
6201         assert(const_meth);
6202         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6203         methop->op_u.op_meth_sv = const_meth;
6204         methop->op_private = (U8)(0 | (flags >> 8));
6205         methop->op_next = (OP*)methop;
6206     }
6207
6208 #ifdef USE_ITHREADS
6209     methop->op_rclass_targ = 0;
6210 #else
6211     methop->op_rclass_sv = NULL;
6212 #endif
6213
6214     OpTYPE_set(methop, type);
6215     return CHECKOP(type, methop);
6216 }
6217
6218 OP *
6219 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6220     PERL_ARGS_ASSERT_NEWMETHOP;
6221     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6222 }
6223
6224 /*
6225 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6226
6227 Constructs, checks, and returns an op of method type with a constant
6228 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6229 C<op_flags>, and, shifted up eight bits, the eight bits of
6230 C<op_private>.  C<const_meth> supplies a constant method name;
6231 it must be a shared COW string.
6232 Supported optypes: C<OP_METHOD_NAMED>.
6233
6234 =cut
6235 */
6236
6237 OP *
6238 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6239     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6240     return newMETHOP_internal(type, flags, NULL, const_meth);
6241 }
6242
6243 /*
6244 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6245
6246 Constructs, checks, and returns an op of any binary type.  C<type>
6247 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6248 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6249 the eight bits of C<op_private>, except that the bit with value 1 or
6250 2 is automatically set as required.  C<first> and C<last> supply up to
6251 two ops to be the direct children of the binary op; they are consumed
6252 by this function and become part of the constructed op tree.
6253
6254 =cut
6255 */
6256
6257 OP *
6258 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6259 {
6260     dVAR;
6261     BINOP *binop;
6262
6263     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6264         || type == OP_NULL || type == OP_CUSTOM);
6265
6266     NewOp(1101, binop, 1, BINOP);
6267
6268     if (!first)
6269         first = newOP(OP_NULL, 0);
6270
6271     OpTYPE_set(binop, type);
6272     binop->op_first = first;
6273     binop->op_flags = (U8)(flags | OPf_KIDS);
6274     if (!last) {
6275         last = first;
6276         binop->op_private = (U8)(1 | (flags >> 8));
6277     }
6278     else {
6279         binop->op_private = (U8)(2 | (flags >> 8));
6280         OpMORESIB_set(first, last);
6281     }
6282
6283     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6284         OpLASTSIB_set(last, (OP*)binop);
6285
6286     binop->op_last = OpSIBLING(binop->op_first);
6287     if (binop->op_last)
6288         OpLASTSIB_set(binop->op_last, (OP*)binop);
6289
6290     binop = (BINOP*)CHECKOP(type, binop);
6291     if (binop->op_next || binop->op_type != (OPCODE)type)
6292         return (OP*)binop;
6293
6294     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6295 }
6296
6297 static int uvcompare(const void *a, const void *b)
6298     __attribute__nonnull__(1)
6299     __attribute__nonnull__(2)
6300     __attribute__pure__;
6301 static int uvcompare(const void *a, const void *b)
6302 {
6303     if (*((const UV *)a) < (*(const UV *)b))
6304         return -1;
6305     if (*((const UV *)a) > (*(const UV *)b))
6306         return 1;
6307     if (*((const UV *)a+1) < (*(const UV *)b+1))
6308         return -1;
6309     if (*((const UV *)a+1) > (*(const UV *)b+1))
6310         return 1;
6311     return 0;
6312 }
6313
6314 static OP *
6315 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6316 {
6317     SV * const tstr = ((SVOP*)expr)->op_sv;
6318     SV * const rstr =
6319                               ((SVOP*)repl)->op_sv;
6320     STRLEN tlen;
6321     STRLEN rlen;
6322     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6323     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6324     I32 i;
6325     I32 j;
6326     I32 grows = 0;
6327     short *tbl;
6328
6329     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
6330     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
6331     I32 del              = o->op_private & OPpTRANS_DELETE;
6332     SV* swash;
6333
6334     PERL_ARGS_ASSERT_PMTRANS;
6335
6336     PL_hints |= HINT_BLOCK_SCOPE;
6337
6338     if (SvUTF8(tstr))
6339         o->op_private |= OPpTRANS_FROM_UTF;
6340
6341     if (SvUTF8(rstr))
6342         o->op_private |= OPpTRANS_TO_UTF;
6343
6344     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6345         SV* const listsv = newSVpvs("# comment\n");
6346         SV* transv = NULL;
6347         const U8* tend = t + tlen;
6348         const U8* rend = r + rlen;
6349         STRLEN ulen;
6350         UV tfirst = 1;
6351         UV tlast = 0;
6352         IV tdiff;
6353         STRLEN tcount = 0;
6354         UV rfirst = 1;
6355         UV rlast = 0;
6356         IV rdiff;
6357         STRLEN rcount = 0;
6358         IV diff;
6359         I32 none = 0;
6360         U32 max = 0;
6361         I32 bits;
6362         I32 havefinal = 0;
6363         U32 final = 0;
6364         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6365         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6366         U8* tsave = NULL;
6367         U8* rsave = NULL;
6368         const U32 flags = UTF8_ALLOW_DEFAULT;
6369
6370         if (!from_utf) {
6371             STRLEN len = tlen;
6372             t = tsave = bytes_to_utf8(t, &len);
6373             tend = t + len;
6374         }
6375         if (!to_utf && rlen) {
6376             STRLEN len = rlen;
6377             r = rsave = bytes_to_utf8(r, &len);
6378             rend = r + len;
6379         }
6380
6381 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6382  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6383  * odd.  */
6384
6385         if (complement) {
6386             U8 tmpbuf[UTF8_MAXBYTES+1];
6387             UV *cp;
6388             UV nextmin = 0;
6389             Newx(cp, 2*tlen, UV);
6390             i = 0;
6391             transv = newSVpvs("");
6392             while (t < tend) {
6393                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6394                 t += ulen;
6395                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6396                     t++;
6397                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6398                     t += ulen;
6399                 }
6400                 else {
6401                  cp[2*i+1] = cp[2*i];
6402                 }
6403                 i++;
6404             }
6405             qsort(cp, i, 2*sizeof(UV), uvcompare);
6406             for (j = 0; j < i; j++) {
6407                 UV  val = cp[2*j];
6408                 diff = val - nextmin;
6409                 if (diff > 0) {
6410                     t = uvchr_to_utf8(tmpbuf,nextmin);
6411                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6412                     if (diff > 1) {
6413                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6414                         t = uvchr_to_utf8(tmpbuf, val - 1);
6415                         sv_catpvn(transv, (char *)&range_mark, 1);
6416                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6417                     }
6418                 }
6419                 val = cp[2*j+1];
6420                 if (val >= nextmin)
6421                     nextmin = val + 1;
6422             }
6423             t = uvchr_to_utf8(tmpbuf,nextmin);
6424             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6425             {
6426                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6427                 sv_catpvn(transv, (char *)&range_mark, 1);
6428             }
6429             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6430             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6431             t = (const U8*)SvPVX_const(transv);
6432             tlen = SvCUR(transv);
6433             tend = t + tlen;
6434             Safefree(cp);
6435         }
6436         else if (!rlen && !del) {
6437             r = t; rlen = tlen; rend = tend;
6438         }
6439         if (!squash) {
6440                 if ((!rlen && !del) || t == r ||
6441                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6442                 {
6443                     o->op_private |= OPpTRANS_IDENTICAL;
6444                 }
6445         }
6446
6447         while (t < tend || tfirst <= tlast) {
6448             /* see if we need more "t" chars */
6449             if (tfirst > tlast) {
6450                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6451                 t += ulen;
6452                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6453                     t++;
6454                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6455                     t += ulen;
6456                 }
6457                 else
6458                     tlast = tfirst;
6459             }
6460
6461             /* now see if we need more "r" chars */
6462             if (rfirst > rlast) {
6463                 if (r < rend) {
6464                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6465                     r += ulen;
6466                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6467                         r++;
6468                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6469                         r += ulen;
6470                     }
6471                     else
6472                         rlast = rfirst;
6473                 }
6474                 else {
6475                     if (!havefinal++)
6476                         final = rlast;
6477                     rfirst = rlast = 0xffffffff;
6478                 }
6479             }
6480
6481             /* now see which range will peter out first, if either. */
6482             tdiff = tlast - tfirst;
6483             rdiff = rlast - rfirst;
6484             tcount += tdiff + 1;
6485             rcount += rdiff + 1;
6486
6487             if (tdiff <= rdiff)
6488                 diff = tdiff;
6489             else
6490                 diff = rdiff;
6491
6492             if (rfirst == 0xffffffff) {
6493                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6494                 if (diff > 0)
6495                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6496                                    (long)tfirst, (long)tlast);
6497                 else
6498                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6499             }
6500             else {
6501                 if (diff > 0)
6502                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6503                                    (long)tfirst, (long)(tfirst + diff),
6504                                    (long)rfirst);
6505                 else
6506                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6507                                    (long)tfirst, (long)rfirst);
6508
6509                 if (rfirst + diff > max)
6510                     max = rfirst + diff;
6511                 if (!grows)
6512                     grows = (tfirst < rfirst &&
6513                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6514                 rfirst += diff + 1;
6515             }
6516             tfirst += diff + 1;
6517         }
6518
6519         none = ++max;
6520         if (del)
6521             del = ++max;
6522
6523         if (max > 0xffff)
6524             bits = 32;
6525         else if (max > 0xff)
6526             bits = 16;
6527         else
6528             bits = 8;
6529
6530         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6531 #ifdef USE_ITHREADS
6532         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6533         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6534         PAD_SETSV(cPADOPo->op_padix, swash);
6535         SvPADTMP_on(swash);
6536         SvREADONLY_on(swash);
6537 #else
6538         cSVOPo->op_sv = swash;
6539 #endif
6540         SvREFCNT_dec(listsv);
6541         SvREFCNT_dec(transv);
6542
6543         if (!del && havefinal && rlen)
6544             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6545                            newSVuv((UV)final), 0);
6546
6547         Safefree(tsave);
6548         Safefree(rsave);
6549
6550         tlen = tcount;
6551         rlen = rcount;
6552         if (r < rend)
6553             rlen++;
6554         else if (rlast == 0xffffffff)
6555             rlen = 0;
6556
6557         goto warnins;
6558     }
6559
6560     tbl = (short*)PerlMemShared_calloc(
6561         (o->op_private & OPpTRANS_COMPLEMENT) &&
6562             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
6563         sizeof(short));
6564     cPVOPo->op_pv = (char*)tbl;
6565     if (complement) {
6566         for (i = 0; i < (I32)tlen; i++)
6567             tbl[t[i]] = -1;
6568         for (i = 0, j = 0; i < 256; i++) {
6569             if (!tbl[i]) {
6570                 if (j >= (I32)rlen) {
6571                     if (del)
6572                         tbl[i] = -2;
6573                     else if (rlen)
6574                         tbl[i] = r[j-1];
6575                     else
6576                         tbl[i] = (short)i;
6577                 }
6578                 else {
6579                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
6580                         grows = 1;
6581                     tbl[i] = r[j++];
6582                 }
6583             }
6584         }
6585         if (!del) {
6586             if (!rlen) {
6587                 j = rlen;
6588                 if (!squash)
6589                     o->op_private |= OPpTRANS_IDENTICAL;
6590             }
6591             else if (j >= (I32)rlen)
6592                 j = rlen - 1;
6593             else {
6594                 tbl =
6595                     (short *)
6596                     PerlMemShared_realloc(tbl,
6597                                           (0x101+rlen-j) * sizeof(short));
6598                 cPVOPo->op_pv = (char*)tbl;
6599             }
6600             tbl[0x100] = (short)(rlen - j);
6601             for (i=0; i < (I32)rlen - j; i++)
6602                 tbl[0x101+i] = r[j+i];
6603         }
6604     }
6605     else {
6606         if (!rlen && !del) {
6607             r = t; rlen = tlen;
6608             if (!squash)
6609                 o->op_private |= OPpTRANS_IDENTICAL;
6610         }
6611         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6612             o->op_private |= OPpTRANS_IDENTICAL;
6613         }
6614         for (i = 0; i < 256; i++)
6615             tbl[i] = -1;
6616         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
6617             if (j >= (I32)rlen) {
6618                 if (del) {
6619                     if (tbl[t[i]] == -1)
6620                         tbl[t[i]] = -2;
6621                     continue;
6622                 }
6623                 --j;
6624             }
6625             if (tbl[t[i]] == -1) {
6626                 if (     UVCHR_IS_INVARIANT(t[i])
6627                     && ! UVCHR_IS_INVARIANT(r[j]))
6628                     grows = 1;
6629                 tbl[t[i]] = r[j];
6630             }
6631         }
6632     }
6633
6634   warnins:
6635     if(del && rlen == tlen) {
6636         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6637     } else if(rlen > tlen && !complement) {
6638         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6639     }
6640
6641     if (grows)
6642         o->op_private |= OPpTRANS_GROWS;
6643     op_free(expr);
6644     op_free(repl);
6645
6646     return o;
6647 }
6648
6649 /*
6650 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6651
6652 Constructs, checks, and returns an op of any pattern matching type.
6653 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6654 and, shifted up eight bits, the eight bits of C<op_private>.
6655
6656 =cut
6657 */
6658
6659 OP *
6660 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6661 {
6662     dVAR;
6663     PMOP *pmop;
6664
6665     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6666         || type == OP_CUSTOM);
6667
6668     NewOp(1101, pmop, 1, PMOP);
6669     OpTYPE_set(pmop, type);
6670     pmop->op_flags = (U8)flags;
6671     pmop->op_private = (U8)(0 | (flags >> 8));
6672     if (PL_opargs[type] & OA_RETSCALAR)
6673         scalar((OP *)pmop);
6674
6675     if (PL_hints & HINT_RE_TAINT)
6676         pmop->op_pmflags |= PMf_RETAINT;
6677 #ifdef USE_LOCALE_CTYPE
6678     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6679         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6680     }
6681     else
6682 #endif
6683          if (IN_UNI_8_BIT) {
6684         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6685     }
6686     if (PL_hints & HINT_RE_FLAGS) {
6687         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6688          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6689         );
6690         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6691         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6692          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6693         );
6694         if (reflags && SvOK(reflags)) {
6695             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6696         }
6697     }
6698
6699
6700 #ifdef USE_ITHREADS
6701     assert(SvPOK(PL_regex_pad[0]));
6702     if (SvCUR(PL_regex_pad[0])) {
6703         /* Pop off the "packed" IV from the end.  */
6704         SV *const repointer_list = PL_regex_pad[0];
6705         const char *p = SvEND(repointer_list) - sizeof(IV);
6706         const IV offset = *((IV*)p);
6707
6708         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6709
6710         SvEND_set(repointer_list, p);
6711
6712         pmop->op_pmoffset = offset;
6713         /* This slot should be free, so assert this:  */
6714         assert(PL_regex_pad[offset] == &PL_sv_undef);
6715     } else {
6716         SV * const repointer = &PL_sv_undef;
6717         av_push(PL_regex_padav, repointer);
6718         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6719         PL_regex_pad = AvARRAY(PL_regex_padav);
6720     }
6721 #endif
6722
6723     return CHECKOP(type, pmop);
6724 }
6725
6726 static void
6727 S_set_haseval(pTHX)
6728 {
6729     PADOFFSET i = 1;
6730     PL_cv_has_eval = 1;
6731     /* Any pad names in scope are potentially lvalues.  */
6732     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6733         PADNAME *pn = PAD_COMPNAME_SV(i);
6734         if (!pn || !PadnameLEN(pn))
6735             continue;
6736         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6737             S_mark_padname_lvalue(aTHX_ pn);
6738     }
6739 }
6740
6741 /* Given some sort of match op o, and an expression expr containing a
6742  * pattern, either compile expr into a regex and attach it to o (if it's
6743  * constant), or convert expr into a runtime regcomp op sequence (if it's
6744  * not)
6745  *
6746  * Flags currently has 2 bits of meaning:
6747  * 1: isreg indicates that the pattern is part of a regex construct, eg
6748  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6749  * split "pattern", which aren't. In the former case, expr will be a list
6750  * if the pattern contains more than one term (eg /a$b/).
6751  * 2: The pattern is for a split.
6752  *
6753  * When the pattern has been compiled within a new anon CV (for
6754  * qr/(?{...})/ ), then floor indicates the savestack level just before
6755  * the new sub was created
6756  */
6757
6758 OP *
6759 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6760 {
6761     PMOP *pm;
6762     LOGOP *rcop;
6763     I32 repl_has_vars = 0;
6764     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6765     bool is_compiletime;
6766     bool has_code;
6767     bool isreg    = cBOOL(flags & 1);
6768     bool is_split = cBOOL(flags & 2);
6769
6770     PERL_ARGS_ASSERT_PMRUNTIME;
6771
6772     if (is_trans) {
6773         return pmtrans(o, expr, repl);
6774     }
6775
6776     /* find whether we have any runtime or code elements;
6777      * at the same time, temporarily set the op_next of each DO block;
6778      * then when we LINKLIST, this will cause the DO blocks to be excluded
6779      * from the op_next chain (and from having LINKLIST recursively
6780      * applied to them). We fix up the DOs specially later */
6781
6782     is_compiletime = 1;
6783     has_code = 0;
6784     if (expr->op_type == OP_LIST) {
6785         OP *o;
6786         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6787             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6788                 has_code = 1;
6789                 assert(!o->op_next);
6790                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6791                     assert(PL_parser && PL_parser->error_count);
6792                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6793                        the op we were expecting to see, to avoid crashing
6794                        elsewhere.  */
6795                     op_sibling_splice(expr, o, 0,
6796                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6797                 }
6798                 o->op_next = OpSIBLING(o);
6799             }
6800             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6801                 is_compiletime = 0;
6802         }
6803     }
6804     else if (expr->op_type != OP_CONST)
6805         is_compiletime = 0;
6806
6807     LINKLIST(expr);
6808
6809     /* fix up DO blocks; treat each one as a separate little sub;
6810      * also, mark any arrays as LIST/REF */
6811
6812     if (expr->op_type == OP_LIST) {
6813         OP *o;
6814         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6815
6816             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6817                 assert( !(o->op_flags  & OPf_WANT));
6818                 /* push the array rather than its contents. The regex
6819                  * engine will retrieve and join the elements later */
6820                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6821                 continue;
6822             }
6823
6824             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6825                 continue;
6826             o->op_next = NULL; /* undo temporary hack from above */
6827             scalar(o);
6828             LINKLIST(o);
6829             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6830                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6831                 /* skip ENTER */
6832                 assert(leaveop->op_first->op_type == OP_ENTER);
6833                 assert(OpHAS_SIBLING(leaveop->op_first));
6834                 o->op_next = OpSIBLING(leaveop->op_first);
6835                 /* skip leave */
6836                 assert(leaveop->op_flags & OPf_KIDS);
6837                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6838                 leaveop->op_next = NULL; /* stop on last op */
6839                 op_null((OP*)leaveop);
6840             }
6841             else {
6842                 /* skip SCOPE */
6843                 OP *scope = cLISTOPo->op_first;
6844                 assert(scope->op_type == OP_SCOPE);
6845                 assert(scope->op_flags & OPf_KIDS);
6846                 scope->op_next = NULL; /* stop on last op */
6847                 op_null(scope);
6848             }
6849
6850             if (is_compiletime)
6851                 /* runtime finalizes as part of finalizing whole tree */
6852                 optimize_optree(o);
6853
6854             /* have to peep the DOs individually as we've removed it from
6855              * the op_next chain */
6856             CALL_PEEP(o);
6857             S_prune_chain_head(&(o->op_next));
6858             if (is_compiletime)
6859                 /* runtime finalizes as part of finalizing whole tree */
6860                 finalize_optree(o);
6861         }
6862     }
6863     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6864         assert( !(expr->op_flags  & OPf_WANT));
6865         /* push the array rather than its contents. The regex
6866          * engine will retrieve and join the elements later */
6867         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6868     }
6869
6870     PL_hints |= HINT_BLOCK_SCOPE;
6871     pm = (PMOP*)o;
6872     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6873
6874     if (is_compiletime) {
6875         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6876         regexp_engine const *eng = current_re_engine();
6877
6878         if (is_split) {
6879             /* make engine handle split ' ' specially */
6880             pm->op_pmflags |= PMf_SPLIT;
6881             rx_flags |= RXf_SPLIT;
6882         }
6883
6884         /* Skip compiling if parser found an error for this pattern */
6885         if (pm->op_pmflags & PMf_HAS_ERROR) {
6886             return o;
6887         }
6888
6889         if (!has_code || !eng->op_comp) {
6890             /* compile-time simple constant pattern */
6891
6892             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
6893                 /* whoops! we guessed that a qr// had a code block, but we
6894                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
6895                  * that isn't required now. Note that we have to be pretty
6896                  * confident that nothing used that CV's pad while the
6897                  * regex was parsed, except maybe op targets for \Q etc.
6898                  * If there were any op targets, though, they should have
6899                  * been stolen by constant folding.
6900                  */
6901 #ifdef DEBUGGING
6902                 SSize_t i = 0;
6903                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
6904                 while (++i <= AvFILLp(PL_comppad)) {
6905 #  ifdef USE_PAD_RESET
6906                     /* under USE_PAD_RESET, pad swipe replaces a swiped
6907                      * folded constant with a fresh padtmp */
6908                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
6909 #  else
6910                     assert(!PL_curpad[i]);
6911 #  endif
6912                 }
6913 #endif
6914                 /* But we know that one op is using this CV's slab. */
6915                 cv_forget_slab(PL_compcv);
6916                 LEAVE_SCOPE(floor);
6917                 pm->op_pmflags &= ~PMf_HAS_CV;
6918             }
6919
6920             PM_SETRE(pm,
6921                 eng->op_comp
6922                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6923                                         rx_flags, pm->op_pmflags)
6924                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6925                                         rx_flags, pm->op_pmflags)
6926             );
6927             op_free(expr);
6928         }
6929         else {
6930             /* compile-time pattern that includes literal code blocks */
6931             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6932                         rx_flags,
6933                         (pm->op_pmflags |
6934                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
6935                     );
6936             PM_SETRE(pm, re);
6937             if (pm->op_pmflags & PMf_HAS_CV) {
6938                 CV *cv;
6939                 /* this QR op (and the anon sub we embed it in) is never
6940                  * actually executed. It's just a placeholder where we can
6941                  * squirrel away expr in op_code_list without the peephole
6942                  * optimiser etc processing it for a second time */
6943                 OP *qr = newPMOP(OP_QR, 0);
6944                 ((PMOP*)qr)->op_code_list = expr;
6945
6946                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
6947                 SvREFCNT_inc_simple_void(PL_compcv);
6948                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
6949                 ReANY(re)->qr_anoncv = cv;
6950
6951                 /* attach the anon CV to the pad so that
6952                  * pad_fixup_inner_anons() can find it */
6953                 (void)pad_add_anon(cv, o->op_type);
6954                 SvREFCNT_inc_simple_void(cv);
6955             }
6956             else {
6957                 pm->op_code_list = expr;
6958             }
6959         }
6960     }
6961     else {
6962         /* runtime pattern: build chain of regcomp etc ops */
6963         bool reglist;
6964         PADOFFSET cv_targ = 0;
6965
6966         reglist = isreg && expr->op_type == OP_LIST;
6967         if (reglist)
6968             op_null(expr);
6969
6970         if (has_code) {
6971             pm->op_code_list = expr;
6972             /* don't free op_code_list; its ops are embedded elsewhere too */
6973             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
6974         }
6975
6976         if (is_split)
6977             /* make engine handle split ' ' specially */
6978             pm->op_pmflags |= PMf_SPLIT;
6979
6980         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
6981          * to allow its op_next to be pointed past the regcomp and
6982          * preceding stacking ops;
6983          * OP_REGCRESET is there to reset taint before executing the
6984          * stacking ops */
6985         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
6986             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
6987
6988         if (pm->op_pmflags & PMf_HAS_CV) {
6989             /* we have a runtime qr with literal code. This means
6990              * that the qr// has been wrapped in a new CV, which
6991              * means that runtime consts, vars etc will have been compiled
6992              * against a new pad. So... we need to execute those ops
6993              * within the environment of the new CV. So wrap them in a call
6994              * to a new anon sub. i.e. for
6995              *
6996              *     qr/a$b(?{...})/,
6997              *
6998              * we build an anon sub that looks like
6999              *
7000              *     sub { "a", $b, '(?{...})' }
7001              *
7002              * and call it, passing the returned list to regcomp.
7003              * Or to put it another way, the list of ops that get executed
7004              * are:
7005              *
7006              *     normal              PMf_HAS_CV
7007              *     ------              -------------------
7008              *                         pushmark (for regcomp)
7009              *                         pushmark (for entersub)
7010              *                         anoncode
7011              *                         srefgen
7012              *                         entersub
7013              *     regcreset                  regcreset
7014              *     pushmark                   pushmark
7015              *     const("a")                 const("a")
7016              *     gvsv(b)                    gvsv(b)
7017              *     const("(?{...})")          const("(?{...})")
7018              *                                leavesub
7019              *     regcomp             regcomp
7020              */
7021
7022             SvREFCNT_inc_simple_void(PL_compcv);
7023             CvLVALUE_on(PL_compcv);
7024             /* these lines are just an unrolled newANONATTRSUB */
7025             expr = newSVOP(OP_ANONCODE, 0,
7026                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7027             cv_targ = expr->op_targ;
7028             expr = newUNOP(OP_REFGEN, 0, expr);
7029
7030             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7031         }
7032
7033         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7034         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7035                            | (reglist ? OPf_STACKED : 0);
7036         rcop->op_targ = cv_targ;
7037
7038         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7039         if (PL_hints & HINT_RE_EVAL)
7040             S_set_haseval(aTHX);
7041
7042         /* establish postfix order */
7043         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7044             LINKLIST(expr);
7045             rcop->op_next = expr;
7046             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7047         }
7048         else {
7049             rcop->op_next = LINKLIST(expr);
7050             expr->op_next = (OP*)rcop;
7051         }
7052
7053         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7054     }
7055
7056     if (repl) {
7057         OP *curop = repl;
7058         bool konst;
7059         /* If we are looking at s//.../e with a single statement, get past
7060            the implicit do{}. */
7061         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7062              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7063              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7064          {
7065             OP *sib;
7066             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7067             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7068              && !OpHAS_SIBLING(sib))
7069                 curop = sib;
7070         }
7071         if (curop->op_type == OP_CONST)
7072             konst = TRUE;
7073         else if (( (curop->op_type == OP_RV2SV ||
7074                     curop->op_type == OP_RV2AV ||
7075                     curop->op_type == OP_RV2HV ||
7076                     curop->op_type == OP_RV2GV)
7077                    && cUNOPx(curop)->op_first
7078                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7079                 || curop->op_type == OP_PADSV
7080                 || curop->op_type == OP_PADAV
7081                 || curop->op_type == OP_PADHV
7082                 || curop->op_type == OP_PADANY) {
7083             repl_has_vars = 1;
7084             konst = TRUE;
7085         }
7086         else konst = FALSE;
7087         if (konst
7088             && !(repl_has_vars
7089                  && (!PM_GETRE(pm)
7090                      || !RX_PRELEN(PM_GETRE(pm))
7091                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7092         {
7093             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7094             op_prepend_elem(o->op_type, scalar(repl), o);
7095         }
7096         else {
7097             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7098             rcop->op_private = 1;
7099
7100             /* establish postfix order */
7101             rcop->op_next = LINKLIST(repl);
7102             repl->op_next = (OP*)rcop;
7103
7104             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7105             assert(!(pm->op_pmflags & PMf_ONCE));
7106             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7107             rcop->op_next = 0;
7108         }
7109     }
7110
7111     return (OP*)pm;
7112 }
7113
7114 /*
7115 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7116
7117 Constructs, checks, and returns an op of any type that involves an
7118 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7119 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7120 takes ownership of one reference to it.
7121
7122 =cut
7123 */
7124
7125 OP *
7126 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7127 {
7128     dVAR;
7129     SVOP *svop;
7130
7131     PERL_ARGS_ASSERT_NEWSVOP;
7132
7133     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7134         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7135         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7136         || type == OP_CUSTOM);
7137
7138     NewOp(1101, svop, 1, SVOP);
7139     OpTYPE_set(svop, type);
7140     svop->op_sv = sv;
7141     svop->op_next = (OP*)svop;
7142     svop->op_flags = (U8)flags;
7143     svop->op_private = (U8)(0 | (flags >> 8));
7144     if (PL_opargs[type] & OA_RETSCALAR)
7145         scalar((OP*)svop);
7146     if (PL_opargs[type] & OA_TARGET)
7147         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7148     return CHECKOP(type, svop);
7149 }
7150
7151 /*
7152 =for apidoc Am|OP *|newDEFSVOP|
7153
7154 Constructs and returns an op to access C<$_>.
7155
7156 =cut
7157 */
7158
7159 OP *
7160 Perl_newDEFSVOP(pTHX)
7161 {
7162         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7163 }
7164
7165 #ifdef USE_ITHREADS
7166
7167 /*
7168 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7169
7170 Constructs, checks, and returns an op of any type that involves a
7171 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7172 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7173 is populated with C<sv>; this function takes ownership of one reference
7174 to it.
7175
7176 This function only exists if Perl has been compiled to use ithreads.
7177
7178 =cut
7179 */
7180
7181 OP *
7182 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7183 {
7184     dVAR;
7185     PADOP *padop;
7186
7187     PERL_ARGS_ASSERT_NEWPADOP;
7188
7189     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7190         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7191         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7192         || type == OP_CUSTOM);
7193
7194     NewOp(1101, padop, 1, PADOP);
7195     OpTYPE_set(padop, type);
7196     padop->op_padix =
7197         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7198     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7199     PAD_SETSV(padop->op_padix, sv);
7200     assert(sv);
7201     padop->op_next = (OP*)padop;
7202     padop->op_flags = (U8)flags;
7203     if (PL_opargs[type] & OA_RETSCALAR)
7204         scalar((OP*)padop);
7205     if (PL_opargs[type] & OA_TARGET)
7206         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7207     return CHECKOP(type, padop);
7208 }
7209
7210 #endif /* USE_ITHREADS */
7211
7212 /*
7213 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7214
7215 Constructs, checks, and returns an op of any type that involves an
7216 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7217 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7218 reference; calling this function does not transfer ownership of any
7219 reference to it.
7220
7221 =cut
7222 */
7223
7224 OP *
7225 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7226 {
7227     PERL_ARGS_ASSERT_NEWGVOP;
7228
7229 #ifdef USE_ITHREADS
7230     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7231 #else
7232     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7233 #endif
7234 }
7235
7236 /*
7237 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7238
7239 Constructs, checks, and returns an op of any type that involves an
7240 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7241 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7242 Depending on the op type, the memory referenced by C<pv> may be freed
7243 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7244 have been allocated using C<PerlMemShared_malloc>.
7245
7246 =cut
7247 */
7248
7249 OP *
7250 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7251 {
7252     dVAR;
7253     const bool utf8 = cBOOL(flags & SVf_UTF8);
7254     PVOP *pvop;
7255
7256     flags &= ~SVf_UTF8;
7257
7258     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7259         || type == OP_RUNCV || type == OP_CUSTOM
7260         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7261
7262     NewOp(1101, pvop, 1, PVOP);
7263     OpTYPE_set(pvop, type);
7264     pvop->op_pv = pv;
7265     pvop->op_next = (OP*)pvop;
7266     pvop->op_flags = (U8)flags;
7267     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7268     if (PL_opargs[type] & OA_RETSCALAR)
7269         scalar((OP*)pvop);
7270     if (PL_opargs[type] & OA_TARGET)
7271         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7272     return CHECKOP(type, pvop);
7273 }
7274
7275 void
7276 Perl_package(pTHX_ OP *o)
7277 {
7278     SV *const sv = cSVOPo->op_sv;
7279
7280     PERL_ARGS_ASSERT_PACKAGE;
7281
7282     SAVEGENERICSV(PL_curstash);
7283     save_item(PL_curstname);
7284
7285     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7286
7287     sv_setsv(PL_curstname, sv);
7288
7289     PL_hints |= HINT_BLOCK_SCOPE;
7290     PL_parser->copline = NOLINE;
7291
7292     op_free(o);
7293 }
7294
7295 void
7296 Perl_package_version( pTHX_ OP *v )
7297 {
7298     U32 savehints = PL_hints;
7299     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7300     PL_hints &= ~HINT_STRICT_VARS;
7301     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7302     PL_hints = savehints;
7303     op_free(v);
7304 }
7305
7306 void
7307 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7308 {
7309     OP *pack;
7310     OP *imop;
7311     OP *veop;
7312     SV *use_version = NULL;
7313
7314     PERL_ARGS_ASSERT_UTILIZE;
7315
7316     if (idop->op_type != OP_CONST)
7317         Perl_croak(aTHX_ "Module name must be constant");
7318
7319     veop = NULL;
7320
7321     if (version) {
7322         SV * const vesv = ((SVOP*)version)->op_sv;
7323
7324         if (!arg && !SvNIOKp(vesv)) {
7325             arg = version;
7326         }
7327         else {
7328             OP *pack;
7329             SV *meth;
7330
7331             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7332                 Perl_croak(aTHX_ "Version number must be a constant number");
7333
7334             /* Make copy of idop so we don't free it twice */
7335             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7336
7337             /* Fake up a method call to VERSION */
7338             meth = newSVpvs_share("VERSION");
7339             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7340                             op_append_elem(OP_LIST,
7341                                         op_prepend_elem(OP_LIST, pack, version),
7342                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7343         }
7344     }
7345
7346     /* Fake up an import/unimport */
7347     if (arg && arg->op_type == OP_STUB) {
7348         imop = arg;             /* no import on explicit () */
7349     }
7350     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7351         imop = NULL;            /* use 5.0; */
7352         if (aver)
7353             use_version = ((SVOP*)idop)->op_sv;
7354         else
7355             idop->op_private |= OPpCONST_NOVER;
7356     }
7357     else {
7358         SV *meth;
7359
7360         /* Make copy of idop so we don't free it twice */
7361         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7362
7363         /* Fake up a method call to import/unimport */
7364         meth = aver
7365             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7366         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7367                        op_append_elem(OP_LIST,
7368                                    op_prepend_elem(OP_LIST, pack, arg),
7369                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7370                        ));
7371     }
7372
7373     /* Fake up the BEGIN {}, which does its thing immediately. */
7374     newATTRSUB(floor,
7375         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7376         NULL,
7377         NULL,
7378         op_append_elem(OP_LINESEQ,
7379             op_append_elem(OP_LINESEQ,
7380                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7381                 newSTATEOP(0, NULL, veop)),
7382             newSTATEOP(0, NULL, imop) ));
7383
7384     if (use_version) {
7385         /* Enable the
7386          * feature bundle that corresponds to the required version. */
7387         use_version = sv_2mortal(new_version(use_version));
7388         S_enable_feature_bundle(aTHX_ use_version);
7389
7390         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7391         if (vcmp(use_version,
7392                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7393             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7394                 PL_hints |= HINT_STRICT_REFS;
7395             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7396                 PL_hints |= HINT_STRICT_SUBS;
7397             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7398                 PL_hints |= HINT_STRICT_VARS;
7399         }
7400         /* otherwise they are off */
7401         else {
7402             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7403                 PL_hints &= ~HINT_STRICT_REFS;
7404             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7405                 PL_hints &= ~HINT_STRICT_SUBS;
7406             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7407                 PL_hints &= ~HINT_STRICT_VARS;
7408         }
7409     }
7410
7411     /* The "did you use incorrect case?" warning used to be here.
7412      * The problem is that on case-insensitive filesystems one
7413      * might get false positives for "use" (and "require"):
7414      * "use Strict" or "require CARP" will work.  This causes
7415      * portability problems for the script: in case-strict
7416      * filesystems the script will stop working.
7417      *
7418      * The "incorrect case" warning checked whether "use Foo"
7419      * imported "Foo" to your namespace, but that is wrong, too:
7420      * there is no requirement nor promise in the language that
7421      * a Foo.pm should or would contain anything in package "Foo".
7422      *
7423      * There is very little Configure-wise that can be done, either:
7424      * the case-sensitivity of the build filesystem of Perl does not
7425      * help in guessing the case-sensitivity of the runtime environment.
7426      */
7427
7428     PL_hints |= HINT_BLOCK_SCOPE;
7429     PL_parser->copline = NOLINE;
7430     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7431 }
7432
7433 /*
7434 =head1 Embedding Functions
7435
7436 =for apidoc load_module
7437
7438 Loads the module whose name is pointed to by the string part of C<name>.
7439 Note that the actual module name, not its filename, should be given.
7440 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7441 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7442 trailing arguments can be used to specify arguments to the module's C<import()>
7443 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7444 on the flags. The flags argument is a bitwise-ORed collection of any of
7445 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7446 (or 0 for no flags).
7447
7448 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7449 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7450 the trailing optional arguments may be omitted entirely. Otherwise, if
7451 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7452 exactly one C<OP*>, containing the op tree that produces the relevant import
7453 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7454 will be used as import arguments; and the list must be terminated with C<(SV*)
7455 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7456 set, the trailing C<NULL> pointer is needed even if no import arguments are
7457 desired. The reference count for each specified C<SV*> argument is
7458 decremented. In addition, the C<name> argument is modified.
7459
7460 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7461 than C<use>.
7462
7463 =cut */
7464
7465 void
7466 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7467 {
7468     va_list args;
7469
7470     PERL_ARGS_ASSERT_LOAD_MODULE;
7471
7472     va_start(args, ver);
7473     vload_module(flags, name, ver, &args);
7474     va_end(args);
7475 }
7476
7477 #ifdef PERL_IMPLICIT_CONTEXT
7478 void
7479 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7480 {
7481     dTHX;
7482     va_list args;
7483     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7484     va_start(args, ver);
7485     vload_module(flags, name, ver, &args);
7486     va_end(args);
7487 }
7488 #endif
7489
7490 void
7491 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7492 {
7493     OP *veop, *imop;
7494     OP * const modname = newSVOP(OP_CONST, 0, name);
7495
7496     PERL_ARGS_ASSERT_VLOAD_MODULE;
7497
7498     modname->op_private |= OPpCONST_BARE;
7499     if (ver) {
7500         veop = newSVOP(OP_CONST, 0, ver);
7501     }
7502     else
7503         veop = NULL;
7504     if (flags & PERL_LOADMOD_NOIMPORT) {
7505         imop = sawparens(newNULLLIST());
7506     }
7507     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7508         imop = va_arg(*args, OP*);
7509     }
7510     else {
7511         SV *sv;
7512         imop = NULL;
7513         sv = va_arg(*args, SV*);
7514         while (sv) {
7515             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7516             sv = va_arg(*args, SV*);
7517         }
7518     }
7519
7520     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7521      * that it has a PL_parser to play with while doing that, and also
7522      * that it doesn't mess with any existing parser, by creating a tmp
7523      * new parser with lex_start(). This won't actually be used for much,
7524      * since pp_require() will create another parser for the real work.
7525      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7526
7527     ENTER;
7528     SAVEVPTR(PL_curcop);
7529     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7530     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7531             veop, modname, imop);
7532     LEAVE;
7533 }
7534
7535 PERL_STATIC_INLINE OP *
7536 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7537 {
7538     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7539                    newLISTOP(OP_LIST, 0, arg,
7540                              newUNOP(OP_RV2CV, 0,
7541                                      newGVOP(OP_GV, 0, gv))));
7542 }
7543
7544 OP *
7545 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7546 {
7547     OP *doop;
7548     GV *gv;
7549
7550     PERL_ARGS_ASSERT_DOFILE;
7551
7552     if (!force_builtin && (gv = gv_override("do", 2))) {
7553         doop = S_new_entersubop(aTHX_ gv, term);
7554     }
7555     else {
7556         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7557     }
7558     return doop;
7559 }
7560
7561 /*
7562 =head1 Optree construction
7563
7564 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7565
7566 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7567 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7568 be set automatically, and, shifted up eight bits, the eight bits of
7569 C<op_private>, except that the bit with value 1 or 2 is automatically
7570 set as required.  C<listval> and C<subscript> supply the parameters of
7571 the slice; they are consumed by this function and become part of the
7572 constructed op tree.
7573
7574 =cut
7575 */
7576
7577 OP *
7578 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7579 {
7580     return newBINOP(OP_LSLICE, flags,
7581             list(force_list(subscript, 1)),
7582             list(force_list(listval,   1)) );
7583 }
7584
7585 #define ASSIGN_LIST   1
7586 #define ASSIGN_REF    2
7587
7588 STATIC I32
7589 S_assignment_type(pTHX_ const OP *o)
7590 {
7591     unsigned type;
7592     U8 flags;
7593     U8 ret;
7594
7595     if (!o)
7596         return TRUE;
7597
7598     if (o->op_type == OP_SREFGEN)
7599     {
7600         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7601         type = kid->op_type;
7602         flags = o->op_flags | kid->op_flags;
7603         if (!(flags & OPf_PARENS)
7604           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7605               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7606             return ASSIGN_REF;
7607         ret = ASSIGN_REF;
7608     } else {
7609         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7610             o = cUNOPo->op_first;
7611         flags = o->op_flags;
7612         type = o->op_type;
7613         ret = 0;
7614     }
7615
7616     if (type == OP_COND_EXPR) {
7617         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7618         const I32 t = assignment_type(sib);
7619         const I32 f = assignment_type(OpSIBLING(sib));
7620
7621         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7622             return ASSIGN_LIST;
7623         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7624             yyerror("Assignment to both a list and a scalar");
7625         return FALSE;
7626     }
7627
7628     if (type == OP_LIST &&
7629         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7630         o->op_private & OPpLVAL_INTRO)
7631         return ret;
7632
7633     if (type == OP_LIST || flags & OPf_PARENS ||
7634         type == OP_RV2AV || type == OP_RV2HV ||
7635         type == OP_ASLICE || type == OP_HSLICE ||
7636         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7637         return TRUE;
7638
7639     if (type == OP_PADAV || type == OP_PADHV)
7640         return TRUE;
7641
7642     if (type == OP_RV2SV)
7643         return ret;
7644
7645     return ret;
7646 }
7647
7648 static OP *
7649 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7650 {
7651     const PADOFFSET target = padop->op_targ;
7652     OP *const other = newOP(OP_PADSV,
7653                             padop->op_flags
7654                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7655     OP *const first = newOP(OP_NULL, 0);
7656     OP *const nullop = newCONDOP(0, first, initop, other);
7657     /* XXX targlex disabled for now; see ticket #124160
7658         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7659      */
7660     OP *const condop = first->op_next;
7661
7662     OpTYPE_set(condop, OP_ONCE);
7663     other->op_targ = target;
7664     nullop->op_flags |= OPf_WANT_SCALAR;
7665
7666     /* Store the initializedness of state vars in a separate
7667        pad entry.  */
7668     condop->op_targ =
7669       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7670     /* hijacking PADSTALE for uninitialized state variables */
7671     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7672
7673     return nullop;
7674 }
7675
7676 /*
7677 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7678
7679 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7680 supply the parameters of the assignment; they are consumed by this
7681 function and become part of the constructed op tree.
7682
7683 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7684 a suitable conditional optree is constructed.  If C<optype> is the opcode
7685 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7686 performs the binary operation and assigns the result to the left argument.
7687 Either way, if C<optype> is non-zero then C<flags> has no effect.
7688
7689 If C<optype> is zero, then a plain scalar or list assignment is
7690 constructed.  Which type of assignment it is is automatically determined.
7691 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7692 will be set automatically, and, shifted up eight bits, the eight bits
7693 of C<op_private>, except that the bit with value 1 or 2 is automatically
7694 set as required.
7695
7696 =cut
7697 */
7698
7699 OP *
7700 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7701 {
7702     OP *o;
7703     I32 assign_type;
7704
7705     if (optype) {
7706         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7707             right = scalar(right);
7708             return newLOGOP(optype, 0,
7709                 op_lvalue(scalar(left), optype),
7710                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7711         }
7712         else {
7713             return newBINOP(optype, OPf_STACKED,
7714                 op_lvalue(scalar(left), optype), scalar(right));
7715         }
7716     }
7717
7718     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7719         OP *state_var_op = NULL;
7720         static const char no_list_state[] = "Initialization of state variables"
7721             " in list currently forbidden";
7722         OP *curop;
7723
7724         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7725             left->op_private &= ~ OPpSLICEWARNING;
7726
7727         PL_modcount = 0;
7728         left = op_lvalue(left, OP_AASSIGN);
7729         curop = list(force_list(left, 1));
7730         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7731         o->op_private = (U8)(0 | (flags >> 8));
7732
7733         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7734         {
7735             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7736             if (!(left->op_flags & OPf_PARENS) &&
7737                     lop->op_type == OP_PUSHMARK &&
7738                     (vop = OpSIBLING(lop)) &&
7739                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7740                     !(vop->op_flags & OPf_PARENS) &&
7741                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7742                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7743                     (eop = OpSIBLING(vop)) &&
7744                     eop->op_type == OP_ENTERSUB &&
7745                     !OpHAS_SIBLING(eop)) {
7746                 state_var_op = vop;
7747             } else {
7748                 while (lop) {
7749                     if ((lop->op_type == OP_PADSV ||
7750                          lop->op_type == OP_PADAV ||
7751                          lop->op_type == OP_PADHV ||
7752                          lop->op_type == OP_PADANY)
7753                       && (lop->op_private & OPpPAD_STATE)
7754                     )
7755                         yyerror(no_list_state);
7756                     lop = OpSIBLING(lop);
7757                 }
7758             }
7759         }
7760         else if (  (left->op_private & OPpLVAL_INTRO)
7761                 && (left->op_private & OPpPAD_STATE)
7762                 && (   left->op_type == OP_PADSV
7763                     || left->op_type == OP_PADAV
7764                     || left->op_type == OP_PADHV
7765                     || left->op_type == OP_PADANY)
7766         ) {
7767                 /* All single variable list context state assignments, hence
7768                    state ($a) = ...
7769                    (state $a) = ...
7770                    state @a = ...
7771                    state (@a) = ...
7772                    (state @a) = ...
7773                    state %a = ...
7774                    state (%a) = ...
7775                    (state %a) = ...
7776                 */
7777                 if (left->op_flags & OPf_PARENS)
7778                     yyerror(no_list_state);
7779                 else
7780                     state_var_op = left;
7781         }
7782
7783         /* optimise @a = split(...) into:
7784         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7785         * @a, my @a, local @a:  split(...)          (where @a is attached to
7786         *                                            the split op itself)
7787         */
7788
7789         if (   right
7790             && right->op_type == OP_SPLIT
7791             /* don't do twice, e.g. @b = (@a = split) */
7792             && !(right->op_private & OPpSPLIT_ASSIGN))
7793         {
7794             OP *gvop = NULL;
7795
7796             if (   (  left->op_type == OP_RV2AV
7797                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7798                 || left->op_type == OP_PADAV)
7799             {
7800                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7801                 OP *tmpop;
7802                 if (gvop) {
7803 #ifdef USE_ITHREADS
7804                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7805                         = cPADOPx(gvop)->op_padix;
7806                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7807 #else
7808                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7809                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7810                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7811 #endif
7812                     right->op_private |=
7813                         left->op_private & OPpOUR_INTRO;
7814                 }
7815                 else {
7816                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7817                     left->op_targ = 0;  /* steal it */
7818                     right->op_private |= OPpSPLIT_LEX;
7819                 }
7820                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7821
7822               detach_split:
7823                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7824                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7825                 assert(OpSIBLING(tmpop) == right);
7826                 assert(!OpHAS_SIBLING(right));
7827                 /* detach the split subtreee from the o tree,
7828                  * then free the residual o tree */
7829                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7830                 op_free(o);                     /* blow off assign */
7831                 right->op_private |= OPpSPLIT_ASSIGN;
7832                 right->op_flags &= ~OPf_WANT;
7833                         /* "I don't know and I don't care." */
7834                 return right;
7835             }
7836             else if (left->op_type == OP_RV2AV) {
7837                 /* @{expr} */
7838
7839                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7840                 assert(OpSIBLING(pushop) == left);
7841                 /* Detach the array ...  */
7842                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7843                 /* ... and attach it to the split.  */
7844                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7845                                   0, left);
7846                 right->op_flags |= OPf_STACKED;
7847                 /* Detach split and expunge aassign as above.  */
7848                 goto detach_split;
7849             }
7850             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7851                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
7852             {
7853                 /* convert split(...,0) to split(..., PL_modcount+1) */
7854                 SV ** const svp =
7855                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7856                 SV * const sv = *svp;
7857                 if (SvIOK(sv) && SvIVX(sv) == 0)
7858                 {
7859                   if (right->op_private & OPpSPLIT_IMPLIM) {
7860                     /* our own SV, created in ck_split */
7861                     SvREADONLY_off(sv);
7862                     sv_setiv(sv, PL_modcount+1);
7863                   }
7864                   else {
7865                     /* SV may belong to someone else */
7866                     SvREFCNT_dec(sv);
7867                     *svp = newSViv(PL_modcount+1);
7868                   }
7869                 }
7870             }
7871         }
7872
7873         if (state_var_op)
7874             o = S_newONCEOP(aTHX_ o, state_var_op);
7875         return o;
7876     }
7877     if (assign_type == ASSIGN_REF)
7878         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7879     if (!right)
7880         right = newOP(OP_UNDEF, 0);
7881     if (right->op_type == OP_READLINE) {
7882         right->op_flags |= OPf_STACKED;
7883         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7884                 scalar(right));
7885     }
7886     else {
7887         o = newBINOP(OP_SASSIGN, flags,
7888             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
7889     }
7890     return o;
7891 }
7892
7893 /*
7894 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
7895
7896 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
7897 but will be a C<dbstate> op if debugging is enabled for currently-compiled
7898 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
7899 If C<label> is non-null, it supplies the name of a label to attach to
7900 the state op; this function takes ownership of the memory pointed at by
7901 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
7902 for the state op.
7903
7904 If C<o> is null, the state op is returned.  Otherwise the state op is
7905 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
7906 is consumed by this function and becomes part of the returned op tree.
7907
7908 =cut
7909 */
7910
7911 OP *
7912 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
7913 {
7914     dVAR;
7915     const U32 seq = intro_my();
7916     const U32 utf8 = flags & SVf_UTF8;
7917     COP *cop;
7918
7919     PL_parser->parsed_sub = 0;
7920
7921     flags &= ~SVf_UTF8;
7922
7923     NewOp(1101, cop, 1, COP);
7924     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
7925         OpTYPE_set(cop, OP_DBSTATE);
7926     }
7927     else {
7928         OpTYPE_set(cop, OP_NEXTSTATE);
7929     }
7930     cop->op_flags = (U8)flags;
7931     CopHINTS_set(cop, PL_hints);
7932 #ifdef VMS
7933     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
7934 #endif
7935     cop->op_next = (OP*)cop;
7936
7937     cop->cop_seq = seq;
7938     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7939     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
7940     if (label) {
7941         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
7942
7943         PL_hints |= HINT_BLOCK_SCOPE;
7944         /* It seems that we need to defer freeing this pointer, as other parts
7945            of the grammar end up wanting to copy it after this op has been
7946            created. */
7947         SAVEFREEPV(label);
7948     }
7949
7950     if (PL_parser->preambling != NOLINE) {
7951         CopLINE_set(cop, PL_parser->preambling);
7952         PL_parser->copline = NOLINE;
7953     }
7954     else if (PL_parser->copline == NOLINE)
7955         CopLINE_set(cop, CopLINE(PL_curcop));
7956     else {
7957         CopLINE_set(cop, PL_parser->copline);
7958         PL_parser->copline = NOLINE;
7959     }
7960 #ifdef USE_ITHREADS
7961     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
7962 #else
7963     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
7964 #endif
7965     CopSTASH_set(cop, PL_curstash);
7966
7967     if (cop->op_type == OP_DBSTATE) {
7968         /* this line can have a breakpoint - store the cop in IV */
7969         AV *av = CopFILEAVx(PL_curcop);
7970         if (av) {
7971             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
7972             if (svp && *svp != &PL_sv_undef ) {
7973                 (void)SvIOK_on(*svp);
7974                 SvIV_set(*svp, PTR2IV(cop));
7975             }
7976         }
7977     }
7978
7979     if (flags & OPf_SPECIAL)
7980         op_null((OP*)cop);
7981     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
7982 }
7983
7984 /*
7985 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
7986
7987 Constructs, checks, and returns a logical (flow control) op.  C<type>
7988 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
7989 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
7990 the eight bits of C<op_private>, except that the bit with value 1 is
7991 automatically set.  C<first> supplies the expression controlling the
7992 flow, and C<other> supplies the side (alternate) chain of ops; they are
7993 consumed by this function and become part of the constructed op tree.
7994
7995 =cut
7996 */
7997
7998 OP *
7999 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8000 {
8001     PERL_ARGS_ASSERT_NEWLOGOP;
8002
8003     return new_logop(type, flags, &first, &other);
8004 }
8005
8006 STATIC OP *
8007 S_search_const(pTHX_ OP *o)
8008 {
8009     PERL_ARGS_ASSERT_SEARCH_CONST;
8010
8011     switch (o->op_type) {
8012         case OP_CONST:
8013             return o;
8014         case OP_NULL:
8015             if (o->op_flags & OPf_KIDS)
8016                 return search_const(cUNOPo->op_first);
8017             break;
8018         case OP_LEAVE:
8019         case OP_SCOPE:
8020         case OP_LINESEQ:
8021         {
8022             OP *kid;
8023             if (!(o->op_flags & OPf_KIDS))
8024                 return NULL;
8025             kid = cLISTOPo->op_first;
8026             do {
8027                 switch (kid->op_type) {
8028                     case OP_ENTER:
8029                     case OP_NULL:
8030                     case OP_NEXTSTATE:
8031                         kid = OpSIBLING(kid);
8032                         break;
8033                     default:
8034                         if (kid != cLISTOPo->op_last)
8035                             return NULL;
8036                         goto last;
8037                 }
8038             } while (kid);
8039             if (!kid)
8040                 kid = cLISTOPo->op_last;
8041           last:
8042             return search_const(kid);
8043         }
8044     }
8045
8046     return NULL;
8047 }
8048
8049 STATIC OP *
8050 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8051 {
8052     dVAR;
8053     LOGOP *logop;
8054     OP *o;
8055     OP *first;
8056     OP *other;
8057     OP *cstop = NULL;
8058     int prepend_not = 0;
8059
8060     PERL_ARGS_ASSERT_NEW_LOGOP;
8061
8062     first = *firstp;
8063     other = *otherp;
8064
8065     /* [perl #59802]: Warn about things like "return $a or $b", which
8066        is parsed as "(return $a) or $b" rather than "return ($a or
8067        $b)".  NB: This also applies to xor, which is why we do it
8068        here.
8069      */
8070     switch (first->op_type) {
8071     case OP_NEXT:
8072     case OP_LAST:
8073     case OP_REDO:
8074         /* XXX: Perhaps we should emit a stronger warning for these.
8075            Even with the high-precedence operator they don't seem to do
8076            anything sensible.
8077
8078            But until we do, fall through here.
8079          */
8080     case OP_RETURN:
8081     case OP_EXIT:
8082     case OP_DIE:
8083     case OP_GOTO:
8084         /* XXX: Currently we allow people to "shoot themselves in the
8085            foot" by explicitly writing "(return $a) or $b".
8086
8087            Warn unless we are looking at the result from folding or if
8088            the programmer explicitly grouped the operators like this.
8089            The former can occur with e.g.
8090
8091                 use constant FEATURE => ( $] >= ... );
8092                 sub { not FEATURE and return or do_stuff(); }
8093          */
8094         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8095             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8096                            "Possible precedence issue with control flow operator");
8097         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8098            the "or $b" part)?
8099         */
8100         break;
8101     }
8102
8103     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8104         return newBINOP(type, flags, scalar(first), scalar(other));
8105
8106     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8107         || type == OP_CUSTOM);
8108
8109     scalarboolean(first);
8110
8111     /* search for a constant op that could let us fold the test */
8112     if ((cstop = search_const(first))) {
8113         if (cstop->op_private & OPpCONST_STRICT)
8114             no_bareword_allowed(cstop);
8115         else if ((cstop->op_private & OPpCONST_BARE))
8116                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8117         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8118             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8119             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8120             /* Elide the (constant) lhs, since it can't affect the outcome */
8121             *firstp = NULL;
8122             if (other->op_type == OP_CONST)
8123                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8124             op_free(first);
8125             if (other->op_type == OP_LEAVE)
8126                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8127             else if (other->op_type == OP_MATCH
8128                   || other->op_type == OP_SUBST
8129                   || other->op_type == OP_TRANSR
8130                   || other->op_type == OP_TRANS)
8131                 /* Mark the op as being unbindable with =~ */
8132                 other->op_flags |= OPf_SPECIAL;
8133
8134             other->op_folded = 1;
8135             return other;
8136         }
8137         else {
8138             /* Elide the rhs, since the outcome is entirely determined by
8139              * the (constant) lhs */
8140
8141             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8142             const OP *o2 = other;
8143             if ( ! (o2->op_type == OP_LIST
8144                     && (( o2 = cUNOPx(o2)->op_first))
8145                     && o2->op_type == OP_PUSHMARK
8146                     && (( o2 = OpSIBLING(o2))) )
8147             )
8148                 o2 = other;
8149             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8150                         || o2->op_type == OP_PADHV)
8151                 && o2->op_private & OPpLVAL_INTRO
8152                 && !(o2->op_private & OPpPAD_STATE))
8153             {
8154                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8155                                 "Deprecated use of my() in false conditional. "
8156                                 "This will be a fatal error in Perl 5.30");
8157             }
8158
8159             *otherp = NULL;
8160             if (cstop->op_type == OP_CONST)
8161                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8162             op_free(other);
8163             return first;
8164         }
8165     }
8166     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8167         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8168     {
8169         const OP * const k1 = ((UNOP*)first)->op_first;
8170         const OP * const k2 = OpSIBLING(k1);
8171         OPCODE warnop = 0;
8172         switch (first->op_type)
8173         {
8174         case OP_NULL:
8175             if (k2 && k2->op_type == OP_READLINE
8176                   && (k2->op_flags & OPf_STACKED)
8177                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8178             {
8179                 warnop = k2->op_type;
8180             }
8181             break;
8182
8183         case OP_SASSIGN:
8184             if (k1->op_type == OP_READDIR
8185                   || k1->op_type == OP_GLOB
8186                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8187                  || k1->op_type == OP_EACH
8188                  || k1->op_type == OP_AEACH)
8189             {
8190                 warnop = ((k1->op_type == OP_NULL)
8191                           ? (OPCODE)k1->op_targ : k1->op_type);
8192             }
8193             break;
8194         }
8195         if (warnop) {
8196             const line_t oldline = CopLINE(PL_curcop);
8197             /* This ensures that warnings are reported at the first line
8198                of the construction, not the last.  */
8199             CopLINE_set(PL_curcop, PL_parser->copline);
8200             Perl_warner(aTHX_ packWARN(WARN_MISC),
8201                  "Value of %s%s can be \"0\"; test with defined()",
8202                  PL_op_desc[warnop],
8203                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8204                   ? " construct" : "() operator"));
8205             CopLINE_set(PL_curcop, oldline);
8206         }
8207     }
8208
8209     /* optimize AND and OR ops that have NOTs as children */
8210     if (first->op_type == OP_NOT
8211         && (first->op_flags & OPf_KIDS)
8212         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8213             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8214         ) {
8215         if (type == OP_AND || type == OP_OR) {
8216             if (type == OP_AND)
8217                 type = OP_OR;
8218             else
8219                 type = OP_AND;
8220             op_null(first);
8221             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8222                 op_null(other);
8223                 prepend_not = 1; /* prepend a NOT op later */
8224             }
8225         }
8226     }
8227
8228     logop = alloc_LOGOP(type, first, LINKLIST(other));
8229     logop->op_flags |= (U8)flags;
8230     logop->op_private = (U8)(1 | (flags >> 8));
8231
8232     /* establish postfix order */
8233     logop->op_next = LINKLIST(first);
8234     first->op_next = (OP*)logop;
8235     assert(!OpHAS_SIBLING(first));
8236     op_sibling_splice((OP*)logop, first, 0, other);
8237
8238     CHECKOP(type,logop);
8239
8240     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8241                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8242                 (OP*)logop);
8243     other->op_next = o;
8244
8245     return o;
8246 }
8247
8248 /*
8249 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8250
8251 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8252 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8253 will be set automatically, and, shifted up eight bits, the eight bits of
8254 C<op_private>, except that the bit with value 1 is automatically set.
8255 C<first> supplies the expression selecting between the two branches,
8256 and C<trueop> and C<falseop> supply the branches; they are consumed by
8257 this function and become part of the constructed op tree.
8258
8259 =cut
8260 */
8261
8262 OP *
8263 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8264 {
8265     dVAR;
8266     LOGOP *logop;
8267     OP *start;
8268     OP *o;
8269     OP *cstop;
8270
8271     PERL_ARGS_ASSERT_NEWCONDOP;
8272
8273     if (!falseop)
8274         return newLOGOP(OP_AND, 0, first, trueop);
8275     if (!trueop)
8276         return newLOGOP(OP_OR, 0, first, falseop);
8277
8278     scalarboolean(first);
8279     if ((cstop = search_const(first))) {
8280         /* Left or right arm of the conditional?  */
8281         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8282         OP *live = left ? trueop : falseop;
8283         OP *const dead = left ? falseop : trueop;
8284         if (cstop->op_private & OPpCONST_BARE &&
8285             cstop->op_private & OPpCONST_STRICT) {
8286             no_bareword_allowed(cstop);
8287         }
8288         op_free(first);
8289         op_free(dead);
8290         if (live->op_type == OP_LEAVE)
8291             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8292         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8293               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8294             /* Mark the op as being unbindable with =~ */
8295             live->op_flags |= OPf_SPECIAL;
8296         live->op_folded = 1;
8297         return live;
8298     }
8299     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8300     logop->op_flags |= (U8)flags;
8301     logop->op_private = (U8)(1 | (flags >> 8));
8302     logop->op_next = LINKLIST(falseop);
8303
8304     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8305             logop);
8306
8307     /* establish postfix order */
8308     start = LINKLIST(first);
8309     first->op_next = (OP*)logop;
8310
8311     /* make first, trueop, falseop siblings */
8312     op_sibling_splice((OP*)logop, first,  0, trueop);
8313     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8314
8315     o = newUNOP(OP_NULL, 0, (OP*)logop);
8316
8317     trueop->op_next = falseop->op_next = o;
8318
8319     o->op_next = start;
8320     return o;
8321 }
8322
8323 /*
8324 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8325
8326 Constructs and returns a C<range> op, with subordinate C<flip> and
8327 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8328 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8329 for both the C<flip> and C<range> ops, except that the bit with value
8330 1 is automatically set.  C<left> and C<right> supply the expressions
8331 controlling the endpoints of the range; they are consumed by this function
8332 and become part of the constructed op tree.
8333
8334 =cut
8335 */
8336
8337 OP *
8338 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8339 {
8340     LOGOP *range;
8341     OP *flip;
8342     OP *flop;
8343     OP *leftstart;
8344     OP *o;
8345
8346     PERL_ARGS_ASSERT_NEWRANGE;
8347
8348     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8349     range->op_flags = OPf_KIDS;
8350     leftstart = LINKLIST(left);
8351     range->op_private = (U8)(1 | (flags >> 8));
8352
8353     /* make left and right siblings */
8354     op_sibling_splice((OP*)range, left, 0, right);
8355
8356     range->op_next = (OP*)range;
8357     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8358     flop = newUNOP(OP_FLOP, 0, flip);
8359     o = newUNOP(OP_NULL, 0, flop);
8360     LINKLIST(flop);
8361     range->op_next = leftstart;
8362
8363     left->op_next = flip;
8364     right->op_next = flop;
8365
8366     range->op_targ =
8367         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8368     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8369     flip->op_targ =
8370         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8371     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8372     SvPADTMP_on(PAD_SV(flip->op_targ));
8373
8374     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8375     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8376
8377     /* check barewords before they might be optimized aways */
8378     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8379         no_bareword_allowed(left);
8380     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8381         no_bareword_allowed(right);
8382
8383     flip->op_next = o;
8384     if (!flip->op_private || !flop->op_private)
8385         LINKLIST(o);            /* blow off optimizer unless constant */
8386
8387     return o;
8388 }
8389
8390 /*
8391 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8392
8393 Constructs, checks, and returns an op tree expressing a loop.  This is
8394 only a loop in the control flow through the op tree; it does not have
8395 the heavyweight loop structure that allows exiting the loop by C<last>
8396 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8397 top-level op, except that some bits will be set automatically as required.
8398 C<expr> supplies the expression controlling loop iteration, and C<block>
8399 supplies the body of the loop; they are consumed by this function and
8400 become part of the constructed op tree.  C<debuggable> is currently
8401 unused and should always be 1.
8402
8403 =cut
8404 */
8405
8406 OP *
8407 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8408 {
8409     OP* listop;
8410     OP* o;
8411     const bool once = block && block->op_flags & OPf_SPECIAL &&
8412                       block->op_type == OP_NULL;
8413
8414     PERL_UNUSED_ARG(debuggable);
8415
8416     if (expr) {
8417         if (once && (
8418               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8419            || (  expr->op_type == OP_NOT
8420               && cUNOPx(expr)->op_first->op_type == OP_CONST
8421               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8422               )
8423            ))
8424             /* Return the block now, so that S_new_logop does not try to
8425                fold it away. */
8426             return block;       /* do {} while 0 does once */
8427         if (expr->op_type == OP_READLINE
8428             || expr->op_type == OP_READDIR
8429             || expr->op_type == OP_GLOB
8430             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8431             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8432             expr = newUNOP(OP_DEFINED, 0,
8433                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8434         } else if (expr->op_flags & OPf_KIDS) {
8435             const OP * const k1 = ((UNOP*)expr)->op_first;
8436             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8437             switch (expr->op_type) {
8438               case OP_NULL:
8439                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8440                       && (k2->op_flags & OPf_STACKED)
8441                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8442                     expr = newUNOP(OP_DEFINED, 0, expr);
8443                 break;
8444
8445               case OP_SASSIGN:
8446                 if (k1 && (k1->op_type == OP_READDIR
8447                       || k1->op_type == OP_GLOB
8448                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8449                      || k1->op_type == OP_EACH
8450                      || k1->op_type == OP_AEACH))
8451                     expr = newUNOP(OP_DEFINED, 0, expr);
8452                 break;
8453             }
8454         }
8455     }
8456
8457     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8458      * op, in listop. This is wrong. [perl #27024] */
8459     if (!block)
8460         block = newOP(OP_NULL, 0);
8461     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8462     o = new_logop(OP_AND, 0, &expr, &listop);
8463
8464     if (once) {
8465         ASSUME(listop);
8466     }
8467
8468     if (listop)
8469         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8470
8471     if (once && o != listop)
8472     {
8473         assert(cUNOPo->op_first->op_type == OP_AND
8474             || cUNOPo->op_first->op_type == OP_OR);
8475         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8476     }
8477
8478     if (o == listop)
8479         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8480
8481     o->op_flags |= flags;
8482     o = op_scope(o);
8483     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8484     return o;
8485 }
8486
8487 /*
8488 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8489
8490 Constructs, checks, and returns an op tree expressing a C<while> loop.
8491 This is a heavyweight loop, with structure that allows exiting the loop
8492 by C<last> and suchlike.
8493
8494 C<loop> is an optional preconstructed C<enterloop> op to use in the
8495 loop; if it is null then a suitable op will be constructed automatically.
8496 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8497 main body of the loop, and C<cont> optionally supplies a C<continue> block
8498 that operates as a second half of the body.  All of these optree inputs
8499 are consumed by this function and become part of the constructed op tree.
8500
8501 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8502 op and, shifted up eight bits, the eight bits of C<op_private> for
8503 the C<leaveloop> op, except that (in both cases) some bits will be set
8504 automatically.  C<debuggable> is currently unused and should always be 1.
8505 C<has_my> can be supplied as true to force the
8506 loop body to be enclosed in its own scope.
8507
8508 =cut
8509 */
8510
8511 OP *
8512 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8513         OP *expr, OP *block, OP *cont, I32 has_my)
8514 {
8515     dVAR;
8516     OP *redo;
8517     OP *next = NULL;
8518     OP *listop;
8519     OP *o;
8520     U8 loopflags = 0;
8521
8522     PERL_UNUSED_ARG(debuggable);
8523
8524     if (expr) {
8525         if (expr->op_type == OP_READLINE
8526          || expr->op_type == OP_READDIR
8527          || expr->op_type == OP_GLOB
8528          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8529                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8530             expr = newUNOP(OP_DEFINED, 0,
8531                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8532         } else if (expr->op_flags & OPf_KIDS) {
8533             const OP * const k1 = ((UNOP*)expr)->op_first;
8534             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8535             switch (expr->op_type) {
8536               case OP_NULL:
8537                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8538                       && (k2->op_flags & OPf_STACKED)
8539                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8540                     expr = newUNOP(OP_DEFINED, 0, expr);
8541                 break;
8542
8543               case OP_SASSIGN:
8544                 if (k1 && (k1->op_type == OP_READDIR
8545                       || k1->op_type == OP_GLOB
8546                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8547                      || k1->op_type == OP_EACH
8548                      || k1->op_type == OP_AEACH))
8549                     expr = newUNOP(OP_DEFINED, 0, expr);
8550                 break;
8551             }
8552         }
8553     }
8554
8555     if (!block)
8556         block = newOP(OP_NULL, 0);
8557     else if (cont || has_my) {
8558         block = op_scope(block);
8559     }
8560
8561     if (cont) {
8562         next = LINKLIST(cont);
8563     }
8564     if (expr) {
8565         OP * const unstack = newOP(OP_UNSTACK, 0);
8566         if (!next)
8567             next = unstack;
8568         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8569     }
8570
8571     assert(block);
8572     listop = op_append_list(OP_LINESEQ, block, cont);
8573     assert(listop);
8574     redo = LINKLIST(listop);
8575
8576     if (expr) {
8577         scalar(listop);
8578         o = new_logop(OP_AND, 0, &expr, &listop);
8579         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8580             op_free((OP*)loop);
8581             return expr;                /* listop already freed by new_logop */
8582         }
8583         if (listop)
8584             ((LISTOP*)listop)->op_last->op_next =
8585                 (o == listop ? redo : LINKLIST(o));
8586     }
8587     else
8588         o = listop;
8589
8590     if (!loop) {
8591         NewOp(1101,loop,1,LOOP);
8592         OpTYPE_set(loop, OP_ENTERLOOP);
8593         loop->op_private = 0;
8594         loop->op_next = (OP*)loop;
8595     }
8596
8597     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8598
8599     loop->op_redoop = redo;
8600     loop->op_lastop = o;
8601     o->op_private |= loopflags;
8602
8603     if (next)
8604         loop->op_nextop = next;
8605     else
8606         loop->op_nextop = o;
8607
8608     o->op_flags |= flags;
8609     o->op_private |= (flags >> 8);
8610     return o;
8611 }
8612
8613 /*
8614 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8615
8616 Constructs, checks, and returns an op tree expressing a C<foreach>
8617 loop (iteration through a list of values).  This is a heavyweight loop,
8618 with structure that allows exiting the loop by C<last> and suchlike.
8619
8620 C<sv> optionally supplies the variable that will be aliased to each
8621 item in turn; if null, it defaults to C<$_>.
8622 C<expr> supplies the list of values to iterate over.  C<block> supplies
8623 the main body of the loop, and C<cont> optionally supplies a C<continue>
8624 block that operates as a second half of the body.  All of these optree
8625 inputs are consumed by this function and become part of the constructed
8626 op tree.
8627
8628 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8629 op and, shifted up eight bits, the eight bits of C<op_private> for
8630 the C<leaveloop> op, except that (in both cases) some bits will be set
8631 automatically.
8632
8633 =cut
8634 */
8635
8636 OP *
8637 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8638 {
8639     dVAR;
8640     LOOP *loop;
8641     OP *wop;
8642     PADOFFSET padoff = 0;
8643     I32 iterflags = 0;
8644     I32 iterpflags = 0;
8645
8646     PERL_ARGS_ASSERT_NEWFOROP;
8647
8648     if (sv) {
8649         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8650             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8651             OpTYPE_set(sv, OP_RV2GV);
8652
8653             /* The op_type check is needed to prevent a possible segfault
8654              * if the loop variable is undeclared and 'strict vars' is in
8655              * effect. This is illegal but is nonetheless parsed, so we
8656              * may reach this point with an OP_CONST where we're expecting
8657              * an OP_GV.
8658              */
8659             if (cUNOPx(sv)->op_first->op_type == OP_GV
8660              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8661                 iterpflags |= OPpITER_DEF;
8662         }
8663         else if (sv->op_type == OP_PADSV) { /* private variable */
8664             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8665             padoff = sv->op_targ;
8666             sv->op_targ = 0;
8667             op_free(sv);
8668             sv = NULL;
8669             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8670         }
8671         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8672             NOOP;
8673         else
8674             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8675         if (padoff) {
8676             PADNAME * const pn = PAD_COMPNAME(padoff);
8677             const char * const name = PadnamePV(pn);
8678
8679             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8680                 iterpflags |= OPpITER_DEF;
8681         }
8682     }
8683     else {
8684         sv = newGVOP(OP_GV, 0, PL_defgv);
8685         iterpflags |= OPpITER_DEF;
8686     }
8687
8688     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8689         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8690         iterflags |= OPf_STACKED;
8691     }
8692     else if (expr->op_type == OP_NULL &&
8693              (expr->op_flags & OPf_KIDS) &&
8694              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8695     {
8696         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8697          * set the STACKED flag to indicate that these values are to be
8698          * treated as min/max values by 'pp_enteriter'.
8699          */
8700         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8701         LOGOP* const range = (LOGOP*) flip->op_first;
8702         OP* const left  = range->op_first;
8703         OP* const right = OpSIBLING(left);
8704         LISTOP* listop;
8705
8706         range->op_flags &= ~OPf_KIDS;
8707         /* detach range's children */
8708         op_sibling_splice((OP*)range, NULL, -1, NULL);
8709
8710         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8711         listop->op_first->op_next = range->op_next;
8712         left->op_next = range->op_other;
8713         right->op_next = (OP*)listop;
8714         listop->op_next = listop->op_first;
8715
8716         op_free(expr);
8717         expr = (OP*)(listop);
8718         op_null(expr);
8719         iterflags |= OPf_STACKED;
8720     }
8721     else {
8722         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8723     }
8724
8725     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8726                                   op_append_elem(OP_LIST, list(expr),
8727                                                  scalar(sv)));
8728     assert(!loop->op_next);
8729     /* for my  $x () sets OPpLVAL_INTRO;
8730      * for our $x () sets OPpOUR_INTRO */
8731     loop->op_private = (U8)iterpflags;
8732     if (loop->op_slabbed
8733      && DIFF(loop, OpSLOT(loop)->opslot_next)
8734          < SIZE_TO_PSIZE(sizeof(LOOP)))
8735     {
8736         LOOP *tmp;
8737         NewOp(1234,tmp,1,LOOP);
8738         Copy(loop,tmp,1,LISTOP);
8739 #ifdef PERL_OP_PARENT
8740         assert(loop->op_last->op_sibparent == (OP*)loop);
8741         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8742 #endif
8743         S_op_destroy(aTHX_ (OP*)loop);
8744         loop = tmp;
8745     }
8746     else if (!loop->op_slabbed)
8747     {
8748         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8749 #ifdef PERL_OP_PARENT
8750         OpLASTSIB_set(loop->op_last, (OP*)loop);
8751 #endif
8752     }
8753     loop->op_targ = padoff;
8754     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8755     return wop;
8756 }
8757
8758 /*
8759 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8760
8761 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8762 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8763 determining the target of the op; it is consumed by this function and
8764 becomes part of the constructed op tree.
8765
8766 =cut
8767 */
8768
8769 OP*
8770 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8771 {
8772     OP *o = NULL;
8773
8774     PERL_ARGS_ASSERT_NEWLOOPEX;
8775
8776     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8777         || type == OP_CUSTOM);
8778
8779     if (type != OP_GOTO) {
8780         /* "last()" means "last" */
8781         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8782             o = newOP(type, OPf_SPECIAL);
8783         }
8784     }
8785     else {
8786         /* Check whether it's going to be a goto &function */
8787         if (label->op_type == OP_ENTERSUB
8788                 && !(label->op_flags & OPf_STACKED))
8789             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8790     }
8791
8792     /* Check for a constant argument */
8793     if (label->op_type == OP_CONST) {
8794             SV * const sv = ((SVOP *)label)->op_sv;
8795             STRLEN l;
8796             const char *s = SvPV_const(sv,l);
8797             if (l == strlen(s)) {
8798                 o = newPVOP(type,
8799                             SvUTF8(((SVOP*)label)->op_sv),
8800                             savesharedpv(
8801                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8802             }
8803     }
8804
8805     /* If we have already created an op, we do not need the label. */
8806     if (o)
8807                 op_free(label);
8808     else o = newUNOP(type, OPf_STACKED, label);
8809
8810     PL_hints |= HINT_BLOCK_SCOPE;
8811     return o;
8812 }
8813
8814 /* if the condition is a literal array or hash
8815    (or @{ ... } etc), make a reference to it.
8816  */
8817 STATIC OP *
8818 S_ref_array_or_hash(pTHX_ OP *cond)
8819 {
8820     if (cond
8821     && (cond->op_type == OP_RV2AV
8822     ||  cond->op_type == OP_PADAV
8823     ||  cond->op_type == OP_RV2HV
8824     ||  cond->op_type == OP_PADHV))
8825
8826         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8827
8828     else if(cond
8829     && (cond->op_type == OP_ASLICE
8830     ||  cond->op_type == OP_KVASLICE
8831     ||  cond->op_type == OP_HSLICE
8832     ||  cond->op_type == OP_KVHSLICE)) {
8833
8834         /* anonlist now needs a list from this op, was previously used in
8835          * scalar context */
8836         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8837         cond->op_flags |= OPf_WANT_LIST;
8838
8839         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8840     }
8841
8842     else
8843         return cond;
8844 }
8845
8846 /* These construct the optree fragments representing given()
8847    and when() blocks.
8848
8849    entergiven and enterwhen are LOGOPs; the op_other pointer
8850    points up to the associated leave op. We need this so we
8851    can put it in the context and make break/continue work.
8852    (Also, of course, pp_enterwhen will jump straight to
8853    op_other if the match fails.)
8854  */
8855
8856 STATIC OP *
8857 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8858                    I32 enter_opcode, I32 leave_opcode,
8859                    PADOFFSET entertarg)
8860 {
8861     dVAR;
8862     LOGOP *enterop;
8863     OP *o;
8864
8865     PERL_ARGS_ASSERT_NEWGIVWHENOP;
8866     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8867
8868     enterop = alloc_LOGOP(enter_opcode, block, NULL);
8869     enterop->op_targ = 0;
8870     enterop->op_private = 0;
8871
8872     o = newUNOP(leave_opcode, 0, (OP *) enterop);
8873
8874     if (cond) {
8875         /* prepend cond if we have one */
8876         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8877
8878         o->op_next = LINKLIST(cond);
8879         cond->op_next = (OP *) enterop;
8880     }
8881     else {
8882         /* This is a default {} block */
8883         enterop->op_flags |= OPf_SPECIAL;
8884         o      ->op_flags |= OPf_SPECIAL;
8885
8886         o->op_next = (OP *) enterop;
8887     }
8888
8889     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
8890                                        entergiven and enterwhen both
8891                                        use ck_null() */
8892
8893     enterop->op_next = LINKLIST(block);
8894     block->op_next = enterop->op_other = o;
8895
8896     return o;
8897 }
8898
8899 /* Does this look like a boolean operation? For these purposes
8900    a boolean operation is:
8901      - a subroutine call [*]
8902      - a logical connective
8903      - a comparison operator
8904      - a filetest operator, with the exception of -s -M -A -C
8905      - defined(), exists() or eof()
8906      - /$re/ or $foo =~ /$re/
8907
8908    [*] possibly surprising
8909  */
8910 STATIC bool
8911 S_looks_like_bool(pTHX_ const OP *o)
8912 {
8913     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
8914
8915     switch(o->op_type) {
8916         case OP_OR:
8917         case OP_DOR:
8918             return looks_like_bool(cLOGOPo->op_first);
8919
8920         case OP_AND:
8921         {
8922             OP* sibl = OpSIBLING(cLOGOPo->op_first);
8923             ASSUME(sibl);
8924             return (
8925                 looks_like_bool(cLOGOPo->op_first)
8926              && looks_like_bool(sibl));
8927         }
8928
8929         case OP_NULL:
8930         case OP_SCALAR:
8931             return (
8932                 o->op_flags & OPf_KIDS
8933             && looks_like_bool(cUNOPo->op_first));
8934
8935         case OP_ENTERSUB:
8936
8937         case OP_NOT:    case OP_XOR:
8938
8939         case OP_EQ:     case OP_NE:     case OP_LT:
8940         case OP_GT:     case OP_LE:     case OP_GE:
8941
8942         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
8943         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
8944
8945         case OP_SEQ:    case OP_SNE:    case OP_SLT:
8946         case OP_SGT:    case OP_SLE:    case OP_SGE:
8947
8948         case OP_SMARTMATCH:
8949
8950         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
8951         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
8952         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
8953         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
8954         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
8955         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
8956         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
8957         case OP_FTTEXT:   case OP_FTBINARY:
8958
8959         case OP_DEFINED: case OP_EXISTS:
8960         case OP_MATCH:   case OP_EOF:
8961
8962         case OP_FLOP:
8963
8964             return TRUE;
8965
8966         case OP_CONST:
8967             /* Detect comparisons that have been optimized away */
8968             if (cSVOPo->op_sv == &PL_sv_yes
8969             ||  cSVOPo->op_sv == &PL_sv_no)
8970
8971                 return TRUE;
8972             else
8973                 return FALSE;
8974
8975         /* FALLTHROUGH */
8976         default:
8977             return FALSE;
8978     }
8979 }
8980
8981 /*
8982 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
8983
8984 Constructs, checks, and returns an op tree expressing a C<given> block.
8985 C<cond> supplies the expression to whose value C<$_> will be locally
8986 aliased, and C<block> supplies the body of the C<given> construct; they
8987 are consumed by this function and become part of the constructed op tree.
8988 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
8989
8990 =cut
8991 */
8992
8993 OP *
8994 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
8995 {
8996     PERL_ARGS_ASSERT_NEWGIVENOP;
8997     PERL_UNUSED_ARG(defsv_off);
8998
8999     assert(!defsv_off);
9000     return newGIVWHENOP(
9001         ref_array_or_hash(cond),
9002         block,
9003         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9004         0);
9005 }
9006
9007 /*
9008 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9009
9010 Constructs, checks, and returns an op tree expressing a C<when> block.
9011 C<cond> supplies the test expression, and C<block> supplies the block
9012 that will be executed if the test evaluates to true; they are consumed
9013 by this function and become part of the constructed op tree.  C<cond>
9014 will be interpreted DWIMically, often as a comparison against C<$_>,
9015 and may be null to generate a C<default> block.
9016
9017 =cut
9018 */
9019
9020 OP *
9021 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9022 {
9023     const bool cond_llb = (!cond || looks_like_bool(cond));
9024     OP *cond_op;
9025
9026     PERL_ARGS_ASSERT_NEWWHENOP;
9027
9028     if (cond_llb)
9029         cond_op = cond;
9030     else {
9031         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9032                 newDEFSVOP(),
9033                 scalar(ref_array_or_hash(cond)));
9034     }
9035
9036     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9037 }
9038
9039 /* must not conflict with SVf_UTF8 */
9040 #define CV_CKPROTO_CURSTASH     0x1
9041
9042 void
9043 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9044                     const STRLEN len, const U32 flags)
9045 {
9046     SV *name = NULL, *msg;
9047     const char * cvp = SvROK(cv)
9048                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9049                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9050                            : ""
9051                         : CvPROTO(cv);
9052     STRLEN clen = CvPROTOLEN(cv), plen = len;
9053
9054     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9055
9056     if (p == NULL && cvp == NULL)
9057         return;
9058
9059     if (!ckWARN_d(WARN_PROTOTYPE))
9060         return;
9061
9062     if (p && cvp) {
9063         p = S_strip_spaces(aTHX_ p, &plen);
9064         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9065         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9066             if (plen == clen && memEQ(cvp, p, plen))
9067                 return;
9068         } else {
9069             if (flags & SVf_UTF8) {
9070                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9071                     return;
9072             }
9073             else {
9074                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9075                     return;
9076             }
9077         }
9078     }
9079
9080     msg = sv_newmortal();
9081
9082     if (gv)
9083     {
9084         if (isGV(gv))
9085             gv_efullname3(name = sv_newmortal(), gv, NULL);
9086         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9087             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9088         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9089             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9090             sv_catpvs(name, "::");
9091             if (SvROK(gv)) {
9092                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9093                 assert (CvNAMED(SvRV_const(gv)));
9094                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9095             }
9096             else sv_catsv(name, (SV *)gv);
9097         }
9098         else name = (SV *)gv;
9099     }
9100     sv_setpvs(msg, "Prototype mismatch:");
9101     if (name)
9102         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9103     if (cvp)
9104         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9105             UTF8fARG(SvUTF8(cv),clen,cvp)
9106         );
9107     else
9108         sv_catpvs(msg, ": none");
9109     sv_catpvs(msg, " vs ");
9110     if (p)
9111         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9112     else
9113         sv_catpvs(msg, "none");
9114     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9115 }
9116
9117 static void const_sv_xsub(pTHX_ CV* cv);
9118 static void const_av_xsub(pTHX_ CV* cv);
9119
9120 /*
9121
9122 =head1 Optree Manipulation Functions
9123
9124 =for apidoc cv_const_sv
9125
9126 If C<cv> is a constant sub eligible for inlining, returns the constant
9127 value returned by the sub.  Otherwise, returns C<NULL>.
9128
9129 Constant subs can be created with C<newCONSTSUB> or as described in
9130 L<perlsub/"Constant Functions">.
9131
9132 =cut
9133 */
9134 SV *
9135 Perl_cv_const_sv(const CV *const cv)
9136 {
9137     SV *sv;
9138     if (!cv)
9139         return NULL;
9140     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9141         return NULL;
9142     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9143     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9144     return sv;
9145 }
9146
9147 SV *
9148 Perl_cv_const_sv_or_av(const CV * const cv)
9149 {
9150     if (!cv)
9151         return NULL;
9152     if (SvROK(cv)) return SvRV((SV *)cv);
9153     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9154     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9155 }
9156
9157 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9158  * Can be called in 2 ways:
9159  *
9160  * !allow_lex
9161  *      look for a single OP_CONST with attached value: return the value
9162  *
9163  * allow_lex && !CvCONST(cv);
9164  *
9165  *      examine the clone prototype, and if contains only a single
9166  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9167  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9168  *      a candidate for "constizing" at clone time, and return NULL.
9169  */
9170
9171 static SV *
9172 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9173 {
9174     SV *sv = NULL;
9175     bool padsv = FALSE;
9176
9177     assert(o);
9178     assert(cv);
9179
9180     for (; o; o = o->op_next) {
9181         const OPCODE type = o->op_type;
9182
9183         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9184              || type == OP_NULL
9185              || type == OP_PUSHMARK)
9186                 continue;
9187         if (type == OP_DBSTATE)
9188                 continue;
9189         if (type == OP_LEAVESUB)
9190             break;
9191         if (sv)
9192             return NULL;
9193         if (type == OP_CONST && cSVOPo->op_sv)
9194             sv = cSVOPo->op_sv;
9195         else if (type == OP_UNDEF && !o->op_private) {
9196             sv = newSV(0);
9197             SAVEFREESV(sv);
9198         }
9199         else if (allow_lex && type == OP_PADSV) {
9200                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9201                 {
9202                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9203                     padsv = TRUE;
9204                 }
9205                 else
9206                     return NULL;
9207         }
9208         else {
9209             return NULL;
9210         }
9211     }
9212     if (padsv) {
9213         CvCONST_on(cv);
9214         return NULL;
9215     }
9216     return sv;
9217 }
9218
9219 static void
9220 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9221                         PADNAME * const name, SV ** const const_svp)
9222 {
9223     assert (cv);
9224     assert (o || name);
9225     assert (const_svp);
9226     if (!block) {
9227         if (CvFLAGS(PL_compcv)) {
9228             /* might have had built-in attrs applied */
9229             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9230             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9231              && ckWARN(WARN_MISC))
9232             {
9233                 /* protect against fatal warnings leaking compcv */
9234                 SAVEFREESV(PL_compcv);
9235                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9236                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9237             }
9238             CvFLAGS(cv) |=
9239                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9240                   & ~(CVf_LVALUE * pureperl));
9241         }
9242         return;
9243     }
9244
9245     /* redundant check for speed: */
9246     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9247         const line_t oldline = CopLINE(PL_curcop);
9248         SV *namesv = o
9249             ? cSVOPo->op_sv
9250             : sv_2mortal(newSVpvn_utf8(
9251                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9252               ));
9253         if (PL_parser && PL_parser->copline != NOLINE)
9254             /* This ensures that warnings are reported at the first
9255                line of a redefinition, not the last.  */
9256             CopLINE_set(PL_curcop, PL_parser->copline);
9257         /* protect against fatal warnings leaking compcv */
9258         SAVEFREESV(PL_compcv);
9259         report_redefined_cv(namesv, cv, const_svp);
9260         SvREFCNT_inc_simple_void_NN(PL_compcv);
9261         CopLINE_set(PL_curcop, oldline);
9262     }
9263     SAVEFREESV(cv);
9264     return;
9265 }
9266
9267 CV *
9268 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9269 {
9270     CV **spot;
9271     SV **svspot;
9272     const char *ps;
9273     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9274     U32 ps_utf8 = 0;
9275     CV *cv = NULL;
9276     CV *compcv = PL_compcv;
9277     SV *const_sv;
9278     PADNAME *name;
9279     PADOFFSET pax = o->op_targ;
9280     CV *outcv = CvOUTSIDE(PL_compcv);
9281     CV *clonee = NULL;
9282     HEK *hek = NULL;
9283     bool reusable = FALSE;
9284     OP *start = NULL;
9285 #ifdef PERL_DEBUG_READONLY_OPS
9286     OPSLAB *slab = NULL;
9287 #endif
9288
9289     PERL_ARGS_ASSERT_NEWMYSUB;
9290
9291     PL_hints |= HINT_BLOCK_SCOPE;
9292
9293     /* Find the pad slot for storing the new sub.
9294        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9295        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9296        ing sub.  And then we need to dig deeper if this is a lexical from
9297        outside, as in:
9298            my sub foo; sub { sub foo { } }
9299      */
9300   redo:
9301     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9302     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9303         pax = PARENT_PAD_INDEX(name);
9304         outcv = CvOUTSIDE(outcv);
9305         assert(outcv);
9306         goto redo;
9307     }
9308     svspot =
9309         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9310                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9311     spot = (CV **)svspot;
9312
9313     if (!(PL_parser && PL_parser->error_count))
9314         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9315
9316     if (proto) {
9317         assert(proto->op_type == OP_CONST);
9318         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9319         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9320     }
9321     else
9322         ps = NULL;
9323
9324     if (proto)
9325         SAVEFREEOP(proto);
9326     if (attrs)
9327         SAVEFREEOP(attrs);
9328
9329     if (PL_parser && PL_parser->error_count) {
9330         op_free(block);
9331         SvREFCNT_dec(PL_compcv);
9332         PL_compcv = 0;
9333         goto done;
9334     }
9335
9336     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9337         cv = *spot;
9338         svspot = (SV **)(spot = &clonee);
9339     }
9340     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9341         cv = *spot;
9342     else {
9343         assert (SvTYPE(*spot) == SVt_PVCV);
9344         if (CvNAMED(*spot))
9345             hek = CvNAME_HEK(*spot);
9346         else {
9347             dVAR;
9348             U32 hash;
9349             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9350             CvNAME_HEK_set(*spot, hek =
9351                 share_hek(
9352                     PadnamePV(name)+1,
9353                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9354                     hash
9355                 )
9356             );
9357             CvLEXICAL_on(*spot);
9358         }
9359         cv = PadnamePROTOCV(name);
9360         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9361     }
9362
9363     if (block) {
9364         /* This makes sub {}; work as expected.  */
9365         if (block->op_type == OP_STUB) {
9366             const line_t l = PL_parser->copline;
9367             op_free(block);
9368             block = newSTATEOP(0, NULL, 0);
9369             PL_parser->copline = l;
9370         }
9371         block = CvLVALUE(compcv)
9372              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9373                    ? newUNOP(OP_LEAVESUBLV, 0,
9374                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9375                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9376         start = LINKLIST(block);
9377         block->op_next = 0;
9378         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9379             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9380         else
9381             const_sv = NULL;
9382     }
9383     else
9384         const_sv = NULL;
9385
9386     if (cv) {
9387         const bool exists = CvROOT(cv) || CvXSUB(cv);
9388
9389         /* if the subroutine doesn't exist and wasn't pre-declared
9390          * with a prototype, assume it will be AUTOLOADed,
9391          * skipping the prototype check
9392          */
9393         if (exists || SvPOK(cv))
9394             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9395                                  ps_utf8);
9396         /* already defined? */
9397         if (exists) {
9398             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9399             if (block)
9400                 cv = NULL;
9401             else {
9402                 if (attrs)
9403                     goto attrs;
9404                 /* just a "sub foo;" when &foo is already defined */
9405                 SAVEFREESV(compcv);
9406                 goto done;
9407             }
9408         }
9409         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9410             cv = NULL;
9411             reusable = TRUE;
9412         }
9413     }
9414
9415     if (const_sv) {
9416         SvREFCNT_inc_simple_void_NN(const_sv);
9417         SvFLAGS(const_sv) |= SVs_PADTMP;
9418         if (cv) {
9419             assert(!CvROOT(cv) && !CvCONST(cv));
9420             cv_forget_slab(cv);
9421         }
9422         else {
9423             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9424             CvFILE_set_from_cop(cv, PL_curcop);
9425             CvSTASH_set(cv, PL_curstash);
9426             *spot = cv;
9427         }
9428         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9429         CvXSUBANY(cv).any_ptr = const_sv;
9430         CvXSUB(cv) = const_sv_xsub;
9431         CvCONST_on(cv);
9432         CvISXSUB_on(cv);
9433         PoisonPADLIST(cv);
9434         CvFLAGS(cv) |= CvMETHOD(compcv);
9435         op_free(block);
9436         SvREFCNT_dec(compcv);
9437         PL_compcv = NULL;
9438         goto setname;
9439     }
9440
9441     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9442        determine whether this sub definition is in the same scope as its
9443        declaration.  If this sub definition is inside an inner named pack-
9444        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9445        the package sub.  So check PadnameOUTER(name) too.
9446      */
9447     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9448         assert(!CvWEAKOUTSIDE(compcv));
9449         SvREFCNT_dec(CvOUTSIDE(compcv));
9450         CvWEAKOUTSIDE_on(compcv);
9451     }
9452     /* XXX else do we have a circular reference? */
9453
9454     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9455         /* transfer PL_compcv to cv */
9456         if (block) {
9457             cv_flags_t preserved_flags =
9458                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9459             PADLIST *const temp_padl = CvPADLIST(cv);
9460             CV *const temp_cv = CvOUTSIDE(cv);
9461             const cv_flags_t other_flags =
9462                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9463             OP * const cvstart = CvSTART(cv);
9464
9465             SvPOK_off(cv);
9466             CvFLAGS(cv) =
9467                 CvFLAGS(compcv) | preserved_flags;
9468             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9469             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9470             CvPADLIST_set(cv, CvPADLIST(compcv));
9471             CvOUTSIDE(compcv) = temp_cv;
9472             CvPADLIST_set(compcv, temp_padl);
9473             CvSTART(cv) = CvSTART(compcv);
9474             CvSTART(compcv) = cvstart;
9475             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9476             CvFLAGS(compcv) |= other_flags;
9477
9478             if (CvFILE(cv) && CvDYNFILE(cv)) {
9479                 Safefree(CvFILE(cv));
9480             }
9481
9482             /* inner references to compcv must be fixed up ... */
9483             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9484             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9485                 ++PL_sub_generation;
9486         }
9487         else {
9488             /* Might have had built-in attributes applied -- propagate them. */
9489             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9490         }
9491         /* ... before we throw it away */
9492         SvREFCNT_dec(compcv);
9493         PL_compcv = compcv = cv;
9494     }
9495     else {
9496         cv = compcv;
9497         *spot = cv;
9498     }
9499
9500   setname:
9501     CvLEXICAL_on(cv);
9502     if (!CvNAME_HEK(cv)) {
9503         if (hek) (void)share_hek_hek(hek);
9504         else {
9505             dVAR;
9506             U32 hash;
9507             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9508             hek = share_hek(PadnamePV(name)+1,
9509                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9510                       hash);
9511         }
9512         CvNAME_HEK_set(cv, hek);
9513     }
9514
9515     if (const_sv)
9516         goto clone;
9517
9518     CvFILE_set_from_cop(cv, PL_curcop);
9519     CvSTASH_set(cv, PL_curstash);
9520
9521     if (ps) {
9522         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9523         if (ps_utf8)
9524             SvUTF8_on(MUTABLE_SV(cv));
9525     }
9526
9527     if (block) {
9528         /* If we assign an optree to a PVCV, then we've defined a
9529          * subroutine that the debugger could be able to set a breakpoint
9530          * in, so signal to pp_entereval that it should not throw away any
9531          * saved lines at scope exit.  */
9532
9533         PL_breakable_sub_gen++;
9534         CvROOT(cv) = block;
9535         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9536            itself has a refcount. */
9537         CvSLABBED_off(cv);
9538         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9539 #ifdef PERL_DEBUG_READONLY_OPS
9540         slab = (OPSLAB *)CvSTART(cv);
9541 #endif
9542         S_process_optree(aTHX_ cv, block, start);
9543     }
9544
9545   attrs:
9546     if (attrs) {
9547         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9548         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9549     }
9550
9551     if (block) {
9552         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9553             SV * const tmpstr = sv_newmortal();
9554             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9555                                                   GV_ADDMULTI, SVt_PVHV);
9556             HV *hv;
9557             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9558                                           CopFILE(PL_curcop),
9559                                           (long)PL_subline,
9560                                           (long)CopLINE(PL_curcop));
9561             if (HvNAME_HEK(PL_curstash)) {
9562                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9563                 sv_catpvs(tmpstr, "::");
9564             }
9565             else
9566                 sv_setpvs(tmpstr, "__ANON__::");
9567
9568             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9569                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9570             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9571                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9572             hv = GvHVn(db_postponed);
9573             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9574                 CV * const pcv = GvCV(db_postponed);
9575                 if (pcv) {
9576                     dSP;
9577                     PUSHMARK(SP);
9578                     XPUSHs(tmpstr);
9579                     PUTBACK;
9580                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9581                 }
9582             }
9583         }
9584     }
9585
9586   clone:
9587     if (clonee) {
9588         assert(CvDEPTH(outcv));
9589         spot = (CV **)
9590             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9591         if (reusable)
9592             cv_clone_into(clonee, *spot);
9593         else *spot = cv_clone(clonee);
9594         SvREFCNT_dec_NN(clonee);
9595         cv = *spot;
9596     }
9597
9598     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9599         PADOFFSET depth = CvDEPTH(outcv);
9600         while (--depth) {
9601             SV *oldcv;
9602             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9603             oldcv = *svspot;
9604             *svspot = SvREFCNT_inc_simple_NN(cv);
9605             SvREFCNT_dec(oldcv);
9606         }
9607     }
9608
9609   done:
9610     if (PL_parser)
9611         PL_parser->copline = NOLINE;
9612     LEAVE_SCOPE(floor);
9613 #ifdef PERL_DEBUG_READONLY_OPS
9614     if (slab)
9615         Slab_to_ro(slab);
9616 #endif
9617     op_free(o);
9618     return cv;
9619 }
9620
9621 /*
9622 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9623
9624 Construct a Perl subroutine, also performing some surrounding jobs.
9625
9626 This function is expected to be called in a Perl compilation context,
9627 and some aspects of the subroutine are taken from global variables
9628 associated with compilation.  In particular, C<PL_compcv> represents
9629 the subroutine that is currently being compiled.  It must be non-null
9630 when this function is called, and some aspects of the subroutine being
9631 constructed are taken from it.  The constructed subroutine may actually
9632 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9633
9634 If C<block> is null then the subroutine will have no body, and for the
9635 time being it will be an error to call it.  This represents a forward
9636 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9637 non-null then it provides the Perl code of the subroutine body, which
9638 will be executed when the subroutine is called.  This body includes
9639 any argument unwrapping code resulting from a subroutine signature or
9640 similar.  The pad use of the code must correspond to the pad attached
9641 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9642 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9643 by this function and will become part of the constructed subroutine.
9644
9645 C<proto> specifies the subroutine's prototype, unless one is supplied
9646 as an attribute (see below).  If C<proto> is null, then the subroutine
9647 will not have a prototype.  If C<proto> is non-null, it must point to a
9648 C<const> op whose value is a string, and the subroutine will have that
9649 string as its prototype.  If a prototype is supplied as an attribute, the
9650 attribute takes precedence over C<proto>, but in that case C<proto> should
9651 preferably be null.  In any case, C<proto> is consumed by this function.
9652
9653 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9654 attributes take effect by built-in means, being applied to C<PL_compcv>
9655 immediately when seen.  Other attributes are collected up and attached
9656 to the subroutine by this route.  C<attrs> may be null to supply no
9657 attributes, or point to a C<const> op for a single attribute, or point
9658 to a C<list> op whose children apart from the C<pushmark> are C<const>
9659 ops for one or more attributes.  Each C<const> op must be a string,
9660 giving the attribute name optionally followed by parenthesised arguments,
9661 in the manner in which attributes appear in Perl source.  The attributes
9662 will be applied to the sub by this function.  C<attrs> is consumed by
9663 this function.
9664
9665 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9666 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9667 must point to a C<const> op, which will be consumed by this function,
9668 and its string value supplies a name for the subroutine.  The name may
9669 be qualified or unqualified, and if it is unqualified then a default
9670 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9671 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9672 by which the subroutine will be named.
9673
9674 If there is already a subroutine of the specified name, then the new
9675 sub will either replace the existing one in the glob or be merged with
9676 the existing one.  A warning may be generated about redefinition.
9677
9678 If the subroutine has one of a few special names, such as C<BEGIN> or
9679 C<END>, then it will be claimed by the appropriate queue for automatic
9680 running of phase-related subroutines.  In this case the relevant glob will
9681 be left not containing any subroutine, even if it did contain one before.
9682 In the case of C<BEGIN>, the subroutine will be executed and the reference
9683 to it disposed of before this function returns.
9684
9685 The function returns a pointer to the constructed subroutine.  If the sub
9686 is anonymous then ownership of one counted reference to the subroutine
9687 is transferred to the caller.  If the sub is named then the caller does
9688 not get ownership of a reference.  In most such cases, where the sub
9689 has a non-phase name, the sub will be alive at the point it is returned
9690 by virtue of being contained in the glob that names it.  A phase-named
9691 subroutine will usually be alive by virtue of the reference owned by the
9692 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9693 been executed, will quite likely have been destroyed already by the
9694 time this function returns, making it erroneous for the caller to make
9695 any use of the returned pointer.  It is the caller's responsibility to
9696 ensure that it knows which of these situations applies.
9697
9698 =cut
9699 */
9700
9701 /* _x = extended */
9702 CV *
9703 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9704                             OP *block, bool o_is_gv)
9705 {
9706     GV *gv;
9707     const char *ps;
9708     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9709     U32 ps_utf8 = 0;
9710     CV *cv = NULL;     /* the previous CV with this name, if any */
9711     SV *const_sv;
9712     const bool ec = PL_parser && PL_parser->error_count;
9713     /* If the subroutine has no body, no attributes, and no builtin attributes
9714        then it's just a sub declaration, and we may be able to get away with
9715        storing with a placeholder scalar in the symbol table, rather than a
9716        full CV.  If anything is present then it will take a full CV to
9717        store it.  */
9718     const I32 gv_fetch_flags
9719         = ec ? GV_NOADD_NOINIT :
9720         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9721         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9722     STRLEN namlen = 0;
9723     const char * const name =
9724          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9725     bool has_name;
9726     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9727     bool evanescent = FALSE;
9728     OP *start = NULL;
9729 #ifdef PERL_DEBUG_READONLY_OPS
9730     OPSLAB *slab = NULL;
9731 #endif
9732
9733     if (o_is_gv) {
9734         gv = (GV*)o;
9735         o = NULL;
9736         has_name = TRUE;
9737     } else if (name) {
9738         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9739            hek and CvSTASH pointer together can imply the GV.  If the name
9740            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9741            CvSTASH, so forego the optimisation if we find any.
9742            Also, we may be called from load_module at run time, so
9743            PL_curstash (which sets CvSTASH) may not point to the stash the
9744            sub is stored in.  */
9745         const I32 flags =
9746            ec ? GV_NOADD_NOINIT
9747               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9748                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9749                     ? gv_fetch_flags
9750                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9751         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9752         has_name = TRUE;
9753     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9754         SV * const sv = sv_newmortal();
9755         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9756                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9757                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9758         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9759         has_name = TRUE;
9760     } else if (PL_curstash) {
9761         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9762         has_name = FALSE;
9763     } else {
9764         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9765         has_name = FALSE;
9766     }
9767
9768     if (!ec) {
9769         if (isGV(gv)) {
9770             move_proto_attr(&proto, &attrs, gv, 0);
9771         } else {
9772             assert(cSVOPo);
9773             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9774         }
9775     }
9776
9777     if (proto) {
9778         assert(proto->op_type == OP_CONST);
9779         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9780         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9781     }
9782     else
9783         ps = NULL;
9784
9785     if (o)
9786         SAVEFREEOP(o);
9787     if (proto)
9788         SAVEFREEOP(proto);
9789     if (attrs)
9790         SAVEFREEOP(attrs);
9791
9792     if (ec) {
9793         op_free(block);
9794
9795         if (name)
9796             SvREFCNT_dec(PL_compcv);
9797         else
9798             cv = PL_compcv;
9799
9800         PL_compcv = 0;
9801         if (name && block) {
9802             const char *s = (char *) my_memrchr(name, ':', namlen);
9803             s = s ? s+1 : name;
9804             if (strEQ(s, "BEGIN")) {
9805                 if (PL_in_eval & EVAL_KEEPERR)
9806                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9807                 else {
9808                     SV * const errsv = ERRSV;
9809                     /* force display of errors found but not reported */
9810                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9811                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9812                 }
9813             }
9814         }
9815         goto done;
9816     }
9817
9818     if (!block && SvTYPE(gv) != SVt_PVGV) {
9819         /* If we are not defining a new sub and the existing one is not a
9820            full GV + CV... */
9821         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9822             /* We are applying attributes to an existing sub, so we need it
9823                upgraded if it is a constant.  */
9824             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9825                 gv_init_pvn(gv, PL_curstash, name, namlen,
9826                             SVf_UTF8 * name_is_utf8);
9827         }
9828         else {                  /* Maybe prototype now, and had at maximum
9829                                    a prototype or const/sub ref before.  */
9830             if (SvTYPE(gv) > SVt_NULL) {
9831                 cv_ckproto_len_flags((const CV *)gv,
9832                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9833                                     ps_len, ps_utf8);
9834             }
9835
9836             if (!SvROK(gv)) {
9837                 if (ps) {
9838                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9839                     if (ps_utf8)
9840                         SvUTF8_on(MUTABLE_SV(gv));
9841                 }
9842                 else
9843                     sv_setiv(MUTABLE_SV(gv), -1);
9844             }
9845
9846             SvREFCNT_dec(PL_compcv);
9847             cv = PL_compcv = NULL;
9848             goto done;
9849         }
9850     }
9851
9852     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9853         ? NULL
9854         : isGV(gv)
9855             ? GvCV(gv)
9856             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9857                 ? (CV *)SvRV(gv)
9858                 : NULL;
9859
9860     if (block) {
9861         assert(PL_parser);
9862         /* This makes sub {}; work as expected.  */
9863         if (block->op_type == OP_STUB) {
9864             const line_t l = PL_parser->copline;
9865             op_free(block);
9866             block = newSTATEOP(0, NULL, 0);
9867             PL_parser->copline = l;
9868         }
9869         block = CvLVALUE(PL_compcv)
9870              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9871                     && (!isGV(gv) || !GvASSUMECV(gv)))
9872                    ? newUNOP(OP_LEAVESUBLV, 0,
9873                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9874                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9875         start = LINKLIST(block);
9876         block->op_next = 0;
9877         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9878             const_sv =
9879                 S_op_const_sv(aTHX_ start, PL_compcv,
9880                                         cBOOL(CvCLONE(PL_compcv)));
9881         else
9882             const_sv = NULL;
9883     }
9884     else
9885         const_sv = NULL;
9886
9887     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
9888         cv_ckproto_len_flags((const CV *)gv,
9889                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9890                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
9891         if (SvROK(gv)) {
9892             /* All the other code for sub redefinition warnings expects the
9893                clobbered sub to be a CV.  Instead of making all those code
9894                paths more complex, just inline the RV version here.  */
9895             const line_t oldline = CopLINE(PL_curcop);
9896             assert(IN_PERL_COMPILETIME);
9897             if (PL_parser && PL_parser->copline != NOLINE)
9898                 /* This ensures that warnings are reported at the first
9899                    line of a redefinition, not the last.  */
9900                 CopLINE_set(PL_curcop, PL_parser->copline);
9901             /* protect against fatal warnings leaking compcv */
9902             SAVEFREESV(PL_compcv);
9903
9904             if (ckWARN(WARN_REDEFINE)
9905              || (  ckWARN_d(WARN_REDEFINE)
9906                 && (  !const_sv || SvRV(gv) == const_sv
9907                    || sv_cmp(SvRV(gv), const_sv)  ))) {
9908                 assert(cSVOPo);
9909                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9910                           "Constant subroutine %" SVf " redefined",
9911                           SVfARG(cSVOPo->op_sv));
9912             }
9913
9914             SvREFCNT_inc_simple_void_NN(PL_compcv);
9915             CopLINE_set(PL_curcop, oldline);
9916             SvREFCNT_dec(SvRV(gv));
9917         }
9918     }
9919
9920     if (cv) {
9921         const bool exists = CvROOT(cv) || CvXSUB(cv);
9922
9923         /* if the subroutine doesn't exist and wasn't pre-declared
9924          * with a prototype, assume it will be AUTOLOADed,
9925          * skipping the prototype check
9926          */
9927         if (exists || SvPOK(cv))
9928             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
9929         /* already defined (or promised)? */
9930         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
9931             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
9932             if (block)
9933                 cv = NULL;
9934             else {
9935                 if (attrs)
9936                     goto attrs;
9937                 /* just a "sub foo;" when &foo is already defined */
9938                 SAVEFREESV(PL_compcv);
9939                 goto done;
9940             }
9941         }
9942     }
9943
9944     if (const_sv) {
9945         SvREFCNT_inc_simple_void_NN(const_sv);
9946         SvFLAGS(const_sv) |= SVs_PADTMP;
9947         if (cv) {
9948             assert(!CvROOT(cv) && !CvCONST(cv));
9949             cv_forget_slab(cv);
9950             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9951             CvXSUBANY(cv).any_ptr = const_sv;
9952             CvXSUB(cv) = const_sv_xsub;
9953             CvCONST_on(cv);
9954             CvISXSUB_on(cv);
9955             PoisonPADLIST(cv);
9956             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9957         }
9958         else {
9959             if (isGV(gv) || CvMETHOD(PL_compcv)) {
9960                 if (name && isGV(gv))
9961                     GvCV_set(gv, NULL);
9962                 cv = newCONSTSUB_flags(
9963                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9964                     const_sv
9965                 );
9966                 assert(cv);
9967                 assert(SvREFCNT((SV*)cv) != 0);
9968                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9969             }
9970             else {
9971                 if (!SvROK(gv)) {
9972                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
9973                     prepare_SV_for_RV((SV *)gv);
9974                     SvOK_off((SV *)gv);
9975                     SvROK_on(gv);
9976                 }
9977                 SvRV_set(gv, const_sv);
9978             }
9979         }
9980         op_free(block);
9981         SvREFCNT_dec(PL_compcv);
9982         PL_compcv = NULL;
9983         goto done;
9984     }
9985
9986     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
9987     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
9988         cv = NULL;
9989
9990     if (cv) {                           /* must reuse cv if autoloaded */
9991         /* transfer PL_compcv to cv */
9992         if (block) {
9993             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
9994             PADLIST *const temp_av = CvPADLIST(cv);
9995             CV *const temp_cv = CvOUTSIDE(cv);
9996             const cv_flags_t other_flags =
9997                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9998             OP * const cvstart = CvSTART(cv);
9999
10000             if (isGV(gv)) {
10001                 CvGV_set(cv,gv);
10002                 assert(!CvCVGV_RC(cv));
10003                 assert(CvGV(cv) == gv);
10004             }
10005             else {
10006                 dVAR;
10007                 U32 hash;
10008                 PERL_HASH(hash, name, namlen);
10009                 CvNAME_HEK_set(cv,
10010                                share_hek(name,
10011                                          name_is_utf8
10012                                             ? -(SSize_t)namlen
10013                                             :  (SSize_t)namlen,
10014                                          hash));
10015             }
10016
10017             SvPOK_off(cv);
10018             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10019                                              | CvNAMED(cv);
10020             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10021             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10022             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10023             CvOUTSIDE(PL_compcv) = temp_cv;
10024             CvPADLIST_set(PL_compcv, temp_av);
10025             CvSTART(cv) = CvSTART(PL_compcv);
10026             CvSTART(PL_compcv) = cvstart;
10027             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10028             CvFLAGS(PL_compcv) |= other_flags;
10029
10030             if (CvFILE(cv) && CvDYNFILE(cv)) {
10031                 Safefree(CvFILE(cv));
10032             }
10033             CvFILE_set_from_cop(cv, PL_curcop);
10034             CvSTASH_set(cv, PL_curstash);
10035
10036             /* inner references to PL_compcv must be fixed up ... */
10037             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10038             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10039                 ++PL_sub_generation;
10040         }
10041         else {
10042             /* Might have had built-in attributes applied -- propagate them. */
10043             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10044         }
10045         /* ... before we throw it away */
10046         SvREFCNT_dec(PL_compcv);
10047         PL_compcv = cv;
10048     }
10049     else {
10050         cv = PL_compcv;
10051         if (name && isGV(gv)) {
10052             GvCV_set(gv, cv);
10053             GvCVGEN(gv) = 0;
10054             if (HvENAME_HEK(GvSTASH(gv)))
10055                 /* sub Foo::bar { (shift)+1 } */
10056                 gv_method_changed(gv);
10057         }
10058         else if (name) {
10059             if (!SvROK(gv)) {
10060                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10061                 prepare_SV_for_RV((SV *)gv);
10062                 SvOK_off((SV *)gv);
10063                 SvROK_on(gv);
10064             }
10065             SvRV_set(gv, (SV *)cv);
10066             if (HvENAME_HEK(PL_curstash))
10067                 mro_method_changed_in(PL_curstash);
10068         }
10069     }
10070     assert(cv);
10071     assert(SvREFCNT((SV*)cv) != 0);
10072
10073     if (!CvHASGV(cv)) {
10074         if (isGV(gv))
10075             CvGV_set(cv, gv);
10076         else {
10077             dVAR;
10078             U32 hash;
10079             PERL_HASH(hash, name, namlen);
10080             CvNAME_HEK_set(cv, share_hek(name,
10081                                          name_is_utf8
10082                                             ? -(SSize_t)namlen
10083                                             :  (SSize_t)namlen,
10084                                          hash));
10085         }
10086         CvFILE_set_from_cop(cv, PL_curcop);
10087         CvSTASH_set(cv, PL_curstash);
10088     }
10089
10090     if (ps) {
10091         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10092         if ( ps_utf8 )
10093             SvUTF8_on(MUTABLE_SV(cv));
10094     }
10095
10096     if (block) {
10097         /* If we assign an optree to a PVCV, then we've defined a
10098          * subroutine that the debugger could be able to set a breakpoint
10099          * in, so signal to pp_entereval that it should not throw away any
10100          * saved lines at scope exit.  */
10101
10102         PL_breakable_sub_gen++;
10103         CvROOT(cv) = block;
10104         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10105            itself has a refcount. */
10106         CvSLABBED_off(cv);
10107         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10108 #ifdef PERL_DEBUG_READONLY_OPS
10109         slab = (OPSLAB *)CvSTART(cv);
10110 #endif
10111         S_process_optree(aTHX_ cv, block, start);
10112     }
10113
10114   attrs:
10115     if (attrs) {
10116         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10117         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10118                         ? GvSTASH(CvGV(cv))
10119                         : PL_curstash;
10120         if (!name)
10121             SAVEFREESV(cv);
10122         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10123         if (!name)
10124             SvREFCNT_inc_simple_void_NN(cv);
10125     }
10126
10127     if (block && has_name) {
10128         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10129             SV * const tmpstr = cv_name(cv,NULL,0);
10130             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10131                                                   GV_ADDMULTI, SVt_PVHV);
10132             HV *hv;
10133             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10134                                           CopFILE(PL_curcop),
10135                                           (long)PL_subline,
10136                                           (long)CopLINE(PL_curcop));
10137             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10138                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10139             hv = GvHVn(db_postponed);
10140             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10141                 CV * const pcv = GvCV(db_postponed);
10142                 if (pcv) {
10143                     dSP;
10144                     PUSHMARK(SP);
10145                     XPUSHs(tmpstr);
10146                     PUTBACK;
10147                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10148                 }
10149             }
10150         }
10151
10152         if (name) {
10153             if (PL_parser && PL_parser->error_count)
10154                 clear_special_blocks(name, gv, cv);
10155             else
10156                 evanescent =
10157                     process_special_blocks(floor, name, gv, cv);
10158         }
10159     }
10160     assert(cv);
10161
10162   done:
10163     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10164     if (PL_parser)
10165         PL_parser->copline = NOLINE;
10166     LEAVE_SCOPE(floor);
10167
10168     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10169     if (!evanescent) {
10170 #ifdef PERL_DEBUG_READONLY_OPS
10171     if (slab)
10172         Slab_to_ro(slab);
10173 #endif
10174     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10175         pad_add_weakref(cv);
10176     }
10177     return cv;
10178 }
10179
10180 STATIC void
10181 S_clear_special_blocks(pTHX_ const char *const fullname,
10182                        GV *const gv, CV *const cv) {
10183     const char *colon;
10184     const char *name;
10185
10186     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10187
10188     colon = strrchr(fullname,':');
10189     name = colon ? colon + 1 : fullname;
10190
10191     if ((*name == 'B' && strEQ(name, "BEGIN"))
10192         || (*name == 'E' && strEQ(name, "END"))
10193         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10194         || (*name == 'C' && strEQ(name, "CHECK"))
10195         || (*name == 'I' && strEQ(name, "INIT"))) {
10196         if (!isGV(gv)) {
10197             (void)CvGV(cv);
10198             assert(isGV(gv));
10199         }
10200         GvCV_set(gv, NULL);
10201         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10202     }
10203 }
10204
10205 /* Returns true if the sub has been freed.  */
10206 STATIC bool
10207 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10208                          GV *const gv,
10209                          CV *const cv)
10210 {
10211     const char *const colon = strrchr(fullname,':');
10212     const char *const name = colon ? colon + 1 : fullname;
10213
10214     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10215
10216     if (*name == 'B') {
10217         if (strEQ(name, "BEGIN")) {
10218             const I32 oldscope = PL_scopestack_ix;
10219             dSP;
10220             (void)CvGV(cv);
10221             if (floor) LEAVE_SCOPE(floor);
10222             ENTER;
10223             PUSHSTACKi(PERLSI_REQUIRE);
10224             SAVECOPFILE(&PL_compiling);
10225             SAVECOPLINE(&PL_compiling);
10226             SAVEVPTR(PL_curcop);
10227
10228             DEBUG_x( dump_sub(gv) );
10229             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10230             GvCV_set(gv,0);             /* cv has been hijacked */
10231             call_list(oldscope, PL_beginav);
10232
10233             POPSTACK;
10234             LEAVE;
10235             return !PL_savebegin;
10236         }
10237         else
10238             return FALSE;
10239     } else {
10240         if (*name == 'E') {
10241             if strEQ(name, "END") {
10242                 DEBUG_x( dump_sub(gv) );
10243                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10244             } else
10245                 return FALSE;
10246         } else if (*name == 'U') {
10247             if (strEQ(name, "UNITCHECK")) {
10248                 /* It's never too late to run a unitcheck block */
10249                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10250             }
10251             else
10252                 return FALSE;
10253         } else if (*name == 'C') {
10254             if (strEQ(name, "CHECK")) {
10255                 if (PL_main_start)
10256                     /* diag_listed_as: Too late to run %s block */
10257                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10258                                    "Too late to run CHECK block");
10259                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10260             }
10261             else
10262                 return FALSE;
10263         } else if (*name == 'I') {
10264             if (strEQ(name, "INIT")) {
10265                 if (PL_main_start)
10266                     /* diag_listed_as: Too late to run %s block */
10267                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10268                                    "Too late to run INIT block");
10269                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10270             }
10271             else
10272                 return FALSE;
10273         } else
10274             return FALSE;
10275         DEBUG_x( dump_sub(gv) );
10276         (void)CvGV(cv);
10277         GvCV_set(gv,0);         /* cv has been hijacked */
10278         return FALSE;
10279     }
10280 }
10281
10282 /*
10283 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10284
10285 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10286 rather than of counted length, and no flags are set.  (This means that
10287 C<name> is always interpreted as Latin-1.)
10288
10289 =cut
10290 */
10291
10292 CV *
10293 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10294 {
10295     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10296 }
10297
10298 /*
10299 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10300
10301 Construct a constant subroutine, also performing some surrounding
10302 jobs.  A scalar constant-valued subroutine is eligible for inlining
10303 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10304 123 }>>.  Other kinds of constant subroutine have other treatment.
10305
10306 The subroutine will have an empty prototype and will ignore any arguments
10307 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10308 is null, the subroutine will yield an empty list.  If C<sv> points to a
10309 scalar, the subroutine will always yield that scalar.  If C<sv> points
10310 to an array, the subroutine will always yield a list of the elements of
10311 that array in list context, or the number of elements in the array in
10312 scalar context.  This function takes ownership of one counted reference
10313 to the scalar or array, and will arrange for the object to live as long
10314 as the subroutine does.  If C<sv> points to a scalar then the inlining
10315 assumes that the value of the scalar will never change, so the caller
10316 must ensure that the scalar is not subsequently written to.  If C<sv>
10317 points to an array then no such assumption is made, so it is ostensibly
10318 safe to mutate the array or its elements, but whether this is really
10319 supported has not been determined.
10320
10321 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10322 Other aspects of the subroutine will be left in their default state.
10323 The caller is free to mutate the subroutine beyond its initial state
10324 after this function has returned.
10325
10326 If C<name> is null then the subroutine will be anonymous, with its
10327 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10328 subroutine will be named accordingly, referenced by the appropriate glob.
10329 C<name> is a string of length C<len> bytes giving a sigilless symbol
10330 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10331 otherwise.  The name may be either qualified or unqualified.  If the
10332 name is unqualified then it defaults to being in the stash specified by
10333 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10334 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10335 semantics.
10336
10337 C<flags> should not have bits set other than C<SVf_UTF8>.
10338
10339 If there is already a subroutine of the specified name, then the new sub
10340 will replace the existing one in the glob.  A warning may be generated
10341 about the redefinition.
10342
10343 If the subroutine has one of a few special names, such as C<BEGIN> or
10344 C<END>, then it will be claimed by the appropriate queue for automatic
10345 running of phase-related subroutines.  In this case the relevant glob will
10346 be left not containing any subroutine, even if it did contain one before.
10347 Execution of the subroutine will likely be a no-op, unless C<sv> was
10348 a tied array or the caller modified the subroutine in some interesting
10349 way before it was executed.  In the case of C<BEGIN>, the treatment is
10350 buggy: the sub will be executed when only half built, and may be deleted
10351 prematurely, possibly causing a crash.
10352
10353 The function returns a pointer to the constructed subroutine.  If the sub
10354 is anonymous then ownership of one counted reference to the subroutine
10355 is transferred to the caller.  If the sub is named then the caller does
10356 not get ownership of a reference.  In most such cases, where the sub
10357 has a non-phase name, the sub will be alive at the point it is returned
10358 by virtue of being contained in the glob that names it.  A phase-named
10359 subroutine will usually be alive by virtue of the reference owned by
10360 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10361 destroyed already by the time this function returns, but currently bugs
10362 occur in that case before the caller gets control.  It is the caller's
10363 responsibility to ensure that it knows which of these situations applies.
10364
10365 =cut
10366 */
10367
10368 CV *
10369 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10370                              U32 flags, SV *sv)
10371 {
10372     CV* cv;
10373     const char *const file = CopFILE(PL_curcop);
10374
10375     ENTER;
10376
10377     if (IN_PERL_RUNTIME) {
10378         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10379          * an op shared between threads. Use a non-shared COP for our
10380          * dirty work */
10381          SAVEVPTR(PL_curcop);
10382          SAVECOMPILEWARNINGS();
10383          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10384          PL_curcop = &PL_compiling;
10385     }
10386     SAVECOPLINE(PL_curcop);
10387     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10388
10389     SAVEHINTS();
10390     PL_hints &= ~HINT_BLOCK_SCOPE;
10391
10392     if (stash) {
10393         SAVEGENERICSV(PL_curstash);
10394         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10395     }
10396
10397     /* Protect sv against leakage caused by fatal warnings. */
10398     if (sv) SAVEFREESV(sv);
10399
10400     /* file becomes the CvFILE. For an XS, it's usually static storage,
10401        and so doesn't get free()d.  (It's expected to be from the C pre-
10402        processor __FILE__ directive). But we need a dynamically allocated one,
10403        and we need it to get freed.  */
10404     cv = newXS_len_flags(name, len,
10405                          sv && SvTYPE(sv) == SVt_PVAV
10406                              ? const_av_xsub
10407                              : const_sv_xsub,
10408                          file ? file : "", "",
10409                          &sv, XS_DYNAMIC_FILENAME | flags);
10410     assert(cv);
10411     assert(SvREFCNT((SV*)cv) != 0);
10412     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10413     CvCONST_on(cv);
10414
10415     LEAVE;
10416
10417     return cv;
10418 }
10419
10420 /*
10421 =for apidoc U||newXS
10422
10423 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10424 static storage, as it is used directly as CvFILE(), without a copy being made.
10425
10426 =cut
10427 */
10428
10429 CV *
10430 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10431 {
10432     PERL_ARGS_ASSERT_NEWXS;
10433     return newXS_len_flags(
10434         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10435     );
10436 }
10437
10438 CV *
10439 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10440                  const char *const filename, const char *const proto,
10441                  U32 flags)
10442 {
10443     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10444     return newXS_len_flags(
10445        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10446     );
10447 }
10448
10449 CV *
10450 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10451 {
10452     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10453     return newXS_len_flags(
10454         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10455     );
10456 }
10457
10458 /*
10459 =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
10460
10461 Construct an XS subroutine, also performing some surrounding jobs.
10462
10463 The subroutine will have the entry point C<subaddr>.  It will have
10464 the prototype specified by the nul-terminated string C<proto>, or
10465 no prototype if C<proto> is null.  The prototype string is copied;
10466 the caller can mutate the supplied string afterwards.  If C<filename>
10467 is non-null, it must be a nul-terminated filename, and the subroutine
10468 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10469 point directly to the supplied string, which must be static.  If C<flags>
10470 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10471 be taken instead.
10472
10473 Other aspects of the subroutine will be left in their default state.
10474 If anything else needs to be done to the subroutine for it to function
10475 correctly, it is the caller's responsibility to do that after this
10476 function has constructed it.  However, beware of the subroutine
10477 potentially being destroyed before this function returns, as described
10478 below.
10479
10480 If C<name> is null then the subroutine will be anonymous, with its
10481 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10482 subroutine will be named accordingly, referenced by the appropriate glob.
10483 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10484 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10485 The name may be either qualified or unqualified, with the stash defaulting
10486 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10487 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10488 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10489 the stash if necessary, with C<GV_ADDMULTI> semantics.
10490
10491 If there is already a subroutine of the specified name, then the new sub
10492 will replace the existing one in the glob.  A warning may be generated
10493 about the redefinition.  If the old subroutine was C<CvCONST> then the
10494 decision about whether to warn is influenced by an expectation about
10495 whether the new subroutine will become a constant of similar value.
10496 That expectation is determined by C<const_svp>.  (Note that the call to
10497 this function doesn't make the new subroutine C<CvCONST> in any case;
10498 that is left to the caller.)  If C<const_svp> is null then it indicates
10499 that the new subroutine will not become a constant.  If C<const_svp>
10500 is non-null then it indicates that the new subroutine will become a
10501 constant, and it points to an C<SV*> that provides the constant value
10502 that the subroutine will have.
10503
10504 If the subroutine has one of a few special names, such as C<BEGIN> or
10505 C<END>, then it will be claimed by the appropriate queue for automatic
10506 running of phase-related subroutines.  In this case the relevant glob will
10507 be left not containing any subroutine, even if it did contain one before.
10508 In the case of C<BEGIN>, the subroutine will be executed and the reference
10509 to it disposed of before this function returns, and also before its
10510 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10511 constructed by this function to be ready for execution then the caller
10512 must prevent this happening by giving the subroutine a different name.
10513
10514 The function returns a pointer to the constructed subroutine.  If the sub
10515 is anonymous then ownership of one counted reference to the subroutine
10516 is transferred to the caller.  If the sub is named then the caller does
10517 not get ownership of a reference.  In most such cases, where the sub
10518 has a non-phase name, the sub will be alive at the point it is returned
10519 by virtue of being contained in the glob that names it.  A phase-named
10520 subroutine will usually be alive by virtue of the reference owned by the
10521 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10522 been executed, will quite likely have been destroyed already by the
10523 time this function returns, making it erroneous for the caller to make
10524 any use of the returned pointer.  It is the caller's responsibility to
10525 ensure that it knows which of these situations applies.
10526
10527 =cut
10528 */
10529
10530 CV *
10531 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10532                            XSUBADDR_t subaddr, const char *const filename,
10533                            const char *const proto, SV **const_svp,
10534                            U32 flags)
10535 {
10536     CV *cv;
10537     bool interleave = FALSE;
10538     bool evanescent = FALSE;
10539
10540     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10541
10542     {
10543         GV * const gv = gv_fetchpvn(
10544                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10545                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10546                                 sizeof("__ANON__::__ANON__") - 1,
10547                             GV_ADDMULTI | flags, SVt_PVCV);
10548
10549         if ((cv = (name ? GvCV(gv) : NULL))) {
10550             if (GvCVGEN(gv)) {
10551                 /* just a cached method */
10552                 SvREFCNT_dec(cv);
10553                 cv = NULL;
10554             }
10555             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10556                 /* already defined (or promised) */
10557                 /* Redundant check that allows us to avoid creating an SV
10558                    most of the time: */
10559                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10560                     report_redefined_cv(newSVpvn_flags(
10561                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10562                                         ),
10563                                         cv, const_svp);
10564                 }
10565                 interleave = TRUE;
10566                 ENTER;
10567                 SAVEFREESV(cv);
10568                 cv = NULL;
10569             }
10570         }
10571
10572         if (cv)                         /* must reuse cv if autoloaded */
10573             cv_undef(cv);
10574         else {
10575             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10576             if (name) {
10577                 GvCV_set(gv,cv);
10578                 GvCVGEN(gv) = 0;
10579                 if (HvENAME_HEK(GvSTASH(gv)))
10580                     gv_method_changed(gv); /* newXS */
10581             }
10582         }
10583         assert(cv);
10584         assert(SvREFCNT((SV*)cv) != 0);
10585
10586         CvGV_set(cv, gv);
10587         if(filename) {
10588             /* XSUBs can't be perl lang/perl5db.pl debugged
10589             if (PERLDB_LINE_OR_SAVESRC)
10590                 (void)gv_fetchfile(filename); */
10591             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10592             if (flags & XS_DYNAMIC_FILENAME) {
10593                 CvDYNFILE_on(cv);
10594                 CvFILE(cv) = savepv(filename);
10595             } else {
10596             /* NOTE: not copied, as it is expected to be an external constant string */
10597                 CvFILE(cv) = (char *)filename;
10598             }
10599         } else {
10600             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10601             CvFILE(cv) = (char*)PL_xsubfilename;
10602         }
10603         CvISXSUB_on(cv);
10604         CvXSUB(cv) = subaddr;
10605 #ifndef PERL_IMPLICIT_CONTEXT
10606         CvHSCXT(cv) = &PL_stack_sp;
10607 #else
10608         PoisonPADLIST(cv);
10609 #endif
10610
10611         if (name)
10612             evanescent = process_special_blocks(0, name, gv, cv);
10613         else
10614             CvANON_on(cv);
10615     } /* <- not a conditional branch */
10616
10617     assert(cv);
10618     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10619
10620     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10621     if (interleave) LEAVE;
10622     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10623     return cv;
10624 }
10625
10626 CV *
10627 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10628 {
10629     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10630     GV *cvgv;
10631     PERL_ARGS_ASSERT_NEWSTUB;
10632     assert(!GvCVu(gv));
10633     GvCV_set(gv, cv);
10634     GvCVGEN(gv) = 0;
10635     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10636         gv_method_changed(gv);
10637     if (SvFAKE(gv)) {
10638         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10639         SvFAKE_off(cvgv);
10640     }
10641     else cvgv = gv;
10642     CvGV_set(cv, cvgv);
10643     CvFILE_set_from_cop(cv, PL_curcop);
10644     CvSTASH_set(cv, PL_curstash);
10645     GvMULTI_on(gv);
10646     return cv;
10647 }
10648
10649 void
10650 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10651 {
10652     CV *cv;
10653     GV *gv;
10654     OP *root;
10655     OP *start;
10656
10657     if (PL_parser && PL_parser->error_count) {
10658         op_free(block);
10659         goto finish;
10660     }
10661
10662     gv = o
10663         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10664         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10665
10666     GvMULTI_on(gv);
10667     if ((cv = GvFORM(gv))) {
10668         if (ckWARN(WARN_REDEFINE)) {
10669             const line_t oldline = CopLINE(PL_curcop);
10670             if (PL_parser && PL_parser->copline != NOLINE)
10671                 CopLINE_set(PL_curcop, PL_parser->copline);
10672             if (o) {
10673                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10674                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10675             } else {
10676                 /* diag_listed_as: Format %s redefined */
10677                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10678                             "Format STDOUT redefined");
10679             }
10680             CopLINE_set(PL_curcop, oldline);
10681         }
10682         SvREFCNT_dec(cv);
10683     }
10684     cv = PL_compcv;
10685     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10686     CvGV_set(cv, gv);
10687     CvFILE_set_from_cop(cv, PL_curcop);
10688
10689
10690     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10691     CvROOT(cv) = root;
10692     start = LINKLIST(root);
10693     root->op_next = 0;
10694     S_process_optree(aTHX_ cv, root, start);
10695     cv_forget_slab(cv);
10696
10697   finish:
10698     op_free(o);
10699     if (PL_parser)
10700         PL_parser->copline = NOLINE;
10701     LEAVE_SCOPE(floor);
10702     PL_compiling.cop_seq = 0;
10703 }
10704
10705 OP *
10706 Perl_newANONLIST(pTHX_ OP *o)
10707 {
10708     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10709 }
10710
10711 OP *
10712 Perl_newANONHASH(pTHX_ OP *o)
10713 {
10714     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10715 }
10716
10717 OP *
10718 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10719 {
10720     return newANONATTRSUB(floor, proto, NULL, block);
10721 }
10722
10723 OP *
10724 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10725 {
10726     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10727     OP * anoncode =
10728         newSVOP(OP_ANONCODE, 0,
10729                 cv);
10730     if (CvANONCONST(cv))
10731         anoncode = newUNOP(OP_ANONCONST, 0,
10732                            op_convert_list(OP_ENTERSUB,
10733                                            OPf_STACKED|OPf_WANT_SCALAR,
10734                                            anoncode));
10735     return newUNOP(OP_REFGEN, 0, anoncode);
10736 }
10737
10738 OP *
10739 Perl_oopsAV(pTHX_ OP *o)
10740 {
10741     dVAR;
10742
10743     PERL_ARGS_ASSERT_OOPSAV;
10744
10745     switch (o->op_type) {
10746     case OP_PADSV:
10747     case OP_PADHV:
10748         OpTYPE_set(o, OP_PADAV);
10749         return ref(o, OP_RV2AV);
10750
10751     case OP_RV2SV:
10752     case OP_RV2HV:
10753         OpTYPE_set(o, OP_RV2AV);
10754         ref(o, OP_RV2AV);
10755         break;
10756
10757     default:
10758         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10759         break;
10760     }
10761     return o;
10762 }
10763
10764 OP *
10765 Perl_oopsHV(pTHX_ OP *o)
10766 {
10767     dVAR;
10768
10769     PERL_ARGS_ASSERT_OOPSHV;
10770
10771     switch (o->op_type) {
10772     case OP_PADSV:
10773     case OP_PADAV:
10774         OpTYPE_set(o, OP_PADHV);
10775         return ref(o, OP_RV2HV);
10776
10777     case OP_RV2SV:
10778     case OP_RV2AV:
10779         OpTYPE_set(o, OP_RV2HV);
10780         /* rv2hv steals the bottom bit for its own uses */
10781         o->op_private &= ~OPpARG1_MASK;
10782         ref(o, OP_RV2HV);
10783         break;
10784
10785     default:
10786         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10787         break;
10788     }
10789     return o;
10790 }
10791
10792 OP *
10793 Perl_newAVREF(pTHX_ OP *o)
10794 {
10795     dVAR;
10796
10797     PERL_ARGS_ASSERT_NEWAVREF;
10798
10799     if (o->op_type == OP_PADANY) {
10800         OpTYPE_set(o, OP_PADAV);
10801         return o;
10802     }
10803     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10804         Perl_croak(aTHX_ "Can't use an array as a reference");
10805     }
10806     return newUNOP(OP_RV2AV, 0, scalar(o));
10807 }
10808
10809 OP *
10810 Perl_newGVREF(pTHX_ I32 type, OP *o)
10811 {
10812     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10813         return newUNOP(OP_NULL, 0, o);
10814     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10815 }
10816
10817 OP *
10818 Perl_newHVREF(pTHX_ OP *o)
10819 {
10820     dVAR;
10821
10822     PERL_ARGS_ASSERT_NEWHVREF;
10823
10824     if (o->op_type == OP_PADANY) {
10825         OpTYPE_set(o, OP_PADHV);
10826         return o;
10827     }
10828     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10829         Perl_croak(aTHX_ "Can't use a hash as a reference");
10830     }
10831     return newUNOP(OP_RV2HV, 0, scalar(o));
10832 }
10833
10834 OP *
10835 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10836 {
10837     if (o->op_type == OP_PADANY) {
10838         dVAR;
10839         OpTYPE_set(o, OP_PADCV);
10840     }
10841     return newUNOP(OP_RV2CV, flags, scalar(o));
10842 }
10843
10844 OP *
10845 Perl_newSVREF(pTHX_ OP *o)
10846 {
10847     dVAR;
10848
10849     PERL_ARGS_ASSERT_NEWSVREF;
10850
10851     if (o->op_type == OP_PADANY) {
10852         OpTYPE_set(o, OP_PADSV);
10853         scalar(o);
10854         return o;
10855     }
10856     return newUNOP(OP_RV2SV, 0, scalar(o));
10857 }
10858
10859 /* Check routines. See the comments at the top of this file for details
10860  * on when these are called */
10861
10862 OP *
10863 Perl_ck_anoncode(pTHX_ OP *o)
10864 {
10865     PERL_ARGS_ASSERT_CK_ANONCODE;
10866
10867     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10868     cSVOPo->op_sv = NULL;
10869     return o;
10870 }
10871
10872 static void
10873 S_io_hints(pTHX_ OP *o)
10874 {
10875 #if O_BINARY != 0 || O_TEXT != 0
10876     HV * const table =
10877         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10878     if (table) {
10879         SV **svp = hv_fetchs(table, "open_IN", FALSE);
10880         if (svp && *svp) {
10881             STRLEN len = 0;
10882             const char *d = SvPV_const(*svp, len);
10883             const I32 mode = mode_from_discipline(d, len);
10884             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10885 #  if O_BINARY != 0
10886             if (mode & O_BINARY)
10887                 o->op_private |= OPpOPEN_IN_RAW;
10888 #  endif
10889 #  if O_TEXT != 0
10890             if (mode & O_TEXT)
10891                 o->op_private |= OPpOPEN_IN_CRLF;
10892 #  endif
10893         }
10894
10895         svp = hv_fetchs(table, "open_OUT", FALSE);
10896         if (svp && *svp) {
10897             STRLEN len = 0;
10898             const char *d = SvPV_const(*svp, len);
10899             const I32 mode = mode_from_discipline(d, len);
10900             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10901 #  if O_BINARY != 0
10902             if (mode & O_BINARY)
10903                 o->op_private |= OPpOPEN_OUT_RAW;
10904 #  endif
10905 #  if O_TEXT != 0
10906             if (mode & O_TEXT)
10907                 o->op_private |= OPpOPEN_OUT_CRLF;
10908 #  endif
10909         }
10910     }
10911 #else
10912     PERL_UNUSED_CONTEXT;
10913     PERL_UNUSED_ARG(o);
10914 #endif
10915 }
10916
10917 OP *
10918 Perl_ck_backtick(pTHX_ OP *o)
10919 {
10920     GV *gv;
10921     OP *newop = NULL;
10922     OP *sibl;
10923     PERL_ARGS_ASSERT_CK_BACKTICK;
10924     o = ck_fun(o);
10925     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
10926     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
10927      && (gv = gv_override("readpipe",8)))
10928     {
10929         /* detach rest of siblings from o and its first child */
10930         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10931         newop = S_new_entersubop(aTHX_ gv, sibl);
10932     }
10933     else if (!(o->op_flags & OPf_KIDS))
10934         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
10935     if (newop) {
10936         op_free(o);
10937         return newop;
10938     }
10939     S_io_hints(aTHX_ o);
10940     return o;
10941 }
10942
10943 OP *
10944 Perl_ck_bitop(pTHX_ OP *o)
10945 {
10946     PERL_ARGS_ASSERT_CK_BITOP;
10947
10948     o->op_private = (U8)(PL_hints & HINT_INTEGER);
10949
10950     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
10951             && OP_IS_INFIX_BIT(o->op_type))
10952     {
10953         const OP * const left = cBINOPo->op_first;
10954         const OP * const right = OpSIBLING(left);
10955         if ((OP_IS_NUMCOMPARE(left->op_type) &&
10956                 (left->op_flags & OPf_PARENS) == 0) ||
10957             (OP_IS_NUMCOMPARE(right->op_type) &&
10958                 (right->op_flags & OPf_PARENS) == 0))
10959             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
10960                           "Possible precedence problem on bitwise %s operator",
10961                            o->op_type ==  OP_BIT_OR
10962                          ||o->op_type == OP_NBIT_OR  ? "|"
10963                         :  o->op_type ==  OP_BIT_AND
10964                          ||o->op_type == OP_NBIT_AND ? "&"
10965                         :  o->op_type ==  OP_BIT_XOR
10966                          ||o->op_type == OP_NBIT_XOR ? "^"
10967                         :  o->op_type == OP_SBIT_OR  ? "|."
10968                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
10969                            );
10970     }
10971     return o;
10972 }
10973
10974 PERL_STATIC_INLINE bool
10975 is_dollar_bracket(pTHX_ const OP * const o)
10976 {
10977     const OP *kid;
10978     PERL_UNUSED_CONTEXT;
10979     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
10980         && (kid = cUNOPx(o)->op_first)
10981         && kid->op_type == OP_GV
10982         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
10983 }
10984
10985 /* for lt, gt, le, ge, eq, ne and their i_ variants */
10986
10987 OP *
10988 Perl_ck_cmp(pTHX_ OP *o)
10989 {
10990     bool is_eq;
10991     bool neg;
10992     bool reverse;
10993     bool iv0;
10994     OP *indexop, *constop, *start;
10995     SV *sv;
10996     IV iv;
10997
10998     PERL_ARGS_ASSERT_CK_CMP;
10999
11000     is_eq = (   o->op_type == OP_EQ
11001              || o->op_type == OP_NE
11002              || o->op_type == OP_I_EQ
11003              || o->op_type == OP_I_NE);
11004
11005     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11006         const OP *kid = cUNOPo->op_first;
11007         if (kid &&
11008             (
11009                 (   is_dollar_bracket(aTHX_ kid)
11010                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11011                 )
11012              || (   kid->op_type == OP_CONST
11013                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11014                 )
11015            )
11016         )
11017             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11018                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11019     }
11020
11021     /* convert (index(...) == -1) and variations into
11022      *   (r)index/BOOL(,NEG)
11023      */
11024
11025     reverse = FALSE;
11026
11027     indexop = cUNOPo->op_first;
11028     constop = OpSIBLING(indexop);
11029     start = NULL;
11030     if (indexop->op_type == OP_CONST) {
11031         constop = indexop;
11032         indexop = OpSIBLING(constop);
11033         start = constop;
11034         reverse = TRUE;
11035     }
11036
11037     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11038         return o;
11039
11040     /* ($lex = index(....)) == -1 */
11041     if (indexop->op_private & OPpTARGET_MY)
11042         return o;
11043
11044     if (constop->op_type != OP_CONST)
11045         return o;
11046
11047     sv = cSVOPx_sv(constop);
11048     if (!(sv && SvIOK_notUV(sv)))
11049         return o;
11050
11051     iv = SvIVX(sv);
11052     if (iv != -1 && iv != 0)
11053         return o;
11054     iv0 = (iv == 0);
11055
11056     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11057         if (!(iv0 ^ reverse))
11058             return o;
11059         neg = iv0;
11060     }
11061     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11062         if (iv0 ^ reverse)
11063             return o;
11064         neg = !iv0;
11065     }
11066     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11067         if (!(iv0 ^ reverse))
11068             return o;
11069         neg = !iv0;
11070     }
11071     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11072         if (iv0 ^ reverse)
11073             return o;
11074         neg = iv0;
11075     }
11076     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11077         if (iv0)
11078             return o;
11079         neg = TRUE;
11080     }
11081     else {
11082         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11083         if (iv0)
11084             return o;
11085         neg = FALSE;
11086     }
11087
11088     indexop->op_flags &= ~OPf_PARENS;
11089     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11090     indexop->op_private |= OPpTRUEBOOL;
11091     if (neg)
11092         indexop->op_private |= OPpINDEX_BOOLNEG;
11093     /* cut out the index op and free the eq,const ops */
11094     (void)op_sibling_splice(o, start, 1, NULL);
11095     op_free(o);
11096
11097     return indexop;
11098 }
11099
11100
11101 OP *
11102 Perl_ck_concat(pTHX_ OP *o)
11103 {
11104     const OP * const kid = cUNOPo->op_first;
11105
11106     PERL_ARGS_ASSERT_CK_CONCAT;
11107     PERL_UNUSED_CONTEXT;
11108
11109     /* reuse the padtmp returned by the concat child */
11110     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11111             !(kUNOP->op_first->op_flags & OPf_MOD))
11112     {
11113         o->op_flags |= OPf_STACKED;
11114         o->op_private |= OPpCONCAT_NESTED;
11115     }
11116     return o;
11117 }
11118
11119 OP *
11120 Perl_ck_spair(pTHX_ OP *o)
11121 {
11122     dVAR;
11123
11124     PERL_ARGS_ASSERT_CK_SPAIR;
11125
11126     if (o->op_flags & OPf_KIDS) {
11127         OP* newop;
11128         OP* kid;
11129         OP* kidkid;
11130         const OPCODE type = o->op_type;
11131         o = modkids(ck_fun(o), type);
11132         kid    = cUNOPo->op_first;
11133         kidkid = kUNOP->op_first;
11134         newop = OpSIBLING(kidkid);
11135         if (newop) {
11136             const OPCODE type = newop->op_type;
11137             if (OpHAS_SIBLING(newop))
11138                 return o;
11139             if (o->op_type == OP_REFGEN
11140              && (  type == OP_RV2CV
11141                 || (  !(newop->op_flags & OPf_PARENS)
11142                    && (  type == OP_RV2AV || type == OP_PADAV
11143                       || type == OP_RV2HV || type == OP_PADHV))))
11144                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11145             else if (OP_GIMME(newop,0) != G_SCALAR)
11146                 return o;
11147         }
11148         /* excise first sibling */
11149         op_sibling_splice(kid, NULL, 1, NULL);
11150         op_free(kidkid);
11151     }
11152     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11153      * and OP_CHOMP into OP_SCHOMP */
11154     o->op_ppaddr = PL_ppaddr[++o->op_type];
11155     return ck_fun(o);
11156 }
11157
11158 OP *
11159 Perl_ck_delete(pTHX_ OP *o)
11160 {
11161     PERL_ARGS_ASSERT_CK_DELETE;
11162
11163     o = ck_fun(o);
11164     o->op_private = 0;
11165     if (o->op_flags & OPf_KIDS) {
11166         OP * const kid = cUNOPo->op_first;
11167         switch (kid->op_type) {
11168         case OP_ASLICE:
11169             o->op_flags |= OPf_SPECIAL;
11170             /* FALLTHROUGH */
11171         case OP_HSLICE:
11172             o->op_private |= OPpSLICE;
11173             break;
11174         case OP_AELEM:
11175             o->op_flags |= OPf_SPECIAL;
11176             /* FALLTHROUGH */
11177         case OP_HELEM:
11178             break;
11179         case OP_KVASLICE:
11180             o->op_flags |= OPf_SPECIAL;
11181             /* FALLTHROUGH */
11182         case OP_KVHSLICE:
11183             o->op_private |= OPpKVSLICE;
11184             break;
11185         default:
11186             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11187                              "element or slice");
11188         }
11189         if (kid->op_private & OPpLVAL_INTRO)
11190             o->op_private |= OPpLVAL_INTRO;
11191         op_null(kid);
11192     }
11193     return o;
11194 }
11195
11196 OP *
11197 Perl_ck_eof(pTHX_ OP *o)
11198 {
11199     PERL_ARGS_ASSERT_CK_EOF;
11200
11201     if (o->op_flags & OPf_KIDS) {
11202         OP *kid;
11203         if (cLISTOPo->op_first->op_type == OP_STUB) {
11204             OP * const newop
11205                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11206             op_free(o);
11207             o = newop;
11208         }
11209         o = ck_fun(o);
11210         kid = cLISTOPo->op_first;
11211         if (kid->op_type == OP_RV2GV)
11212             kid->op_private |= OPpALLOW_FAKE;
11213     }
11214     return o;
11215 }
11216
11217
11218 OP *
11219 Perl_ck_eval(pTHX_ OP *o)
11220 {
11221     dVAR;
11222
11223     PERL_ARGS_ASSERT_CK_EVAL;
11224
11225     PL_hints |= HINT_BLOCK_SCOPE;
11226     if (o->op_flags & OPf_KIDS) {
11227         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11228         assert(kid);
11229
11230         if (o->op_type == OP_ENTERTRY) {
11231             LOGOP *enter;
11232
11233             /* cut whole sibling chain free from o */
11234             op_sibling_splice(o, NULL, -1, NULL);
11235             op_free(o);
11236
11237             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11238
11239             /* establish postfix order */
11240             enter->op_next = (OP*)enter;
11241
11242             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11243             OpTYPE_set(o, OP_LEAVETRY);
11244             enter->op_other = o;
11245             return o;
11246         }
11247         else {
11248             scalar((OP*)kid);
11249             S_set_haseval(aTHX);
11250         }
11251     }
11252     else {
11253         const U8 priv = o->op_private;
11254         op_free(o);
11255         /* the newUNOP will recursively call ck_eval(), which will handle
11256          * all the stuff at the end of this function, like adding
11257          * OP_HINTSEVAL
11258          */
11259         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11260     }
11261     o->op_targ = (PADOFFSET)PL_hints;
11262     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11263     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11264      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11265         /* Store a copy of %^H that pp_entereval can pick up. */
11266         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11267                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11268         /* append hhop to only child  */
11269         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11270
11271         o->op_private |= OPpEVAL_HAS_HH;
11272     }
11273     if (!(o->op_private & OPpEVAL_BYTES)
11274          && FEATURE_UNIEVAL_IS_ENABLED)
11275             o->op_private |= OPpEVAL_UNICODE;
11276     return o;
11277 }
11278
11279 OP *
11280 Perl_ck_exec(pTHX_ OP *o)
11281 {
11282     PERL_ARGS_ASSERT_CK_EXEC;
11283
11284     if (o->op_flags & OPf_STACKED) {
11285         OP *kid;
11286         o = ck_fun(o);
11287         kid = OpSIBLING(cUNOPo->op_first);
11288         if (kid->op_type == OP_RV2GV)
11289             op_null(kid);
11290     }
11291     else
11292         o = listkids(o);
11293     return o;
11294 }
11295
11296 OP *
11297 Perl_ck_exists(pTHX_ OP *o)
11298 {
11299     PERL_ARGS_ASSERT_CK_EXISTS;
11300
11301     o = ck_fun(o);
11302     if (o->op_flags & OPf_KIDS) {
11303         OP * const kid = cUNOPo->op_first;
11304         if (kid->op_type == OP_ENTERSUB) {
11305             (void) ref(kid, o->op_type);
11306             if (kid->op_type != OP_RV2CV
11307                         && !(PL_parser && PL_parser->error_count))
11308                 Perl_croak(aTHX_
11309                           "exists argument is not a subroutine name");
11310             o->op_private |= OPpEXISTS_SUB;
11311         }
11312         else if (kid->op_type == OP_AELEM)
11313             o->op_flags |= OPf_SPECIAL;
11314         else if (kid->op_type != OP_HELEM)
11315             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11316                              "element or a subroutine");
11317         op_null(kid);
11318     }
11319     return o;
11320 }
11321
11322 OP *
11323 Perl_ck_rvconst(pTHX_ OP *o)
11324 {
11325     dVAR;
11326     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11327
11328     PERL_ARGS_ASSERT_CK_RVCONST;
11329
11330     if (o->op_type == OP_RV2HV)
11331         /* rv2hv steals the bottom bit for its own uses */
11332         o->op_private &= ~OPpARG1_MASK;
11333
11334     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11335
11336     if (kid->op_type == OP_CONST) {
11337         int iscv;
11338         GV *gv;
11339         SV * const kidsv = kid->op_sv;
11340
11341         /* Is it a constant from cv_const_sv()? */
11342         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11343             return o;
11344         }
11345         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11346         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11347             const char *badthing;
11348             switch (o->op_type) {
11349             case OP_RV2SV:
11350                 badthing = "a SCALAR";
11351                 break;
11352             case OP_RV2AV:
11353                 badthing = "an ARRAY";
11354                 break;
11355             case OP_RV2HV:
11356                 badthing = "a HASH";
11357                 break;
11358             default:
11359                 badthing = NULL;
11360                 break;
11361             }
11362             if (badthing)
11363                 Perl_croak(aTHX_
11364                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11365                            SVfARG(kidsv), badthing);
11366         }
11367         /*
11368          * This is a little tricky.  We only want to add the symbol if we
11369          * didn't add it in the lexer.  Otherwise we get duplicate strict
11370          * warnings.  But if we didn't add it in the lexer, we must at
11371          * least pretend like we wanted to add it even if it existed before,
11372          * or we get possible typo warnings.  OPpCONST_ENTERED says
11373          * whether the lexer already added THIS instance of this symbol.
11374          */
11375         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11376         gv = gv_fetchsv(kidsv,
11377                 o->op_type == OP_RV2CV
11378                         && o->op_private & OPpMAY_RETURN_CONSTANT
11379                     ? GV_NOEXPAND
11380                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11381                 iscv
11382                     ? SVt_PVCV
11383                     : o->op_type == OP_RV2SV
11384                         ? SVt_PV
11385                         : o->op_type == OP_RV2AV
11386                             ? SVt_PVAV
11387                             : o->op_type == OP_RV2HV
11388                                 ? SVt_PVHV
11389                                 : SVt_PVGV);
11390         if (gv) {
11391             if (!isGV(gv)) {
11392                 assert(iscv);
11393                 assert(SvROK(gv));
11394                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11395                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11396                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11397             }
11398             OpTYPE_set(kid, OP_GV);
11399             SvREFCNT_dec(kid->op_sv);
11400 #ifdef USE_ITHREADS
11401             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11402             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11403             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11404             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11405             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11406 #else
11407             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11408 #endif
11409             kid->op_private = 0;
11410             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11411             SvFAKE_off(gv);
11412         }
11413     }
11414     return o;
11415 }
11416
11417 OP *
11418 Perl_ck_ftst(pTHX_ OP *o)
11419 {
11420     dVAR;
11421     const I32 type = o->op_type;
11422
11423     PERL_ARGS_ASSERT_CK_FTST;
11424
11425     if (o->op_flags & OPf_REF) {
11426         NOOP;
11427     }
11428     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11429         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11430         const OPCODE kidtype = kid->op_type;
11431
11432         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11433          && !kid->op_folded) {
11434             OP * const newop = newGVOP(type, OPf_REF,
11435                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11436             op_free(o);
11437             return newop;
11438         }
11439
11440         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11441             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11442             if (name) {
11443                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11444                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11445                             array_passed_to_stat, name);
11446             }
11447             else {
11448                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11449                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11450             }
11451        }
11452         scalar((OP *) kid);
11453         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11454             o->op_private |= OPpFT_ACCESS;
11455         if (type != OP_STAT && type != OP_LSTAT
11456             && PL_check[kidtype] == Perl_ck_ftst
11457             && kidtype != OP_STAT && kidtype != OP_LSTAT
11458         ) {
11459             o->op_private |= OPpFT_STACKED;
11460             kid->op_private |= OPpFT_STACKING;
11461             if (kidtype == OP_FTTTY && (
11462                    !(kid->op_private & OPpFT_STACKED)
11463                 || kid->op_private & OPpFT_AFTER_t
11464                ))
11465                 o->op_private |= OPpFT_AFTER_t;
11466         }
11467     }
11468     else {
11469         op_free(o);
11470         if (type == OP_FTTTY)
11471             o = newGVOP(type, OPf_REF, PL_stdingv);
11472         else
11473             o = newUNOP(type, 0, newDEFSVOP());
11474     }
11475     return o;
11476 }
11477
11478 OP *
11479 Perl_ck_fun(pTHX_ OP *o)
11480 {
11481     const int type = o->op_type;
11482     I32 oa = PL_opargs[type] >> OASHIFT;
11483
11484     PERL_ARGS_ASSERT_CK_FUN;
11485
11486     if (o->op_flags & OPf_STACKED) {
11487         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11488             oa &= ~OA_OPTIONAL;
11489         else
11490             return no_fh_allowed(o);
11491     }
11492
11493     if (o->op_flags & OPf_KIDS) {
11494         OP *prev_kid = NULL;
11495         OP *kid = cLISTOPo->op_first;
11496         I32 numargs = 0;
11497         bool seen_optional = FALSE;
11498
11499         if (kid->op_type == OP_PUSHMARK ||
11500             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11501         {
11502             prev_kid = kid;
11503             kid = OpSIBLING(kid);
11504         }
11505         if (kid && kid->op_type == OP_COREARGS) {
11506             bool optional = FALSE;
11507             while (oa) {
11508                 numargs++;
11509                 if (oa & OA_OPTIONAL) optional = TRUE;
11510                 oa = oa >> 4;
11511             }
11512             if (optional) o->op_private |= numargs;
11513             return o;
11514         }
11515
11516         while (oa) {
11517             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11518                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11519                     kid = newDEFSVOP();
11520                     /* append kid to chain */
11521                     op_sibling_splice(o, prev_kid, 0, kid);
11522                 }
11523                 seen_optional = TRUE;
11524             }
11525             if (!kid) break;
11526
11527             numargs++;
11528             switch (oa & 7) {
11529             case OA_SCALAR:
11530                 /* list seen where single (scalar) arg expected? */
11531                 if (numargs == 1 && !(oa >> 4)
11532                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11533                 {
11534                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11535                 }
11536                 if (type != OP_DELETE) scalar(kid);
11537                 break;
11538             case OA_LIST:
11539                 if (oa < 16) {
11540                     kid = 0;
11541                     continue;
11542                 }
11543                 else
11544                     list(kid);
11545                 break;
11546             case OA_AVREF:
11547                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11548                     && !OpHAS_SIBLING(kid))
11549                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11550                                    "Useless use of %s with no values",
11551                                    PL_op_desc[type]);
11552
11553                 if (kid->op_type == OP_CONST
11554                       && (  !SvROK(cSVOPx_sv(kid))
11555                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11556                         )
11557                     bad_type_pv(numargs, "array", o, kid);
11558                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11559                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11560                                          PL_op_desc[type]), 0);
11561                 }
11562                 else {
11563                     op_lvalue(kid, type);
11564                 }
11565                 break;
11566             case OA_HVREF:
11567                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11568                     bad_type_pv(numargs, "hash", o, kid);
11569                 op_lvalue(kid, type);
11570                 break;
11571             case OA_CVREF:
11572                 {
11573                     /* replace kid with newop in chain */
11574                     OP * const newop =
11575                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11576                     newop->op_next = newop;
11577                     kid = newop;
11578                 }
11579                 break;
11580             case OA_FILEREF:
11581                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11582                     if (kid->op_type == OP_CONST &&
11583                         (kid->op_private & OPpCONST_BARE))
11584                     {
11585                         OP * const newop = newGVOP(OP_GV, 0,
11586                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11587                         /* replace kid with newop in chain */
11588                         op_sibling_splice(o, prev_kid, 1, newop);
11589                         op_free(kid);
11590                         kid = newop;
11591                     }
11592                     else if (kid->op_type == OP_READLINE) {
11593                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11594                         bad_type_pv(numargs, "HANDLE", o, kid);
11595                     }
11596                     else {
11597                         I32 flags = OPf_SPECIAL;
11598                         I32 priv = 0;
11599                         PADOFFSET targ = 0;
11600
11601                         /* is this op a FH constructor? */
11602                         if (is_handle_constructor(o,numargs)) {
11603                             const char *name = NULL;
11604                             STRLEN len = 0;
11605                             U32 name_utf8 = 0;
11606                             bool want_dollar = TRUE;
11607
11608                             flags = 0;
11609                             /* Set a flag to tell rv2gv to vivify
11610                              * need to "prove" flag does not mean something
11611                              * else already - NI-S 1999/05/07
11612                              */
11613                             priv = OPpDEREF;
11614                             if (kid->op_type == OP_PADSV) {
11615                                 PADNAME * const pn
11616                                     = PAD_COMPNAME_SV(kid->op_targ);
11617                                 name = PadnamePV (pn);
11618                                 len  = PadnameLEN(pn);
11619                                 name_utf8 = PadnameUTF8(pn);
11620                             }
11621                             else if (kid->op_type == OP_RV2SV
11622                                      && kUNOP->op_first->op_type == OP_GV)
11623                             {
11624                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11625                                 name = GvNAME(gv);
11626                                 len = GvNAMELEN(gv);
11627                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11628                             }
11629                             else if (kid->op_type == OP_AELEM
11630                                      || kid->op_type == OP_HELEM)
11631                             {
11632                                  OP *firstop;
11633                                  OP *op = ((BINOP*)kid)->op_first;
11634                                  name = NULL;
11635                                  if (op) {
11636                                       SV *tmpstr = NULL;
11637                                       const char * const a =
11638                                            kid->op_type == OP_AELEM ?
11639                                            "[]" : "{}";
11640                                       if (((op->op_type == OP_RV2AV) ||
11641                                            (op->op_type == OP_RV2HV)) &&
11642                                           (firstop = ((UNOP*)op)->op_first) &&
11643                                           (firstop->op_type == OP_GV)) {
11644                                            /* packagevar $a[] or $h{} */
11645                                            GV * const gv = cGVOPx_gv(firstop);
11646                                            if (gv)
11647                                                 tmpstr =
11648                                                      Perl_newSVpvf(aTHX_
11649                                                                    "%s%c...%c",
11650                                                                    GvNAME(gv),
11651                                                                    a[0], a[1]);
11652                                       }
11653                                       else if (op->op_type == OP_PADAV
11654                                                || op->op_type == OP_PADHV) {
11655                                            /* lexicalvar $a[] or $h{} */
11656                                            const char * const padname =
11657                                                 PAD_COMPNAME_PV(op->op_targ);
11658                                            if (padname)
11659                                                 tmpstr =
11660                                                      Perl_newSVpvf(aTHX_
11661                                                                    "%s%c...%c",
11662                                                                    padname + 1,
11663                                                                    a[0], a[1]);
11664                                       }
11665                                       if (tmpstr) {
11666                                            name = SvPV_const(tmpstr, len);
11667                                            name_utf8 = SvUTF8(tmpstr);
11668                                            sv_2mortal(tmpstr);
11669                                       }
11670                                  }
11671                                  if (!name) {
11672                                       name = "__ANONIO__";
11673                                       len = 10;
11674                                       want_dollar = FALSE;
11675                                  }
11676                                  op_lvalue(kid, type);
11677                             }
11678                             if (name) {
11679                                 SV *namesv;
11680                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11681                                 namesv = PAD_SVl(targ);
11682                                 if (want_dollar && *name != '$')
11683                                     sv_setpvs(namesv, "$");
11684                                 else
11685                                     SvPVCLEAR(namesv);
11686                                 sv_catpvn(namesv, name, len);
11687                                 if ( name_utf8 ) SvUTF8_on(namesv);
11688                             }
11689                         }
11690                         scalar(kid);
11691                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11692                                     OP_RV2GV, flags);
11693                         kid->op_targ = targ;
11694                         kid->op_private |= priv;
11695                     }
11696                 }
11697                 scalar(kid);
11698                 break;
11699             case OA_SCALARREF:
11700                 if ((type == OP_UNDEF || type == OP_POS)
11701                     && numargs == 1 && !(oa >> 4)
11702                     && kid->op_type == OP_LIST)
11703                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11704                 op_lvalue(scalar(kid), type);
11705                 break;
11706             }
11707             oa >>= 4;
11708             prev_kid = kid;
11709             kid = OpSIBLING(kid);
11710         }
11711         /* FIXME - should the numargs or-ing move after the too many
11712          * arguments check? */
11713         o->op_private |= numargs;
11714         if (kid)
11715             return too_many_arguments_pv(o,OP_DESC(o), 0);
11716         listkids(o);
11717     }
11718     else if (PL_opargs[type] & OA_DEFGV) {
11719         /* Ordering of these two is important to keep f_map.t passing.  */
11720         op_free(o);
11721         return newUNOP(type, 0, newDEFSVOP());
11722     }
11723
11724     if (oa) {
11725         while (oa & OA_OPTIONAL)
11726             oa >>= 4;
11727         if (oa && oa != OA_LIST)
11728             return too_few_arguments_pv(o,OP_DESC(o), 0);
11729     }
11730     return o;
11731 }
11732
11733 OP *
11734 Perl_ck_glob(pTHX_ OP *o)
11735 {
11736     GV *gv;
11737
11738     PERL_ARGS_ASSERT_CK_GLOB;
11739
11740     o = ck_fun(o);
11741     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11742         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11743
11744     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11745     {
11746         /* convert
11747          *     glob
11748          *       \ null - const(wildcard)
11749          * into
11750          *     null
11751          *       \ enter
11752          *            \ list
11753          *                 \ mark - glob - rv2cv
11754          *                             |        \ gv(CORE::GLOBAL::glob)
11755          *                             |
11756          *                              \ null - const(wildcard)
11757          */
11758         o->op_flags |= OPf_SPECIAL;
11759         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11760         o = S_new_entersubop(aTHX_ gv, o);
11761         o = newUNOP(OP_NULL, 0, o);
11762         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11763         return o;
11764     }
11765     else o->op_flags &= ~OPf_SPECIAL;
11766 #if !defined(PERL_EXTERNAL_GLOB)
11767     if (!PL_globhook) {
11768         ENTER;
11769         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11770                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11771         LEAVE;
11772     }
11773 #endif /* !PERL_EXTERNAL_GLOB */
11774     gv = (GV *)newSV(0);
11775     gv_init(gv, 0, "", 0, 0);
11776     gv_IOadd(gv);
11777     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11778     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11779     scalarkids(o);
11780     return o;
11781 }
11782
11783 OP *
11784 Perl_ck_grep(pTHX_ OP *o)
11785 {
11786     LOGOP *gwop;
11787     OP *kid;
11788     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11789
11790     PERL_ARGS_ASSERT_CK_GREP;
11791
11792     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11793
11794     if (o->op_flags & OPf_STACKED) {
11795         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11796         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11797             return no_fh_allowed(o);
11798         o->op_flags &= ~OPf_STACKED;
11799     }
11800     kid = OpSIBLING(cLISTOPo->op_first);
11801     if (type == OP_MAPWHILE)
11802         list(kid);
11803     else
11804         scalar(kid);
11805     o = ck_fun(o);
11806     if (PL_parser && PL_parser->error_count)
11807         return o;
11808     kid = OpSIBLING(cLISTOPo->op_first);
11809     if (kid->op_type != OP_NULL)
11810         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11811     kid = kUNOP->op_first;
11812
11813     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11814     kid->op_next = (OP*)gwop;
11815     o->op_private = gwop->op_private = 0;
11816     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11817
11818     kid = OpSIBLING(cLISTOPo->op_first);
11819     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11820         op_lvalue(kid, OP_GREPSTART);
11821
11822     return (OP*)gwop;
11823 }
11824
11825 OP *
11826 Perl_ck_index(pTHX_ OP *o)
11827 {
11828     PERL_ARGS_ASSERT_CK_INDEX;
11829
11830     if (o->op_flags & OPf_KIDS) {
11831         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11832         if (kid)
11833             kid = OpSIBLING(kid);                       /* get past "big" */
11834         if (kid && kid->op_type == OP_CONST) {
11835             const bool save_taint = TAINT_get;
11836             SV *sv = kSVOP->op_sv;
11837             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11838                 && SvOK(sv) && !SvROK(sv))
11839             {
11840                 sv = newSV(0);
11841                 sv_copypv(sv, kSVOP->op_sv);
11842                 SvREFCNT_dec_NN(kSVOP->op_sv);
11843                 kSVOP->op_sv = sv;
11844             }
11845             if (SvOK(sv)) fbm_compile(sv, 0);
11846             TAINT_set(save_taint);
11847 #ifdef NO_TAINT_SUPPORT
11848             PERL_UNUSED_VAR(save_taint);
11849 #endif
11850         }
11851     }
11852     return ck_fun(o);
11853 }
11854
11855 OP *
11856 Perl_ck_lfun(pTHX_ OP *o)
11857 {
11858     const OPCODE type = o->op_type;
11859
11860     PERL_ARGS_ASSERT_CK_LFUN;
11861
11862     return modkids(ck_fun(o), type);
11863 }
11864
11865 OP *
11866 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
11867 {
11868     PERL_ARGS_ASSERT_CK_DEFINED;
11869
11870     if ((o->op_flags & OPf_KIDS)) {
11871         switch (cUNOPo->op_first->op_type) {
11872         case OP_RV2AV:
11873         case OP_PADAV:
11874             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11875                              " (Maybe you should just omit the defined()?)");
11876             NOT_REACHED; /* NOTREACHED */
11877             break;
11878         case OP_RV2HV:
11879         case OP_PADHV:
11880             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11881                              " (Maybe you should just omit the defined()?)");
11882             NOT_REACHED; /* NOTREACHED */
11883             break;
11884         default:
11885             /* no warning */
11886             break;
11887         }
11888     }
11889     return ck_rfun(o);
11890 }
11891
11892 OP *
11893 Perl_ck_readline(pTHX_ OP *o)
11894 {
11895     PERL_ARGS_ASSERT_CK_READLINE;
11896
11897     if (o->op_flags & OPf_KIDS) {
11898          OP *kid = cLISTOPo->op_first;
11899          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11900     }
11901     else {
11902         OP * const newop
11903             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
11904         op_free(o);
11905         return newop;
11906     }
11907     return o;
11908 }
11909
11910 OP *
11911 Perl_ck_rfun(pTHX_ OP *o)
11912 {
11913     const OPCODE type = o->op_type;
11914
11915     PERL_ARGS_ASSERT_CK_RFUN;
11916
11917     return refkids(ck_fun(o), type);
11918 }
11919
11920 OP *
11921 Perl_ck_listiob(pTHX_ OP *o)
11922 {
11923     OP *kid;
11924
11925     PERL_ARGS_ASSERT_CK_LISTIOB;
11926
11927     kid = cLISTOPo->op_first;
11928     if (!kid) {
11929         o = force_list(o, 1);
11930         kid = cLISTOPo->op_first;
11931     }
11932     if (kid->op_type == OP_PUSHMARK)
11933         kid = OpSIBLING(kid);
11934     if (kid && o->op_flags & OPf_STACKED)
11935         kid = OpSIBLING(kid);
11936     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
11937         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
11938          && !kid->op_folded) {
11939             o->op_flags |= OPf_STACKED; /* make it a filehandle */
11940             scalar(kid);
11941             /* replace old const op with new OP_RV2GV parent */
11942             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
11943                                         OP_RV2GV, OPf_REF);
11944             kid = OpSIBLING(kid);
11945         }
11946     }
11947
11948     if (!kid)
11949         op_append_elem(o->op_type, o, newDEFSVOP());
11950
11951     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
11952     return listkids(o);
11953 }
11954
11955 OP *
11956 Perl_ck_smartmatch(pTHX_ OP *o)
11957 {
11958     dVAR;
11959     PERL_ARGS_ASSERT_CK_SMARTMATCH;
11960     if (0 == (o->op_flags & OPf_SPECIAL)) {
11961         OP *first  = cBINOPo->op_first;
11962         OP *second = OpSIBLING(first);
11963
11964         /* Implicitly take a reference to an array or hash */
11965
11966         /* remove the original two siblings, then add back the
11967          * (possibly different) first and second sibs.
11968          */
11969         op_sibling_splice(o, NULL, 1, NULL);
11970         op_sibling_splice(o, NULL, 1, NULL);
11971         first  = ref_array_or_hash(first);
11972         second = ref_array_or_hash(second);
11973         op_sibling_splice(o, NULL, 0, second);
11974         op_sibling_splice(o, NULL, 0, first);
11975
11976         /* Implicitly take a reference to a regular expression */
11977         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
11978             OpTYPE_set(first, OP_QR);
11979         }
11980         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
11981             OpTYPE_set(second, OP_QR);
11982         }
11983     }
11984
11985     return o;
11986 }
11987
11988
11989 static OP *
11990 S_maybe_targlex(pTHX_ OP *o)
11991 {
11992     OP * const kid = cLISTOPo->op_first;
11993     /* has a disposable target? */
11994     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
11995         && !(kid->op_flags & OPf_STACKED)
11996         /* Cannot steal the second time! */
11997         && !(kid->op_private & OPpTARGET_MY)
11998         )
11999     {
12000         OP * const kkid = OpSIBLING(kid);
12001
12002         /* Can just relocate the target. */
12003         if (kkid && kkid->op_type == OP_PADSV
12004             && (!(kkid->op_private & OPpLVAL_INTRO)
12005                || kkid->op_private & OPpPAD_STATE))
12006         {
12007             kid->op_targ = kkid->op_targ;
12008             kkid->op_targ = 0;
12009             /* Now we do not need PADSV and SASSIGN.
12010              * Detach kid and free the rest. */
12011             op_sibling_splice(o, NULL, 1, NULL);
12012             op_free(o);
12013             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12014             return kid;
12015         }
12016     }
12017     return o;
12018 }
12019
12020 OP *
12021 Perl_ck_sassign(pTHX_ OP *o)
12022 {
12023     dVAR;
12024     OP * const kid = cBINOPo->op_first;
12025
12026     PERL_ARGS_ASSERT_CK_SASSIGN;
12027
12028     if (OpHAS_SIBLING(kid)) {
12029         OP *kkid = OpSIBLING(kid);
12030         /* For state variable assignment with attributes, kkid is a list op
12031            whose op_last is a padsv. */
12032         if ((kkid->op_type == OP_PADSV ||
12033              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12034               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12035              )
12036             )
12037                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12038                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12039             return S_newONCEOP(aTHX_ o, kkid);
12040         }
12041     }
12042     return S_maybe_targlex(aTHX_ o);
12043 }
12044
12045
12046 OP *
12047 Perl_ck_match(pTHX_ OP *o)
12048 {
12049     PERL_UNUSED_CONTEXT;
12050     PERL_ARGS_ASSERT_CK_MATCH;
12051
12052     return o;
12053 }
12054
12055 OP *
12056 Perl_ck_method(pTHX_ OP *o)
12057 {
12058     SV *sv, *methsv, *rclass;
12059     const char* method;
12060     char* compatptr;
12061     int utf8;
12062     STRLEN len, nsplit = 0, i;
12063     OP* new_op;
12064     OP * const kid = cUNOPo->op_first;
12065
12066     PERL_ARGS_ASSERT_CK_METHOD;
12067     if (kid->op_type != OP_CONST) return o;
12068
12069     sv = kSVOP->op_sv;
12070
12071     /* replace ' with :: */
12072     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12073                                         SvEND(sv) - SvPVX(sv) )))
12074     {
12075         *compatptr = ':';
12076         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12077     }
12078
12079     method = SvPVX_const(sv);
12080     len = SvCUR(sv);
12081     utf8 = SvUTF8(sv) ? -1 : 1;
12082
12083     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12084         nsplit = i+1;
12085         break;
12086     }
12087
12088     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12089
12090     if (!nsplit) { /* $proto->method() */
12091         op_free(o);
12092         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12093     }
12094
12095     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12096         op_free(o);
12097         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12098     }
12099
12100     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12101     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12102         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12103         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12104     } else {
12105         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12106         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12107     }
12108 #ifdef USE_ITHREADS
12109     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12110 #else
12111     cMETHOPx(new_op)->op_rclass_sv = rclass;
12112 #endif
12113     op_free(o);
12114     return new_op;
12115 }
12116
12117 OP *
12118 Perl_ck_null(pTHX_ OP *o)
12119 {
12120     PERL_ARGS_ASSERT_CK_NULL;
12121     PERL_UNUSED_CONTEXT;
12122     return o;
12123 }
12124
12125 OP *
12126 Perl_ck_open(pTHX_ OP *o)
12127 {
12128     PERL_ARGS_ASSERT_CK_OPEN;
12129
12130     S_io_hints(aTHX_ o);
12131     {
12132          /* In case of three-arg dup open remove strictness
12133           * from the last arg if it is a bareword. */
12134          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12135          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12136          OP *oa;
12137          const char *mode;
12138
12139          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12140              (last->op_private & OPpCONST_BARE) &&
12141              (last->op_private & OPpCONST_STRICT) &&
12142              (oa = OpSIBLING(first)) &&         /* The fh. */
12143              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12144              (oa->op_type == OP_CONST) &&
12145              SvPOK(((SVOP*)oa)->op_sv) &&
12146              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12147              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12148              (last == OpSIBLING(oa)))                   /* The bareword. */
12149               last->op_private &= ~OPpCONST_STRICT;
12150     }
12151     return ck_fun(o);
12152 }
12153
12154 OP *
12155 Perl_ck_prototype(pTHX_ OP *o)
12156 {
12157     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12158     if (!(o->op_flags & OPf_KIDS)) {
12159         op_free(o);
12160         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12161     }
12162     return o;
12163 }
12164
12165 OP *
12166 Perl_ck_refassign(pTHX_ OP *o)
12167 {
12168     OP * const right = cLISTOPo->op_first;
12169     OP * const left = OpSIBLING(right);
12170     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12171     bool stacked = 0;
12172
12173     PERL_ARGS_ASSERT_CK_REFASSIGN;
12174     assert (left);
12175     assert (left->op_type == OP_SREFGEN);
12176
12177     o->op_private = 0;
12178     /* we use OPpPAD_STATE in refassign to mean either of those things,
12179      * and the code assumes the two flags occupy the same bit position
12180      * in the various ops below */
12181     assert(OPpPAD_STATE == OPpOUR_INTRO);
12182
12183     switch (varop->op_type) {
12184     case OP_PADAV:
12185         o->op_private |= OPpLVREF_AV;
12186         goto settarg;
12187     case OP_PADHV:
12188         o->op_private |= OPpLVREF_HV;
12189         /* FALLTHROUGH */
12190     case OP_PADSV:
12191       settarg:
12192         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12193         o->op_targ = varop->op_targ;
12194         varop->op_targ = 0;
12195         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12196         break;
12197
12198     case OP_RV2AV:
12199         o->op_private |= OPpLVREF_AV;
12200         goto checkgv;
12201         NOT_REACHED; /* NOTREACHED */
12202     case OP_RV2HV:
12203         o->op_private |= OPpLVREF_HV;
12204         /* FALLTHROUGH */
12205     case OP_RV2SV:
12206       checkgv:
12207         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12208         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12209       detach_and_stack:
12210         /* Point varop to its GV kid, detached.  */
12211         varop = op_sibling_splice(varop, NULL, -1, NULL);
12212         stacked = TRUE;
12213         break;
12214     case OP_RV2CV: {
12215         OP * const kidparent =
12216             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12217         OP * const kid = cUNOPx(kidparent)->op_first;
12218         o->op_private |= OPpLVREF_CV;
12219         if (kid->op_type == OP_GV) {
12220             varop = kidparent;
12221             goto detach_and_stack;
12222         }
12223         if (kid->op_type != OP_PADCV)   goto bad;
12224         o->op_targ = kid->op_targ;
12225         kid->op_targ = 0;
12226         break;
12227     }
12228     case OP_AELEM:
12229     case OP_HELEM:
12230         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12231         o->op_private |= OPpLVREF_ELEM;
12232         op_null(varop);
12233         stacked = TRUE;
12234         /* Detach varop.  */
12235         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12236         break;
12237     default:
12238       bad:
12239         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12240         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12241                                 "assignment",
12242                                  OP_DESC(varop)));
12243         return o;
12244     }
12245     if (!FEATURE_REFALIASING_IS_ENABLED)
12246         Perl_croak(aTHX_
12247                   "Experimental aliasing via reference not enabled");
12248     Perl_ck_warner_d(aTHX_
12249                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12250                     "Aliasing via reference is experimental");
12251     if (stacked) {
12252         o->op_flags |= OPf_STACKED;
12253         op_sibling_splice(o, right, 1, varop);
12254     }
12255     else {
12256         o->op_flags &=~ OPf_STACKED;
12257         op_sibling_splice(o, right, 1, NULL);
12258     }
12259     op_free(left);
12260     return o;
12261 }
12262
12263 OP *
12264 Perl_ck_repeat(pTHX_ OP *o)
12265 {
12266     PERL_ARGS_ASSERT_CK_REPEAT;
12267
12268     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12269         OP* kids;
12270         o->op_private |= OPpREPEAT_DOLIST;
12271         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12272         kids = force_list(kids, 1); /* promote it to a list */
12273         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12274     }
12275     else
12276         scalar(o);
12277     return o;
12278 }
12279
12280 OP *
12281 Perl_ck_require(pTHX_ OP *o)
12282 {
12283     GV* gv;
12284
12285     PERL_ARGS_ASSERT_CK_REQUIRE;
12286
12287     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12288         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12289         U32 hash;
12290         char *s;
12291         STRLEN len;
12292         if (kid->op_type == OP_CONST) {
12293           SV * const sv = kid->op_sv;
12294           U32 const was_readonly = SvREADONLY(sv);
12295           if (kid->op_private & OPpCONST_BARE) {
12296             dVAR;
12297             const char *end;
12298             HEK *hek;
12299
12300             if (was_readonly) {
12301                     SvREADONLY_off(sv);
12302             }
12303             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12304
12305             s = SvPVX(sv);
12306             len = SvCUR(sv);
12307             end = s + len;
12308             /* treat ::foo::bar as foo::bar */
12309             if (len >= 2 && s[0] == ':' && s[1] == ':')
12310                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12311             if (s == end)
12312                 DIE(aTHX_ "Bareword in require maps to empty filename");
12313
12314             for (; s < end; s++) {
12315                 if (*s == ':' && s[1] == ':') {
12316                     *s = '/';
12317                     Move(s+2, s+1, end - s - 1, char);
12318                     --end;
12319                 }
12320             }
12321             SvEND_set(sv, end);
12322             sv_catpvs(sv, ".pm");
12323             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12324             hek = share_hek(SvPVX(sv),
12325                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12326                             hash);
12327             sv_sethek(sv, hek);
12328             unshare_hek(hek);
12329             SvFLAGS(sv) |= was_readonly;
12330           }
12331           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12332                 && !SvVOK(sv)) {
12333             s = SvPV(sv, len);
12334             if (SvREFCNT(sv) > 1) {
12335                 kid->op_sv = newSVpvn_share(
12336                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12337                 SvREFCNT_dec_NN(sv);
12338             }
12339             else {
12340                 dVAR;
12341                 HEK *hek;
12342                 if (was_readonly) SvREADONLY_off(sv);
12343                 PERL_HASH(hash, s, len);
12344                 hek = share_hek(s,
12345                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12346                                 hash);
12347                 sv_sethek(sv, hek);
12348                 unshare_hek(hek);
12349                 SvFLAGS(sv) |= was_readonly;
12350             }
12351           }
12352         }
12353     }
12354
12355     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12356         /* handle override, if any */
12357      && (gv = gv_override("require", 7))) {
12358         OP *kid, *newop;
12359         if (o->op_flags & OPf_KIDS) {
12360             kid = cUNOPo->op_first;
12361             op_sibling_splice(o, NULL, -1, NULL);
12362         }
12363         else {
12364             kid = newDEFSVOP();
12365         }
12366         op_free(o);
12367         newop = S_new_entersubop(aTHX_ gv, kid);
12368         return newop;
12369     }
12370
12371     return ck_fun(o);
12372 }
12373
12374 OP *
12375 Perl_ck_return(pTHX_ OP *o)
12376 {
12377     OP *kid;
12378
12379     PERL_ARGS_ASSERT_CK_RETURN;
12380
12381     kid = OpSIBLING(cLISTOPo->op_first);
12382     if (PL_compcv && CvLVALUE(PL_compcv)) {
12383         for (; kid; kid = OpSIBLING(kid))
12384             op_lvalue(kid, OP_LEAVESUBLV);
12385     }
12386
12387     return o;
12388 }
12389
12390 OP *
12391 Perl_ck_select(pTHX_ OP *o)
12392 {
12393     dVAR;
12394     OP* kid;
12395
12396     PERL_ARGS_ASSERT_CK_SELECT;
12397
12398     if (o->op_flags & OPf_KIDS) {
12399         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12400         if (kid && OpHAS_SIBLING(kid)) {
12401             OpTYPE_set(o, OP_SSELECT);
12402             o = ck_fun(o);
12403             return fold_constants(op_integerize(op_std_init(o)));
12404         }
12405     }
12406     o = ck_fun(o);
12407     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12408     if (kid && kid->op_type == OP_RV2GV)
12409         kid->op_private &= ~HINT_STRICT_REFS;
12410     return o;
12411 }
12412
12413 OP *
12414 Perl_ck_shift(pTHX_ OP *o)
12415 {
12416     const I32 type = o->op_type;
12417
12418     PERL_ARGS_ASSERT_CK_SHIFT;
12419
12420     if (!(o->op_flags & OPf_KIDS)) {
12421         OP *argop;
12422
12423         if (!CvUNIQUE(PL_compcv)) {
12424             o->op_flags |= OPf_SPECIAL;
12425             return o;
12426         }
12427
12428         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12429         op_free(o);
12430         return newUNOP(type, 0, scalar(argop));
12431     }
12432     return scalar(ck_fun(o));
12433 }
12434
12435 OP *
12436 Perl_ck_sort(pTHX_ OP *o)
12437 {
12438     OP *firstkid;
12439     OP *kid;
12440     HV * const hinthv =
12441         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12442     U8 stacked;
12443
12444     PERL_ARGS_ASSERT_CK_SORT;
12445
12446     if (hinthv) {
12447             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12448             if (svp) {
12449                 const I32 sorthints = (I32)SvIV(*svp);
12450                 if ((sorthints & HINT_SORT_STABLE) != 0)
12451                     o->op_private |= OPpSORT_STABLE;
12452                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12453                     o->op_private |= OPpSORT_UNSTABLE;
12454             }
12455     }
12456
12457     if (o->op_flags & OPf_STACKED)
12458         simplify_sort(o);
12459     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12460
12461     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12462         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12463
12464         /* if the first arg is a code block, process it and mark sort as
12465          * OPf_SPECIAL */
12466         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12467             LINKLIST(kid);
12468             if (kid->op_type == OP_LEAVE)
12469                     op_null(kid);                       /* wipe out leave */
12470             /* Prevent execution from escaping out of the sort block. */
12471             kid->op_next = 0;
12472
12473             /* provide scalar context for comparison function/block */
12474             kid = scalar(firstkid);
12475             kid->op_next = kid;
12476             o->op_flags |= OPf_SPECIAL;
12477         }
12478         else if (kid->op_type == OP_CONST
12479               && kid->op_private & OPpCONST_BARE) {
12480             char tmpbuf[256];
12481             STRLEN len;
12482             PADOFFSET off;
12483             const char * const name = SvPV(kSVOP_sv, len);
12484             *tmpbuf = '&';
12485             assert (len < 256);
12486             Copy(name, tmpbuf+1, len, char);
12487             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12488             if (off != NOT_IN_PAD) {
12489                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12490                     SV * const fq =
12491                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12492                     sv_catpvs(fq, "::");
12493                     sv_catsv(fq, kSVOP_sv);
12494                     SvREFCNT_dec_NN(kSVOP_sv);
12495                     kSVOP->op_sv = fq;
12496                 }
12497                 else {
12498                     OP * const padop = newOP(OP_PADCV, 0);
12499                     padop->op_targ = off;
12500                     /* replace the const op with the pad op */
12501                     op_sibling_splice(firstkid, NULL, 1, padop);
12502                     op_free(kid);
12503                 }
12504             }
12505         }
12506
12507         firstkid = OpSIBLING(firstkid);
12508     }
12509
12510     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12511         /* provide list context for arguments */
12512         list(kid);
12513         if (stacked)
12514             op_lvalue(kid, OP_GREPSTART);
12515     }
12516
12517     return o;
12518 }
12519
12520 /* for sort { X } ..., where X is one of
12521  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12522  * elide the second child of the sort (the one containing X),
12523  * and set these flags as appropriate
12524         OPpSORT_NUMERIC;
12525         OPpSORT_INTEGER;
12526         OPpSORT_DESCEND;
12527  * Also, check and warn on lexical $a, $b.
12528  */
12529
12530 STATIC void
12531 S_simplify_sort(pTHX_ OP *o)
12532 {
12533     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12534     OP *k;
12535     int descending;
12536     GV *gv;
12537     const char *gvname;
12538     bool have_scopeop;
12539
12540     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12541
12542     kid = kUNOP->op_first;                              /* get past null */
12543     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12544      && kid->op_type != OP_LEAVE)
12545         return;
12546     kid = kLISTOP->op_last;                             /* get past scope */
12547     switch(kid->op_type) {
12548         case OP_NCMP:
12549         case OP_I_NCMP:
12550         case OP_SCMP:
12551             if (!have_scopeop) goto padkids;
12552             break;
12553         default:
12554             return;
12555     }
12556     k = kid;                                            /* remember this node*/
12557     if (kBINOP->op_first->op_type != OP_RV2SV
12558      || kBINOP->op_last ->op_type != OP_RV2SV)
12559     {
12560         /*
12561            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12562            then used in a comparison.  This catches most, but not
12563            all cases.  For instance, it catches
12564                sort { my($a); $a <=> $b }
12565            but not
12566                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12567            (although why you'd do that is anyone's guess).
12568         */
12569
12570        padkids:
12571         if (!ckWARN(WARN_SYNTAX)) return;
12572         kid = kBINOP->op_first;
12573         do {
12574             if (kid->op_type == OP_PADSV) {
12575                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12576                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12577                  && (  PadnamePV(name)[1] == 'a'
12578                     || PadnamePV(name)[1] == 'b'  ))
12579                     /* diag_listed_as: "my %s" used in sort comparison */
12580                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12581                                      "\"%s %s\" used in sort comparison",
12582                                       PadnameIsSTATE(name)
12583                                         ? "state"
12584                                         : "my",
12585                                       PadnamePV(name));
12586             }
12587         } while ((kid = OpSIBLING(kid)));
12588         return;
12589     }
12590     kid = kBINOP->op_first;                             /* get past cmp */
12591     if (kUNOP->op_first->op_type != OP_GV)
12592         return;
12593     kid = kUNOP->op_first;                              /* get past rv2sv */
12594     gv = kGVOP_gv;
12595     if (GvSTASH(gv) != PL_curstash)
12596         return;
12597     gvname = GvNAME(gv);
12598     if (*gvname == 'a' && gvname[1] == '\0')
12599         descending = 0;
12600     else if (*gvname == 'b' && gvname[1] == '\0')
12601         descending = 1;
12602     else
12603         return;
12604
12605     kid = k;                                            /* back to cmp */
12606     /* already checked above that it is rv2sv */
12607     kid = kBINOP->op_last;                              /* down to 2nd arg */
12608     if (kUNOP->op_first->op_type != OP_GV)
12609         return;
12610     kid = kUNOP->op_first;                              /* get past rv2sv */
12611     gv = kGVOP_gv;
12612     if (GvSTASH(gv) != PL_curstash)
12613         return;
12614     gvname = GvNAME(gv);
12615     if ( descending
12616          ? !(*gvname == 'a' && gvname[1] == '\0')
12617          : !(*gvname == 'b' && gvname[1] == '\0'))
12618         return;
12619     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12620     if (descending)
12621         o->op_private |= OPpSORT_DESCEND;
12622     if (k->op_type == OP_NCMP)
12623         o->op_private |= OPpSORT_NUMERIC;
12624     if (k->op_type == OP_I_NCMP)
12625         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12626     kid = OpSIBLING(cLISTOPo->op_first);
12627     /* cut out and delete old block (second sibling) */
12628     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12629     op_free(kid);
12630 }
12631
12632 OP *
12633 Perl_ck_split(pTHX_ OP *o)
12634 {
12635     dVAR;
12636     OP *kid;
12637     OP *sibs;
12638
12639     PERL_ARGS_ASSERT_CK_SPLIT;
12640
12641     assert(o->op_type == OP_LIST);
12642
12643     if (o->op_flags & OPf_STACKED)
12644         return no_fh_allowed(o);
12645
12646     kid = cLISTOPo->op_first;
12647     /* delete leading NULL node, then add a CONST if no other nodes */
12648     assert(kid->op_type == OP_NULL);
12649     op_sibling_splice(o, NULL, 1,
12650         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12651     op_free(kid);
12652     kid = cLISTOPo->op_first;
12653
12654     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12655         /* remove match expression, and replace with new optree with
12656          * a match op at its head */
12657         op_sibling_splice(o, NULL, 1, NULL);
12658         /* pmruntime will handle split " " behavior with flag==2 */
12659         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12660         op_sibling_splice(o, NULL, 0, kid);
12661     }
12662
12663     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12664
12665     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12666       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12667                      "Use of /g modifier is meaningless in split");
12668     }
12669
12670     /* eliminate the split op, and move the match op (plus any children)
12671      * into its place, then convert the match op into a split op. i.e.
12672      *
12673      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12674      *    |                        |                     |
12675      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12676      *    |                        |                     |
12677      *    R                        X - Y                 X - Y
12678      *    |
12679      *    X - Y
12680      *
12681      * (R, if it exists, will be a regcomp op)
12682      */
12683
12684     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12685     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12686     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12687     OpTYPE_set(kid, OP_SPLIT);
12688     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12689     kid->op_private = o->op_private;
12690     op_free(o);
12691     o = kid;
12692     kid = sibs; /* kid is now the string arg of the split */
12693
12694     if (!kid) {
12695         kid = newDEFSVOP();
12696         op_append_elem(OP_SPLIT, o, kid);
12697     }
12698     scalar(kid);
12699
12700     kid = OpSIBLING(kid);
12701     if (!kid) {
12702         kid = newSVOP(OP_CONST, 0, newSViv(0));
12703         op_append_elem(OP_SPLIT, o, kid);
12704         o->op_private |= OPpSPLIT_IMPLIM;
12705     }
12706     scalar(kid);
12707
12708     if (OpHAS_SIBLING(kid))
12709         return too_many_arguments_pv(o,OP_DESC(o), 0);
12710
12711     return o;
12712 }
12713
12714 OP *
12715 Perl_ck_stringify(pTHX_ OP *o)
12716 {
12717     OP * const kid = OpSIBLING(cUNOPo->op_first);
12718     PERL_ARGS_ASSERT_CK_STRINGIFY;
12719     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12720          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12721          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12722         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12723     {
12724         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12725         op_free(o);
12726         return kid;
12727     }
12728     return ck_fun(o);
12729 }
12730
12731 OP *
12732 Perl_ck_join(pTHX_ OP *o)
12733 {
12734     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12735
12736     PERL_ARGS_ASSERT_CK_JOIN;
12737
12738     if (kid && kid->op_type == OP_MATCH) {
12739         if (ckWARN(WARN_SYNTAX)) {
12740             const REGEXP *re = PM_GETRE(kPMOP);
12741             const SV *msg = re
12742                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12743                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12744                     : newSVpvs_flags( "STRING", SVs_TEMP );
12745             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12746                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12747                         SVfARG(msg), SVfARG(msg));
12748         }
12749     }
12750     if (kid
12751      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12752         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12753         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12754            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12755     {
12756         const OP * const bairn = OpSIBLING(kid); /* the list */
12757         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12758          && OP_GIMME(bairn,0) == G_SCALAR)
12759         {
12760             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12761                                      op_sibling_splice(o, kid, 1, NULL));
12762             op_free(o);
12763             return ret;
12764         }
12765     }
12766
12767     return ck_fun(o);
12768 }
12769
12770 /*
12771 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12772
12773 Examines an op, which is expected to identify a subroutine at runtime,
12774 and attempts to determine at compile time which subroutine it identifies.
12775 This is normally used during Perl compilation to determine whether
12776 a prototype can be applied to a function call.  C<cvop> is the op
12777 being considered, normally an C<rv2cv> op.  A pointer to the identified
12778 subroutine is returned, if it could be determined statically, and a null
12779 pointer is returned if it was not possible to determine statically.
12780
12781 Currently, the subroutine can be identified statically if the RV that the
12782 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12783 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12784 suitable if the constant value must be an RV pointing to a CV.  Details of
12785 this process may change in future versions of Perl.  If the C<rv2cv> op
12786 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12787 the subroutine statically: this flag is used to suppress compile-time
12788 magic on a subroutine call, forcing it to use default runtime behaviour.
12789
12790 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12791 of a GV reference is modified.  If a GV was examined and its CV slot was
12792 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12793 If the op is not optimised away, and the CV slot is later populated with
12794 a subroutine having a prototype, that flag eventually triggers the warning
12795 "called too early to check prototype".
12796
12797 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12798 of returning a pointer to the subroutine it returns a pointer to the
12799 GV giving the most appropriate name for the subroutine in this context.
12800 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12801 (C<CvANON>) subroutine that is referenced through a GV it will be the
12802 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12803 A null pointer is returned as usual if there is no statically-determinable
12804 subroutine.
12805
12806 =cut
12807 */
12808
12809 /* shared by toke.c:yylex */
12810 CV *
12811 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12812 {
12813     PADNAME *name = PAD_COMPNAME(off);
12814     CV *compcv = PL_compcv;
12815     while (PadnameOUTER(name)) {
12816         assert(PARENT_PAD_INDEX(name));
12817         compcv = CvOUTSIDE(compcv);
12818         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12819                 [off = PARENT_PAD_INDEX(name)];
12820     }
12821     assert(!PadnameIsOUR(name));
12822     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12823         return PadnamePROTOCV(name);
12824     }
12825     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12826 }
12827
12828 CV *
12829 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12830 {
12831     OP *rvop;
12832     CV *cv;
12833     GV *gv;
12834     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12835     if (flags & ~RV2CVOPCV_FLAG_MASK)
12836         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12837     if (cvop->op_type != OP_RV2CV)
12838         return NULL;
12839     if (cvop->op_private & OPpENTERSUB_AMPER)
12840         return NULL;
12841     if (!(cvop->op_flags & OPf_KIDS))
12842         return NULL;
12843     rvop = cUNOPx(cvop)->op_first;
12844     switch (rvop->op_type) {
12845         case OP_GV: {
12846             gv = cGVOPx_gv(rvop);
12847             if (!isGV(gv)) {
12848                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12849                     cv = MUTABLE_CV(SvRV(gv));
12850                     gv = NULL;
12851                     break;
12852                 }
12853                 if (flags & RV2CVOPCV_RETURN_STUB)
12854                     return (CV *)gv;
12855                 else return NULL;
12856             }
12857             cv = GvCVu(gv);
12858             if (!cv) {
12859                 if (flags & RV2CVOPCV_MARK_EARLY)
12860                     rvop->op_private |= OPpEARLY_CV;
12861                 return NULL;
12862             }
12863         } break;
12864         case OP_CONST: {
12865             SV *rv = cSVOPx_sv(rvop);
12866             if (!SvROK(rv))
12867                 return NULL;
12868             cv = (CV*)SvRV(rv);
12869             gv = NULL;
12870         } break;
12871         case OP_PADCV: {
12872             cv = find_lexical_cv(rvop->op_targ);
12873             gv = NULL;
12874         } break;
12875         default: {
12876             return NULL;
12877         } NOT_REACHED; /* NOTREACHED */
12878     }
12879     if (SvTYPE((SV*)cv) != SVt_PVCV)
12880         return NULL;
12881     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12882         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12883             gv = CvGV(cv);
12884         return (CV*)gv;
12885     }
12886     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
12887         if (CvLEXICAL(cv) || CvNAMED(cv))
12888             return NULL;
12889         if (!CvANON(cv) || !gv)
12890             gv = CvGV(cv);
12891         return (CV*)gv;
12892
12893     } else {
12894         return cv;
12895     }
12896 }
12897
12898 /*
12899 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
12900
12901 Performs the default fixup of the arguments part of an C<entersub>
12902 op tree.  This consists of applying list context to each of the
12903 argument ops.  This is the standard treatment used on a call marked
12904 with C<&>, or a method call, or a call through a subroutine reference,
12905 or any other call where the callee can't be identified at compile time,
12906 or a call where the callee has no prototype.
12907
12908 =cut
12909 */
12910
12911 OP *
12912 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
12913 {
12914     OP *aop;
12915
12916     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
12917
12918     aop = cUNOPx(entersubop)->op_first;
12919     if (!OpHAS_SIBLING(aop))
12920         aop = cUNOPx(aop)->op_first;
12921     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
12922         /* skip the extra attributes->import() call implicitly added in
12923          * something like foo(my $x : bar)
12924          */
12925         if (   aop->op_type == OP_ENTERSUB
12926             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
12927         )
12928             continue;
12929         list(aop);
12930         op_lvalue(aop, OP_ENTERSUB);
12931     }
12932     return entersubop;
12933 }
12934
12935 /*
12936 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
12937
12938 Performs the fixup of the arguments part of an C<entersub> op tree
12939 based on a subroutine prototype.  This makes various modifications to
12940 the argument ops, from applying context up to inserting C<refgen> ops,
12941 and checking the number and syntactic types of arguments, as directed by
12942 the prototype.  This is the standard treatment used on a subroutine call,
12943 not marked with C<&>, where the callee can be identified at compile time
12944 and has a prototype.
12945
12946 C<protosv> supplies the subroutine prototype to be applied to the call.
12947 It may be a normal defined scalar, of which the string value will be used.
12948 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
12949 that has been cast to C<SV*>) which has a prototype.  The prototype
12950 supplied, in whichever form, does not need to match the actual callee
12951 referenced by the op tree.
12952
12953 If the argument ops disagree with the prototype, for example by having
12954 an unacceptable number of arguments, a valid op tree is returned anyway.
12955 The error is reflected in the parser state, normally resulting in a single
12956 exception at the top level of parsing which covers all the compilation
12957 errors that occurred.  In the error message, the callee is referred to
12958 by the name defined by the C<namegv> parameter.
12959
12960 =cut
12961 */
12962
12963 OP *
12964 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
12965 {
12966     STRLEN proto_len;
12967     const char *proto, *proto_end;
12968     OP *aop, *prev, *cvop, *parent;
12969     int optional = 0;
12970     I32 arg = 0;
12971     I32 contextclass = 0;
12972     const char *e = NULL;
12973     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
12974     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
12975         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
12976                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
12977     if (SvTYPE(protosv) == SVt_PVCV)
12978          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
12979     else proto = SvPV(protosv, proto_len);
12980     proto = S_strip_spaces(aTHX_ proto, &proto_len);
12981     proto_end = proto + proto_len;
12982     parent = entersubop;
12983     aop = cUNOPx(entersubop)->op_first;
12984     if (!OpHAS_SIBLING(aop)) {
12985         parent = aop;
12986         aop = cUNOPx(aop)->op_first;
12987     }
12988     prev = aop;
12989     aop = OpSIBLING(aop);
12990     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12991     while (aop != cvop) {
12992         OP* o3 = aop;
12993
12994         if (proto >= proto_end)
12995         {
12996             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
12997             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12998                                         SVfARG(namesv)), SvUTF8(namesv));
12999             return entersubop;
13000         }
13001
13002         switch (*proto) {
13003             case ';':
13004                 optional = 1;
13005                 proto++;
13006                 continue;
13007             case '_':
13008                 /* _ must be at the end */
13009                 if (proto[1] && !strchr(";@%", proto[1]))
13010                     goto oops;
13011                 /* FALLTHROUGH */
13012             case '$':
13013                 proto++;
13014                 arg++;
13015                 scalar(aop);
13016                 break;
13017             case '%':
13018             case '@':
13019                 list(aop);
13020                 arg++;
13021                 break;
13022             case '&':
13023                 proto++;
13024                 arg++;
13025                 if (    o3->op_type != OP_UNDEF
13026                     && (o3->op_type != OP_SREFGEN
13027                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13028                                 != OP_ANONCODE
13029                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13030                                 != OP_RV2CV)))
13031                     bad_type_gv(arg, namegv, o3,
13032                             arg == 1 ? "block or sub {}" : "sub {}");
13033                 break;
13034             case '*':
13035                 /* '*' allows any scalar type, including bareword */
13036                 proto++;
13037                 arg++;
13038                 if (o3->op_type == OP_RV2GV)
13039                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13040                 else if (o3->op_type == OP_CONST)
13041                     o3->op_private &= ~OPpCONST_STRICT;
13042                 scalar(aop);
13043                 break;
13044             case '+':
13045                 proto++;
13046                 arg++;
13047                 if (o3->op_type == OP_RV2AV ||
13048                     o3->op_type == OP_PADAV ||
13049                     o3->op_type == OP_RV2HV ||
13050                     o3->op_type == OP_PADHV
13051                 ) {
13052                     goto wrapref;
13053                 }
13054                 scalar(aop);
13055                 break;
13056             case '[': case ']':
13057                 goto oops;
13058
13059             case '\\':
13060                 proto++;
13061                 arg++;
13062             again:
13063                 switch (*proto++) {
13064                     case '[':
13065                         if (contextclass++ == 0) {
13066                             e = (char *) memchr(proto, ']', proto_end - proto);
13067                             if (!e || e == proto)
13068                                 goto oops;
13069                         }
13070                         else
13071                             goto oops;
13072                         goto again;
13073
13074                     case ']':
13075                         if (contextclass) {
13076                             const char *p = proto;
13077                             const char *const end = proto;
13078                             contextclass = 0;
13079                             while (*--p != '[')
13080                                 /* \[$] accepts any scalar lvalue */
13081                                 if (*p == '$'
13082                                  && Perl_op_lvalue_flags(aTHX_
13083                                      scalar(o3),
13084                                      OP_READ, /* not entersub */
13085                                      OP_LVALUE_NO_CROAK
13086                                     )) goto wrapref;
13087                             bad_type_gv(arg, namegv, o3,
13088                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13089                         } else
13090                             goto oops;
13091                         break;
13092                     case '*':
13093                         if (o3->op_type == OP_RV2GV)
13094                             goto wrapref;
13095                         if (!contextclass)
13096                             bad_type_gv(arg, namegv, o3, "symbol");
13097                         break;
13098                     case '&':
13099                         if (o3->op_type == OP_ENTERSUB
13100                          && !(o3->op_flags & OPf_STACKED))
13101                             goto wrapref;
13102                         if (!contextclass)
13103                             bad_type_gv(arg, namegv, o3, "subroutine");
13104                         break;
13105                     case '$':
13106                         if (o3->op_type == OP_RV2SV ||
13107                                 o3->op_type == OP_PADSV ||
13108                                 o3->op_type == OP_HELEM ||
13109                                 o3->op_type == OP_AELEM)
13110                             goto wrapref;
13111                         if (!contextclass) {
13112                             /* \$ accepts any scalar lvalue */
13113                             if (Perl_op_lvalue_flags(aTHX_
13114                                     scalar(o3),
13115                                     OP_READ,  /* not entersub */
13116                                     OP_LVALUE_NO_CROAK
13117                                )) goto wrapref;
13118                             bad_type_gv(arg, namegv, o3, "scalar");
13119                         }
13120                         break;
13121                     case '@':
13122                         if (o3->op_type == OP_RV2AV ||
13123                                 o3->op_type == OP_PADAV)
13124                         {
13125                             o3->op_flags &=~ OPf_PARENS;
13126                             goto wrapref;
13127                         }
13128                         if (!contextclass)
13129                             bad_type_gv(arg, namegv, o3, "array");
13130                         break;
13131                     case '%':
13132                         if (o3->op_type == OP_RV2HV ||
13133                                 o3->op_type == OP_PADHV)
13134                         {
13135                             o3->op_flags &=~ OPf_PARENS;
13136                             goto wrapref;
13137                         }
13138                         if (!contextclass)
13139                             bad_type_gv(arg, namegv, o3, "hash");
13140                         break;
13141                     wrapref:
13142                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13143                                                 OP_REFGEN, 0);
13144                         if (contextclass && e) {
13145                             proto = e + 1;
13146                             contextclass = 0;
13147                         }
13148                         break;
13149                     default: goto oops;
13150                 }
13151                 if (contextclass)
13152                     goto again;
13153                 break;
13154             case ' ':
13155                 proto++;
13156                 continue;
13157             default:
13158             oops: {
13159                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13160                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13161                                   SVfARG(protosv));
13162             }
13163         }
13164
13165         op_lvalue(aop, OP_ENTERSUB);
13166         prev = aop;
13167         aop = OpSIBLING(aop);
13168     }
13169     if (aop == cvop && *proto == '_') {
13170         /* generate an access to $_ */
13171         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13172     }
13173     if (!optional && proto_end > proto &&
13174         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13175     {
13176         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13177         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13178                                     SVfARG(namesv)), SvUTF8(namesv));
13179     }
13180     return entersubop;
13181 }
13182
13183 /*
13184 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13185
13186 Performs the fixup of the arguments part of an C<entersub> op tree either
13187 based on a subroutine prototype or using default list-context processing.
13188 This is the standard treatment used on a subroutine call, not marked
13189 with C<&>, where the callee can be identified at compile time.
13190
13191 C<protosv> supplies the subroutine prototype to be applied to the call,
13192 or indicates that there is no prototype.  It may be a normal scalar,
13193 in which case if it is defined then the string value will be used
13194 as a prototype, and if it is undefined then there is no prototype.
13195 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13196 that has been cast to C<SV*>), of which the prototype will be used if it
13197 has one.  The prototype (or lack thereof) supplied, in whichever form,
13198 does not need to match the actual callee referenced by the op tree.
13199
13200 If the argument ops disagree with the prototype, for example by having
13201 an unacceptable number of arguments, a valid op tree is returned anyway.
13202 The error is reflected in the parser state, normally resulting in a single
13203 exception at the top level of parsing which covers all the compilation
13204 errors that occurred.  In the error message, the callee is referred to
13205 by the name defined by the C<namegv> parameter.
13206
13207 =cut
13208 */
13209
13210 OP *
13211 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13212         GV *namegv, SV *protosv)
13213 {
13214     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13215     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13216         return ck_entersub_args_proto(entersubop, namegv, protosv);
13217     else
13218         return ck_entersub_args_list(entersubop);
13219 }
13220
13221 OP *
13222 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13223 {
13224     IV cvflags = SvIVX(protosv);
13225     int opnum = cvflags & 0xffff;
13226     OP *aop = cUNOPx(entersubop)->op_first;
13227
13228     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13229
13230     if (!opnum) {
13231         OP *cvop;
13232         if (!OpHAS_SIBLING(aop))
13233             aop = cUNOPx(aop)->op_first;
13234         aop = OpSIBLING(aop);
13235         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13236         if (aop != cvop) {
13237             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13238             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13239                 SVfARG(namesv)), SvUTF8(namesv));
13240         }
13241
13242         op_free(entersubop);
13243         switch(cvflags >> 16) {
13244         case 'F': return newSVOP(OP_CONST, 0,
13245                                         newSVpv(CopFILE(PL_curcop),0));
13246         case 'L': return newSVOP(
13247                            OP_CONST, 0,
13248                            Perl_newSVpvf(aTHX_
13249                              "%" IVdf, (IV)CopLINE(PL_curcop)
13250                            )
13251                          );
13252         case 'P': return newSVOP(OP_CONST, 0,
13253                                    (PL_curstash
13254                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13255                                      : &PL_sv_undef
13256                                    )
13257                                 );
13258         }
13259         NOT_REACHED; /* NOTREACHED */
13260     }
13261     else {
13262         OP *prev, *cvop, *first, *parent;
13263         U32 flags = 0;
13264
13265         parent = entersubop;
13266         if (!OpHAS_SIBLING(aop)) {
13267             parent = aop;
13268             aop = cUNOPx(aop)->op_first;
13269         }
13270
13271         first = prev = aop;
13272         aop = OpSIBLING(aop);
13273         /* find last sibling */
13274         for (cvop = aop;
13275              OpHAS_SIBLING(cvop);
13276              prev = cvop, cvop = OpSIBLING(cvop))
13277             ;
13278         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13279             /* Usually, OPf_SPECIAL on an op with no args means that it had
13280              * parens, but these have their own meaning for that flag: */
13281             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13282             && opnum != OP_DELETE && opnum != OP_EXISTS)
13283                 flags |= OPf_SPECIAL;
13284         /* excise cvop from end of sibling chain */
13285         op_sibling_splice(parent, prev, 1, NULL);
13286         op_free(cvop);
13287         if (aop == cvop) aop = NULL;
13288
13289         /* detach remaining siblings from the first sibling, then
13290          * dispose of original optree */
13291
13292         if (aop)
13293             op_sibling_splice(parent, first, -1, NULL);
13294         op_free(entersubop);
13295
13296         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13297             flags |= OPpEVAL_BYTES <<8;
13298
13299         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13300         case OA_UNOP:
13301         case OA_BASEOP_OR_UNOP:
13302         case OA_FILESTATOP:
13303             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13304         case OA_BASEOP:
13305             if (aop) {
13306                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13307                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13308                     SVfARG(namesv)), SvUTF8(namesv));
13309                 op_free(aop);
13310             }
13311             return opnum == OP_RUNCV
13312                 ? newPVOP(OP_RUNCV,0,NULL)
13313                 : newOP(opnum,0);
13314         default:
13315             return op_convert_list(opnum,0,aop);
13316         }
13317     }
13318     NOT_REACHED; /* NOTREACHED */
13319     return entersubop;
13320 }
13321
13322 /*
13323 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13324
13325 Retrieves the function that will be used to fix up a call to C<cv>.
13326 Specifically, the function is applied to an C<entersub> op tree for a
13327 subroutine call, not marked with C<&>, where the callee can be identified
13328 at compile time as C<cv>.
13329
13330 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13331 for it is returned in C<*ckobj_p>, and control flags are returned in
13332 C<*ckflags_p>.  The function is intended to be called in this manner:
13333
13334  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13335
13336 In this call, C<entersubop> is a pointer to the C<entersub> op,
13337 which may be replaced by the check function, and C<namegv> supplies
13338 the name that should be used by the check function to refer
13339 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13340 It is permitted to apply the check function in non-standard situations,
13341 such as to a call to a different subroutine or to a method call.
13342
13343 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13344 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13345 instead, anything that can be used as the first argument to L</cv_name>.
13346 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13347 check function requires C<namegv> to be a genuine GV.
13348
13349 By default, the check function is
13350 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13351 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13352 flag is clear.  This implements standard prototype processing.  It can
13353 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13354
13355 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13356 indicates that the caller only knows about the genuine GV version of
13357 C<namegv>, and accordingly the corresponding bit will always be set in
13358 C<*ckflags_p>, regardless of the check function's recorded requirements.
13359 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13360 indicates the caller knows about the possibility of passing something
13361 other than a GV as C<namegv>, and accordingly the corresponding bit may
13362 be either set or clear in C<*ckflags_p>, indicating the check function's
13363 recorded requirements.
13364
13365 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13366 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13367 (for which see above).  All other bits should be clear.
13368
13369 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13370
13371 The original form of L</cv_get_call_checker_flags>, which does not return
13372 checker flags.  When using a checker function returned by this function,
13373 it is only safe to call it with a genuine GV as its C<namegv> argument.
13374
13375 =cut
13376 */
13377
13378 void
13379 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13380         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13381 {
13382     MAGIC *callmg;
13383     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13384     PERL_UNUSED_CONTEXT;
13385     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13386     if (callmg) {
13387         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13388         *ckobj_p = callmg->mg_obj;
13389         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13390     } else {
13391         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13392         *ckobj_p = (SV*)cv;
13393         *ckflags_p = gflags & MGf_REQUIRE_GV;
13394     }
13395 }
13396
13397 void
13398 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13399 {
13400     U32 ckflags;
13401     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13402     PERL_UNUSED_CONTEXT;
13403     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13404         &ckflags);
13405 }
13406
13407 /*
13408 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13409
13410 Sets the function that will be used to fix up a call to C<cv>.
13411 Specifically, the function is applied to an C<entersub> op tree for a
13412 subroutine call, not marked with C<&>, where the callee can be identified
13413 at compile time as C<cv>.
13414
13415 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13416 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13417 The function should be defined like this:
13418
13419     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13420
13421 It is intended to be called in this manner:
13422
13423     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13424
13425 In this call, C<entersubop> is a pointer to the C<entersub> op,
13426 which may be replaced by the check function, and C<namegv> supplies
13427 the name that should be used by the check function to refer
13428 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13429 It is permitted to apply the check function in non-standard situations,
13430 such as to a call to a different subroutine or to a method call.
13431
13432 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13433 CV or other SV instead.  Whatever is passed can be used as the first
13434 argument to L</cv_name>.  You can force perl to pass a GV by including
13435 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13436
13437 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13438 bit currently has a defined meaning (for which see above).  All other
13439 bits should be clear.
13440
13441 The current setting for a particular CV can be retrieved by
13442 L</cv_get_call_checker_flags>.
13443
13444 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13445
13446 The original form of L</cv_set_call_checker_flags>, which passes it the
13447 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13448 of that flag setting is that the check function is guaranteed to get a
13449 genuine GV as its C<namegv> argument.
13450
13451 =cut
13452 */
13453
13454 void
13455 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13456 {
13457     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13458     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13459 }
13460
13461 void
13462 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13463                                      SV *ckobj, U32 ckflags)
13464 {
13465     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13466     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13467         if (SvMAGICAL((SV*)cv))
13468             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13469     } else {
13470         MAGIC *callmg;
13471         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13472         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13473         assert(callmg);
13474         if (callmg->mg_flags & MGf_REFCOUNTED) {
13475             SvREFCNT_dec(callmg->mg_obj);
13476             callmg->mg_flags &= ~MGf_REFCOUNTED;
13477         }
13478         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13479         callmg->mg_obj = ckobj;
13480         if (ckobj != (SV*)cv) {
13481             SvREFCNT_inc_simple_void_NN(ckobj);
13482             callmg->mg_flags |= MGf_REFCOUNTED;
13483         }
13484         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13485                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13486     }
13487 }
13488
13489 static void
13490 S_entersub_alloc_targ(pTHX_ OP * const o)
13491 {
13492     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13493     o->op_private |= OPpENTERSUB_HASTARG;
13494 }
13495
13496 OP *
13497 Perl_ck_subr(pTHX_ OP *o)
13498 {
13499     OP *aop, *cvop;
13500     CV *cv;
13501     GV *namegv;
13502     SV **const_class = NULL;
13503
13504     PERL_ARGS_ASSERT_CK_SUBR;
13505
13506     aop = cUNOPx(o)->op_first;
13507     if (!OpHAS_SIBLING(aop))
13508         aop = cUNOPx(aop)->op_first;
13509     aop = OpSIBLING(aop);
13510     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13511     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13512     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13513
13514     o->op_private &= ~1;
13515     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13516     if (PERLDB_SUB && PL_curstash != PL_debstash)
13517         o->op_private |= OPpENTERSUB_DB;
13518     switch (cvop->op_type) {
13519         case OP_RV2CV:
13520             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13521             op_null(cvop);
13522             break;
13523         case OP_METHOD:
13524         case OP_METHOD_NAMED:
13525         case OP_METHOD_SUPER:
13526         case OP_METHOD_REDIR:
13527         case OP_METHOD_REDIR_SUPER:
13528             o->op_flags |= OPf_REF;
13529             if (aop->op_type == OP_CONST) {
13530                 aop->op_private &= ~OPpCONST_STRICT;
13531                 const_class = &cSVOPx(aop)->op_sv;
13532             }
13533             else if (aop->op_type == OP_LIST) {
13534                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13535                 if (sib && sib->op_type == OP_CONST) {
13536                     sib->op_private &= ~OPpCONST_STRICT;
13537                     const_class = &cSVOPx(sib)->op_sv;
13538                 }
13539             }
13540             /* make class name a shared cow string to speedup method calls */
13541             /* constant string might be replaced with object, f.e. bigint */
13542             if (const_class && SvPOK(*const_class)) {
13543                 STRLEN len;
13544                 const char* str = SvPV(*const_class, len);
13545                 if (len) {
13546                     SV* const shared = newSVpvn_share(
13547                         str, SvUTF8(*const_class)
13548                                     ? -(SSize_t)len : (SSize_t)len,
13549                         0
13550                     );
13551                     if (SvREADONLY(*const_class))
13552                         SvREADONLY_on(shared);
13553                     SvREFCNT_dec(*const_class);
13554                     *const_class = shared;
13555                 }
13556             }
13557             break;
13558     }
13559
13560     if (!cv) {
13561         S_entersub_alloc_targ(aTHX_ o);
13562         return ck_entersub_args_list(o);
13563     } else {
13564         Perl_call_checker ckfun;
13565         SV *ckobj;
13566         U32 ckflags;
13567         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13568         if (CvISXSUB(cv) || !CvROOT(cv))
13569             S_entersub_alloc_targ(aTHX_ o);
13570         if (!namegv) {
13571             /* The original call checker API guarantees that a GV will be
13572                be provided with the right name.  So, if the old API was
13573                used (or the REQUIRE_GV flag was passed), we have to reify
13574                the CV’s GV, unless this is an anonymous sub.  This is not
13575                ideal for lexical subs, as its stringification will include
13576                the package.  But it is the best we can do.  */
13577             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13578                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13579                     namegv = CvGV(cv);
13580             }
13581             else namegv = MUTABLE_GV(cv);
13582             /* After a syntax error in a lexical sub, the cv that
13583                rv2cv_op_cv returns may be a nameless stub. */
13584             if (!namegv) return ck_entersub_args_list(o);
13585
13586         }
13587         return ckfun(aTHX_ o, namegv, ckobj);
13588     }
13589 }
13590
13591 OP *
13592 Perl_ck_svconst(pTHX_ OP *o)
13593 {
13594     SV * const sv = cSVOPo->op_sv;
13595     PERL_ARGS_ASSERT_CK_SVCONST;
13596     PERL_UNUSED_CONTEXT;
13597 #ifdef PERL_COPY_ON_WRITE
13598     /* Since the read-only flag may be used to protect a string buffer, we
13599        cannot do copy-on-write with existing read-only scalars that are not
13600        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13601        that constant, mark the constant as COWable here, if it is not
13602        already read-only. */
13603     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13604         SvIsCOW_on(sv);
13605         CowREFCNT(sv) = 0;
13606 # ifdef PERL_DEBUG_READONLY_COW
13607         sv_buf_to_ro(sv);
13608 # endif
13609     }
13610 #endif
13611     SvREADONLY_on(sv);
13612     return o;
13613 }
13614
13615 OP *
13616 Perl_ck_trunc(pTHX_ OP *o)
13617 {
13618     PERL_ARGS_ASSERT_CK_TRUNC;
13619
13620     if (o->op_flags & OPf_KIDS) {
13621         SVOP *kid = (SVOP*)cUNOPo->op_first;
13622
13623         if (kid->op_type == OP_NULL)
13624             kid = (SVOP*)OpSIBLING(kid);
13625         if (kid && kid->op_type == OP_CONST &&
13626             (kid->op_private & OPpCONST_BARE) &&
13627             !kid->op_folded)
13628         {
13629             o->op_flags |= OPf_SPECIAL;
13630             kid->op_private &= ~OPpCONST_STRICT;
13631         }
13632     }
13633     return ck_fun(o);
13634 }
13635
13636 OP *
13637 Perl_ck_substr(pTHX_ OP *o)
13638 {
13639     PERL_ARGS_ASSERT_CK_SUBSTR;
13640
13641     o = ck_fun(o);
13642     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13643         OP *kid = cLISTOPo->op_first;
13644
13645         if (kid->op_type == OP_NULL)
13646             kid = OpSIBLING(kid);
13647         if (kid)
13648             /* Historically, substr(delete $foo{bar},...) has been allowed
13649                with 4-arg substr.  Keep it working by applying entersub
13650                lvalue context.  */
13651             op_lvalue(kid, OP_ENTERSUB);
13652
13653     }
13654     return o;
13655 }
13656
13657 OP *
13658 Perl_ck_tell(pTHX_ OP *o)
13659 {
13660     PERL_ARGS_ASSERT_CK_TELL;
13661     o = ck_fun(o);
13662     if (o->op_flags & OPf_KIDS) {
13663      OP *kid = cLISTOPo->op_first;
13664      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13665      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13666     }
13667     return o;
13668 }
13669
13670 OP *
13671 Perl_ck_each(pTHX_ OP *o)
13672 {
13673     dVAR;
13674     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13675     const unsigned orig_type  = o->op_type;
13676
13677     PERL_ARGS_ASSERT_CK_EACH;
13678
13679     if (kid) {
13680         switch (kid->op_type) {
13681             case OP_PADHV:
13682             case OP_RV2HV:
13683                 break;
13684             case OP_PADAV:
13685             case OP_RV2AV:
13686                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13687                             : orig_type == OP_KEYS ? OP_AKEYS
13688                             :                        OP_AVALUES);
13689                 break;
13690             case OP_CONST:
13691                 if (kid->op_private == OPpCONST_BARE
13692                  || !SvROK(cSVOPx_sv(kid))
13693                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13694                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13695                    )
13696                     goto bad;
13697                 /* FALLTHROUGH */
13698             default:
13699                 qerror(Perl_mess(aTHX_
13700                     "Experimental %s on scalar is now forbidden",
13701                      PL_op_desc[orig_type]));
13702                bad:
13703                 bad_type_pv(1, "hash or array", o, kid);
13704                 return o;
13705         }
13706     }
13707     return ck_fun(o);
13708 }
13709
13710 OP *
13711 Perl_ck_length(pTHX_ OP *o)
13712 {
13713     PERL_ARGS_ASSERT_CK_LENGTH;
13714
13715     o = ck_fun(o);
13716
13717     if (ckWARN(WARN_SYNTAX)) {
13718         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13719
13720         if (kid) {
13721             SV *name = NULL;
13722             const bool hash = kid->op_type == OP_PADHV
13723                            || kid->op_type == OP_RV2HV;
13724             switch (kid->op_type) {
13725                 case OP_PADHV:
13726                 case OP_PADAV:
13727                 case OP_RV2HV:
13728                 case OP_RV2AV:
13729                     name = S_op_varname(aTHX_ kid);
13730                     break;
13731                 default:
13732                     return o;
13733             }
13734             if (name)
13735                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13736                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13737                     ")\"?)",
13738                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13739                 );
13740             else if (hash)
13741      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13742                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13743                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13744             else
13745      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13746                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13747                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13748         }
13749     }
13750
13751     return o;
13752 }
13753
13754
13755
13756 /*
13757    ---------------------------------------------------------
13758
13759    Common vars in list assignment
13760
13761    There now follows some enums and static functions for detecting
13762    common variables in list assignments. Here is a little essay I wrote
13763    for myself when trying to get my head around this. DAPM.
13764
13765    ----
13766
13767    First some random observations:
13768
13769    * If a lexical var is an alias of something else, e.g.
13770        for my $x ($lex, $pkg, $a[0]) {...}
13771      then the act of aliasing will increase the reference count of the SV
13772
13773    * If a package var is an alias of something else, it may still have a
13774      reference count of 1, depending on how the alias was created, e.g.
13775      in *a = *b, $a may have a refcount of 1 since the GP is shared
13776      with a single GvSV pointer to the SV. So If it's an alias of another
13777      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13778      a lexical var or an array element, then it will have RC > 1.
13779
13780    * There are many ways to create a package alias; ultimately, XS code
13781      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13782      run-time tracing mechanisms are unlikely to be able to catch all cases.
13783
13784    * When the LHS is all my declarations, the same vars can't appear directly
13785      on the RHS, but they can indirectly via closures, aliasing and lvalue
13786      subs. But those techniques all involve an increase in the lexical
13787      scalar's ref count.
13788
13789    * When the LHS is all lexical vars (but not necessarily my declarations),
13790      it is possible for the same lexicals to appear directly on the RHS, and
13791      without an increased ref count, since the stack isn't refcounted.
13792      This case can be detected at compile time by scanning for common lex
13793      vars with PL_generation.
13794
13795    * lvalue subs defeat common var detection, but they do at least
13796      return vars with a temporary ref count increment. Also, you can't
13797      tell at compile time whether a sub call is lvalue.
13798
13799
13800    So...
13801
13802    A: There are a few circumstances where there definitely can't be any
13803      commonality:
13804
13805        LHS empty:  () = (...);
13806        RHS empty:  (....) = ();
13807        RHS contains only constants or other 'can't possibly be shared'
13808            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13809            i.e. they only contain ops not marked as dangerous, whose children
13810            are also not dangerous;
13811        LHS ditto;
13812        LHS contains a single scalar element: e.g. ($x) = (....); because
13813            after $x has been modified, it won't be used again on the RHS;
13814        RHS contains a single element with no aggregate on LHS: e.g.
13815            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13816            won't be used again.
13817
13818    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13819      we can ignore):
13820
13821        my ($a, $b, @c) = ...;
13822
13823        Due to closure and goto tricks, these vars may already have content.
13824        For the same reason, an element on the RHS may be a lexical or package
13825        alias of one of the vars on the left, or share common elements, for
13826        example:
13827
13828            my ($x,$y) = f(); # $x and $y on both sides
13829            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13830
13831        and
13832
13833            my $ra = f();
13834            my @a = @$ra;  # elements of @a on both sides
13835            sub f { @a = 1..4; \@a }
13836
13837
13838        First, just consider scalar vars on LHS:
13839
13840            RHS is safe only if (A), or in addition,
13841                * contains only lexical *scalar* vars, where neither side's
13842                  lexicals have been flagged as aliases
13843
13844            If RHS is not safe, then it's always legal to check LHS vars for
13845            RC==1, since the only RHS aliases will always be associated
13846            with an RC bump.
13847
13848            Note that in particular, RHS is not safe if:
13849
13850                * it contains package scalar vars; e.g.:
13851
13852                    f();
13853                    my ($x, $y) = (2, $x_alias);
13854                    sub f { $x = 1; *x_alias = \$x; }
13855
13856                * It contains other general elements, such as flattened or
13857                * spliced or single array or hash elements, e.g.
13858
13859                    f();
13860                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13861
13862                    sub f {
13863                        ($x, $y) = (1,2);
13864                        use feature 'refaliasing';
13865                        \($a[0], $a[1]) = \($y,$x);
13866                    }
13867
13868                  It doesn't matter if the array/hash is lexical or package.
13869
13870                * it contains a function call that happens to be an lvalue
13871                  sub which returns one or more of the above, e.g.
13872
13873                    f();
13874                    my ($x,$y) = f();
13875
13876                    sub f : lvalue {
13877                        ($x, $y) = (1,2);
13878                        *x1 = \$x;
13879                        $y, $x1;
13880                    }
13881
13882                    (so a sub call on the RHS should be treated the same
13883                    as having a package var on the RHS).
13884
13885                * any other "dangerous" thing, such an op or built-in that
13886                  returns one of the above, e.g. pp_preinc
13887
13888
13889            If RHS is not safe, what we can do however is at compile time flag
13890            that the LHS are all my declarations, and at run time check whether
13891            all the LHS have RC == 1, and if so skip the full scan.
13892
13893        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
13894
13895            Here the issue is whether there can be elements of @a on the RHS
13896            which will get prematurely freed when @a is cleared prior to
13897            assignment. This is only a problem if the aliasing mechanism
13898            is one which doesn't increase the refcount - only if RC == 1
13899            will the RHS element be prematurely freed.
13900
13901            Because the array/hash is being INTROed, it or its elements
13902            can't directly appear on the RHS:
13903
13904                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
13905
13906            but can indirectly, e.g.:
13907
13908                my $r = f();
13909                my (@a) = @$r;
13910                sub f { @a = 1..3; \@a }
13911
13912            So if the RHS isn't safe as defined by (A), we must always
13913            mortalise and bump the ref count of any remaining RHS elements
13914            when assigning to a non-empty LHS aggregate.
13915
13916            Lexical scalars on the RHS aren't safe if they've been involved in
13917            aliasing, e.g.
13918
13919                use feature 'refaliasing';
13920
13921                f();
13922                \(my $lex) = \$pkg;
13923                my @a = ($lex,3); # equivalent to ($a[0],3)
13924
13925                sub f {
13926                    @a = (1,2);
13927                    \$pkg = \$a[0];
13928                }
13929
13930            Similarly with lexical arrays and hashes on the RHS:
13931
13932                f();
13933                my @b;
13934                my @a = (@b);
13935
13936                sub f {
13937                    @a = (1,2);
13938                    \$b[0] = \$a[1];
13939                    \$b[1] = \$a[0];
13940                }
13941
13942
13943
13944    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
13945        my $a; ($a, my $b) = (....);
13946
13947        The difference between (B) and (C) is that it is now physically
13948        possible for the LHS vars to appear on the RHS too, where they
13949        are not reference counted; but in this case, the compile-time
13950        PL_generation sweep will detect such common vars.
13951
13952        So the rules for (C) differ from (B) in that if common vars are
13953        detected, the runtime "test RC==1" optimisation can no longer be used,
13954        and a full mark and sweep is required
13955
13956    D: As (C), but in addition the LHS may contain package vars.
13957
13958        Since package vars can be aliased without a corresponding refcount
13959        increase, all bets are off. It's only safe if (A). E.g.
13960
13961            my ($x, $y) = (1,2);
13962
13963            for $x_alias ($x) {
13964                ($x_alias, $y) = (3, $x); # whoops
13965            }
13966
13967        Ditto for LHS aggregate package vars.
13968
13969    E: Any other dangerous ops on LHS, e.g.
13970            (f(), $a[0], @$r) = (...);
13971
13972        this is similar to (E) in that all bets are off. In addition, it's
13973        impossible to determine at compile time whether the LHS
13974        contains a scalar or an aggregate, e.g.
13975
13976            sub f : lvalue { @a }
13977            (f()) = 1..3;
13978
13979 * ---------------------------------------------------------
13980 */
13981
13982
13983 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
13984  * that at least one of the things flagged was seen.
13985  */
13986
13987 enum {
13988     AAS_MY_SCALAR       = 0x001, /* my $scalar */
13989     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
13990     AAS_LEX_SCALAR      = 0x004, /* $lexical */
13991     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
13992     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
13993     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
13994     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
13995     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
13996                                          that's flagged OA_DANGEROUS */
13997     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
13998                                         not in any of the categories above */
13999     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14000 };
14001
14002
14003
14004 /* helper function for S_aassign_scan().
14005  * check a PAD-related op for commonality and/or set its generation number.
14006  * Returns a boolean indicating whether its shared */
14007
14008 static bool
14009 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14010 {
14011     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14012         /* lexical used in aliasing */
14013         return TRUE;
14014
14015     if (rhs)
14016         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14017     else
14018         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14019
14020     return FALSE;
14021 }
14022
14023
14024 /*
14025   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14026   It scans the left or right hand subtree of the aassign op, and returns a
14027   set of flags indicating what sorts of things it found there.
14028   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14029   set PL_generation on lexical vars; if the latter, we see if
14030   PL_generation matches.
14031   'top' indicates whether we're recursing or at the top level.
14032   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14033   This fn will increment it by the number seen. It's not intended to
14034   be an accurate count (especially as many ops can push a variable
14035   number of SVs onto the stack); rather it's used as to test whether there
14036   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14037 */
14038
14039 static int
14040 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14041 {
14042     int flags = 0;
14043     bool kid_top = FALSE;
14044
14045     /* first, look for a solitary @_ on the RHS */
14046     if (   rhs
14047         && top
14048         && (o->op_flags & OPf_KIDS)
14049         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14050     ) {
14051         OP *kid = cUNOPo->op_first;
14052         if (   (   kid->op_type == OP_PUSHMARK
14053                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14054             && ((kid = OpSIBLING(kid)))
14055             && !OpHAS_SIBLING(kid)
14056             && kid->op_type == OP_RV2AV
14057             && !(kid->op_flags & OPf_REF)
14058             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14059             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14060             && ((kid = cUNOPx(kid)->op_first))
14061             && kid->op_type == OP_GV
14062             && cGVOPx_gv(kid) == PL_defgv
14063         )
14064             flags |= AAS_DEFAV;
14065     }
14066
14067     switch (o->op_type) {
14068     case OP_GVSV:
14069         (*scalars_p)++;
14070         return AAS_PKG_SCALAR;
14071
14072     case OP_PADAV:
14073     case OP_PADHV:
14074         (*scalars_p) += 2;
14075         /* if !top, could be e.g. @a[0,1] */
14076         if (top && (o->op_flags & OPf_REF))
14077             return (o->op_private & OPpLVAL_INTRO)
14078                 ? AAS_MY_AGG : AAS_LEX_AGG;
14079         return AAS_DANGEROUS;
14080
14081     case OP_PADSV:
14082         {
14083             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14084                         ?  AAS_LEX_SCALAR_COMM : 0;
14085             (*scalars_p)++;
14086             return (o->op_private & OPpLVAL_INTRO)
14087                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14088         }
14089
14090     case OP_RV2AV:
14091     case OP_RV2HV:
14092         (*scalars_p) += 2;
14093         if (cUNOPx(o)->op_first->op_type != OP_GV)
14094             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14095         /* @pkg, %pkg */
14096         /* if !top, could be e.g. @a[0,1] */
14097         if (top && (o->op_flags & OPf_REF))
14098             return AAS_PKG_AGG;
14099         return AAS_DANGEROUS;
14100
14101     case OP_RV2SV:
14102         (*scalars_p)++;
14103         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14104             (*scalars_p) += 2;
14105             return AAS_DANGEROUS; /* ${expr} */
14106         }
14107         return AAS_PKG_SCALAR; /* $pkg */
14108
14109     case OP_SPLIT:
14110         if (o->op_private & OPpSPLIT_ASSIGN) {
14111             /* the assign in @a = split() has been optimised away
14112              * and the @a attached directly to the split op
14113              * Treat the array as appearing on the RHS, i.e.
14114              *    ... = (@a = split)
14115              * is treated like
14116              *    ... = @a;
14117              */
14118
14119             if (o->op_flags & OPf_STACKED)
14120                 /* @{expr} = split() - the array expression is tacked
14121                  * on as an extra child to split - process kid */
14122                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14123                                         top, scalars_p);
14124
14125             /* ... else array is directly attached to split op */
14126             (*scalars_p) += 2;
14127             if (PL_op->op_private & OPpSPLIT_LEX)
14128                 return (o->op_private & OPpLVAL_INTRO)
14129                     ? AAS_MY_AGG : AAS_LEX_AGG;
14130             else
14131                 return AAS_PKG_AGG;
14132         }
14133         (*scalars_p)++;
14134         /* other args of split can't be returned */
14135         return AAS_SAFE_SCALAR;
14136
14137     case OP_UNDEF:
14138         /* undef counts as a scalar on the RHS:
14139          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14140          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14141          */
14142         if (rhs)
14143             (*scalars_p)++;
14144         flags = AAS_SAFE_SCALAR;
14145         break;
14146
14147     case OP_PUSHMARK:
14148     case OP_STUB:
14149         /* these are all no-ops; they don't push a potentially common SV
14150          * onto the stack, so they are neither AAS_DANGEROUS nor
14151          * AAS_SAFE_SCALAR */
14152         return 0;
14153
14154     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14155         break;
14156
14157     case OP_NULL:
14158     case OP_LIST:
14159         /* these do nothing but may have children; but their children
14160          * should also be treated as top-level */
14161         kid_top = top;
14162         break;
14163
14164     default:
14165         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14166             (*scalars_p) += 2;
14167             flags = AAS_DANGEROUS;
14168             break;
14169         }
14170
14171         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14172             && (o->op_private & OPpTARGET_MY))
14173         {
14174             (*scalars_p)++;
14175             return S_aassign_padcheck(aTHX_ o, rhs)
14176                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14177         }
14178
14179         /* if its an unrecognised, non-dangerous op, assume that it
14180          * it the cause of at least one safe scalar */
14181         (*scalars_p)++;
14182         flags = AAS_SAFE_SCALAR;
14183         break;
14184     }
14185
14186     /* XXX this assumes that all other ops are "transparent" - i.e. that
14187      * they can return some of their children. While this true for e.g.
14188      * sort and grep, it's not true for e.g. map. We really need a
14189      * 'transparent' flag added to regen/opcodes
14190      */
14191     if (o->op_flags & OPf_KIDS) {
14192         OP *kid;
14193         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14194             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14195     }
14196     return flags;
14197 }
14198
14199
14200 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14201    and modify the optree to make them work inplace */
14202
14203 STATIC void
14204 S_inplace_aassign(pTHX_ OP *o) {
14205
14206     OP *modop, *modop_pushmark;
14207     OP *oright;
14208     OP *oleft, *oleft_pushmark;
14209
14210     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14211
14212     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14213
14214     assert(cUNOPo->op_first->op_type == OP_NULL);
14215     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14216     assert(modop_pushmark->op_type == OP_PUSHMARK);
14217     modop = OpSIBLING(modop_pushmark);
14218
14219     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14220         return;
14221
14222     /* no other operation except sort/reverse */
14223     if (OpHAS_SIBLING(modop))
14224         return;
14225
14226     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14227     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14228
14229     if (modop->op_flags & OPf_STACKED) {
14230         /* skip sort subroutine/block */
14231         assert(oright->op_type == OP_NULL);
14232         oright = OpSIBLING(oright);
14233     }
14234
14235     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14236     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14237     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14238     oleft = OpSIBLING(oleft_pushmark);
14239
14240     /* Check the lhs is an array */
14241     if (!oleft ||
14242         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14243         || OpHAS_SIBLING(oleft)
14244         || (oleft->op_private & OPpLVAL_INTRO)
14245     )
14246         return;
14247
14248     /* Only one thing on the rhs */
14249     if (OpHAS_SIBLING(oright))
14250         return;
14251
14252     /* check the array is the same on both sides */
14253     if (oleft->op_type == OP_RV2AV) {
14254         if (oright->op_type != OP_RV2AV
14255             || !cUNOPx(oright)->op_first
14256             || cUNOPx(oright)->op_first->op_type != OP_GV
14257             || cUNOPx(oleft )->op_first->op_type != OP_GV
14258             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14259                cGVOPx_gv(cUNOPx(oright)->op_first)
14260         )
14261             return;
14262     }
14263     else if (oright->op_type != OP_PADAV
14264         || oright->op_targ != oleft->op_targ
14265     )
14266         return;
14267
14268     /* This actually is an inplace assignment */
14269
14270     modop->op_private |= OPpSORT_INPLACE;
14271
14272     /* transfer MODishness etc from LHS arg to RHS arg */
14273     oright->op_flags = oleft->op_flags;
14274
14275     /* remove the aassign op and the lhs */
14276     op_null(o);
14277     op_null(oleft_pushmark);
14278     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14279         op_null(cUNOPx(oleft)->op_first);
14280     op_null(oleft);
14281 }
14282
14283
14284
14285 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14286  * that potentially represent a series of one or more aggregate derefs
14287  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14288  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14289  * additional ops left in too).
14290  *
14291  * The caller will have already verified that the first few ops in the
14292  * chain following 'start' indicate a multideref candidate, and will have
14293  * set 'orig_o' to the point further on in the chain where the first index
14294  * expression (if any) begins.  'orig_action' specifies what type of
14295  * beginning has already been determined by the ops between start..orig_o
14296  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14297  *
14298  * 'hints' contains any hints flags that need adding (currently just
14299  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14300  */
14301
14302 STATIC void
14303 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14304 {
14305     dVAR;
14306     int pass;
14307     UNOP_AUX_item *arg_buf = NULL;
14308     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14309     int index_skip         = -1;    /* don't output index arg on this action */
14310
14311     /* similar to regex compiling, do two passes; the first pass
14312      * determines whether the op chain is convertible and calculates the
14313      * buffer size; the second pass populates the buffer and makes any
14314      * changes necessary to ops (such as moving consts to the pad on
14315      * threaded builds).
14316      *
14317      * NB: for things like Coverity, note that both passes take the same
14318      * path through the logic tree (except for 'if (pass)' bits), since
14319      * both passes are following the same op_next chain; and in
14320      * particular, if it would return early on the second pass, it would
14321      * already have returned early on the first pass.
14322      */
14323     for (pass = 0; pass < 2; pass++) {
14324         OP *o                = orig_o;
14325         UV action            = orig_action;
14326         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14327         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14328         int action_count     = 0;     /* number of actions seen so far */
14329         int action_ix        = 0;     /* action_count % (actions per IV) */
14330         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14331         bool is_last         = FALSE; /* no more derefs to follow */
14332         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14333         UNOP_AUX_item *arg     = arg_buf;
14334         UNOP_AUX_item *action_ptr = arg_buf;
14335
14336         if (pass)
14337             action_ptr->uv = 0;
14338         arg++;
14339
14340         switch (action) {
14341         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14342         case MDEREF_HV_gvhv_helem:
14343             next_is_hash = TRUE;
14344             /* FALLTHROUGH */
14345         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14346         case MDEREF_AV_gvav_aelem:
14347             if (pass) {
14348 #ifdef USE_ITHREADS
14349                 arg->pad_offset = cPADOPx(start)->op_padix;
14350                 /* stop it being swiped when nulled */
14351                 cPADOPx(start)->op_padix = 0;
14352 #else
14353                 arg->sv = cSVOPx(start)->op_sv;
14354                 cSVOPx(start)->op_sv = NULL;
14355 #endif
14356             }
14357             arg++;
14358             break;
14359
14360         case MDEREF_HV_padhv_helem:
14361         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14362             next_is_hash = TRUE;
14363             /* FALLTHROUGH */
14364         case MDEREF_AV_padav_aelem:
14365         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14366             if (pass) {
14367                 arg->pad_offset = start->op_targ;
14368                 /* we skip setting op_targ = 0 for now, since the intact
14369                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14370                 reset_start_targ = TRUE;
14371             }
14372             arg++;
14373             break;
14374
14375         case MDEREF_HV_pop_rv2hv_helem:
14376             next_is_hash = TRUE;
14377             /* FALLTHROUGH */
14378         case MDEREF_AV_pop_rv2av_aelem:
14379             break;
14380
14381         default:
14382             NOT_REACHED; /* NOTREACHED */
14383             return;
14384         }
14385
14386         while (!is_last) {
14387             /* look for another (rv2av/hv; get index;
14388              * aelem/helem/exists/delele) sequence */
14389
14390             OP *kid;
14391             bool is_deref;
14392             bool ok;
14393             UV index_type = MDEREF_INDEX_none;
14394
14395             if (action_count) {
14396                 /* if this is not the first lookup, consume the rv2av/hv  */
14397
14398                 /* for N levels of aggregate lookup, we normally expect
14399                  * that the first N-1 [ah]elem ops will be flagged as
14400                  * /DEREF (so they autovivifiy if necessary), and the last
14401                  * lookup op not to be.
14402                  * For other things (like @{$h{k1}{k2}}) extra scope or
14403                  * leave ops can appear, so abandon the effort in that
14404                  * case */
14405                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14406                     return;
14407
14408                 /* rv2av or rv2hv sKR/1 */
14409
14410                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14411                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14412                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14413                     return;
14414
14415                 /* at this point, we wouldn't expect any of these
14416                  * possible private flags:
14417                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14418                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14419                  */
14420                 ASSUME(!(o->op_private &
14421                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14422
14423                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14424
14425                 /* make sure the type of the previous /DEREF matches the
14426                  * type of the next lookup */
14427                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14428                 top_op = o;
14429
14430                 action = next_is_hash
14431                             ? MDEREF_HV_vivify_rv2hv_helem
14432                             : MDEREF_AV_vivify_rv2av_aelem;
14433                 o = o->op_next;
14434             }
14435
14436             /* if this is the second pass, and we're at the depth where
14437              * previously we encountered a non-simple index expression,
14438              * stop processing the index at this point */
14439             if (action_count != index_skip) {
14440
14441                 /* look for one or more simple ops that return an array
14442                  * index or hash key */
14443
14444                 switch (o->op_type) {
14445                 case OP_PADSV:
14446                     /* it may be a lexical var index */
14447                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14448                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14449                     ASSUME(!(o->op_private &
14450                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14451
14452                     if (   OP_GIMME(o,0) == G_SCALAR
14453                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14454                         && o->op_private == 0)
14455                     {
14456                         if (pass)
14457                             arg->pad_offset = o->op_targ;
14458                         arg++;
14459                         index_type = MDEREF_INDEX_padsv;
14460                         o = o->op_next;
14461                     }
14462                     break;
14463
14464                 case OP_CONST:
14465                     if (next_is_hash) {
14466                         /* it's a constant hash index */
14467                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14468                             /* "use constant foo => FOO; $h{+foo}" for
14469                              * some weird FOO, can leave you with constants
14470                              * that aren't simple strings. It's not worth
14471                              * the extra hassle for those edge cases */
14472                             break;
14473
14474                         if (pass) {
14475                             UNOP *rop = NULL;
14476                             OP * helem_op = o->op_next;
14477
14478                             ASSUME(   helem_op->op_type == OP_HELEM
14479                                    || helem_op->op_type == OP_NULL);
14480                             if (helem_op->op_type == OP_HELEM) {
14481                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14482                                 if (   helem_op->op_private & OPpLVAL_INTRO
14483                                     || rop->op_type != OP_RV2HV
14484                                 )
14485                                     rop = NULL;
14486                             }
14487                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14488
14489 #ifdef USE_ITHREADS
14490                             /* Relocate sv to the pad for thread safety */
14491                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14492                             arg->pad_offset = o->op_targ;
14493                             o->op_targ = 0;
14494 #else
14495                             arg->sv = cSVOPx_sv(o);
14496 #endif
14497                         }
14498                     }
14499                     else {
14500                         /* it's a constant array index */
14501                         IV iv;
14502                         SV *ix_sv = cSVOPo->op_sv;
14503                         if (!SvIOK(ix_sv))
14504                             break;
14505                         iv = SvIV(ix_sv);
14506
14507                         if (   action_count == 0
14508                             && iv >= -128
14509                             && iv <= 127
14510                             && (   action == MDEREF_AV_padav_aelem
14511                                 || action == MDEREF_AV_gvav_aelem)
14512                         )
14513                             maybe_aelemfast = TRUE;
14514
14515                         if (pass) {
14516                             arg->iv = iv;
14517                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14518                         }
14519                     }
14520                     if (pass)
14521                         /* we've taken ownership of the SV */
14522                         cSVOPo->op_sv = NULL;
14523                     arg++;
14524                     index_type = MDEREF_INDEX_const;
14525                     o = o->op_next;
14526                     break;
14527
14528                 case OP_GV:
14529                     /* it may be a package var index */
14530
14531                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14532                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14533                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14534                         || o->op_private != 0
14535                     )
14536                         break;
14537
14538                     kid = o->op_next;
14539                     if (kid->op_type != OP_RV2SV)
14540                         break;
14541
14542                     ASSUME(!(kid->op_flags &
14543                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14544                              |OPf_SPECIAL|OPf_PARENS)));
14545                     ASSUME(!(kid->op_private &
14546                                     ~(OPpARG1_MASK
14547                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14548                                      |OPpDEREF|OPpLVAL_INTRO)));
14549                     if(   (kid->op_flags &~ OPf_PARENS)
14550                             != (OPf_WANT_SCALAR|OPf_KIDS)
14551                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14552                     )
14553                         break;
14554
14555                     if (pass) {
14556 #ifdef USE_ITHREADS
14557                         arg->pad_offset = cPADOPx(o)->op_padix;
14558                         /* stop it being swiped when nulled */
14559                         cPADOPx(o)->op_padix = 0;
14560 #else
14561                         arg->sv = cSVOPx(o)->op_sv;
14562                         cSVOPo->op_sv = NULL;
14563 #endif
14564                     }
14565                     arg++;
14566                     index_type = MDEREF_INDEX_gvsv;
14567                     o = kid->op_next;
14568                     break;
14569
14570                 } /* switch */
14571             } /* action_count != index_skip */
14572
14573             action |= index_type;
14574
14575
14576             /* at this point we have either:
14577              *   * detected what looks like a simple index expression,
14578              *     and expect the next op to be an [ah]elem, or
14579              *     an nulled  [ah]elem followed by a delete or exists;
14580              *  * found a more complex expression, so something other
14581              *    than the above follows.
14582              */
14583
14584             /* possibly an optimised away [ah]elem (where op_next is
14585              * exists or delete) */
14586             if (o->op_type == OP_NULL)
14587                 o = o->op_next;
14588
14589             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14590              * OP_EXISTS or OP_DELETE */
14591
14592             /* if something like arybase (a.k.a $[ ) is in scope,
14593              * abandon optimisation attempt */
14594             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14595                && PL_check[o->op_type] != Perl_ck_null)
14596                 return;
14597             /* similarly for customised exists and delete */
14598             if (  (o->op_type == OP_EXISTS)
14599                && PL_check[o->op_type] != Perl_ck_exists)
14600                 return;
14601             if (  (o->op_type == OP_DELETE)
14602                && PL_check[o->op_type] != Perl_ck_delete)
14603                 return;
14604
14605             if (   o->op_type != OP_AELEM
14606                 || (o->op_private &
14607                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14608                 )
14609                 maybe_aelemfast = FALSE;
14610
14611             /* look for aelem/helem/exists/delete. If it's not the last elem
14612              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14613              * flags; if it's the last, then it mustn't have
14614              * OPpDEREF_AV/HV, but may have lots of other flags, like
14615              * OPpLVAL_INTRO etc
14616              */
14617
14618             if (   index_type == MDEREF_INDEX_none
14619                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14620                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14621             )
14622                 ok = FALSE;
14623             else {
14624                 /* we have aelem/helem/exists/delete with valid simple index */
14625
14626                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14627                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14628                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14629
14630                 /* This doesn't make much sense but is legal:
14631                  *    @{ local $x[0][0] } = 1
14632                  * Since scope exit will undo the autovivification,
14633                  * don't bother in the first place. The OP_LEAVE
14634                  * assertion is in case there are other cases of both
14635                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14636                  * exit that would undo the local - in which case this
14637                  * block of code would need rethinking.
14638                  */
14639                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14640 #ifdef DEBUGGING
14641                     OP *n = o->op_next;
14642                     while (n && (  n->op_type == OP_NULL
14643                                 || n->op_type == OP_LIST))
14644                         n = n->op_next;
14645                     assert(n && n->op_type == OP_LEAVE);
14646 #endif
14647                     o->op_private &= ~OPpDEREF;
14648                     is_deref = FALSE;
14649                 }
14650
14651                 if (is_deref) {
14652                     ASSUME(!(o->op_flags &
14653                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14654                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14655
14656                     ok =    (o->op_flags &~ OPf_PARENS)
14657                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14658                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14659                 }
14660                 else if (o->op_type == OP_EXISTS) {
14661                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14662                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14663                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14664                     ok =  !(o->op_private & ~OPpARG1_MASK);
14665                 }
14666                 else if (o->op_type == OP_DELETE) {
14667                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14668                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14669                     ASSUME(!(o->op_private &
14670                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14671                     /* don't handle slices or 'local delete'; the latter
14672                      * is fairly rare, and has a complex runtime */
14673                     ok =  !(o->op_private & ~OPpARG1_MASK);
14674                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14675                         /* skip handling run-tome error */
14676                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14677                 }
14678                 else {
14679                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14680                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14681                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14682                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14683                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14684                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14685                 }
14686             }
14687
14688             if (ok) {
14689                 if (!first_elem_op)
14690                     first_elem_op = o;
14691                 top_op = o;
14692                 if (is_deref) {
14693                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14694                     o = o->op_next;
14695                 }
14696                 else {
14697                     is_last = TRUE;
14698                     action |= MDEREF_FLAG_last;
14699                 }
14700             }
14701             else {
14702                 /* at this point we have something that started
14703                  * promisingly enough (with rv2av or whatever), but failed
14704                  * to find a simple index followed by an
14705                  * aelem/helem/exists/delete. If this is the first action,
14706                  * give up; but if we've already seen at least one
14707                  * aelem/helem, then keep them and add a new action with
14708                  * MDEREF_INDEX_none, which causes it to do the vivify
14709                  * from the end of the previous lookup, and do the deref,
14710                  * but stop at that point. So $a[0][expr] will do one
14711                  * av_fetch, vivify and deref, then continue executing at
14712                  * expr */
14713                 if (!action_count)
14714                     return;
14715                 is_last = TRUE;
14716                 index_skip = action_count;
14717                 action |= MDEREF_FLAG_last;
14718                 if (index_type != MDEREF_INDEX_none)
14719                     arg--;
14720             }
14721
14722             if (pass)
14723                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14724             action_ix++;
14725             action_count++;
14726             /* if there's no space for the next action, create a new slot
14727              * for it *before* we start adding args for that action */
14728             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14729                 action_ptr = arg;
14730                 if (pass)
14731                     arg->uv = 0;
14732                 arg++;
14733                 action_ix = 0;
14734             }
14735         } /* while !is_last */
14736
14737         /* success! */
14738
14739         if (pass) {
14740             OP *mderef;
14741             OP *p, *q;
14742
14743             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14744             if (index_skip == -1) {
14745                 mderef->op_flags = o->op_flags
14746                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14747                 if (o->op_type == OP_EXISTS)
14748                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14749                 else if (o->op_type == OP_DELETE)
14750                     mderef->op_private = OPpMULTIDEREF_DELETE;
14751                 else
14752                     mderef->op_private = o->op_private
14753                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14754             }
14755             /* accumulate strictness from every level (although I don't think
14756              * they can actually vary) */
14757             mderef->op_private |= hints;
14758
14759             /* integrate the new multideref op into the optree and the
14760              * op_next chain.
14761              *
14762              * In general an op like aelem or helem has two child
14763              * sub-trees: the aggregate expression (a_expr) and the
14764              * index expression (i_expr):
14765              *
14766              *     aelem
14767              *       |
14768              *     a_expr - i_expr
14769              *
14770              * The a_expr returns an AV or HV, while the i-expr returns an
14771              * index. In general a multideref replaces most or all of a
14772              * multi-level tree, e.g.
14773              *
14774              *     exists
14775              *       |
14776              *     ex-aelem
14777              *       |
14778              *     rv2av  - i_expr1
14779              *       |
14780              *     helem
14781              *       |
14782              *     rv2hv  - i_expr2
14783              *       |
14784              *     aelem
14785              *       |
14786              *     a_expr - i_expr3
14787              *
14788              * With multideref, all the i_exprs will be simple vars or
14789              * constants, except that i_expr1 may be arbitrary in the case
14790              * of MDEREF_INDEX_none.
14791              *
14792              * The bottom-most a_expr will be either:
14793              *   1) a simple var (so padXv or gv+rv2Xv);
14794              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14795              *      so a simple var with an extra rv2Xv;
14796              *   3) or an arbitrary expression.
14797              *
14798              * 'start', the first op in the execution chain, will point to
14799              *   1),2): the padXv or gv op;
14800              *   3):    the rv2Xv which forms the last op in the a_expr
14801              *          execution chain, and the top-most op in the a_expr
14802              *          subtree.
14803              *
14804              * For all cases, the 'start' node is no longer required,
14805              * but we can't free it since one or more external nodes
14806              * may point to it. E.g. consider
14807              *     $h{foo} = $a ? $b : $c
14808              * Here, both the op_next and op_other branches of the
14809              * cond_expr point to the gv[*h] of the hash expression, so
14810              * we can't free the 'start' op.
14811              *
14812              * For expr->[...], we need to save the subtree containing the
14813              * expression; for the other cases, we just need to save the
14814              * start node.
14815              * So in all cases, we null the start op and keep it around by
14816              * making it the child of the multideref op; for the expr->
14817              * case, the expr will be a subtree of the start node.
14818              *
14819              * So in the simple 1,2 case the  optree above changes to
14820              *
14821              *     ex-exists
14822              *       |
14823              *     multideref
14824              *       |
14825              *     ex-gv (or ex-padxv)
14826              *
14827              *  with the op_next chain being
14828              *
14829              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14830              *
14831              *  In the 3 case, we have
14832              *
14833              *     ex-exists
14834              *       |
14835              *     multideref
14836              *       |
14837              *     ex-rv2xv
14838              *       |
14839              *    rest-of-a_expr
14840              *      subtree
14841              *
14842              *  and
14843              *
14844              *  -> rest-of-a_expr subtree ->
14845              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
14846              *
14847              *
14848              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14849              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14850              * multideref attached as the child, e.g.
14851              *
14852              *     exists
14853              *       |
14854              *     ex-aelem
14855              *       |
14856              *     ex-rv2av  - i_expr1
14857              *       |
14858              *     multideref
14859              *       |
14860              *     ex-whatever
14861              *
14862              */
14863
14864             /* if we free this op, don't free the pad entry */
14865             if (reset_start_targ)
14866                 start->op_targ = 0;
14867
14868
14869             /* Cut the bit we need to save out of the tree and attach to
14870              * the multideref op, then free the rest of the tree */
14871
14872             /* find parent of node to be detached (for use by splice) */
14873             p = first_elem_op;
14874             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
14875                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14876             {
14877                 /* there is an arbitrary expression preceding us, e.g.
14878                  * expr->[..]? so we need to save the 'expr' subtree */
14879                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14880                     p = cUNOPx(p)->op_first;
14881                 ASSUME(   start->op_type == OP_RV2AV
14882                        || start->op_type == OP_RV2HV);
14883             }
14884             else {
14885                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
14886                  * above for exists/delete. */
14887                 while (   (p->op_flags & OPf_KIDS)
14888                        && cUNOPx(p)->op_first != start
14889                 )
14890                     p = cUNOPx(p)->op_first;
14891             }
14892             ASSUME(cUNOPx(p)->op_first == start);
14893
14894             /* detach from main tree, and re-attach under the multideref */
14895             op_sibling_splice(mderef, NULL, 0,
14896                     op_sibling_splice(p, NULL, 1, NULL));
14897             op_null(start);
14898
14899             start->op_next = mderef;
14900
14901             mderef->op_next = index_skip == -1 ? o->op_next : o;
14902
14903             /* excise and free the original tree, and replace with
14904              * the multideref op */
14905             p = op_sibling_splice(top_op, NULL, -1, mderef);
14906             while (p) {
14907                 q = OpSIBLING(p);
14908                 op_free(p);
14909                 p = q;
14910             }
14911             op_null(top_op);
14912         }
14913         else {
14914             Size_t size = arg - arg_buf;
14915
14916             if (maybe_aelemfast && action_count == 1)
14917                 return;
14918
14919             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
14920                                 sizeof(UNOP_AUX_item) * (size + 1));
14921             /* for dumping etc: store the length in a hidden first slot;
14922              * we set the op_aux pointer to the second slot */
14923             arg_buf->uv = size;
14924             arg_buf++;
14925         }
14926     } /* for (pass = ...) */
14927 }
14928
14929 /* See if the ops following o are such that o will always be executed in
14930  * boolean context: that is, the SV which o pushes onto the stack will
14931  * only ever be consumed by later ops via SvTRUE(sv) or similar.
14932  * If so, set a suitable private flag on o. Normally this will be
14933  * bool_flag; but see below why maybe_flag is needed too.
14934  *
14935  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
14936  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
14937  * already be taken, so you'll have to give that op two different flags.
14938  *
14939  * More explanation of 'maybe_flag' and 'safe_and' parameters.
14940  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
14941  * those underlying ops) short-circuit, which means that rather than
14942  * necessarily returning a truth value, they may return the LH argument,
14943  * which may not be boolean. For example in $x = (keys %h || -1), keys
14944  * should return a key count rather than a boolean, even though its
14945  * sort-of being used in boolean context.
14946  *
14947  * So we only consider such logical ops to provide boolean context to
14948  * their LH argument if they themselves are in void or boolean context.
14949  * However, sometimes the context isn't known until run-time. In this
14950  * case the op is marked with the maybe_flag flag it.
14951  *
14952  * Consider the following.
14953  *
14954  *     sub f { ....;  if (%h) { .... } }
14955  *
14956  * This is actually compiled as
14957  *
14958  *     sub f { ....;  %h && do { .... } }
14959  *
14960  * Here we won't know until runtime whether the final statement (and hence
14961  * the &&) is in void context and so is safe to return a boolean value.
14962  * So mark o with maybe_flag rather than the bool_flag.
14963  * Note that there is cost associated with determining context at runtime
14964  * (e.g. a call to block_gimme()), so it may not be worth setting (at
14965  * compile time) and testing (at runtime) maybe_flag if the scalar verses
14966  * boolean costs savings are marginal.
14967  *
14968  * However, we can do slightly better with && (compared to || and //):
14969  * this op only returns its LH argument when that argument is false. In
14970  * this case, as long as the op promises to return a false value which is
14971  * valid in both boolean and scalar contexts, we can mark an op consumed
14972  * by && with bool_flag rather than maybe_flag.
14973  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
14974  * than &PL_sv_no for a false result in boolean context, then it's safe. An
14975  * op which promises to handle this case is indicated by setting safe_and
14976  * to true.
14977  */
14978
14979 static void
14980 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
14981 {
14982     OP *lop;
14983     U8 flag = 0;
14984
14985     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
14986
14987     /* OPpTARGET_MY and boolean context probably don't mix well.
14988      * If someone finds a valid use case, maybe add an extra flag to this
14989      * function which indicates its safe to do so for this op? */
14990     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
14991              && (o->op_private & OPpTARGET_MY)));
14992
14993     lop = o->op_next;
14994
14995     while (lop) {
14996         switch (lop->op_type) {
14997         case OP_NULL:
14998         case OP_SCALAR:
14999             break;
15000
15001         /* these two consume the stack argument in the scalar case,
15002          * and treat it as a boolean in the non linenumber case */
15003         case OP_FLIP:
15004         case OP_FLOP:
15005             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15006                 || (lop->op_private & OPpFLIP_LINENUM))
15007             {
15008                 lop = NULL;
15009                 break;
15010             }
15011             /* FALLTHROUGH */
15012         /* these never leave the original value on the stack */
15013         case OP_NOT:
15014         case OP_XOR:
15015         case OP_COND_EXPR:
15016         case OP_GREPWHILE:
15017             flag = bool_flag;
15018             lop = NULL;
15019             break;
15020
15021         /* OR DOR and AND evaluate their arg as a boolean, but then may
15022          * leave the original scalar value on the stack when following the
15023          * op_next route. If not in void context, we need to ensure
15024          * that whatever follows consumes the arg only in boolean context
15025          * too.
15026          */
15027         case OP_AND:
15028             if (safe_and) {
15029                 flag = bool_flag;
15030                 lop = NULL;
15031                 break;
15032             }
15033             /* FALLTHROUGH */
15034         case OP_OR:
15035         case OP_DOR:
15036             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15037                 flag = bool_flag;
15038                 lop = NULL;
15039             }
15040             else if (!(lop->op_flags & OPf_WANT)) {
15041                 /* unknown context - decide at runtime */
15042                 flag = maybe_flag;
15043                 lop = NULL;
15044             }
15045             break;
15046
15047         default:
15048             lop = NULL;
15049             break;
15050         }
15051
15052         if (lop)
15053             lop = lop->op_next;
15054     }
15055
15056     o->op_private |= flag;
15057 }
15058
15059
15060
15061 /* mechanism for deferring recursion in rpeep() */
15062
15063 #define MAX_DEFERRED 4
15064
15065 #define DEFER(o) \
15066   STMT_START { \
15067     if (defer_ix == (MAX_DEFERRED-1)) { \
15068         OP **defer = defer_queue[defer_base]; \
15069         CALL_RPEEP(*defer); \
15070         S_prune_chain_head(defer); \
15071         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15072         defer_ix--; \
15073     } \
15074     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15075   } STMT_END
15076
15077 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15078 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15079
15080
15081 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15082  * See the comments at the top of this file for more details about when
15083  * peep() is called */
15084
15085 void
15086 Perl_rpeep(pTHX_ OP *o)
15087 {
15088     dVAR;
15089     OP* oldop = NULL;
15090     OP* oldoldop = NULL;
15091     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15092     int defer_base = 0;
15093     int defer_ix = -1;
15094
15095     if (!o || o->op_opt)
15096         return;
15097
15098     assert(o->op_type != OP_FREED);
15099
15100     ENTER;
15101     SAVEOP();
15102     SAVEVPTR(PL_curcop);
15103     for (;; o = o->op_next) {
15104         if (o && o->op_opt)
15105             o = NULL;
15106         if (!o) {
15107             while (defer_ix >= 0) {
15108                 OP **defer =
15109                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15110                 CALL_RPEEP(*defer);
15111                 S_prune_chain_head(defer);
15112             }
15113             break;
15114         }
15115
15116       redo:
15117
15118         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15119         assert(!oldoldop || oldoldop->op_next == oldop);
15120         assert(!oldop    || oldop->op_next    == o);
15121
15122         /* By default, this op has now been optimised. A couple of cases below
15123            clear this again.  */
15124         o->op_opt = 1;
15125         PL_op = o;
15126
15127         /* look for a series of 1 or more aggregate derefs, e.g.
15128          *   $a[1]{foo}[$i]{$k}
15129          * and replace with a single OP_MULTIDEREF op.
15130          * Each index must be either a const, or a simple variable,
15131          *
15132          * First, look for likely combinations of starting ops,
15133          * corresponding to (global and lexical variants of)
15134          *     $a[...]   $h{...}
15135          *     $r->[...] $r->{...}
15136          *     (preceding expression)->[...]
15137          *     (preceding expression)->{...}
15138          * and if so, call maybe_multideref() to do a full inspection
15139          * of the op chain and if appropriate, replace with an
15140          * OP_MULTIDEREF
15141          */
15142         {
15143             UV action;
15144             OP *o2 = o;
15145             U8 hints = 0;
15146
15147             switch (o2->op_type) {
15148             case OP_GV:
15149                 /* $pkg[..]   :   gv[*pkg]
15150                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15151
15152                 /* Fail if there are new op flag combinations that we're
15153                  * not aware of, rather than:
15154                  *  * silently failing to optimise, or
15155                  *  * silently optimising the flag away.
15156                  * If this ASSUME starts failing, examine what new flag
15157                  * has been added to the op, and decide whether the
15158                  * optimisation should still occur with that flag, then
15159                  * update the code accordingly. This applies to all the
15160                  * other ASSUMEs in the block of code too.
15161                  */
15162                 ASSUME(!(o2->op_flags &
15163                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15164                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15165
15166                 o2 = o2->op_next;
15167
15168                 if (o2->op_type == OP_RV2AV) {
15169                     action = MDEREF_AV_gvav_aelem;
15170                     goto do_deref;
15171                 }
15172
15173                 if (o2->op_type == OP_RV2HV) {
15174                     action = MDEREF_HV_gvhv_helem;
15175                     goto do_deref;
15176                 }
15177
15178                 if (o2->op_type != OP_RV2SV)
15179                     break;
15180
15181                 /* at this point we've seen gv,rv2sv, so the only valid
15182                  * construct left is $pkg->[] or $pkg->{} */
15183
15184                 ASSUME(!(o2->op_flags & OPf_STACKED));
15185                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15186                             != (OPf_WANT_SCALAR|OPf_MOD))
15187                     break;
15188
15189                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15190                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15191                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15192                     break;
15193                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15194                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15195                     break;
15196
15197                 o2 = o2->op_next;
15198                 if (o2->op_type == OP_RV2AV) {
15199                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15200                     goto do_deref;
15201                 }
15202                 if (o2->op_type == OP_RV2HV) {
15203                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15204                     goto do_deref;
15205                 }
15206                 break;
15207
15208             case OP_PADSV:
15209                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15210
15211                 ASSUME(!(o2->op_flags &
15212                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15213                 if ((o2->op_flags &
15214                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15215                      != (OPf_WANT_SCALAR|OPf_MOD))
15216                     break;
15217
15218                 ASSUME(!(o2->op_private &
15219                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15220                 /* skip if state or intro, or not a deref */
15221                 if (      o2->op_private != OPpDEREF_AV
15222                        && o2->op_private != OPpDEREF_HV)
15223                     break;
15224
15225                 o2 = o2->op_next;
15226                 if (o2->op_type == OP_RV2AV) {
15227                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15228                     goto do_deref;
15229                 }
15230                 if (o2->op_type == OP_RV2HV) {
15231                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15232                     goto do_deref;
15233                 }
15234                 break;
15235
15236             case OP_PADAV:
15237             case OP_PADHV:
15238                 /*    $lex[..]:  padav[@lex:1,2] sR *
15239                  * or $lex{..}:  padhv[%lex:1,2] sR */
15240                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15241                                             OPf_REF|OPf_SPECIAL)));
15242                 if ((o2->op_flags &
15243                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15244                      != (OPf_WANT_SCALAR|OPf_REF))
15245                     break;
15246                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15247                     break;
15248                 /* OPf_PARENS isn't currently used in this case;
15249                  * if that changes, let us know! */
15250                 ASSUME(!(o2->op_flags & OPf_PARENS));
15251
15252                 /* at this point, we wouldn't expect any of the remaining
15253                  * possible private flags:
15254                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15255                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15256                  *
15257                  * OPpSLICEWARNING shouldn't affect runtime
15258                  */
15259                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15260
15261                 action = o2->op_type == OP_PADAV
15262                             ? MDEREF_AV_padav_aelem
15263                             : MDEREF_HV_padhv_helem;
15264                 o2 = o2->op_next;
15265                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15266                 break;
15267
15268
15269             case OP_RV2AV:
15270             case OP_RV2HV:
15271                 action = o2->op_type == OP_RV2AV
15272                             ? MDEREF_AV_pop_rv2av_aelem
15273                             : MDEREF_HV_pop_rv2hv_helem;
15274                 /* FALLTHROUGH */
15275             do_deref:
15276                 /* (expr)->[...]:  rv2av sKR/1;
15277                  * (expr)->{...}:  rv2hv sKR/1; */
15278
15279                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15280
15281                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15282                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15283                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15284                     break;
15285
15286                 /* at this point, we wouldn't expect any of these
15287                  * possible private flags:
15288                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15289                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15290                  */
15291                 ASSUME(!(o2->op_private &
15292                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15293                      |OPpOUR_INTRO)));
15294                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15295
15296                 o2 = o2->op_next;
15297
15298                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15299                 break;
15300
15301             default:
15302                 break;
15303             }
15304         }
15305
15306
15307         switch (o->op_type) {
15308         case OP_DBSTATE:
15309             PL_curcop = ((COP*)o);              /* for warnings */
15310             break;
15311         case OP_NEXTSTATE:
15312             PL_curcop = ((COP*)o);              /* for warnings */
15313
15314             /* Optimise a "return ..." at the end of a sub to just be "...".
15315              * This saves 2 ops. Before:
15316              * 1  <;> nextstate(main 1 -e:1) v ->2
15317              * 4  <@> return K ->5
15318              * 2    <0> pushmark s ->3
15319              * -    <1> ex-rv2sv sK/1 ->4
15320              * 3      <#> gvsv[*cat] s ->4
15321              *
15322              * After:
15323              * -  <@> return K ->-
15324              * -    <0> pushmark s ->2
15325              * -    <1> ex-rv2sv sK/1 ->-
15326              * 2      <$> gvsv(*cat) s ->3
15327              */
15328             {
15329                 OP *next = o->op_next;
15330                 OP *sibling = OpSIBLING(o);
15331                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15332                     && OP_TYPE_IS(sibling, OP_RETURN)
15333                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15334                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15335                        ||OP_TYPE_IS(sibling->op_next->op_next,
15336                                     OP_LEAVESUBLV))
15337                     && cUNOPx(sibling)->op_first == next
15338                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15339                     && next->op_next
15340                 ) {
15341                     /* Look through the PUSHMARK's siblings for one that
15342                      * points to the RETURN */
15343                     OP *top = OpSIBLING(next);
15344                     while (top && top->op_next) {
15345                         if (top->op_next == sibling) {
15346                             top->op_next = sibling->op_next;
15347                             o->op_next = next->op_next;
15348                             break;
15349                         }
15350                         top = OpSIBLING(top);
15351                     }
15352                 }
15353             }
15354
15355             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15356              *
15357              * This latter form is then suitable for conversion into padrange
15358              * later on. Convert:
15359              *
15360              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15361              *
15362              * into:
15363              *
15364              *   nextstate1 ->     listop     -> nextstate3
15365              *                 /            \
15366              *         pushmark -> padop1 -> padop2
15367              */
15368             if (o->op_next && (
15369                     o->op_next->op_type == OP_PADSV
15370                  || o->op_next->op_type == OP_PADAV
15371                  || o->op_next->op_type == OP_PADHV
15372                 )
15373                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15374                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15375                 && o->op_next->op_next->op_next && (
15376                     o->op_next->op_next->op_next->op_type == OP_PADSV
15377                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15378                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15379                 )
15380                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15381                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15382                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15383                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15384             ) {
15385                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15386
15387                 pad1 =    o->op_next;
15388                 ns2  = pad1->op_next;
15389                 pad2 =  ns2->op_next;
15390                 ns3  = pad2->op_next;
15391
15392                 /* we assume here that the op_next chain is the same as
15393                  * the op_sibling chain */
15394                 assert(OpSIBLING(o)    == pad1);
15395                 assert(OpSIBLING(pad1) == ns2);
15396                 assert(OpSIBLING(ns2)  == pad2);
15397                 assert(OpSIBLING(pad2) == ns3);
15398
15399                 /* excise and delete ns2 */
15400                 op_sibling_splice(NULL, pad1, 1, NULL);
15401                 op_free(ns2);
15402
15403                 /* excise pad1 and pad2 */
15404                 op_sibling_splice(NULL, o, 2, NULL);
15405
15406                 /* create new listop, with children consisting of:
15407                  * a new pushmark, pad1, pad2. */
15408                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15409                 newop->op_flags |= OPf_PARENS;
15410                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15411
15412                 /* insert newop between o and ns3 */
15413                 op_sibling_splice(NULL, o, 0, newop);
15414
15415                 /*fixup op_next chain */
15416                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15417                 o    ->op_next = newpm;
15418                 newpm->op_next = pad1;
15419                 pad1 ->op_next = pad2;
15420                 pad2 ->op_next = newop; /* listop */
15421                 newop->op_next = ns3;
15422
15423                 /* Ensure pushmark has this flag if padops do */
15424                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15425                     newpm->op_flags |= OPf_MOD;
15426                 }
15427
15428                 break;
15429             }
15430
15431             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15432                to carry two labels. For now, take the easier option, and skip
15433                this optimisation if the first NEXTSTATE has a label.  */
15434             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15435                 OP *nextop = o->op_next;
15436                 while (nextop && nextop->op_type == OP_NULL)
15437                     nextop = nextop->op_next;
15438
15439                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15440                     op_null(o);
15441                     if (oldop)
15442                         oldop->op_next = nextop;
15443                     o = nextop;
15444                     /* Skip (old)oldop assignment since the current oldop's
15445                        op_next already points to the next op.  */
15446                     goto redo;
15447                 }
15448             }
15449             break;
15450
15451         case OP_CONCAT:
15452             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15453                 if (o->op_next->op_private & OPpTARGET_MY) {
15454                     if (o->op_flags & OPf_STACKED) /* chained concats */
15455                         break; /* ignore_optimization */
15456                     else {
15457                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15458                         o->op_targ = o->op_next->op_targ;
15459                         o->op_next->op_targ = 0;
15460                         o->op_private |= OPpTARGET_MY;
15461                     }
15462                 }
15463                 op_null(o->op_next);
15464             }
15465             break;
15466         case OP_STUB:
15467             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15468                 break; /* Scalar stub must produce undef.  List stub is noop */
15469             }
15470             goto nothin;
15471         case OP_NULL:
15472             if (o->op_targ == OP_NEXTSTATE
15473                 || o->op_targ == OP_DBSTATE)
15474             {
15475                 PL_curcop = ((COP*)o);
15476             }
15477             /* XXX: We avoid setting op_seq here to prevent later calls
15478                to rpeep() from mistakenly concluding that optimisation
15479                has already occurred. This doesn't fix the real problem,
15480                though (See 20010220.007 (#5874)). AMS 20010719 */
15481             /* op_seq functionality is now replaced by op_opt */
15482             o->op_opt = 0;
15483             /* FALLTHROUGH */
15484         case OP_SCALAR:
15485         case OP_LINESEQ:
15486         case OP_SCOPE:
15487         nothin:
15488             if (oldop) {
15489                 oldop->op_next = o->op_next;
15490                 o->op_opt = 0;
15491                 continue;
15492             }
15493             break;
15494
15495         case OP_PUSHMARK:
15496
15497             /* Given
15498                  5 repeat/DOLIST
15499                  3   ex-list
15500                  1     pushmark
15501                  2     scalar or const
15502                  4   const[0]
15503                convert repeat into a stub with no kids.
15504              */
15505             if (o->op_next->op_type == OP_CONST
15506              || (  o->op_next->op_type == OP_PADSV
15507                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15508              || (  o->op_next->op_type == OP_GV
15509                 && o->op_next->op_next->op_type == OP_RV2SV
15510                 && !(o->op_next->op_next->op_private
15511                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15512             {
15513                 const OP *kid = o->op_next->op_next;
15514                 if (o->op_next->op_type == OP_GV)
15515                    kid = kid->op_next;
15516                 /* kid is now the ex-list.  */
15517                 if (kid->op_type == OP_NULL
15518                  && (kid = kid->op_next)->op_type == OP_CONST
15519                     /* kid is now the repeat count.  */
15520                  && kid->op_next->op_type == OP_REPEAT
15521                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15522                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15523                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15524                  && oldop)
15525                 {
15526                     o = kid->op_next; /* repeat */
15527                     oldop->op_next = o;
15528                     op_free(cBINOPo->op_first);
15529                     op_free(cBINOPo->op_last );
15530                     o->op_flags &=~ OPf_KIDS;
15531                     /* stub is a baseop; repeat is a binop */
15532                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15533                     OpTYPE_set(o, OP_STUB);
15534                     o->op_private = 0;
15535                     break;
15536                 }
15537             }
15538
15539             /* Convert a series of PAD ops for my vars plus support into a
15540              * single padrange op. Basically
15541              *
15542              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15543              *
15544              * becomes, depending on circumstances, one of
15545              *
15546              *    padrange  ----------------------------------> (list) -> rest
15547              *    padrange  --------------------------------------------> rest
15548              *
15549              * where all the pad indexes are sequential and of the same type
15550              * (INTRO or not).
15551              * We convert the pushmark into a padrange op, then skip
15552              * any other pad ops, and possibly some trailing ops.
15553              * Note that we don't null() the skipped ops, to make it
15554              * easier for Deparse to undo this optimisation (and none of
15555              * the skipped ops are holding any resourses). It also makes
15556              * it easier for find_uninit_var(), as it can just ignore
15557              * padrange, and examine the original pad ops.
15558              */
15559         {
15560             OP *p;
15561             OP *followop = NULL; /* the op that will follow the padrange op */
15562             U8 count = 0;
15563             U8 intro = 0;
15564             PADOFFSET base = 0; /* init only to stop compiler whining */
15565             bool gvoid = 0;     /* init only to stop compiler whining */
15566             bool defav = 0;  /* seen (...) = @_ */
15567             bool reuse = 0;  /* reuse an existing padrange op */
15568
15569             /* look for a pushmark -> gv[_] -> rv2av */
15570
15571             {
15572                 OP *rv2av, *q;
15573                 p = o->op_next;
15574                 if (   p->op_type == OP_GV
15575                     && cGVOPx_gv(p) == PL_defgv
15576                     && (rv2av = p->op_next)
15577                     && rv2av->op_type == OP_RV2AV
15578                     && !(rv2av->op_flags & OPf_REF)
15579                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15580                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15581                 ) {
15582                     q = rv2av->op_next;
15583                     if (q->op_type == OP_NULL)
15584                         q = q->op_next;
15585                     if (q->op_type == OP_PUSHMARK) {
15586                         defav = 1;
15587                         p = q;
15588                     }
15589                 }
15590             }
15591             if (!defav) {
15592                 p = o;
15593             }
15594
15595             /* scan for PAD ops */
15596
15597             for (p = p->op_next; p; p = p->op_next) {
15598                 if (p->op_type == OP_NULL)
15599                     continue;
15600
15601                 if ((     p->op_type != OP_PADSV
15602                        && p->op_type != OP_PADAV
15603                        && p->op_type != OP_PADHV
15604                     )
15605                       /* any private flag other than INTRO? e.g. STATE */
15606                    || (p->op_private & ~OPpLVAL_INTRO)
15607                 )
15608                     break;
15609
15610                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15611                  * instead */
15612                 if (   p->op_type == OP_PADAV
15613                     && p->op_next
15614                     && p->op_next->op_type == OP_CONST
15615                     && p->op_next->op_next
15616                     && p->op_next->op_next->op_type == OP_AELEM
15617                 )
15618                     break;
15619
15620                 /* for 1st padop, note what type it is and the range
15621                  * start; for the others, check that it's the same type
15622                  * and that the targs are contiguous */
15623                 if (count == 0) {
15624                     intro = (p->op_private & OPpLVAL_INTRO);
15625                     base = p->op_targ;
15626                     gvoid = OP_GIMME(p,0) == G_VOID;
15627                 }
15628                 else {
15629                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15630                         break;
15631                     /* Note that you'd normally  expect targs to be
15632                      * contiguous in my($a,$b,$c), but that's not the case
15633                      * when external modules start doing things, e.g.
15634                      * Function::Parameters */
15635                     if (p->op_targ != base + count)
15636                         break;
15637                     assert(p->op_targ == base + count);
15638                     /* Either all the padops or none of the padops should
15639                        be in void context.  Since we only do the optimisa-
15640                        tion for av/hv when the aggregate itself is pushed
15641                        on to the stack (one item), there is no need to dis-
15642                        tinguish list from scalar context.  */
15643                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15644                         break;
15645                 }
15646
15647                 /* for AV, HV, only when we're not flattening */
15648                 if (   p->op_type != OP_PADSV
15649                     && !gvoid
15650                     && !(p->op_flags & OPf_REF)
15651                 )
15652                     break;
15653
15654                 if (count >= OPpPADRANGE_COUNTMASK)
15655                     break;
15656
15657                 /* there's a biggest base we can fit into a
15658                  * SAVEt_CLEARPADRANGE in pp_padrange.
15659                  * (The sizeof() stuff will be constant-folded, and is
15660                  * intended to avoid getting "comparison is always false"
15661                  * compiler warnings. See the comments above
15662                  * MEM_WRAP_CHECK for more explanation on why we do this
15663                  * in a weird way to avoid compiler warnings.)
15664                  */
15665                 if (   intro
15666                     && (8*sizeof(base) >
15667                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15668                         ? (Size_t)base
15669                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15670                         ) >
15671                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15672                 )
15673                     break;
15674
15675                 /* Success! We've got another valid pad op to optimise away */
15676                 count++;
15677                 followop = p->op_next;
15678             }
15679
15680             if (count < 1 || (count == 1 && !defav))
15681                 break;
15682
15683             /* pp_padrange in specifically compile-time void context
15684              * skips pushing a mark and lexicals; in all other contexts
15685              * (including unknown till runtime) it pushes a mark and the
15686              * lexicals. We must be very careful then, that the ops we
15687              * optimise away would have exactly the same effect as the
15688              * padrange.
15689              * In particular in void context, we can only optimise to
15690              * a padrange if we see the complete sequence
15691              *     pushmark, pad*v, ...., list
15692              * which has the net effect of leaving the markstack as it
15693              * was.  Not pushing onto the stack (whereas padsv does touch
15694              * the stack) makes no difference in void context.
15695              */
15696             assert(followop);
15697             if (gvoid) {
15698                 if (followop->op_type == OP_LIST
15699                         && OP_GIMME(followop,0) == G_VOID
15700                    )
15701                 {
15702                     followop = followop->op_next; /* skip OP_LIST */
15703
15704                     /* consolidate two successive my(...);'s */
15705
15706                     if (   oldoldop
15707                         && oldoldop->op_type == OP_PADRANGE
15708                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15709                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15710                         && !(oldoldop->op_flags & OPf_SPECIAL)
15711                     ) {
15712                         U8 old_count;
15713                         assert(oldoldop->op_next == oldop);
15714                         assert(   oldop->op_type == OP_NEXTSTATE
15715                                || oldop->op_type == OP_DBSTATE);
15716                         assert(oldop->op_next == o);
15717
15718                         old_count
15719                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15720
15721                        /* Do not assume pad offsets for $c and $d are con-
15722                           tiguous in
15723                             my ($a,$b,$c);
15724                             my ($d,$e,$f);
15725                         */
15726                         if (  oldoldop->op_targ + old_count == base
15727                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15728                             base = oldoldop->op_targ;
15729                             count += old_count;
15730                             reuse = 1;
15731                         }
15732                     }
15733
15734                     /* if there's any immediately following singleton
15735                      * my var's; then swallow them and the associated
15736                      * nextstates; i.e.
15737                      *    my ($a,$b); my $c; my $d;
15738                      * is treated as
15739                      *    my ($a,$b,$c,$d);
15740                      */
15741
15742                     while (    ((p = followop->op_next))
15743                             && (  p->op_type == OP_PADSV
15744                                || p->op_type == OP_PADAV
15745                                || p->op_type == OP_PADHV)
15746                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15747                             && (p->op_private & OPpLVAL_INTRO) == intro
15748                             && !(p->op_private & ~OPpLVAL_INTRO)
15749                             && p->op_next
15750                             && (   p->op_next->op_type == OP_NEXTSTATE
15751                                 || p->op_next->op_type == OP_DBSTATE)
15752                             && count < OPpPADRANGE_COUNTMASK
15753                             && base + count == p->op_targ
15754                     ) {
15755                         count++;
15756                         followop = p->op_next;
15757                     }
15758                 }
15759                 else
15760                     break;
15761             }
15762
15763             if (reuse) {
15764                 assert(oldoldop->op_type == OP_PADRANGE);
15765                 oldoldop->op_next = followop;
15766                 oldoldop->op_private = (intro | count);
15767                 o = oldoldop;
15768                 oldop = NULL;
15769                 oldoldop = NULL;
15770             }
15771             else {
15772                 /* Convert the pushmark into a padrange.
15773                  * To make Deparse easier, we guarantee that a padrange was
15774                  * *always* formerly a pushmark */
15775                 assert(o->op_type == OP_PUSHMARK);
15776                 o->op_next = followop;
15777                 OpTYPE_set(o, OP_PADRANGE);
15778                 o->op_targ = base;
15779                 /* bit 7: INTRO; bit 6..0: count */
15780                 o->op_private = (intro | count);
15781                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15782                               | gvoid * OPf_WANT_VOID
15783                               | (defav ? OPf_SPECIAL : 0));
15784             }
15785             break;
15786         }
15787
15788         case OP_RV2AV:
15789             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15790                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15791             break;
15792
15793         case OP_RV2HV:
15794         case OP_PADHV:
15795             /*'keys %h' in void or scalar context: skip the OP_KEYS
15796              * and perform the functionality directly in the RV2HV/PADHV
15797              * op
15798              */
15799             if (o->op_flags & OPf_REF) {
15800                 OP *k = o->op_next;
15801                 U8 want = (k->op_flags & OPf_WANT);
15802                 if (   k
15803                     && k->op_type == OP_KEYS
15804                     && (   want == OPf_WANT_VOID
15805                         || want == OPf_WANT_SCALAR)
15806                     && !(k->op_private & OPpMAYBE_LVSUB)
15807                     && !(k->op_flags & OPf_MOD)
15808                 ) {
15809                     o->op_next     = k->op_next;
15810                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15811                     o->op_flags   |= want;
15812                     o->op_private |= (o->op_type == OP_PADHV ?
15813                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15814                     /* for keys(%lex), hold onto the OP_KEYS's targ
15815                      * since padhv doesn't have its own targ to return
15816                      * an int with */
15817                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15818                         op_null(k);
15819                 }
15820             }
15821
15822             /* see if %h is used in boolean context */
15823             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15824                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15825
15826
15827             if (o->op_type != OP_PADHV)
15828                 break;
15829             /* FALLTHROUGH */
15830         case OP_PADAV:
15831             if (   o->op_type == OP_PADAV
15832                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15833             )
15834                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15835             /* FALLTHROUGH */
15836         case OP_PADSV:
15837             /* Skip over state($x) in void context.  */
15838             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15839              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15840             {
15841                 oldop->op_next = o->op_next;
15842                 goto redo_nextstate;
15843             }
15844             if (o->op_type != OP_PADAV)
15845                 break;
15846             /* FALLTHROUGH */
15847         case OP_GV:
15848             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15849                 OP* const pop = (o->op_type == OP_PADAV) ?
15850                             o->op_next : o->op_next->op_next;
15851                 IV i;
15852                 if (pop && pop->op_type == OP_CONST &&
15853                     ((PL_op = pop->op_next)) &&
15854                     pop->op_next->op_type == OP_AELEM &&
15855                     !(pop->op_next->op_private &
15856                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15857                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15858                 {
15859                     GV *gv;
15860                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15861                         no_bareword_allowed(pop);
15862                     if (o->op_type == OP_GV)
15863                         op_null(o->op_next);
15864                     op_null(pop->op_next);
15865                     op_null(pop);
15866                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15867                     o->op_next = pop->op_next->op_next;
15868                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15869                     o->op_private = (U8)i;
15870                     if (o->op_type == OP_GV) {
15871                         gv = cGVOPo_gv;
15872                         GvAVn(gv);
15873                         o->op_type = OP_AELEMFAST;
15874                     }
15875                     else
15876                         o->op_type = OP_AELEMFAST_LEX;
15877                 }
15878                 if (o->op_type != OP_GV)
15879                     break;
15880             }
15881
15882             /* Remove $foo from the op_next chain in void context.  */
15883             if (oldop
15884              && (  o->op_next->op_type == OP_RV2SV
15885                 || o->op_next->op_type == OP_RV2AV
15886                 || o->op_next->op_type == OP_RV2HV  )
15887              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15888              && !(o->op_next->op_private & OPpLVAL_INTRO))
15889             {
15890                 oldop->op_next = o->op_next->op_next;
15891                 /* Reprocess the previous op if it is a nextstate, to
15892                    allow double-nextstate optimisation.  */
15893               redo_nextstate:
15894                 if (oldop->op_type == OP_NEXTSTATE) {
15895                     oldop->op_opt = 0;
15896                     o = oldop;
15897                     oldop = oldoldop;
15898                     oldoldop = NULL;
15899                     goto redo;
15900                 }
15901                 o = oldop->op_next;
15902                 goto redo;
15903             }
15904             else if (o->op_next->op_type == OP_RV2SV) {
15905                 if (!(o->op_next->op_private & OPpDEREF)) {
15906                     op_null(o->op_next);
15907                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
15908                                                                | OPpOUR_INTRO);
15909                     o->op_next = o->op_next->op_next;
15910                     OpTYPE_set(o, OP_GVSV);
15911                 }
15912             }
15913             else if (o->op_next->op_type == OP_READLINE
15914                     && o->op_next->op_next->op_type == OP_CONCAT
15915                     && (o->op_next->op_next->op_flags & OPf_STACKED))
15916             {
15917                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
15918                 OpTYPE_set(o, OP_RCATLINE);
15919                 o->op_flags |= OPf_STACKED;
15920                 op_null(o->op_next->op_next);
15921                 op_null(o->op_next);
15922             }
15923
15924             break;
15925
15926         case OP_NOT:
15927             break;
15928
15929         case OP_AND:
15930         case OP_OR:
15931         case OP_DOR:
15932             while (cLOGOP->op_other->op_type == OP_NULL)
15933                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15934             while (o->op_next && (   o->op_type == o->op_next->op_type
15935                                   || o->op_next->op_type == OP_NULL))
15936                 o->op_next = o->op_next->op_next;
15937
15938             /* If we're an OR and our next is an AND in void context, we'll
15939                follow its op_other on short circuit, same for reverse.
15940                We can't do this with OP_DOR since if it's true, its return
15941                value is the underlying value which must be evaluated
15942                by the next op. */
15943             if (o->op_next &&
15944                 (
15945                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
15946                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
15947                 )
15948                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15949             ) {
15950                 o->op_next = ((LOGOP*)o->op_next)->op_other;
15951             }
15952             DEFER(cLOGOP->op_other);
15953             o->op_opt = 1;
15954             break;
15955
15956         case OP_GREPWHILE:
15957             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15958                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15959             /* FALLTHROUGH */
15960         case OP_COND_EXPR:
15961         case OP_MAPWHILE:
15962         case OP_ANDASSIGN:
15963         case OP_ORASSIGN:
15964         case OP_DORASSIGN:
15965         case OP_RANGE:
15966         case OP_ONCE:
15967         case OP_ARGDEFELEM:
15968             while (cLOGOP->op_other->op_type == OP_NULL)
15969                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15970             DEFER(cLOGOP->op_other);
15971             break;
15972
15973         case OP_ENTERLOOP:
15974         case OP_ENTERITER:
15975             while (cLOOP->op_redoop->op_type == OP_NULL)
15976                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
15977             while (cLOOP->op_nextop->op_type == OP_NULL)
15978                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
15979             while (cLOOP->op_lastop->op_type == OP_NULL)
15980                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
15981             /* a while(1) loop doesn't have an op_next that escapes the
15982              * loop, so we have to explicitly follow the op_lastop to
15983              * process the rest of the code */
15984             DEFER(cLOOP->op_lastop);
15985             break;
15986
15987         case OP_ENTERTRY:
15988             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
15989             DEFER(cLOGOPo->op_other);
15990             break;
15991
15992         case OP_SUBST:
15993             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15994                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15995             assert(!(cPMOP->op_pmflags & PMf_ONCE));
15996             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
15997                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
15998                 cPMOP->op_pmstashstartu.op_pmreplstart
15999                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16000             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16001             break;
16002
16003         case OP_SORT: {
16004             OP *oright;
16005
16006             if (o->op_flags & OPf_SPECIAL) {
16007                 /* first arg is a code block */
16008                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16009                 OP * kid          = cUNOPx(nullop)->op_first;
16010
16011                 assert(nullop->op_type == OP_NULL);
16012                 assert(kid->op_type == OP_SCOPE
16013                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16014                 /* since OP_SORT doesn't have a handy op_other-style
16015                  * field that can point directly to the start of the code
16016                  * block, store it in the otherwise-unused op_next field
16017                  * of the top-level OP_NULL. This will be quicker at
16018                  * run-time, and it will also allow us to remove leading
16019                  * OP_NULLs by just messing with op_nexts without
16020                  * altering the basic op_first/op_sibling layout. */
16021                 kid = kLISTOP->op_first;
16022                 assert(
16023                       (kid->op_type == OP_NULL
16024                       && (  kid->op_targ == OP_NEXTSTATE
16025                          || kid->op_targ == OP_DBSTATE  ))
16026                     || kid->op_type == OP_STUB
16027                     || kid->op_type == OP_ENTER
16028                     || (PL_parser && PL_parser->error_count));
16029                 nullop->op_next = kid->op_next;
16030                 DEFER(nullop->op_next);
16031             }
16032
16033             /* check that RHS of sort is a single plain array */
16034             oright = cUNOPo->op_first;
16035             if (!oright || oright->op_type != OP_PUSHMARK)
16036                 break;
16037
16038             if (o->op_private & OPpSORT_INPLACE)
16039                 break;
16040
16041             /* reverse sort ... can be optimised.  */
16042             if (!OpHAS_SIBLING(cUNOPo)) {
16043                 /* Nothing follows us on the list. */
16044                 OP * const reverse = o->op_next;
16045
16046                 if (reverse->op_type == OP_REVERSE &&
16047                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16048                     OP * const pushmark = cUNOPx(reverse)->op_first;
16049                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16050                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16051                         /* reverse -> pushmark -> sort */
16052                         o->op_private |= OPpSORT_REVERSE;
16053                         op_null(reverse);
16054                         pushmark->op_next = oright->op_next;
16055                         op_null(oright);
16056                     }
16057                 }
16058             }
16059
16060             break;
16061         }
16062
16063         case OP_REVERSE: {
16064             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16065             OP *gvop = NULL;
16066             LISTOP *enter, *exlist;
16067
16068             if (o->op_private & OPpSORT_INPLACE)
16069                 break;
16070
16071             enter = (LISTOP *) o->op_next;
16072             if (!enter)
16073                 break;
16074             if (enter->op_type == OP_NULL) {
16075                 enter = (LISTOP *) enter->op_next;
16076                 if (!enter)
16077                     break;
16078             }
16079             /* for $a (...) will have OP_GV then OP_RV2GV here.
16080                for (...) just has an OP_GV.  */
16081             if (enter->op_type == OP_GV) {
16082                 gvop = (OP *) enter;
16083                 enter = (LISTOP *) enter->op_next;
16084                 if (!enter)
16085                     break;
16086                 if (enter->op_type == OP_RV2GV) {
16087                   enter = (LISTOP *) enter->op_next;
16088                   if (!enter)
16089                     break;
16090                 }
16091             }
16092
16093             if (enter->op_type != OP_ENTERITER)
16094                 break;
16095
16096             iter = enter->op_next;
16097             if (!iter || iter->op_type != OP_ITER)
16098                 break;
16099
16100             expushmark = enter->op_first;
16101             if (!expushmark || expushmark->op_type != OP_NULL
16102                 || expushmark->op_targ != OP_PUSHMARK)
16103                 break;
16104
16105             exlist = (LISTOP *) OpSIBLING(expushmark);
16106             if (!exlist || exlist->op_type != OP_NULL
16107                 || exlist->op_targ != OP_LIST)
16108                 break;
16109
16110             if (exlist->op_last != o) {
16111                 /* Mmm. Was expecting to point back to this op.  */
16112                 break;
16113             }
16114             theirmark = exlist->op_first;
16115             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16116                 break;
16117
16118             if (OpSIBLING(theirmark) != o) {
16119                 /* There's something between the mark and the reverse, eg
16120                    for (1, reverse (...))
16121                    so no go.  */
16122                 break;
16123             }
16124
16125             ourmark = ((LISTOP *)o)->op_first;
16126             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16127                 break;
16128
16129             ourlast = ((LISTOP *)o)->op_last;
16130             if (!ourlast || ourlast->op_next != o)
16131                 break;
16132
16133             rv2av = OpSIBLING(ourmark);
16134             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16135                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16136                 /* We're just reversing a single array.  */
16137                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16138                 enter->op_flags |= OPf_STACKED;
16139             }
16140
16141             /* We don't have control over who points to theirmark, so sacrifice
16142                ours.  */
16143             theirmark->op_next = ourmark->op_next;
16144             theirmark->op_flags = ourmark->op_flags;
16145             ourlast->op_next = gvop ? gvop : (OP *) enter;
16146             op_null(ourmark);
16147             op_null(o);
16148             enter->op_private |= OPpITER_REVERSED;
16149             iter->op_private |= OPpITER_REVERSED;
16150
16151             oldoldop = NULL;
16152             oldop    = ourlast;
16153             o        = oldop->op_next;
16154             goto redo;
16155             NOT_REACHED; /* NOTREACHED */
16156             break;
16157         }
16158
16159         case OP_QR:
16160         case OP_MATCH:
16161             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16162                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16163             }
16164             break;
16165
16166         case OP_RUNCV:
16167             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16168              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16169             {
16170                 SV *sv;
16171                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16172                 else {
16173                     sv = newRV((SV *)PL_compcv);
16174                     sv_rvweaken(sv);
16175                     SvREADONLY_on(sv);
16176                 }
16177                 OpTYPE_set(o, OP_CONST);
16178                 o->op_flags |= OPf_SPECIAL;
16179                 cSVOPo->op_sv = sv;
16180             }
16181             break;
16182
16183         case OP_SASSIGN:
16184             if (OP_GIMME(o,0) == G_VOID
16185              || (  o->op_next->op_type == OP_LINESEQ
16186                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16187                    || (  o->op_next->op_next->op_type == OP_RETURN
16188                       && !CvLVALUE(PL_compcv)))))
16189             {
16190                 OP *right = cBINOP->op_first;
16191                 if (right) {
16192                     /*   sassign
16193                     *      RIGHT
16194                     *      substr
16195                     *         pushmark
16196                     *         arg1
16197                     *         arg2
16198                     *         ...
16199                     * becomes
16200                     *
16201                     *  ex-sassign
16202                     *     substr
16203                     *        pushmark
16204                     *        RIGHT
16205                     *        arg1
16206                     *        arg2
16207                     *        ...
16208                     */
16209                     OP *left = OpSIBLING(right);
16210                     if (left->op_type == OP_SUBSTR
16211                          && (left->op_private & 7) < 4) {
16212                         op_null(o);
16213                         /* cut out right */
16214                         op_sibling_splice(o, NULL, 1, NULL);
16215                         /* and insert it as second child of OP_SUBSTR */
16216                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16217                                     right);
16218                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16219                         left->op_flags =
16220                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16221                     }
16222                 }
16223             }
16224             break;
16225
16226         case OP_AASSIGN: {
16227             int l, r, lr, lscalars, rscalars;
16228
16229             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16230                Note that we do this now rather than in newASSIGNOP(),
16231                since only by now are aliased lexicals flagged as such
16232
16233                See the essay "Common vars in list assignment" above for
16234                the full details of the rationale behind all the conditions
16235                below.
16236
16237                PL_generation sorcery:
16238                To detect whether there are common vars, the global var
16239                PL_generation is incremented for each assign op we scan.
16240                Then we run through all the lexical variables on the LHS,
16241                of the assignment, setting a spare slot in each of them to
16242                PL_generation.  Then we scan the RHS, and if any lexicals
16243                already have that value, we know we've got commonality.
16244                Also, if the generation number is already set to
16245                PERL_INT_MAX, then the variable is involved in aliasing, so
16246                we also have potential commonality in that case.
16247              */
16248
16249             PL_generation++;
16250             /* scan LHS */
16251             lscalars = 0;
16252             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16253             /* scan RHS */
16254             rscalars = 0;
16255             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16256             lr = (l|r);
16257
16258
16259             /* After looking for things which are *always* safe, this main
16260              * if/else chain selects primarily based on the type of the
16261              * LHS, gradually working its way down from the more dangerous
16262              * to the more restrictive and thus safer cases */
16263
16264             if (   !l                      /* () = ....; */
16265                 || !r                      /* .... = (); */
16266                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16267                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16268                 || (lscalars < 2)          /* ($x, undef) = ... */
16269             ) {
16270                 NOOP; /* always safe */
16271             }
16272             else if (l & AAS_DANGEROUS) {
16273                 /* always dangerous */
16274                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16275                 o->op_private |= OPpASSIGN_COMMON_AGG;
16276             }
16277             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16278                 /* package vars are always dangerous - too many
16279                  * aliasing possibilities */
16280                 if (l & AAS_PKG_SCALAR)
16281                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16282                 if (l & AAS_PKG_AGG)
16283                     o->op_private |= OPpASSIGN_COMMON_AGG;
16284             }
16285             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16286                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16287             {
16288                 /* LHS contains only lexicals and safe ops */
16289
16290                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16291                     o->op_private |= OPpASSIGN_COMMON_AGG;
16292
16293                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16294                     if (lr & AAS_LEX_SCALAR_COMM)
16295                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16296                     else if (   !(l & AAS_LEX_SCALAR)
16297                              && (r & AAS_DEFAV))
16298                     {
16299                         /* falsely mark
16300                          *    my (...) = @_
16301                          * as scalar-safe for performance reasons.
16302                          * (it will still have been marked _AGG if necessary */
16303                         NOOP;
16304                     }
16305                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16306                         /* if there are only lexicals on the LHS and no
16307                          * common ones on the RHS, then we assume that the
16308                          * only way those lexicals could also get
16309                          * on the RHS is via some sort of dereffing or
16310                          * closure, e.g.
16311                          *    $r = \$lex;
16312                          *    ($lex, $x) = (1, $$r)
16313                          * and in this case we assume the var must have
16314                          *  a bumped ref count. So if its ref count is 1,
16315                          *  it must only be on the LHS.
16316                          */
16317                         o->op_private |= OPpASSIGN_COMMON_RC1;
16318                 }
16319             }
16320
16321             /* ... = ($x)
16322              * may have to handle aggregate on LHS, but we can't
16323              * have common scalars. */
16324             if (rscalars < 2)
16325                 o->op_private &=
16326                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16327
16328             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16329                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16330             break;
16331         }
16332
16333         case OP_REF:
16334             /* see if ref() is used in boolean context */
16335             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16336                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16337             break;
16338
16339         case OP_LENGTH:
16340             /* see if the op is used in known boolean context,
16341              * but not if OA_TARGLEX optimisation is enabled */
16342             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16343                 && !(o->op_private & OPpTARGET_MY)
16344             )
16345                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16346             break;
16347
16348         case OP_POS:
16349             /* see if the op is used in known boolean context */
16350             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16351                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16352             break;
16353
16354         case OP_CUSTOM: {
16355             Perl_cpeep_t cpeep =
16356                 XopENTRYCUSTOM(o, xop_peep);
16357             if (cpeep)
16358                 cpeep(aTHX_ o, oldop);
16359             break;
16360         }
16361
16362         }
16363         /* did we just null the current op? If so, re-process it to handle
16364          * eliding "empty" ops from the chain */
16365         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16366             o->op_opt = 0;
16367             o = oldop;
16368         }
16369         else {
16370             oldoldop = oldop;
16371             oldop = o;
16372         }
16373     }
16374     LEAVE;
16375 }
16376
16377 void
16378 Perl_peep(pTHX_ OP *o)
16379 {
16380     CALL_RPEEP(o);
16381 }
16382
16383 /*
16384 =head1 Custom Operators
16385
16386 =for apidoc Ao||custom_op_xop
16387 Return the XOP structure for a given custom op.  This macro should be
16388 considered internal to C<OP_NAME> and the other access macros: use them instead.
16389 This macro does call a function.  Prior
16390 to 5.19.6, this was implemented as a
16391 function.
16392
16393 =cut
16394 */
16395
16396 XOPRETANY
16397 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16398 {
16399     SV *keysv;
16400     HE *he = NULL;
16401     XOP *xop;
16402
16403     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16404
16405     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16406     assert(o->op_type == OP_CUSTOM);
16407
16408     /* This is wrong. It assumes a function pointer can be cast to IV,
16409      * which isn't guaranteed, but this is what the old custom OP code
16410      * did. In principle it should be safer to Copy the bytes of the
16411      * pointer into a PV: since the new interface is hidden behind
16412      * functions, this can be changed later if necessary.  */
16413     /* Change custom_op_xop if this ever happens */
16414     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16415
16416     if (PL_custom_ops)
16417         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16418
16419     /* assume noone will have just registered a desc */
16420     if (!he && PL_custom_op_names &&
16421         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16422     ) {
16423         const char *pv;
16424         STRLEN l;
16425
16426         /* XXX does all this need to be shared mem? */
16427         Newxz(xop, 1, XOP);
16428         pv = SvPV(HeVAL(he), l);
16429         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16430         if (PL_custom_op_descs &&
16431             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16432         ) {
16433             pv = SvPV(HeVAL(he), l);
16434             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16435         }
16436         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16437     }
16438     else {
16439         if (!he)
16440             xop = (XOP *)&xop_null;
16441         else
16442             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16443     }
16444     {
16445         XOPRETANY any;
16446         if(field == XOPe_xop_ptr) {
16447             any.xop_ptr = xop;
16448         } else {
16449             const U32 flags = XopFLAGS(xop);
16450             if(flags & field) {
16451                 switch(field) {
16452                 case XOPe_xop_name:
16453                     any.xop_name = xop->xop_name;
16454                     break;
16455                 case XOPe_xop_desc:
16456                     any.xop_desc = xop->xop_desc;
16457                     break;
16458                 case XOPe_xop_class:
16459                     any.xop_class = xop->xop_class;
16460                     break;
16461                 case XOPe_xop_peep:
16462                     any.xop_peep = xop->xop_peep;
16463                     break;
16464                 default:
16465                     NOT_REACHED; /* NOTREACHED */
16466                     break;
16467                 }
16468             } else {
16469                 switch(field) {
16470                 case XOPe_xop_name:
16471                     any.xop_name = XOPd_xop_name;
16472                     break;
16473                 case XOPe_xop_desc:
16474                     any.xop_desc = XOPd_xop_desc;
16475                     break;
16476                 case XOPe_xop_class:
16477                     any.xop_class = XOPd_xop_class;
16478                     break;
16479                 case XOPe_xop_peep:
16480                     any.xop_peep = XOPd_xop_peep;
16481                     break;
16482                 default:
16483                     NOT_REACHED; /* NOTREACHED */
16484                     break;
16485                 }
16486             }
16487         }
16488         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16489          * op.c: In function 'Perl_custom_op_get_field':
16490          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16491          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16492          * expands to assert(0), which expands to ((0) ? (void)0 :
16493          * __assert(...)), and gcc doesn't know that __assert can never return. */
16494         return any;
16495     }
16496 }
16497
16498 /*
16499 =for apidoc Ao||custom_op_register
16500 Register a custom op.  See L<perlguts/"Custom Operators">.
16501
16502 =cut
16503 */
16504
16505 void
16506 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16507 {
16508     SV *keysv;
16509
16510     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16511
16512     /* see the comment in custom_op_xop */
16513     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16514
16515     if (!PL_custom_ops)
16516         PL_custom_ops = newHV();
16517
16518     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16519         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16520 }
16521
16522 /*
16523
16524 =for apidoc core_prototype
16525
16526 This function assigns the prototype of the named core function to C<sv>, or
16527 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16528 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16529 by C<keyword()>.  It must not be equal to 0.
16530
16531 =cut
16532 */
16533
16534 SV *
16535 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16536                           int * const opnum)
16537 {
16538     int i = 0, n = 0, seen_question = 0, defgv = 0;
16539     I32 oa;
16540 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16541     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16542     bool nullret = FALSE;
16543
16544     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16545
16546     assert (code);
16547
16548     if (!sv) sv = sv_newmortal();
16549
16550 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16551
16552     switch (code < 0 ? -code : code) {
16553     case KEY_and   : case KEY_chop: case KEY_chomp:
16554     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16555     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16556     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16557     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16558     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16559     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16560     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16561     case KEY_x     : case KEY_xor    :
16562         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16563     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16564     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16565     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16566     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16567     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16568     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16569         retsetpvs("", 0);
16570     case KEY_evalbytes:
16571         name = "entereval"; break;
16572     case KEY_readpipe:
16573         name = "backtick";
16574     }
16575
16576 #undef retsetpvs
16577
16578   findopnum:
16579     while (i < MAXO) {  /* The slow way. */
16580         if (strEQ(name, PL_op_name[i])
16581             || strEQ(name, PL_op_desc[i]))
16582         {
16583             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16584             goto found;
16585         }
16586         i++;
16587     }
16588     return NULL;
16589   found:
16590     defgv = PL_opargs[i] & OA_DEFGV;
16591     oa = PL_opargs[i] >> OASHIFT;
16592     while (oa) {
16593         if (oa & OA_OPTIONAL && !seen_question && (
16594               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16595         )) {
16596             seen_question = 1;
16597             str[n++] = ';';
16598         }
16599         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16600             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16601             /* But globs are already references (kinda) */
16602             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16603         ) {
16604             str[n++] = '\\';
16605         }
16606         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16607          && !scalar_mod_type(NULL, i)) {
16608             str[n++] = '[';
16609             str[n++] = '$';
16610             str[n++] = '@';
16611             str[n++] = '%';
16612             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16613             str[n++] = '*';
16614             str[n++] = ']';
16615         }
16616         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16617         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16618             str[n-1] = '_'; defgv = 0;
16619         }
16620         oa = oa >> 4;
16621     }
16622     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16623     str[n++] = '\0';
16624     sv_setpvn(sv, str, n - 1);
16625     if (opnum) *opnum = i;
16626     return sv;
16627 }
16628
16629 OP *
16630 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16631                       const int opnum)
16632 {
16633     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16634     OP *o;
16635
16636     PERL_ARGS_ASSERT_CORESUB_OP;
16637
16638     switch(opnum) {
16639     case 0:
16640         return op_append_elem(OP_LINESEQ,
16641                        argop,
16642                        newSLICEOP(0,
16643                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16644                                   newOP(OP_CALLER,0)
16645                        )
16646                );
16647     case OP_EACH:
16648     case OP_KEYS:
16649     case OP_VALUES:
16650         o = newUNOP(OP_AVHVSWITCH,0,argop);
16651         o->op_private = opnum-OP_EACH;
16652         return o;
16653     case OP_SELECT: /* which represents OP_SSELECT as well */
16654         if (code)
16655             return newCONDOP(
16656                          0,
16657                          newBINOP(OP_GT, 0,
16658                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16659                                   newSVOP(OP_CONST, 0, newSVuv(1))
16660                                  ),
16661                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16662                                     OP_SSELECT),
16663                          coresub_op(coreargssv, 0, OP_SELECT)
16664                    );
16665         /* FALLTHROUGH */
16666     default:
16667         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16668         case OA_BASEOP:
16669             return op_append_elem(
16670                         OP_LINESEQ, argop,
16671                         newOP(opnum,
16672                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16673                                 ? OPpOFFBYONE << 8 : 0)
16674                    );
16675         case OA_BASEOP_OR_UNOP:
16676             if (opnum == OP_ENTEREVAL) {
16677                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16678                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16679             }
16680             else o = newUNOP(opnum,0,argop);
16681             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16682             else {
16683           onearg:
16684               if (is_handle_constructor(o, 1))
16685                 argop->op_private |= OPpCOREARGS_DEREF1;
16686               if (scalar_mod_type(NULL, opnum))
16687                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16688             }
16689             return o;
16690         default:
16691             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16692             if (is_handle_constructor(o, 2))
16693                 argop->op_private |= OPpCOREARGS_DEREF2;
16694             if (opnum == OP_SUBSTR) {
16695                 o->op_private |= OPpMAYBE_LVSUB;
16696                 return o;
16697             }
16698             else goto onearg;
16699         }
16700     }
16701 }
16702
16703 void
16704 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16705                                SV * const *new_const_svp)
16706 {
16707     const char *hvname;
16708     bool is_const = !!CvCONST(old_cv);
16709     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16710
16711     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16712
16713     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16714         return;
16715         /* They are 2 constant subroutines generated from
16716            the same constant. This probably means that
16717            they are really the "same" proxy subroutine
16718            instantiated in 2 places. Most likely this is
16719            when a constant is exported twice.  Don't warn.
16720         */
16721     if (
16722         (ckWARN(WARN_REDEFINE)
16723          && !(
16724                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16725              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16726              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16727                  strEQ(hvname, "autouse"))
16728              )
16729         )
16730      || (is_const
16731          && ckWARN_d(WARN_REDEFINE)
16732          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16733         )
16734     )
16735         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16736                           is_const
16737                             ? "Constant subroutine %" SVf " redefined"
16738                             : "Subroutine %" SVf " redefined",
16739                           SVfARG(name));
16740 }
16741
16742 /*
16743 =head1 Hook manipulation
16744
16745 These functions provide convenient and thread-safe means of manipulating
16746 hook variables.
16747
16748 =cut
16749 */
16750
16751 /*
16752 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16753
16754 Puts a C function into the chain of check functions for a specified op
16755 type.  This is the preferred way to manipulate the L</PL_check> array.
16756 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16757 is a pointer to the C function that is to be added to that opcode's
16758 check chain, and C<old_checker_p> points to the storage location where a
16759 pointer to the next function in the chain will be stored.  The value of
16760 C<new_checker> is written into the L</PL_check> array, while the value
16761 previously stored there is written to C<*old_checker_p>.
16762
16763 L</PL_check> is global to an entire process, and a module wishing to
16764 hook op checking may find itself invoked more than once per process,
16765 typically in different threads.  To handle that situation, this function
16766 is idempotent.  The location C<*old_checker_p> must initially (once
16767 per process) contain a null pointer.  A C variable of static duration
16768 (declared at file scope, typically also marked C<static> to give
16769 it internal linkage) will be implicitly initialised appropriately,
16770 if it does not have an explicit initialiser.  This function will only
16771 actually modify the check chain if it finds C<*old_checker_p> to be null.
16772 This function is also thread safe on the small scale.  It uses appropriate
16773 locking to avoid race conditions in accessing L</PL_check>.
16774
16775 When this function is called, the function referenced by C<new_checker>
16776 must be ready to be called, except for C<*old_checker_p> being unfilled.
16777 In a threading situation, C<new_checker> may be called immediately,
16778 even before this function has returned.  C<*old_checker_p> will always
16779 be appropriately set before C<new_checker> is called.  If C<new_checker>
16780 decides not to do anything special with an op that it is given (which
16781 is the usual case for most uses of op check hooking), it must chain the
16782 check function referenced by C<*old_checker_p>.
16783
16784 Taken all together, XS code to hook an op checker should typically look
16785 something like this:
16786
16787     static Perl_check_t nxck_frob;
16788     static OP *myck_frob(pTHX_ OP *op) {
16789         ...
16790         op = nxck_frob(aTHX_ op);
16791         ...
16792         return op;
16793     }
16794     BOOT:
16795         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16796
16797 If you want to influence compilation of calls to a specific subroutine,
16798 then use L</cv_set_call_checker_flags> rather than hooking checking of
16799 all C<entersub> ops.
16800
16801 =cut
16802 */
16803
16804 void
16805 Perl_wrap_op_checker(pTHX_ Optype opcode,
16806     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16807 {
16808     dVAR;
16809
16810     PERL_UNUSED_CONTEXT;
16811     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16812     if (*old_checker_p) return;
16813     OP_CHECK_MUTEX_LOCK;
16814     if (!*old_checker_p) {
16815         *old_checker_p = PL_check[opcode];
16816         PL_check[opcode] = new_checker;
16817     }
16818     OP_CHECK_MUTEX_UNLOCK;
16819 }
16820
16821 #include "XSUB.h"
16822
16823 /* Efficient sub that returns a constant scalar value. */
16824 static void
16825 const_sv_xsub(pTHX_ CV* cv)
16826 {
16827     dXSARGS;
16828     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16829     PERL_UNUSED_ARG(items);
16830     if (!sv) {
16831         XSRETURN(0);
16832     }
16833     EXTEND(sp, 1);
16834     ST(0) = sv;
16835     XSRETURN(1);
16836 }
16837
16838 static void
16839 const_av_xsub(pTHX_ CV* cv)
16840 {
16841     dXSARGS;
16842     AV * const av = MUTABLE_AV(XSANY.any_ptr);
16843     SP -= items;
16844     assert(av);
16845 #ifndef DEBUGGING
16846     if (!av) {
16847         XSRETURN(0);
16848     }
16849 #endif
16850     if (SvRMAGICAL(av))
16851         Perl_croak(aTHX_ "Magical list constants are not supported");
16852     if (GIMME_V != G_ARRAY) {
16853         EXTEND(SP, 1);
16854         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16855         XSRETURN(1);
16856     }
16857     EXTEND(SP, AvFILLp(av)+1);
16858     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16859     XSRETURN(AvFILLp(av)+1);
16860 }
16861
16862
16863 /*
16864  * ex: set ts=8 sts=4 sw=4 et:
16865  */