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 void
 423 Perl_Slab_Free(pTHX_ void *op)
 424 {
 425     OP * const o = (OP *)op;
 426     OPSLAB *slab;
 427
 428     PERL_ARGS_ASSERT_SLAB_FREE;
 429
 430     if (!o->op_slabbed) {
 431         if (!o->op_static)
 432             PerlMemShared_free(op);
 433         return;
 434     }
 435
 436     slab = OpSLAB(o);
 437     /* If this op is already freed, our refcount will get screwy. */
 438     assert(o->op_type != OP_FREED);
 439     o->op_type = OP_FREED;
 440     o->op_next = slab->opslab_freed;
 441     slab->opslab_freed = o;
 442     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 443     OpslabREFCNT_dec_padok(slab);
 444 }
 445
 446 void
 447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 448 {
 449     const bool havepad = !!PL_comppad;
 450     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 451     if (havepad) {
 452         ENTER;
 453         PAD_SAVE_SETNULLPAD();
 454     }
 455     opslab_free(slab);
 456     if (havepad) LEAVE;
 457 }
 458
 459 void
 460 Perl_opslab_free(pTHX_ OPSLAB *slab)
 461 {
 462     OPSLAB *slab2;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE;
 464     PERL_UNUSED_CONTEXT;
 465     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 466     assert(slab->opslab_refcnt == 1);
 467     do {
 468         slab2 = slab->opslab_next;
 469 #ifdef DEBUGGING
 470         slab->opslab_refcnt = ~(size_t)0;
 471 #endif
 472 #ifdef PERL_DEBUG_READONLY_OPS
 473         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 474                                                (void*)slab));
 475         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 476             perror("munmap failed");
 477             abort();
 478         }
 479 #else
 480         PerlMemShared_free(slab);
 481 #endif
 482         slab = slab2;
 483     } while (slab);
 484 }
 485
 486 void
 487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 488 {
 489     OPSLAB *slab2;
 490     OPSLOT *slot;
 491 #ifdef DEBUGGING
 492     size_t savestack_count = 0;
 493 #endif
 494     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 495     slab2 = slab;
 496     do {
 497         for (slot = slab2->opslab_first;
 498              slot->opslot_next;
 499              slot = slot->opslot_next) {
 500             if (slot->opslot_op.op_type != OP_FREED
 501              && !(slot->opslot_op.op_savefree
 502 #ifdef DEBUGGING
 503                   && ++savestack_count
 504 #endif
 505                  )
 506             ) {
 507                 assert(slot->opslot_op.op_slabbed);
 508                 op_free(&slot->opslot_op);
 509                 if (slab->opslab_refcnt == 1) goto free;
 510             }
 511         }
 512     } while ((slab2 = slab2->opslab_next));
 513     /* > 1 because the CV still holds a reference count. */
 514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 515 #ifdef DEBUGGING
 516         assert(savestack_count == slab->opslab_refcnt-1);
 517 #endif
 518         /* Remove the CV’s reference count. */
 519         slab->opslab_refcnt--;
 520         return;
 521     }
 522    free:
 523     opslab_free(slab);
 524 }
 525
 526 #ifdef PERL_DEBUG_READONLY_OPS
 527 OP *
 528 Perl_op_refcnt_inc(pTHX_ OP *o)
 529 {
 530     if(o) {
 531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 532         if (slab && slab->opslab_readonly) {
 533             Slab_to_rw(slab);
 534             ++o->op_targ;
 535             Slab_to_ro(slab);
 536         } else {
 537             ++o->op_targ;
 538         }
 539     }
 540     return o;
 541
 542 }
 543
 544 PADOFFSET
 545 Perl_op_refcnt_dec(pTHX_ OP *o)
 546 {
 547     PADOFFSET result;
 548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 549
 550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 551
 552     if (slab && slab->opslab_readonly) {
 553         Slab_to_rw(slab);
 554         result = --o->op_targ;
 555         Slab_to_ro(slab);
 556     } else {
 557         result = --o->op_targ;
 558     }
 559     return result;
 560 }
 561 #endif
 562 /*
 563  * In the following definition, the ", (OP*)0" is just to make the compiler
 564  * think the expression is of the right type: croak actually does a Siglongjmp.
 565  */
 566 #define CHECKOP(type,o) \
 567     ((PL_op_mask && PL_op_mask[type])                           \
 568      ? ( op_free((OP*)o),                                       \
 569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 570          (OP*)0 )                                               \
 571      : PL_check[type](aTHX_ (OP*)o))
 572
 573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 574
 575 #define OpTYPE_set(o,type) \
 576     STMT_START {                                \
 577         o->op_type = (OPCODE)type;              \
 578         o->op_ppaddr = PL_ppaddr[type];         \
 579     } STMT_END
 580
 581 STATIC OP *
 582 S_no_fh_allowed(pTHX_ OP *o)
 583 {
 584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 585
 586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 587                  OP_DESC(o)));
 588     return o;
 589 }
 590
 591 STATIC OP *
 592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 593 {
 594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 596     return o;
 597 }
 598
 599 STATIC OP *
 600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 601 {
 602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 603
 604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 605     return o;
 606 }
 607
 608 STATIC void
 609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 610 {
 611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 612
 613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 615 }
 616
 617 /* remove flags var, its unused in all callers, move to to right end since gv
 618   and kid are always the same */
 619 STATIC void
 620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 621 {
 622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 624
 625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 627 }
 628
 629 STATIC void
 630 S_no_bareword_allowed(pTHX_ OP *o)
 631 {
 632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 633
 634     qerror(Perl_mess(aTHX_
 635                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 636                      SVfARG(cSVOPo_sv)));
 637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 638 }
 639
 640 /* "register" allocation */
 641
 642 PADOFFSET
 643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 644 {
 645     PADOFFSET off;
 646     const bool is_our = (PL_parser->in_my == KEY_our);
 647
 648     PERL_ARGS_ASSERT_ALLOCMY;
 649
 650     if (flags & ~SVf_UTF8)
 651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 652                    (UV)flags);
 653
 654     /* complain about "my $<special_var>" etc etc */
 655     if (   len
 656         && !(  is_our
 657             || isALPHA(name[1])
 658             || (   (flags & SVf_UTF8)
 659                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 660             || (name[1] == '_' && len > 2)))
 661     {
 662         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 663          && isASCII(name[1])
 664          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 665             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 666                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 667                               PL_parser->in_my == KEY_state ? "state" : "my"));
 668         } else {
 669             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 670                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 671         }
 672     }
 673
 674     /* allocate a spare slot and store the name in that slot */
 675
 676     off = pad_add_name_pvn(name, len,
 677                        (is_our ? padadd_OUR :
 678                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 679                     PL_parser->in_my_stash,
 680                     (is_our
 681                         /* $_ is always in main::, even with our */
 682                         ? (PL_curstash && !memEQs(name,len,"$_")
 683                             ? PL_curstash
 684                             : PL_defstash)
 685                         : NULL
 686                     )
 687     );
 688     /* anon sub prototypes contains state vars should always be cloned,
 689      * otherwise the state var would be shared between anon subs */
 690
 691     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 692         CvCLONE_on(PL_compcv);
 693
 694     return off;
 695 }
 696
 697 /*
 698 =head1 Optree Manipulation Functions
 699
 700 =for apidoc alloccopstash
 701
 702 Available only under threaded builds, this function allocates an entry in
 703 C<PL_stashpad> for the stash passed to it.
 704
 705 =cut
 706 */
 707
 708 #ifdef USE_ITHREADS
 709 PADOFFSET
 710 Perl_alloccopstash(pTHX_ HV *hv)
 711 {
 712     PADOFFSET off = 0, o = 1;
 713     bool found_slot = FALSE;
 714
 715     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 716
 717     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 718
 719     for (; o < PL_stashpadmax; ++o) {
 720         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 721         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 722             found_slot = TRUE, off = o;
 723     }
 724     if (!found_slot) {
 725         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 726         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 727         off = PL_stashpadmax;
 728         PL_stashpadmax += 10;
 729     }
 730
 731     PL_stashpad[PL_stashpadix = off] = hv;
 732     return off;
 733 }
 734 #endif
 735
 736 /* free the body of an op without examining its contents.
 737  * Always use this rather than FreeOp directly */
 738
 739 static void
 740 S_op_destroy(pTHX_ OP *o)
 741 {
 742     FreeOp(o);
 743 }
 744
 745 /* Destructor */
 746
 747 /*
 748 =for apidoc Am|void|op_free|OP *o
 749
 750 Free an op.  Only use this when an op is no longer linked to from any
 751 optree.
 752
 753 =cut
 754 */
 755
 756 void
 757 Perl_op_free(pTHX_ OP *o)
 758 {
 759     dVAR;
 760     OPCODE type;
 761     SSize_t defer_ix = -1;
 762     SSize_t defer_stack_alloc = 0;
 763     OP **defer_stack = NULL;
 764
 765     do {
 766
 767         /* Though ops may be freed twice, freeing the op after its slab is a
 768            big no-no. */
 769         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 770         /* During the forced freeing of ops after compilation failure, kidops
 771            may be freed before their parents. */
 772         if (!o || o->op_type == OP_FREED)
 773             continue;
 774
 775         type = o->op_type;
 776
 777         /* an op should only ever acquire op_private flags that we know about.
 778          * If this fails, you may need to fix something in regen/op_private.
 779          * Don't bother testing if:
 780          *   * the op_ppaddr doesn't match the op; someone may have
 781          *     overridden the op and be doing strange things with it;
 782          *   * we've errored, as op flags are often left in an
 783          *     inconsistent state then. Note that an error when
 784          *     compiling the main program leaves PL_parser NULL, so
 785          *     we can't spot faults in the main code, only
 786          *     evaled/required code */
 787 #ifdef DEBUGGING
 788         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 789             && PL_parser
 790             && !PL_parser->error_count)
 791         {
 792             assert(!(o->op_private & ~PL_op_private_valid[type]));
 793         }
 794 #endif
 795
 796         if (o->op_private & OPpREFCOUNTED) {
 797             switch (type) {
 798             case OP_LEAVESUB:
 799             case OP_LEAVESUBLV:
 800             case OP_LEAVEEVAL:
 801             case OP_LEAVE:
 802             case OP_SCOPE:
 803             case OP_LEAVEWRITE:
 804                 {
 805                 PADOFFSET refcnt;
 806                 OP_REFCNT_LOCK;
 807                 refcnt = OpREFCNT_dec(o);
 808                 OP_REFCNT_UNLOCK;
 809                 if (refcnt) {
 810                     /* Need to find and remove any pattern match ops from the list
 811                        we maintain for reset().  */
 812                     find_and_forget_pmops(o);
 813                     continue;
 814                 }
 815                 }
 816                 break;
 817             default:
 818                 break;
 819             }
 820         }
 821
 822         /* Call the op_free hook if it has been set. Do it now so that it's called
 823          * at the right time for refcounted ops, but still before all of the kids
 824          * are freed. */
 825         CALL_OPFREEHOOK(o);
 826
 827         if (o->op_flags & OPf_KIDS) {
 828             OP *kid, *nextkid;
 829             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 830                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 831                 if (!kid || kid->op_type == OP_FREED)
 832                     /* During the forced freeing of ops after
 833                        compilation failure, kidops may be freed before
 834                        their parents. */
 835                     continue;
 836                 if (!(kid->op_flags & OPf_KIDS))
 837                     /* If it has no kids, just free it now */
 838                     op_free(kid);
 839                 else
 840                     DEFER_OP(kid);
 841             }
 842         }
 843         if (type == OP_NULL)
 844             type = (OPCODE)o->op_targ;
 845
 846         if (o->op_slabbed)
 847             Slab_to_rw(OpSLAB(o));
 848
 849         /* COP* is not cleared by op_clear() so that we may track line
 850          * numbers etc even after null() */
 851         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 852             cop_free((COP*)o);
 853         }
 854
 855         op_clear(o);
 856         FreeOp(o);
 857         if (PL_op == o)
 858             PL_op = NULL;
 859     } while ( (o = POP_DEFERRED_OP()) );
 860
 861     Safefree(defer_stack);
 862 }
 863
 864 /* S_op_clear_gv(): free a GV attached to an OP */
 865
 866 STATIC
 867 #ifdef USE_ITHREADS
 868 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 869 #else
 870 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 871 #endif
 872 {
 873
 874     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 875             || o->op_type == OP_MULTIDEREF)
 876 #ifdef USE_ITHREADS
 877                 && PL_curpad
 878                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 879 #else
 880                 ? (GV*)(*svp) : NULL;
 881 #endif
 882     /* It's possible during global destruction that the GV is freed
 883        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 884        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 885        will trigger an assertion failure, because the entry to sv_clear
 886        checks that the scalar is not already freed.  A check of for
 887        !SvIS_FREED(gv) turns out to be invalid, because during global
 888        destruction the reference count can be forced down to zero
 889        (with SVf_BREAK set).  In which case raising to 1 and then
 890        dropping to 0 triggers cleanup before it should happen.  I
 891        *think* that this might actually be a general, systematic,
 892        weakness of the whole idea of SVf_BREAK, in that code *is*
 893        allowed to raise and lower references during global destruction,
 894        so any *valid* code that happens to do this during global
 895        destruction might well trigger premature cleanup.  */
 896     bool still_valid = gv && SvREFCNT(gv);
 897
 898     if (still_valid)
 899         SvREFCNT_inc_simple_void(gv);
 900 #ifdef USE_ITHREADS
 901     if (*ixp > 0) {
 902         pad_swipe(*ixp, TRUE);
 903         *ixp = 0;
 904     }
 905 #else
 906     SvREFCNT_dec(*svp);
 907     *svp = NULL;
 908 #endif
 909     if (still_valid) {
 910         int try_downgrade = SvREFCNT(gv) == 2;
 911         SvREFCNT_dec_NN(gv);
 912         if (try_downgrade)
 913             gv_try_downgrade(gv);
 914     }
 915 }
 916
 917
 918 void
 919 Perl_op_clear(pTHX_ OP *o)
 920 {
 921
 922     dVAR;
 923
 924     PERL_ARGS_ASSERT_OP_CLEAR;
 925
 926     switch (o->op_type) {
 927     case OP_NULL:       /* Was holding old type, if any. */
 928         /* FALLTHROUGH */
 929     case OP_ENTERTRY:
 930     case OP_ENTEREVAL:  /* Was holding hints. */
 931     case OP_ARGDEFELEM: /* Was holding signature index. */
 932         o->op_targ = 0;
 933         break;
 934     default:
 935         if (!(o->op_flags & OPf_REF)
 936             || (PL_check[o->op_type] != Perl_ck_ftst))
 937             break;
 938         /* FALLTHROUGH */
 939     case OP_GVSV:
 940     case OP_GV:
 941     case OP_AELEMFAST:
 942 #ifdef USE_ITHREADS
 943             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 944 #else
 945             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 946 #endif
 947         break;
 948     case OP_METHOD_REDIR:
 949     case OP_METHOD_REDIR_SUPER:
 950 #ifdef USE_ITHREADS
 951         if (cMETHOPx(o)->op_rclass_targ) {
 952             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 953             cMETHOPx(o)->op_rclass_targ = 0;
 954         }
 955 #else
 956         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 957         cMETHOPx(o)->op_rclass_sv = NULL;
 958 #endif
 959     case OP_METHOD_NAMED:
 960     case OP_METHOD_SUPER:
 961         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 962         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 963 #ifdef USE_ITHREADS
 964         if (o->op_targ) {
 965             pad_swipe(o->op_targ, 1);
 966             o->op_targ = 0;
 967         }
 968 #endif
 969         break;
 970     case OP_CONST:
 971     case OP_HINTSEVAL:
 972         SvREFCNT_dec(cSVOPo->op_sv);
 973         cSVOPo->op_sv = NULL;
 974 #ifdef USE_ITHREADS
 975         /** Bug #15654
 976           Even if op_clear does a pad_free for the target of the op,
 977           pad_free doesn't actually remove the sv that exists in the pad;
 978           instead it lives on. This results in that it could be reused as
 979           a target later on when the pad was reallocated.
 980         **/
 981         if(o->op_targ) {
 982           pad_swipe(o->op_targ,1);
 983           o->op_targ = 0;
 984         }
 985 #endif
 986         break;
 987     case OP_DUMP:
 988     case OP_GOTO:
 989     case OP_NEXT:
 990     case OP_LAST:
 991     case OP_REDO:
 992         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 993             break;
 994         /* FALLTHROUGH */
 995     case OP_TRANS:
 996     case OP_TRANSR:
 997         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 998             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 999 #ifdef USE_ITHREADS
1000             if (cPADOPo->op_padix > 0) {
1001                 pad_swipe(cPADOPo->op_padix, TRUE);
1002                 cPADOPo->op_padix = 0;
1003             }
1004 #else
1005             SvREFCNT_dec(cSVOPo->op_sv);
1006             cSVOPo->op_sv = NULL;
1007 #endif
1008         }
1009         else {
1010             PerlMemShared_free(cPVOPo->op_pv);
1011             cPVOPo->op_pv = NULL;
1012         }
1013         break;
1014     case OP_SUBST:
1015         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1016         goto clear_pmop;
1017
1018     case OP_SPLIT:
1019         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1020             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1021         {
1022             if (o->op_private & OPpSPLIT_LEX)
1023                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1024             else
1025 #ifdef USE_ITHREADS
1026                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1027 #else
1028                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1029 #endif
1030         }
1031         /* FALLTHROUGH */
1032     case OP_MATCH:
1033     case OP_QR:
1034     clear_pmop:
1035         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1036             op_free(cPMOPo->op_code_list);
1037         cPMOPo->op_code_list = NULL;
1038         forget_pmop(cPMOPo);
1039         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1040         /* we use the same protection as the "SAFE" version of the PM_ macros
1041          * here since sv_clean_all might release some PMOPs
1042          * after PL_regex_padav has been cleared
1043          * and the clearing of PL_regex_padav needs to
1044          * happen before sv_clean_all
1045          */
1046 #ifdef USE_ITHREADS
1047         if(PL_regex_pad) {        /* We could be in destruction */
1048             const IV offset = (cPMOPo)->op_pmoffset;
1049             ReREFCNT_dec(PM_GETRE(cPMOPo));
1050             PL_regex_pad[offset] = &PL_sv_undef;
1051             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1052                            sizeof(offset));
1053         }
1054 #else
1055         ReREFCNT_dec(PM_GETRE(cPMOPo));
1056         PM_SETRE(cPMOPo, NULL);
1057 #endif
1058
1059         break;
1060
1061     case OP_ARGCHECK:
1062         PerlMemShared_free(cUNOP_AUXo->op_aux);
1063         break;
1064
1065     case OP_MULTIDEREF:
1066         {
1067             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1068             UV actions = items->uv;
1069             bool last = 0;
1070             bool is_hash = FALSE;
1071
1072             while (!last) {
1073                 switch (actions & MDEREF_ACTION_MASK) {
1074
1075                 case MDEREF_reload:
1076                     actions = (++items)->uv;
1077                     continue;
1078
1079                 case MDEREF_HV_padhv_helem:
1080                     is_hash = TRUE;
1081                 case MDEREF_AV_padav_aelem:
1082                     pad_free((++items)->pad_offset);
1083                     goto do_elem;
1084
1085                 case MDEREF_HV_gvhv_helem:
1086                     is_hash = TRUE;
1087                 case MDEREF_AV_gvav_aelem:
1088 #ifdef USE_ITHREADS
1089                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1090 #else
1091                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1092 #endif
1093                     goto do_elem;
1094
1095                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1096                     is_hash = TRUE;
1097                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1098 #ifdef USE_ITHREADS
1099                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1100 #else
1101                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1102 #endif
1103                     goto do_vivify_rv2xv_elem;
1104
1105                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1106                     is_hash = TRUE;
1107                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1108                     pad_free((++items)->pad_offset);
1109                     goto do_vivify_rv2xv_elem;
1110
1111                 case MDEREF_HV_pop_rv2hv_helem:
1112                 case MDEREF_HV_vivify_rv2hv_helem:
1113                     is_hash = TRUE;
1114                 do_vivify_rv2xv_elem:
1115                 case MDEREF_AV_pop_rv2av_aelem:
1116                 case MDEREF_AV_vivify_rv2av_aelem:
1117                 do_elem:
1118                     switch (actions & MDEREF_INDEX_MASK) {
1119                     case MDEREF_INDEX_none:
1120                         last = 1;
1121                         break;
1122                     case MDEREF_INDEX_const:
1123                         if (is_hash) {
1124 #ifdef USE_ITHREADS
1125                             /* see RT #15654 */
1126                             pad_swipe((++items)->pad_offset, 1);
1127 #else
1128                             SvREFCNT_dec((++items)->sv);
1129 #endif
1130                         }
1131                         else
1132                             items++;
1133                         break;
1134                     case MDEREF_INDEX_padsv:
1135                         pad_free((++items)->pad_offset);
1136                         break;
1137                     case MDEREF_INDEX_gvsv:
1138 #ifdef USE_ITHREADS
1139                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1140 #else
1141                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1142 #endif
1143                         break;
1144                     }
1145
1146                     if (actions & MDEREF_FLAG_last)
1147                         last = 1;
1148                     is_hash = FALSE;
1149
1150                     break;
1151
1152                 default:
1153                     assert(0);
1154                     last = 1;
1155                     break;
1156
1157                 } /* switch */
1158
1159                 actions >>= MDEREF_SHIFT;
1160             } /* while */
1161
1162             /* start of malloc is at op_aux[-1], where the length is
1163              * stored */
1164             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1165         }
1166         break;
1167     }
1168
1169     if (o->op_targ > 0) {
1170         pad_free(o->op_targ);
1171         o->op_targ = 0;
1172     }
1173 }
1174
1175 STATIC void
1176 S_cop_free(pTHX_ COP* cop)
1177 {
1178     PERL_ARGS_ASSERT_COP_FREE;
1179
1180     CopFILE_free(cop);
1181     if (! specialWARN(cop->cop_warnings))
1182         PerlMemShared_free(cop->cop_warnings);
1183     cophh_free(CopHINTHASH_get(cop));
1184     if (PL_curcop == cop)
1185        PL_curcop = NULL;
1186 }
1187
1188 STATIC void
1189 S_forget_pmop(pTHX_ PMOP *const o
1190               )
1191 {
1192     HV * const pmstash = PmopSTASH(o);
1193
1194     PERL_ARGS_ASSERT_FORGET_PMOP;
1195
1196     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1197         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1198         if (mg) {
1199             PMOP **const array = (PMOP**) mg->mg_ptr;
1200             U32 count = mg->mg_len / sizeof(PMOP**);
1201             U32 i = count;
1202
1203             while (i--) {
1204                 if (array[i] == o) {
1205                     /* Found it. Move the entry at the end to overwrite it.  */
1206                     array[i] = array[--count];
1207                     mg->mg_len = count * sizeof(PMOP**);
1208                     /* Could realloc smaller at this point always, but probably
1209                        not worth it. Probably worth free()ing if we're the
1210                        last.  */
1211                     if(!count) {
1212                         Safefree(mg->mg_ptr);
1213                         mg->mg_ptr = NULL;
1214                     }
1215                     break;
1216                 }
1217             }
1218         }
1219     }
1220     if (PL_curpm == o)
1221         PL_curpm = NULL;
1222 }
1223
1224 STATIC void
1225 S_find_and_forget_pmops(pTHX_ OP *o)
1226 {
1227     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1228
1229     if (o->op_flags & OPf_KIDS) {
1230         OP *kid = cUNOPo->op_first;
1231         while (kid) {
1232             switch (kid->op_type) {
1233             case OP_SUBST:
1234             case OP_SPLIT:
1235             case OP_MATCH:
1236             case OP_QR:
1237                 forget_pmop((PMOP*)kid);
1238             }
1239             find_and_forget_pmops(kid);
1240             kid = OpSIBLING(kid);
1241         }
1242     }
1243 }
1244
1245 /*
1246 =for apidoc Am|void|op_null|OP *o
1247
1248 Neutralizes an op when it is no longer needed, but is still linked to from
1249 other ops.
1250
1251 =cut
1252 */
1253
1254 void
1255 Perl_op_null(pTHX_ OP *o)
1256 {
1257     dVAR;
1258
1259     PERL_ARGS_ASSERT_OP_NULL;
1260
1261     if (o->op_type == OP_NULL)
1262         return;
1263     op_clear(o);
1264     o->op_targ = o->op_type;
1265     OpTYPE_set(o, OP_NULL);
1266 }
1267
1268 void
1269 Perl_op_refcnt_lock(pTHX)
1270   PERL_TSA_ACQUIRE(PL_op_mutex)
1271 {
1272 #ifdef USE_ITHREADS
1273     dVAR;
1274 #endif
1275     PERL_UNUSED_CONTEXT;
1276     OP_REFCNT_LOCK;
1277 }
1278
1279 void
1280 Perl_op_refcnt_unlock(pTHX)
1281   PERL_TSA_RELEASE(PL_op_mutex)
1282 {
1283 #ifdef USE_ITHREADS
1284     dVAR;
1285 #endif
1286     PERL_UNUSED_CONTEXT;
1287     OP_REFCNT_UNLOCK;
1288 }
1289
1290
1291 /*
1292 =for apidoc op_sibling_splice
1293
1294 A general function for editing the structure of an existing chain of
1295 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1296 you to delete zero or more sequential nodes, replacing them with zero or
1297 more different nodes.  Performs the necessary op_first/op_last
1298 housekeeping on the parent node and op_sibling manipulation on the
1299 children.  The last deleted node will be marked as as the last node by
1300 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1301
1302 Note that op_next is not manipulated, and nodes are not freed; that is the
1303 responsibility of the caller.  It also won't create a new list op for an
1304 empty list etc; use higher-level functions like op_append_elem() for that.
1305
1306 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1307 the splicing doesn't affect the first or last op in the chain.
1308
1309 C<start> is the node preceding the first node to be spliced.  Node(s)
1310 following it will be deleted, and ops will be inserted after it.  If it is
1311 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1312 beginning.
1313
1314 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1315 If -1 or greater than or equal to the number of remaining kids, all
1316 remaining kids are deleted.
1317
1318 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1319 If C<NULL>, no nodes are inserted.
1320
1321 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1322 deleted.
1323
1324 For example:
1325
1326     action                    before      after         returns
1327     ------                    -----       -----         -------
1328
1329                               P           P
1330     splice(P, A, 2, X-Y-Z)    |           |             B-C
1331                               A-B-C-D     A-X-Y-Z-D
1332
1333                               P           P
1334     splice(P, NULL, 1, X-Y)   |           |             A
1335                               A-B-C-D     X-Y-B-C-D
1336
1337                               P           P
1338     splice(P, NULL, 3, NULL)  |           |             A-B-C
1339                               A-B-C-D     D
1340
1341                               P           P
1342     splice(P, B, 0, X-Y)      |           |             NULL
1343                               A-B-C-D     A-B-X-Y-C-D
1344
1345
1346 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1347 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1348
1349 =cut
1350 */
1351
1352 OP *
1353 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1354 {
1355     OP *first;
1356     OP *rest;
1357     OP *last_del = NULL;
1358     OP *last_ins = NULL;
1359
1360     if (start)
1361         first = OpSIBLING(start);
1362     else if (!parent)
1363         goto no_parent;
1364     else
1365         first = cLISTOPx(parent)->op_first;
1366
1367     assert(del_count >= -1);
1368
1369     if (del_count && first) {
1370         last_del = first;
1371         while (--del_count && OpHAS_SIBLING(last_del))
1372             last_del = OpSIBLING(last_del);
1373         rest = OpSIBLING(last_del);
1374         OpLASTSIB_set(last_del, NULL);
1375     }
1376     else
1377         rest = first;
1378
1379     if (insert) {
1380         last_ins = insert;
1381         while (OpHAS_SIBLING(last_ins))
1382             last_ins = OpSIBLING(last_ins);
1383         OpMAYBESIB_set(last_ins, rest, NULL);
1384     }
1385     else
1386         insert = rest;
1387
1388     if (start) {
1389         OpMAYBESIB_set(start, insert, NULL);
1390     }
1391     else {
1392         if (!parent)
1393             goto no_parent;
1394         cLISTOPx(parent)->op_first = insert;
1395         if (insert)
1396             parent->op_flags |= OPf_KIDS;
1397         else
1398             parent->op_flags &= ~OPf_KIDS;
1399     }
1400
1401     if (!rest) {
1402         /* update op_last etc */
1403         U32 type;
1404         OP *lastop;
1405
1406         if (!parent)
1407             goto no_parent;
1408
1409         /* ought to use OP_CLASS(parent) here, but that can't handle
1410          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1411          * either */
1412         type = parent->op_type;
1413         if (type == OP_CUSTOM) {
1414             dTHX;
1415             type = XopENTRYCUSTOM(parent, xop_class);
1416         }
1417         else {
1418             if (type == OP_NULL)
1419                 type = parent->op_targ;
1420             type = PL_opargs[type] & OA_CLASS_MASK;
1421         }
1422
1423         lastop = last_ins ? last_ins : start ? start : NULL;
1424         if (   type == OA_BINOP
1425             || type == OA_LISTOP
1426             || type == OA_PMOP
1427             || type == OA_LOOP
1428         )
1429             cLISTOPx(parent)->op_last = lastop;
1430
1431         if (lastop)
1432             OpLASTSIB_set(lastop, parent);
1433     }
1434     return last_del ? first : NULL;
1435
1436   no_parent:
1437     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1438 }
1439
1440
1441 #ifdef PERL_OP_PARENT
1442
1443 /*
1444 =for apidoc op_parent
1445
1446 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1447 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1448
1449 =cut
1450 */
1451
1452 OP *
1453 Perl_op_parent(OP *o)
1454 {
1455     PERL_ARGS_ASSERT_OP_PARENT;
1456     while (OpHAS_SIBLING(o))
1457         o = OpSIBLING(o);
1458     return o->op_sibparent;
1459 }
1460
1461 #endif
1462
1463
1464 /* replace the sibling following start with a new UNOP, which becomes
1465  * the parent of the original sibling; e.g.
1466  *
1467  *  op_sibling_newUNOP(P, A, unop-args...)
1468  *
1469  *  P              P
1470  *  |      becomes |
1471  *  A-B-C          A-U-C
1472  *                   |
1473  *                   B
1474  *
1475  * where U is the new UNOP.
1476  *
1477  * parent and start args are the same as for op_sibling_splice();
1478  * type and flags args are as newUNOP().
1479  *
1480  * Returns the new UNOP.
1481  */
1482
1483 STATIC OP *
1484 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1485 {
1486     OP *kid, *newop;
1487
1488     kid = op_sibling_splice(parent, start, 1, NULL);
1489     newop = newUNOP(type, flags, kid);
1490     op_sibling_splice(parent, start, 0, newop);
1491     return newop;
1492 }
1493
1494
1495 /* lowest-level newLOGOP-style function - just allocates and populates
1496  * the struct. Higher-level stuff should be done by S_new_logop() /
1497  * newLOGOP(). This function exists mainly to avoid op_first assignment
1498  * being spread throughout this file.
1499  */
1500
1501 LOGOP *
1502 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1503 {
1504     dVAR;
1505     LOGOP *logop;
1506     OP *kid = first;
1507     NewOp(1101, logop, 1, LOGOP);
1508     OpTYPE_set(logop, type);
1509     logop->op_first = first;
1510     logop->op_other = other;
1511     logop->op_flags = OPf_KIDS;
1512     while (kid && OpHAS_SIBLING(kid))
1513         kid = OpSIBLING(kid);
1514     if (kid)
1515         OpLASTSIB_set(kid, (OP*)logop);
1516     return logop;
1517 }
1518
1519
1520 /* Contextualizers */
1521
1522 /*
1523 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1524
1525 Applies a syntactic context to an op tree representing an expression.
1526 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1527 or C<G_VOID> to specify the context to apply.  The modified op tree
1528 is returned.
1529
1530 =cut
1531 */
1532
1533 OP *
1534 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1535 {
1536     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1537     switch (context) {
1538         case G_SCALAR: return scalar(o);
1539         case G_ARRAY:  return list(o);
1540         case G_VOID:   return scalarvoid(o);
1541         default:
1542             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1543                        (long) context);
1544     }
1545 }
1546
1547 /*
1548
1549 =for apidoc Am|OP*|op_linklist|OP *o
1550 This function is the implementation of the L</LINKLIST> macro.  It should
1551 not be called directly.
1552
1553 =cut
1554 */
1555
1556 OP *
1557 Perl_op_linklist(pTHX_ OP *o)
1558 {
1559     OP *first;
1560
1561     PERL_ARGS_ASSERT_OP_LINKLIST;
1562
1563     if (o->op_next)
1564         return o->op_next;
1565
1566     /* establish postfix order */
1567     first = cUNOPo->op_first;
1568     if (first) {
1569         OP *kid;
1570         o->op_next = LINKLIST(first);
1571         kid = first;
1572         for (;;) {
1573             OP *sibl = OpSIBLING(kid);
1574             if (sibl) {
1575                 kid->op_next = LINKLIST(sibl);
1576                 kid = sibl;
1577             } else {
1578                 kid->op_next = o;
1579                 break;
1580             }
1581         }
1582     }
1583     else
1584         o->op_next = o;
1585
1586     return o->op_next;
1587 }
1588
1589 static OP *
1590 S_scalarkids(pTHX_ OP *o)
1591 {
1592     if (o && o->op_flags & OPf_KIDS) {
1593         OP *kid;
1594         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1595             scalar(kid);
1596     }
1597     return o;
1598 }
1599
1600 STATIC OP *
1601 S_scalarboolean(pTHX_ OP *o)
1602 {
1603     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1604
1605     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1606          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1607         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1608          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1609          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1610         if (ckWARN(WARN_SYNTAX)) {
1611             const line_t oldline = CopLINE(PL_curcop);
1612
1613             if (PL_parser && PL_parser->copline != NOLINE) {
1614                 /* This ensures that warnings are reported at the first line
1615                    of the conditional, not the last.  */
1616                 CopLINE_set(PL_curcop, PL_parser->copline);
1617             }
1618             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1619             CopLINE_set(PL_curcop, oldline);
1620         }
1621     }
1622     return scalar(o);
1623 }
1624
1625 static SV *
1626 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1627 {
1628     assert(o);
1629     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1630            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1631     {
1632         const char funny  = o->op_type == OP_PADAV
1633                          || o->op_type == OP_RV2AV ? '@' : '%';
1634         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1635             GV *gv;
1636             if (cUNOPo->op_first->op_type != OP_GV
1637              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1638                 return NULL;
1639             return varname(gv, funny, 0, NULL, 0, subscript_type);
1640         }
1641         return
1642             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1643     }
1644 }
1645
1646 static SV *
1647 S_op_varname(pTHX_ const OP *o)
1648 {
1649     return S_op_varname_subscript(aTHX_ o, 1);
1650 }
1651
1652 static void
1653 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1654 { /* or not so pretty :-) */
1655     if (o->op_type == OP_CONST) {
1656         *retsv = cSVOPo_sv;
1657         if (SvPOK(*retsv)) {
1658             SV *sv = *retsv;
1659             *retsv = sv_newmortal();
1660             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1661                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1662         }
1663         else if (!SvOK(*retsv))
1664             *retpv = "undef";
1665     }
1666     else *retpv = "...";
1667 }
1668
1669 static void
1670 S_scalar_slice_warning(pTHX_ const OP *o)
1671 {
1672     OP *kid;
1673     const char lbrack =
1674         o->op_type == OP_HSLICE ? '{' : '[';
1675     const char rbrack =
1676         o->op_type == OP_HSLICE ? '}' : ']';
1677     SV *name;
1678     SV *keysv = NULL; /* just to silence compiler warnings */
1679     const char *key = NULL;
1680
1681     if (!(o->op_private & OPpSLICEWARNING))
1682         return;
1683     if (PL_parser && PL_parser->error_count)
1684         /* This warning can be nonsensical when there is a syntax error. */
1685         return;
1686
1687     kid = cLISTOPo->op_first;
1688     kid = OpSIBLING(kid); /* get past pushmark */
1689     /* weed out false positives: any ops that can return lists */
1690     switch (kid->op_type) {
1691     case OP_BACKTICK:
1692     case OP_GLOB:
1693     case OP_READLINE:
1694     case OP_MATCH:
1695     case OP_RV2AV:
1696     case OP_EACH:
1697     case OP_VALUES:
1698     case OP_KEYS:
1699     case OP_SPLIT:
1700     case OP_LIST:
1701     case OP_SORT:
1702     case OP_REVERSE:
1703     case OP_ENTERSUB:
1704     case OP_CALLER:
1705     case OP_LSTAT:
1706     case OP_STAT:
1707     case OP_READDIR:
1708     case OP_SYSTEM:
1709     case OP_TMS:
1710     case OP_LOCALTIME:
1711     case OP_GMTIME:
1712     case OP_ENTEREVAL:
1713         return;
1714     }
1715
1716     /* Don't warn if we have a nulled list either. */
1717     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1718         return;
1719
1720     assert(OpSIBLING(kid));
1721     name = S_op_varname(aTHX_ OpSIBLING(kid));
1722     if (!name) /* XS module fiddling with the op tree */
1723         return;
1724     S_op_pretty(aTHX_ kid, &keysv, &key);
1725     assert(SvPOK(name));
1726     sv_chop(name,SvPVX(name)+1);
1727     if (key)
1728        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1729         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1730                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1731                    "%c%s%c",
1732                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1733                     lbrack, key, rbrack);
1734     else
1735        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1736         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1737                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1738                     SVf "%c%" SVf "%c",
1739                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1740                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1741 }
1742
1743 OP *
1744 Perl_scalar(pTHX_ OP *o)
1745 {
1746     OP *kid;
1747
1748     /* assumes no premature commitment */
1749     if (!o || (PL_parser && PL_parser->error_count)
1750          || (o->op_flags & OPf_WANT)
1751          || o->op_type == OP_RETURN)
1752     {
1753         return o;
1754     }
1755
1756     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1757
1758     switch (o->op_type) {
1759     case OP_REPEAT:
1760         scalar(cBINOPo->op_first);
1761         if (o->op_private & OPpREPEAT_DOLIST) {
1762             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1763             assert(kid->op_type == OP_PUSHMARK);
1764             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1765                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1766                 o->op_private &=~ OPpREPEAT_DOLIST;
1767             }
1768         }
1769         break;
1770     case OP_OR:
1771     case OP_AND:
1772     case OP_COND_EXPR:
1773         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1774             scalar(kid);
1775         break;
1776         /* FALLTHROUGH */
1777     case OP_SPLIT:
1778     case OP_MATCH:
1779     case OP_QR:
1780     case OP_SUBST:
1781     case OP_NULL:
1782     default:
1783         if (o->op_flags & OPf_KIDS) {
1784             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1785                 scalar(kid);
1786         }
1787         break;
1788     case OP_LEAVE:
1789     case OP_LEAVETRY:
1790         kid = cLISTOPo->op_first;
1791         scalar(kid);
1792         kid = OpSIBLING(kid);
1793     do_kids:
1794         while (kid) {
1795             OP *sib = OpSIBLING(kid);
1796             if (sib && kid->op_type != OP_LEAVEWHEN
1797              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1798                 || (  sib->op_targ != OP_NEXTSTATE
1799                    && sib->op_targ != OP_DBSTATE  )))
1800                 scalarvoid(kid);
1801             else
1802                 scalar(kid);
1803             kid = sib;
1804         }
1805         PL_curcop = &PL_compiling;
1806         break;
1807     case OP_SCOPE:
1808     case OP_LINESEQ:
1809     case OP_LIST:
1810         kid = cLISTOPo->op_first;
1811         goto do_kids;
1812     case OP_SORT:
1813         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1814         break;
1815     case OP_KVHSLICE:
1816     case OP_KVASLICE:
1817     {
1818         /* Warn about scalar context */
1819         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1820         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1821         SV *name;
1822         SV *keysv;
1823         const char *key = NULL;
1824
1825         /* This warning can be nonsensical when there is a syntax error. */
1826         if (PL_parser && PL_parser->error_count)
1827             break;
1828
1829         if (!ckWARN(WARN_SYNTAX)) break;
1830
1831         kid = cLISTOPo->op_first;
1832         kid = OpSIBLING(kid); /* get past pushmark */
1833         assert(OpSIBLING(kid));
1834         name = S_op_varname(aTHX_ OpSIBLING(kid));
1835         if (!name) /* XS module fiddling with the op tree */
1836             break;
1837         S_op_pretty(aTHX_ kid, &keysv, &key);
1838         assert(SvPOK(name));
1839         sv_chop(name,SvPVX(name)+1);
1840         if (key)
1841   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1842             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1843                        "%%%" SVf "%c%s%c in scalar context better written "
1844                        "as $%" SVf "%c%s%c",
1845                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1846                         lbrack, key, rbrack);
1847         else
1848   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1849             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1850                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1851                        "written as $%" SVf "%c%" SVf "%c",
1852                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1853                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1854     }
1855     }
1856     return o;
1857 }
1858
1859 OP *
1860 Perl_scalarvoid(pTHX_ OP *arg)
1861 {
1862     dVAR;
1863     OP *kid;
1864     SV* sv;
1865     U8 want;
1866     SSize_t defer_stack_alloc = 0;
1867     SSize_t defer_ix = -1;
1868     OP **defer_stack = NULL;
1869     OP *o = arg;
1870
1871     PERL_ARGS_ASSERT_SCALARVOID;
1872
1873     do {
1874         SV *useless_sv = NULL;
1875         const char* useless = NULL;
1876
1877         if (o->op_type == OP_NEXTSTATE
1878             || o->op_type == OP_DBSTATE
1879             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1880                                           || o->op_targ == OP_DBSTATE)))
1881             PL_curcop = (COP*)o;                /* for warning below */
1882
1883         /* assumes no premature commitment */
1884         want = o->op_flags & OPf_WANT;
1885         if ((want && want != OPf_WANT_SCALAR)
1886             || (PL_parser && PL_parser->error_count)
1887             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1888         {
1889             continue;
1890         }
1891
1892         if ((o->op_private & OPpTARGET_MY)
1893             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1894         {
1895             /* newASSIGNOP has already applied scalar context, which we
1896                leave, as if this op is inside SASSIGN.  */
1897             continue;
1898         }
1899
1900         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1901
1902         switch (o->op_type) {
1903         default:
1904             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1905                 break;
1906             /* FALLTHROUGH */
1907         case OP_REPEAT:
1908             if (o->op_flags & OPf_STACKED)
1909                 break;
1910             if (o->op_type == OP_REPEAT)
1911                 scalar(cBINOPo->op_first);
1912             goto func_ops;
1913         case OP_SUBSTR:
1914             if (o->op_private == 4)
1915                 break;
1916             /* FALLTHROUGH */
1917         case OP_WANTARRAY:
1918         case OP_GV:
1919         case OP_SMARTMATCH:
1920         case OP_AV2ARYLEN:
1921         case OP_REF:
1922         case OP_REFGEN:
1923         case OP_SREFGEN:
1924         case OP_DEFINED:
1925         case OP_HEX:
1926         case OP_OCT:
1927         case OP_LENGTH:
1928         case OP_VEC:
1929         case OP_INDEX:
1930         case OP_RINDEX:
1931         case OP_SPRINTF:
1932         case OP_KVASLICE:
1933         case OP_KVHSLICE:
1934         case OP_UNPACK:
1935         case OP_PACK:
1936         case OP_JOIN:
1937         case OP_LSLICE:
1938         case OP_ANONLIST:
1939         case OP_ANONHASH:
1940         case OP_SORT:
1941         case OP_REVERSE:
1942         case OP_RANGE:
1943         case OP_FLIP:
1944         case OP_FLOP:
1945         case OP_CALLER:
1946         case OP_FILENO:
1947         case OP_EOF:
1948         case OP_TELL:
1949         case OP_GETSOCKNAME:
1950         case OP_GETPEERNAME:
1951         case OP_READLINK:
1952         case OP_TELLDIR:
1953         case OP_GETPPID:
1954         case OP_GETPGRP:
1955         case OP_GETPRIORITY:
1956         case OP_TIME:
1957         case OP_TMS:
1958         case OP_LOCALTIME:
1959         case OP_GMTIME:
1960         case OP_GHBYNAME:
1961         case OP_GHBYADDR:
1962         case OP_GHOSTENT:
1963         case OP_GNBYNAME:
1964         case OP_GNBYADDR:
1965         case OP_GNETENT:
1966         case OP_GPBYNAME:
1967         case OP_GPBYNUMBER:
1968         case OP_GPROTOENT:
1969         case OP_GSBYNAME:
1970         case OP_GSBYPORT:
1971         case OP_GSERVENT:
1972         case OP_GPWNAM:
1973         case OP_GPWUID:
1974         case OP_GGRNAM:
1975         case OP_GGRGID:
1976         case OP_GETLOGIN:
1977         case OP_PROTOTYPE:
1978         case OP_RUNCV:
1979         func_ops:
1980             useless = OP_DESC(o);
1981             break;
1982
1983         case OP_GVSV:
1984         case OP_PADSV:
1985         case OP_PADAV:
1986         case OP_PADHV:
1987         case OP_PADANY:
1988         case OP_AELEM:
1989         case OP_AELEMFAST:
1990         case OP_AELEMFAST_LEX:
1991         case OP_ASLICE:
1992         case OP_HELEM:
1993         case OP_HSLICE:
1994             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1995                 /* Otherwise it's "Useless use of grep iterator" */
1996                 useless = OP_DESC(o);
1997             break;
1998
1999         case OP_SPLIT:
2000             if (!(o->op_private & OPpSPLIT_ASSIGN))
2001                 useless = OP_DESC(o);
2002             break;
2003
2004         case OP_NOT:
2005             kid = cUNOPo->op_first;
2006             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2007                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2008                 goto func_ops;
2009             }
2010             useless = "negative pattern binding (!~)";
2011             break;
2012
2013         case OP_SUBST:
2014             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2015                 useless = "non-destructive substitution (s///r)";
2016             break;
2017
2018         case OP_TRANSR:
2019             useless = "non-destructive transliteration (tr///r)";
2020             break;
2021
2022         case OP_RV2GV:
2023         case OP_RV2SV:
2024         case OP_RV2AV:
2025         case OP_RV2HV:
2026             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2027                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2028                 useless = "a variable";
2029             break;
2030
2031         case OP_CONST:
2032             sv = cSVOPo_sv;
2033             if (cSVOPo->op_private & OPpCONST_STRICT)
2034                 no_bareword_allowed(o);
2035             else {
2036                 if (ckWARN(WARN_VOID)) {
2037                     NV nv;
2038                     /* don't warn on optimised away booleans, eg
2039                      * use constant Foo, 5; Foo || print; */
2040                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2041                         useless = NULL;
2042                     /* the constants 0 and 1 are permitted as they are
2043                        conventionally used as dummies in constructs like
2044                        1 while some_condition_with_side_effects;  */
2045                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2046                         useless = NULL;
2047                     else if (SvPOK(sv)) {
2048                         SV * const dsv = newSVpvs("");
2049                         useless_sv
2050                             = Perl_newSVpvf(aTHX_
2051                                             "a constant (%s)",
2052                                             pv_pretty(dsv, SvPVX_const(sv),
2053                                                       SvCUR(sv), 32, NULL, NULL,
2054                                                       PERL_PV_PRETTY_DUMP
2055                                                       | PERL_PV_ESCAPE_NOCLEAR
2056                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2057                         SvREFCNT_dec_NN(dsv);
2058                     }
2059                     else if (SvOK(sv)) {
2060                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2061                     }
2062                     else
2063                         useless = "a constant (undef)";
2064                 }
2065             }
2066             op_null(o);         /* don't execute or even remember it */
2067             break;
2068
2069         case OP_POSTINC:
2070             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2071             break;
2072
2073         case OP_POSTDEC:
2074             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2075             break;
2076
2077         case OP_I_POSTINC:
2078             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2079             break;
2080
2081         case OP_I_POSTDEC:
2082             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2083             break;
2084
2085         case OP_SASSIGN: {
2086             OP *rv2gv;
2087             UNOP *refgen, *rv2cv;
2088             LISTOP *exlist;
2089
2090             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2091                 break;
2092
2093             rv2gv = ((BINOP *)o)->op_last;
2094             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2095                 break;
2096
2097             refgen = (UNOP *)((BINOP *)o)->op_first;
2098
2099             if (!refgen || (refgen->op_type != OP_REFGEN
2100                             && refgen->op_type != OP_SREFGEN))
2101                 break;
2102
2103             exlist = (LISTOP *)refgen->op_first;
2104             if (!exlist || exlist->op_type != OP_NULL
2105                 || exlist->op_targ != OP_LIST)
2106                 break;
2107
2108             if (exlist->op_first->op_type != OP_PUSHMARK
2109                 && exlist->op_first != exlist->op_last)
2110                 break;
2111
2112             rv2cv = (UNOP*)exlist->op_last;
2113
2114             if (rv2cv->op_type != OP_RV2CV)
2115                 break;
2116
2117             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2118             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2119             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2120
2121             o->op_private |= OPpASSIGN_CV_TO_GV;
2122             rv2gv->op_private |= OPpDONT_INIT_GV;
2123             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2124
2125             break;
2126         }
2127
2128         case OP_AASSIGN: {
2129             inplace_aassign(o);
2130             break;
2131         }
2132
2133         case OP_OR:
2134         case OP_AND:
2135             kid = cLOGOPo->op_first;
2136             if (kid->op_type == OP_NOT
2137                 && (kid->op_flags & OPf_KIDS)) {
2138                 if (o->op_type == OP_AND) {
2139                     OpTYPE_set(o, OP_OR);
2140                 } else {
2141                     OpTYPE_set(o, OP_AND);
2142                 }
2143                 op_null(kid);
2144             }
2145             /* FALLTHROUGH */
2146
2147         case OP_DOR:
2148         case OP_COND_EXPR:
2149         case OP_ENTERGIVEN:
2150         case OP_ENTERWHEN:
2151             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2152                 if (!(kid->op_flags & OPf_KIDS))
2153                     scalarvoid(kid);
2154                 else
2155                     DEFER_OP(kid);
2156         break;
2157
2158         case OP_NULL:
2159             if (o->op_flags & OPf_STACKED)
2160                 break;
2161             /* FALLTHROUGH */
2162         case OP_NEXTSTATE:
2163         case OP_DBSTATE:
2164         case OP_ENTERTRY:
2165         case OP_ENTER:
2166             if (!(o->op_flags & OPf_KIDS))
2167                 break;
2168             /* FALLTHROUGH */
2169         case OP_SCOPE:
2170         case OP_LEAVE:
2171         case OP_LEAVETRY:
2172         case OP_LEAVELOOP:
2173         case OP_LINESEQ:
2174         case OP_LEAVEGIVEN:
2175         case OP_LEAVEWHEN:
2176         kids:
2177             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2178                 if (!(kid->op_flags & OPf_KIDS))
2179                     scalarvoid(kid);
2180                 else
2181                     DEFER_OP(kid);
2182             break;
2183         case OP_LIST:
2184             /* If the first kid after pushmark is something that the padrange
2185                optimisation would reject, then null the list and the pushmark.
2186             */
2187             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2188                 && (  !(kid = OpSIBLING(kid))
2189                       || (  kid->op_type != OP_PADSV
2190                             && kid->op_type != OP_PADAV
2191                             && kid->op_type != OP_PADHV)
2192                       || kid->op_private & ~OPpLVAL_INTRO
2193                       || !(kid = OpSIBLING(kid))
2194                       || (  kid->op_type != OP_PADSV
2195                             && kid->op_type != OP_PADAV
2196                             && kid->op_type != OP_PADHV)
2197                       || kid->op_private & ~OPpLVAL_INTRO)
2198             ) {
2199                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2200                 op_null(o); /* NULL the list */
2201             }
2202             goto kids;
2203         case OP_ENTEREVAL:
2204             scalarkids(o);
2205             break;
2206         case OP_SCALAR:
2207             scalar(o);
2208             break;
2209         }
2210
2211         if (useless_sv) {
2212             /* mortalise it, in case warnings are fatal.  */
2213             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2214                            "Useless use of %" SVf " in void context",
2215                            SVfARG(sv_2mortal(useless_sv)));
2216         }
2217         else if (useless) {
2218             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2219                            "Useless use of %s in void context",
2220                            useless);
2221         }
2222     } while ( (o = POP_DEFERRED_OP()) );
2223
2224     Safefree(defer_stack);
2225
2226     return arg;
2227 }
2228
2229 static OP *
2230 S_listkids(pTHX_ OP *o)
2231 {
2232     if (o && o->op_flags & OPf_KIDS) {
2233         OP *kid;
2234         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2235             list(kid);
2236     }
2237     return o;
2238 }
2239
2240 OP *
2241 Perl_list(pTHX_ OP *o)
2242 {
2243     OP *kid;
2244
2245     /* assumes no premature commitment */
2246     if (!o || (o->op_flags & OPf_WANT)
2247          || (PL_parser && PL_parser->error_count)
2248          || o->op_type == OP_RETURN)
2249     {
2250         return o;
2251     }
2252
2253     if ((o->op_private & OPpTARGET_MY)
2254         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2255     {
2256         return o;                               /* As if inside SASSIGN */
2257     }
2258
2259     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2260
2261     switch (o->op_type) {
2262     case OP_FLOP:
2263         list(cBINOPo->op_first);
2264         break;
2265     case OP_REPEAT:
2266         if (o->op_private & OPpREPEAT_DOLIST
2267          && !(o->op_flags & OPf_STACKED))
2268         {
2269             list(cBINOPo->op_first);
2270             kid = cBINOPo->op_last;
2271             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2272              && SvIVX(kSVOP_sv) == 1)
2273             {
2274                 op_null(o); /* repeat */
2275                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2276                 /* const (rhs): */
2277                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2278             }
2279         }
2280         break;
2281     case OP_OR:
2282     case OP_AND:
2283     case OP_COND_EXPR:
2284         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2285             list(kid);
2286         break;
2287     default:
2288     case OP_MATCH:
2289     case OP_QR:
2290     case OP_SUBST:
2291     case OP_NULL:
2292         if (!(o->op_flags & OPf_KIDS))
2293             break;
2294         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2295             list(cBINOPo->op_first);
2296             return gen_constant_list(o);
2297         }
2298         listkids(o);
2299         break;
2300     case OP_LIST:
2301         listkids(o);
2302         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2303             op_null(cUNOPo->op_first); /* NULL the pushmark */
2304             op_null(o); /* NULL the list */
2305         }
2306         break;
2307     case OP_LEAVE:
2308     case OP_LEAVETRY:
2309         kid = cLISTOPo->op_first;
2310         list(kid);
2311         kid = OpSIBLING(kid);
2312     do_kids:
2313         while (kid) {
2314             OP *sib = OpSIBLING(kid);
2315             if (sib && kid->op_type != OP_LEAVEWHEN)
2316                 scalarvoid(kid);
2317             else
2318                 list(kid);
2319             kid = sib;
2320         }
2321         PL_curcop = &PL_compiling;
2322         break;
2323     case OP_SCOPE:
2324     case OP_LINESEQ:
2325         kid = cLISTOPo->op_first;
2326         goto do_kids;
2327     }
2328     return o;
2329 }
2330
2331 static OP *
2332 S_scalarseq(pTHX_ OP *o)
2333 {
2334     if (o) {
2335         const OPCODE type = o->op_type;
2336
2337         if (type == OP_LINESEQ || type == OP_SCOPE ||
2338             type == OP_LEAVE || type == OP_LEAVETRY)
2339         {
2340             OP *kid, *sib;
2341             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2342                 if ((sib = OpSIBLING(kid))
2343                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2344                     || (  sib->op_targ != OP_NEXTSTATE
2345                        && sib->op_targ != OP_DBSTATE  )))
2346                 {
2347                     scalarvoid(kid);
2348                 }
2349             }
2350             PL_curcop = &PL_compiling;
2351         }
2352         o->op_flags &= ~OPf_PARENS;
2353         if (PL_hints & HINT_BLOCK_SCOPE)
2354             o->op_flags |= OPf_PARENS;
2355     }
2356     else
2357         o = newOP(OP_STUB, 0);
2358     return o;
2359 }
2360
2361 STATIC OP *
2362 S_modkids(pTHX_ OP *o, I32 type)
2363 {
2364     if (o && o->op_flags & OPf_KIDS) {
2365         OP *kid;
2366         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2367             op_lvalue(kid, type);
2368     }
2369     return o;
2370 }
2371
2372
2373 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2374  * const fields. Also, convert CONST keys to HEK-in-SVs.
2375  * rop is the op that retrieves the hash;
2376  * key_op is the first key
2377  */
2378
2379 STATIC void
2380 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2381 {
2382     PADNAME *lexname;
2383     GV **fields;
2384     bool check_fields;
2385
2386     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2387     if (rop) {
2388         if (rop->op_first->op_type == OP_PADSV)
2389             /* @$hash{qw(keys here)} */
2390             rop = (UNOP*)rop->op_first;
2391         else {
2392             /* @{$hash}{qw(keys here)} */
2393             if (rop->op_first->op_type == OP_SCOPE
2394                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2395                 {
2396                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2397                 }
2398             else
2399                 rop = NULL;
2400         }
2401     }
2402
2403     lexname = NULL; /* just to silence compiler warnings */
2404     fields  = NULL; /* just to silence compiler warnings */
2405
2406     check_fields =
2407             rop
2408          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2409              SvPAD_TYPED(lexname))
2410          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2411          && isGV(*fields) && GvHV(*fields);
2412
2413     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2414         SV **svp, *sv;
2415         if (key_op->op_type != OP_CONST)
2416             continue;
2417         svp = cSVOPx_svp(key_op);
2418
2419         /* make sure it's not a bareword under strict subs */
2420         if (key_op->op_private & OPpCONST_BARE &&
2421             key_op->op_private & OPpCONST_STRICT)
2422         {
2423             no_bareword_allowed((OP*)key_op);
2424         }
2425
2426         /* Make the CONST have a shared SV */
2427         if (   !SvIsCOW_shared_hash(sv = *svp)
2428             && SvTYPE(sv) < SVt_PVMG
2429             && SvOK(sv)
2430             && !SvROK(sv))
2431         {
2432             SSize_t keylen;
2433             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2434             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2435             SvREFCNT_dec_NN(sv);
2436             *svp = nsv;
2437         }
2438
2439         if (   check_fields
2440             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2441         {
2442             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2443                         "in variable %" PNf " of type %" HEKf,
2444                         SVfARG(*svp), PNfARG(lexname),
2445                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2446         }
2447     }
2448 }
2449
2450
2451 /*
2452 =for apidoc finalize_optree
2453
2454 This function finalizes the optree.  Should be called directly after
2455 the complete optree is built.  It does some additional
2456 checking which can't be done in the normal C<ck_>xxx functions and makes
2457 the tree thread-safe.
2458
2459 =cut
2460 */
2461 void
2462 Perl_finalize_optree(pTHX_ OP* o)
2463 {
2464     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2465
2466     ENTER;
2467     SAVEVPTR(PL_curcop);
2468
2469     finalize_op(o);
2470
2471     LEAVE;
2472 }
2473
2474 #ifdef USE_ITHREADS
2475 /* Relocate sv to the pad for thread safety.
2476  * Despite being a "constant", the SV is written to,
2477  * for reference counts, sv_upgrade() etc. */
2478 PERL_STATIC_INLINE void
2479 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2480 {
2481     PADOFFSET ix;
2482     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2483     if (!*svp) return;
2484     ix = pad_alloc(OP_CONST, SVf_READONLY);
2485     SvREFCNT_dec(PAD_SVl(ix));
2486     PAD_SETSV(ix, *svp);
2487     /* XXX I don't know how this isn't readonly already. */
2488     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2489     *svp = NULL;
2490     *targp = ix;
2491 }
2492 #endif
2493
2494
2495 STATIC void
2496 S_finalize_op(pTHX_ OP* o)
2497 {
2498     PERL_ARGS_ASSERT_FINALIZE_OP;
2499
2500     assert(o->op_type != OP_FREED);
2501
2502     switch (o->op_type) {
2503     case OP_NEXTSTATE:
2504     case OP_DBSTATE:
2505         PL_curcop = ((COP*)o);          /* for warnings */
2506         break;
2507     case OP_EXEC:
2508         if (OpHAS_SIBLING(o)) {
2509             OP *sib = OpSIBLING(o);
2510             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2511                 && ckWARN(WARN_EXEC)
2512                 && OpHAS_SIBLING(sib))
2513             {
2514                     const OPCODE type = OpSIBLING(sib)->op_type;
2515                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2516                         const line_t oldline = CopLINE(PL_curcop);
2517                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2518                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2519                             "Statement unlikely to be reached");
2520                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2521                             "\t(Maybe you meant system() when you said exec()?)\n");
2522                         CopLINE_set(PL_curcop, oldline);
2523                     }
2524             }
2525         }
2526         break;
2527
2528     case OP_GV:
2529         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2530             GV * const gv = cGVOPo_gv;
2531             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2532                 /* XXX could check prototype here instead of just carping */
2533                 SV * const sv = sv_newmortal();
2534                 gv_efullname3(sv, gv, NULL);
2535                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2536                     "%" SVf "() called too early to check prototype",
2537                     SVfARG(sv));
2538             }
2539         }
2540         break;
2541
2542     case OP_CONST:
2543         if (cSVOPo->op_private & OPpCONST_STRICT)
2544             no_bareword_allowed(o);
2545         /* FALLTHROUGH */
2546 #ifdef USE_ITHREADS
2547     case OP_HINTSEVAL:
2548         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2549 #endif
2550         break;
2551
2552 #ifdef USE_ITHREADS
2553     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2554     case OP_METHOD_NAMED:
2555     case OP_METHOD_SUPER:
2556     case OP_METHOD_REDIR:
2557     case OP_METHOD_REDIR_SUPER:
2558         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2559         break;
2560 #endif
2561
2562     case OP_HELEM: {
2563         UNOP *rop;
2564         SVOP *key_op;
2565         OP *kid;
2566
2567         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2568             break;
2569
2570         rop = (UNOP*)((BINOP*)o)->op_first;
2571
2572         goto check_keys;
2573
2574     case OP_HSLICE:
2575         S_scalar_slice_warning(aTHX_ o);
2576         /* FALLTHROUGH */
2577
2578     case OP_KVHSLICE:
2579         kid = OpSIBLING(cLISTOPo->op_first);
2580         if (/* I bet there's always a pushmark... */
2581             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2582             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2583         {
2584             break;
2585         }
2586
2587         key_op = (SVOP*)(kid->op_type == OP_CONST
2588                                 ? kid
2589                                 : OpSIBLING(kLISTOP->op_first));
2590
2591         rop = (UNOP*)((LISTOP*)o)->op_last;
2592
2593       check_keys:
2594         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2595             rop = NULL;
2596         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2597         break;
2598     }
2599     case OP_ASLICE:
2600         S_scalar_slice_warning(aTHX_ o);
2601         break;
2602
2603     case OP_SUBST: {
2604         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2605             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2606         break;
2607     }
2608     default:
2609         break;
2610     }
2611
2612     if (o->op_flags & OPf_KIDS) {
2613         OP *kid;
2614
2615 #ifdef DEBUGGING
2616         /* check that op_last points to the last sibling, and that
2617          * the last op_sibling/op_sibparent field points back to the
2618          * parent, and that the only ops with KIDS are those which are
2619          * entitled to them */
2620         U32 type = o->op_type;
2621         U32 family;
2622         bool has_last;
2623
2624         if (type == OP_NULL) {
2625             type = o->op_targ;
2626             /* ck_glob creates a null UNOP with ex-type GLOB
2627              * (which is a list op. So pretend it wasn't a listop */
2628             if (type == OP_GLOB)
2629                 type = OP_NULL;
2630         }
2631         family = PL_opargs[type] & OA_CLASS_MASK;
2632
2633         has_last = (   family == OA_BINOP
2634                     || family == OA_LISTOP
2635                     || family == OA_PMOP
2636                     || family == OA_LOOP
2637                    );
2638         assert(  has_last /* has op_first and op_last, or ...
2639               ... has (or may have) op_first: */
2640               || family == OA_UNOP
2641               || family == OA_UNOP_AUX
2642               || family == OA_LOGOP
2643               || family == OA_BASEOP_OR_UNOP
2644               || family == OA_FILESTATOP
2645               || family == OA_LOOPEXOP
2646               || family == OA_METHOP
2647               || type == OP_CUSTOM
2648               || type == OP_NULL /* new_logop does this */
2649               );
2650
2651         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2652 #  ifdef PERL_OP_PARENT
2653             if (!OpHAS_SIBLING(kid)) {
2654                 if (has_last)
2655                     assert(kid == cLISTOPo->op_last);
2656                 assert(kid->op_sibparent == o);
2657             }
2658 #  else
2659             if (has_last && !OpHAS_SIBLING(kid))
2660                 assert(kid == cLISTOPo->op_last);
2661 #  endif
2662         }
2663 #endif
2664
2665         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2666             finalize_op(kid);
2667     }
2668 }
2669
2670 /*
2671 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2672
2673 Propagate lvalue ("modifiable") context to an op and its children.
2674 C<type> represents the context type, roughly based on the type of op that
2675 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2676 because it has no op type of its own (it is signalled by a flag on
2677 the lvalue op).
2678
2679 This function detects things that can't be modified, such as C<$x+1>, and
2680 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2681 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2682
2683 It also flags things that need to behave specially in an lvalue context,
2684 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2685
2686 =cut
2687 */
2688
2689 static void
2690 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2691 {
2692     CV *cv = PL_compcv;
2693     PadnameLVALUE_on(pn);
2694     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2695         cv = CvOUTSIDE(cv);
2696         /* RT #127786: cv can be NULL due to an eval within the DB package
2697          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2698          * unless they contain an eval, but calling eval within DB
2699          * pretends the eval was done in the caller's scope.
2700          */
2701         if (!cv)
2702             break;
2703         assert(CvPADLIST(cv));
2704         pn =
2705            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2706         assert(PadnameLEN(pn));
2707         PadnameLVALUE_on(pn);
2708     }
2709 }
2710
2711 static bool
2712 S_vivifies(const OPCODE type)
2713 {
2714     switch(type) {
2715     case OP_RV2AV:     case   OP_ASLICE:
2716     case OP_RV2HV:     case OP_KVASLICE:
2717     case OP_RV2SV:     case   OP_HSLICE:
2718     case OP_AELEMFAST: case OP_KVHSLICE:
2719     case OP_HELEM:
2720     case OP_AELEM:
2721         return 1;
2722     }
2723     return 0;
2724 }
2725
2726 static void
2727 S_lvref(pTHX_ OP *o, I32 type)
2728 {
2729     dVAR;
2730     OP *kid;
2731     switch (o->op_type) {
2732     case OP_COND_EXPR:
2733         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2734              kid = OpSIBLING(kid))
2735             S_lvref(aTHX_ kid, type);
2736         /* FALLTHROUGH */
2737     case OP_PUSHMARK:
2738         return;
2739     case OP_RV2AV:
2740         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2741         o->op_flags |= OPf_STACKED;
2742         if (o->op_flags & OPf_PARENS) {
2743             if (o->op_private & OPpLVAL_INTRO) {
2744                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2745                       "localized parenthesized array in list assignment"));
2746                 return;
2747             }
2748           slurpy:
2749             OpTYPE_set(o, OP_LVAVREF);
2750             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2751             o->op_flags |= OPf_MOD|OPf_REF;
2752             return;
2753         }
2754         o->op_private |= OPpLVREF_AV;
2755         goto checkgv;
2756     case OP_RV2CV:
2757         kid = cUNOPo->op_first;
2758         if (kid->op_type == OP_NULL)
2759             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2760                 ->op_first;
2761         o->op_private = OPpLVREF_CV;
2762         if (kid->op_type == OP_GV)
2763             o->op_flags |= OPf_STACKED;
2764         else if (kid->op_type == OP_PADCV) {
2765             o->op_targ = kid->op_targ;
2766             kid->op_targ = 0;
2767             op_free(cUNOPo->op_first);
2768             cUNOPo->op_first = NULL;
2769             o->op_flags &=~ OPf_KIDS;
2770         }
2771         else goto badref;
2772         break;
2773     case OP_RV2HV:
2774         if (o->op_flags & OPf_PARENS) {
2775           parenhash:
2776             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2777                                  "parenthesized hash in list assignment"));
2778                 return;
2779         }
2780         o->op_private |= OPpLVREF_HV;
2781         /* FALLTHROUGH */
2782     case OP_RV2SV:
2783       checkgv:
2784         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2785         o->op_flags |= OPf_STACKED;
2786         break;
2787     case OP_PADHV:
2788         if (o->op_flags & OPf_PARENS) goto parenhash;
2789         o->op_private |= OPpLVREF_HV;
2790         /* FALLTHROUGH */
2791     case OP_PADSV:
2792         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2793         break;
2794     case OP_PADAV:
2795         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2796         if (o->op_flags & OPf_PARENS) goto slurpy;
2797         o->op_private |= OPpLVREF_AV;
2798         break;
2799     case OP_AELEM:
2800     case OP_HELEM:
2801         o->op_private |= OPpLVREF_ELEM;
2802         o->op_flags   |= OPf_STACKED;
2803         break;
2804     case OP_ASLICE:
2805     case OP_HSLICE:
2806         OpTYPE_set(o, OP_LVREFSLICE);
2807         o->op_private &= OPpLVAL_INTRO;
2808         return;
2809     case OP_NULL:
2810         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2811             goto badref;
2812         else if (!(o->op_flags & OPf_KIDS))
2813             return;
2814         if (o->op_targ != OP_LIST) {
2815             S_lvref(aTHX_ cBINOPo->op_first, type);
2816             return;
2817         }
2818         /* FALLTHROUGH */
2819     case OP_LIST:
2820         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2821             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2822             S_lvref(aTHX_ kid, type);
2823         }
2824         return;
2825     case OP_STUB:
2826         if (o->op_flags & OPf_PARENS)
2827             return;
2828         /* FALLTHROUGH */
2829     default:
2830       badref:
2831         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2832         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2833                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2834                       ? "do block"
2835                       : OP_DESC(o),
2836                      PL_op_desc[type]));
2837         return;
2838     }
2839     OpTYPE_set(o, OP_LVREF);
2840     o->op_private &=
2841         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2842     if (type == OP_ENTERLOOP)
2843         o->op_private |= OPpLVREF_ITER;
2844 }
2845
2846 PERL_STATIC_INLINE bool
2847 S_potential_mod_type(I32 type)
2848 {
2849     /* Types that only potentially result in modification.  */
2850     return type == OP_GREPSTART || type == OP_ENTERSUB
2851         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2852 }
2853
2854 OP *
2855 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2856 {
2857     dVAR;
2858     OP *kid;
2859     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2860     int localize = -1;
2861
2862     if (!o || (PL_parser && PL_parser->error_count))
2863         return o;
2864
2865     if ((o->op_private & OPpTARGET_MY)
2866         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2867     {
2868         return o;
2869     }
2870
2871     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2872
2873     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2874
2875     switch (o->op_type) {
2876     case OP_UNDEF:
2877         PL_modcount++;
2878         return o;
2879     case OP_STUB:
2880         if ((o->op_flags & OPf_PARENS))
2881             break;
2882         goto nomod;
2883     case OP_ENTERSUB:
2884         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2885             !(o->op_flags & OPf_STACKED)) {
2886             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2887             assert(cUNOPo->op_first->op_type == OP_NULL);
2888             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2889             break;
2890         }
2891         else {                          /* lvalue subroutine call */
2892             o->op_private |= OPpLVAL_INTRO;
2893             PL_modcount = RETURN_UNLIMITED_NUMBER;
2894             if (S_potential_mod_type(type)) {
2895                 o->op_private |= OPpENTERSUB_INARGS;
2896                 break;
2897             }
2898             else {                      /* Compile-time error message: */
2899                 OP *kid = cUNOPo->op_first;
2900                 CV *cv;
2901                 GV *gv;
2902                 SV *namesv;
2903
2904                 if (kid->op_type != OP_PUSHMARK) {
2905                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2906                         Perl_croak(aTHX_
2907                                 "panic: unexpected lvalue entersub "
2908                                 "args: type/targ %ld:%" UVuf,
2909                                 (long)kid->op_type, (UV)kid->op_targ);
2910                     kid = kLISTOP->op_first;
2911                 }
2912                 while (OpHAS_SIBLING(kid))
2913                     kid = OpSIBLING(kid);
2914                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2915                     break;      /* Postpone until runtime */
2916                 }
2917
2918                 kid = kUNOP->op_first;
2919                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2920                     kid = kUNOP->op_first;
2921                 if (kid->op_type == OP_NULL)
2922                     Perl_croak(aTHX_
2923                                "Unexpected constant lvalue entersub "
2924                                "entry via type/targ %ld:%" UVuf,
2925                                (long)kid->op_type, (UV)kid->op_targ);
2926                 if (kid->op_type != OP_GV) {
2927                     break;
2928                 }
2929
2930                 gv = kGVOP_gv;
2931                 cv = isGV(gv)
2932                     ? GvCV(gv)
2933                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2934                         ? MUTABLE_CV(SvRV(gv))
2935                         : NULL;
2936                 if (!cv)
2937                     break;
2938                 if (CvLVALUE(cv))
2939                     break;
2940                 if (flags & OP_LVALUE_NO_CROAK)
2941                     return NULL;
2942
2943                 namesv = cv_name(cv, NULL, 0);
2944                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2945                                      "subroutine call of &%" SVf " in %s",
2946                                      SVfARG(namesv), PL_op_desc[type]),
2947                            SvUTF8(namesv));
2948                 return o;
2949             }
2950         }
2951         /* FALLTHROUGH */
2952     default:
2953       nomod:
2954         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2955         /* grep, foreach, subcalls, refgen */
2956         if (S_potential_mod_type(type))
2957             break;
2958         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2959                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2960                       ? "do block"
2961                       : OP_DESC(o)),
2962                      type ? PL_op_desc[type] : "local"));
2963         return o;
2964
2965     case OP_PREINC:
2966     case OP_PREDEC:
2967     case OP_POW:
2968     case OP_MULTIPLY:
2969     case OP_DIVIDE:
2970     case OP_MODULO:
2971     case OP_ADD:
2972     case OP_SUBTRACT:
2973     case OP_CONCAT:
2974     case OP_LEFT_SHIFT:
2975     case OP_RIGHT_SHIFT:
2976     case OP_BIT_AND:
2977     case OP_BIT_XOR:
2978     case OP_BIT_OR:
2979     case OP_I_MULTIPLY:
2980     case OP_I_DIVIDE:
2981     case OP_I_MODULO:
2982     case OP_I_ADD:
2983     case OP_I_SUBTRACT:
2984         if (!(o->op_flags & OPf_STACKED))
2985             goto nomod;
2986         PL_modcount++;
2987         break;
2988
2989     case OP_REPEAT:
2990         if (o->op_flags & OPf_STACKED) {
2991             PL_modcount++;
2992             break;
2993         }
2994         if (!(o->op_private & OPpREPEAT_DOLIST))
2995             goto nomod;
2996         else {
2997             const I32 mods = PL_modcount;
2998             modkids(cBINOPo->op_first, type);
2999             if (type != OP_AASSIGN)
3000                 goto nomod;
3001             kid = cBINOPo->op_last;
3002             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3003                 const IV iv = SvIV(kSVOP_sv);
3004                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3005                     PL_modcount =
3006                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3007             }
3008             else
3009                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3010         }
3011         break;
3012
3013     case OP_COND_EXPR:
3014         localize = 1;
3015         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3016             op_lvalue(kid, type);
3017         break;
3018
3019     case OP_RV2AV:
3020     case OP_RV2HV:
3021         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3022            PL_modcount = RETURN_UNLIMITED_NUMBER;
3023             return o;           /* Treat \(@foo) like ordinary list. */
3024         }
3025         /* FALLTHROUGH */
3026     case OP_RV2GV:
3027         if (scalar_mod_type(o, type))
3028             goto nomod;
3029         ref(cUNOPo->op_first, o->op_type);
3030         /* FALLTHROUGH */
3031     case OP_ASLICE:
3032     case OP_HSLICE:
3033         localize = 1;
3034         /* FALLTHROUGH */
3035     case OP_AASSIGN:
3036         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3037         if (type == OP_LEAVESUBLV && (
3038                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3039              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3040            ))
3041             o->op_private |= OPpMAYBE_LVSUB;
3042         /* FALLTHROUGH */
3043     case OP_NEXTSTATE:
3044     case OP_DBSTATE:
3045        PL_modcount = RETURN_UNLIMITED_NUMBER;
3046         break;
3047     case OP_KVHSLICE:
3048     case OP_KVASLICE:
3049     case OP_AKEYS:
3050         if (type == OP_LEAVESUBLV)
3051             o->op_private |= OPpMAYBE_LVSUB;
3052         goto nomod;
3053     case OP_AVHVSWITCH:
3054         if (type == OP_LEAVESUBLV
3055          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3056             o->op_private |= OPpMAYBE_LVSUB;
3057         goto nomod;
3058     case OP_AV2ARYLEN:
3059         PL_hints |= HINT_BLOCK_SCOPE;
3060         if (type == OP_LEAVESUBLV)
3061             o->op_private |= OPpMAYBE_LVSUB;
3062         PL_modcount++;
3063         break;
3064     case OP_RV2SV:
3065         ref(cUNOPo->op_first, o->op_type);
3066         localize = 1;
3067         /* FALLTHROUGH */
3068     case OP_GV:
3069         PL_hints |= HINT_BLOCK_SCOPE;
3070         /* FALLTHROUGH */
3071     case OP_SASSIGN:
3072     case OP_ANDASSIGN:
3073     case OP_ORASSIGN:
3074     case OP_DORASSIGN:
3075         PL_modcount++;
3076         break;
3077
3078     case OP_AELEMFAST:
3079     case OP_AELEMFAST_LEX:
3080         localize = -1;
3081         PL_modcount++;
3082         break;
3083
3084     case OP_PADAV:
3085     case OP_PADHV:
3086        PL_modcount = RETURN_UNLIMITED_NUMBER;
3087         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3088             return o;           /* Treat \(@foo) like ordinary list. */
3089         if (scalar_mod_type(o, type))
3090             goto nomod;
3091         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3092           && type == OP_LEAVESUBLV)
3093             o->op_private |= OPpMAYBE_LVSUB;
3094         /* FALLTHROUGH */
3095     case OP_PADSV:
3096         PL_modcount++;
3097         if (!type) /* local() */
3098             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3099                               PNfARG(PAD_COMPNAME(o->op_targ)));
3100         if (!(o->op_private & OPpLVAL_INTRO)
3101          || (  type != OP_SASSIGN && type != OP_AASSIGN
3102             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3103             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3104         break;
3105
3106     case OP_PUSHMARK:
3107         localize = 0;
3108         break;
3109
3110     case OP_KEYS:
3111         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3112             goto nomod;
3113         goto lvalue_func;
3114     case OP_SUBSTR:
3115         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3116             goto nomod;
3117         /* FALLTHROUGH */
3118     case OP_POS:
3119     case OP_VEC:
3120       lvalue_func:
3121         if (type == OP_LEAVESUBLV)
3122             o->op_private |= OPpMAYBE_LVSUB;
3123         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3124             /* substr and vec */
3125             /* If this op is in merely potential (non-fatal) modifiable
3126                context, then apply OP_ENTERSUB context to
3127                the kid op (to avoid croaking).  Other-
3128                wise pass this op’s own type so the correct op is mentioned
3129                in error messages.  */
3130             op_lvalue(OpSIBLING(cBINOPo->op_first),
3131                       S_potential_mod_type(type)
3132                         ? (I32)OP_ENTERSUB
3133                         : o->op_type);
3134         }
3135         break;
3136
3137     case OP_AELEM:
3138     case OP_HELEM:
3139         ref(cBINOPo->op_first, o->op_type);
3140         if (type == OP_ENTERSUB &&
3141              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3142             o->op_private |= OPpLVAL_DEFER;
3143         if (type == OP_LEAVESUBLV)
3144             o->op_private |= OPpMAYBE_LVSUB;
3145         localize = 1;
3146         PL_modcount++;
3147         break;
3148
3149     case OP_LEAVE:
3150     case OP_LEAVELOOP:
3151         o->op_private |= OPpLVALUE;
3152         /* FALLTHROUGH */
3153     case OP_SCOPE:
3154     case OP_ENTER:
3155     case OP_LINESEQ:
3156         localize = 0;
3157         if (o->op_flags & OPf_KIDS)
3158             op_lvalue(cLISTOPo->op_last, type);
3159         break;
3160
3161     case OP_NULL:
3162         localize = 0;
3163         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3164             goto nomod;
3165         else if (!(o->op_flags & OPf_KIDS))
3166             break;
3167         if (o->op_targ != OP_LIST) {
3168             op_lvalue(cBINOPo->op_first, type);
3169             break;
3170         }
3171         /* FALLTHROUGH */
3172     case OP_LIST:
3173         localize = 0;
3174         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3175             /* elements might be in void context because the list is
3176                in scalar context or because they are attribute sub calls */
3177             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3178                 op_lvalue(kid, type);
3179         break;
3180
3181     case OP_COREARGS:
3182         return o;
3183
3184     case OP_AND:
3185     case OP_OR:
3186         if (type == OP_LEAVESUBLV
3187          || !S_vivifies(cLOGOPo->op_first->op_type))
3188             op_lvalue(cLOGOPo->op_first, type);
3189         if (type == OP_LEAVESUBLV
3190          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3191             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3192         goto nomod;
3193
3194     case OP_SREFGEN:
3195         if (type == OP_NULL) { /* local */
3196           local_refgen:
3197             if (!FEATURE_MYREF_IS_ENABLED)
3198                 Perl_croak(aTHX_ "The experimental declared_refs "
3199                                  "feature is not enabled");
3200             Perl_ck_warner_d(aTHX_
3201                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3202                     "Declaring references is experimental");
3203             op_lvalue(cUNOPo->op_first, OP_NULL);
3204             return o;
3205         }
3206         if (type != OP_AASSIGN && type != OP_SASSIGN
3207          && type != OP_ENTERLOOP)
3208             goto nomod;
3209         /* Don’t bother applying lvalue context to the ex-list.  */
3210         kid = cUNOPx(cUNOPo->op_first)->op_first;
3211         assert (!OpHAS_SIBLING(kid));
3212         goto kid_2lvref;
3213     case OP_REFGEN:
3214         if (type == OP_NULL) /* local */
3215             goto local_refgen;
3216         if (type != OP_AASSIGN) goto nomod;
3217         kid = cUNOPo->op_first;
3218       kid_2lvref:
3219         {
3220             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3221             S_lvref(aTHX_ kid, type);
3222             if (!PL_parser || PL_parser->error_count == ec) {
3223                 if (!FEATURE_REFALIASING_IS_ENABLED)
3224                     Perl_croak(aTHX_
3225                        "Experimental aliasing via reference not enabled");
3226                 Perl_ck_warner_d(aTHX_
3227                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3228                                 "Aliasing via reference is experimental");
3229             }
3230         }
3231         if (o->op_type == OP_REFGEN)
3232             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3233         op_null(o);
3234         return o;
3235
3236     case OP_SPLIT:
3237         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3238             /* This is actually @array = split.  */
3239             PL_modcount = RETURN_UNLIMITED_NUMBER;
3240             break;
3241         }
3242         goto nomod;
3243
3244     case OP_SCALAR:
3245         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3246         goto nomod;
3247     }
3248
3249     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3250        their argument is a filehandle; thus \stat(".") should not set
3251        it. AMS 20011102 */
3252     if (type == OP_REFGEN &&
3253         PL_check[o->op_type] == Perl_ck_ftst)
3254         return o;
3255
3256     if (type != OP_LEAVESUBLV)
3257         o->op_flags |= OPf_MOD;
3258
3259     if (type == OP_AASSIGN || type == OP_SASSIGN)
3260         o->op_flags |= OPf_SPECIAL
3261                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3262     else if (!type) { /* local() */
3263         switch (localize) {
3264         case 1:
3265             o->op_private |= OPpLVAL_INTRO;
3266             o->op_flags &= ~OPf_SPECIAL;
3267             PL_hints |= HINT_BLOCK_SCOPE;
3268             break;
3269         case 0:
3270             break;
3271         case -1:
3272             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3273                            "Useless localization of %s", OP_DESC(o));
3274         }
3275     }
3276     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3277              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3278         o->op_flags |= OPf_REF;
3279     return o;
3280 }
3281
3282 STATIC bool
3283 S_scalar_mod_type(const OP *o, I32 type)
3284 {
3285     switch (type) {
3286     case OP_POS:
3287     case OP_SASSIGN:
3288         if (o && o->op_type == OP_RV2GV)
3289             return FALSE;
3290         /* FALLTHROUGH */
3291     case OP_PREINC:
3292     case OP_PREDEC:
3293     case OP_POSTINC:
3294     case OP_POSTDEC:
3295     case OP_I_PREINC:
3296     case OP_I_PREDEC:
3297     case OP_I_POSTINC:
3298     case OP_I_POSTDEC:
3299     case OP_POW:
3300     case OP_MULTIPLY:
3301     case OP_DIVIDE:
3302     case OP_MODULO:
3303     case OP_REPEAT:
3304     case OP_ADD:
3305     case OP_SUBTRACT:
3306     case OP_I_MULTIPLY:
3307     case OP_I_DIVIDE:
3308     case OP_I_MODULO:
3309     case OP_I_ADD:
3310     case OP_I_SUBTRACT:
3311     case OP_LEFT_SHIFT:
3312     case OP_RIGHT_SHIFT:
3313     case OP_BIT_AND:
3314     case OP_BIT_XOR:
3315     case OP_BIT_OR:
3316     case OP_NBIT_AND:
3317     case OP_NBIT_XOR:
3318     case OP_NBIT_OR:
3319     case OP_SBIT_AND:
3320     case OP_SBIT_XOR:
3321     case OP_SBIT_OR:
3322     case OP_CONCAT:
3323     case OP_SUBST:
3324     case OP_TRANS:
3325     case OP_TRANSR:
3326     case OP_READ:
3327     case OP_SYSREAD:
3328     case OP_RECV:
3329     case OP_ANDASSIGN:
3330     case OP_ORASSIGN:
3331     case OP_DORASSIGN:
3332     case OP_VEC:
3333     case OP_SUBSTR:
3334         return TRUE;
3335     default:
3336         return FALSE;
3337     }
3338 }
3339
3340 STATIC bool
3341 S_is_handle_constructor(const OP *o, I32 numargs)
3342 {
3343     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3344
3345     switch (o->op_type) {
3346     case OP_PIPE_OP:
3347     case OP_SOCKPAIR:
3348         if (numargs == 2)
3349             return TRUE;
3350         /* FALLTHROUGH */
3351     case OP_SYSOPEN:
3352     case OP_OPEN:
3353     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3354     case OP_SOCKET:
3355     case OP_OPEN_DIR:
3356     case OP_ACCEPT:
3357         if (numargs == 1)
3358             return TRUE;
3359         /* FALLTHROUGH */
3360     default:
3361         return FALSE;
3362     }
3363 }
3364
3365 static OP *
3366 S_refkids(pTHX_ OP *o, I32 type)
3367 {
3368     if (o && o->op_flags & OPf_KIDS) {
3369         OP *kid;
3370         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3371             ref(kid, type);
3372     }
3373     return o;
3374 }
3375
3376 OP *
3377 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3378 {
3379     dVAR;
3380     OP *kid;
3381
3382     PERL_ARGS_ASSERT_DOREF;
3383
3384     if (PL_parser && PL_parser->error_count)
3385         return o;
3386
3387     switch (o->op_type) {
3388     case OP_ENTERSUB:
3389         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3390             !(o->op_flags & OPf_STACKED)) {
3391             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3392             assert(cUNOPo->op_first->op_type == OP_NULL);
3393             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3394             o->op_flags |= OPf_SPECIAL;
3395         }
3396         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3397             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3398                               : type == OP_RV2HV ? OPpDEREF_HV
3399                               : OPpDEREF_SV);
3400             o->op_flags |= OPf_MOD;
3401         }
3402
3403         break;
3404
3405     case OP_COND_EXPR:
3406         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3407             doref(kid, type, set_op_ref);
3408         break;
3409     case OP_RV2SV:
3410         if (type == OP_DEFINED)
3411             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3412         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3413         /* FALLTHROUGH */
3414     case OP_PADSV:
3415         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3416             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3417                               : type == OP_RV2HV ? OPpDEREF_HV
3418                               : OPpDEREF_SV);
3419             o->op_flags |= OPf_MOD;
3420         }
3421         break;
3422
3423     case OP_RV2AV:
3424     case OP_RV2HV:
3425         if (set_op_ref)
3426             o->op_flags |= OPf_REF;
3427         /* FALLTHROUGH */
3428     case OP_RV2GV:
3429         if (type == OP_DEFINED)
3430             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3431         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3432         break;
3433
3434     case OP_PADAV:
3435     case OP_PADHV:
3436         if (set_op_ref)
3437             o->op_flags |= OPf_REF;
3438         break;
3439
3440     case OP_SCALAR:
3441     case OP_NULL:
3442         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3443             break;
3444         doref(cBINOPo->op_first, type, set_op_ref);
3445         break;
3446     case OP_AELEM:
3447     case OP_HELEM:
3448         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3449         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3450             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3451                               : type == OP_RV2HV ? OPpDEREF_HV
3452                               : OPpDEREF_SV);
3453             o->op_flags |= OPf_MOD;
3454         }
3455         break;
3456
3457     case OP_SCOPE:
3458     case OP_LEAVE:
3459         set_op_ref = FALSE;
3460         /* FALLTHROUGH */
3461     case OP_ENTER:
3462     case OP_LIST:
3463         if (!(o->op_flags & OPf_KIDS))
3464             break;
3465         doref(cLISTOPo->op_last, type, set_op_ref);
3466         break;
3467     default:
3468         break;
3469     }
3470     return scalar(o);
3471
3472 }
3473
3474 STATIC OP *
3475 S_dup_attrlist(pTHX_ OP *o)
3476 {
3477     OP *rop;
3478
3479     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3480
3481     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3482      * where the first kid is OP_PUSHMARK and the remaining ones
3483      * are OP_CONST.  We need to push the OP_CONST values.
3484      */
3485     if (o->op_type == OP_CONST)
3486         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3487     else {
3488         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3489         rop = NULL;
3490         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3491             if (o->op_type == OP_CONST)
3492                 rop = op_append_elem(OP_LIST, rop,
3493                                   newSVOP(OP_CONST, o->op_flags,
3494                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3495         }
3496     }
3497     return rop;
3498 }
3499
3500 STATIC void
3501 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3502 {
3503     PERL_ARGS_ASSERT_APPLY_ATTRS;
3504     {
3505         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3506
3507         /* fake up C<use attributes $pkg,$rv,@attrs> */
3508
3509 #define ATTRSMODULE "attributes"
3510 #define ATTRSMODULE_PM "attributes.pm"
3511
3512         Perl_load_module(
3513           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3514           newSVpvs(ATTRSMODULE),
3515           NULL,
3516           op_prepend_elem(OP_LIST,
3517                           newSVOP(OP_CONST, 0, stashsv),
3518                           op_prepend_elem(OP_LIST,
3519                                           newSVOP(OP_CONST, 0,
3520                                                   newRV(target)),
3521                                           dup_attrlist(attrs))));
3522     }
3523 }
3524
3525 STATIC void
3526 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3527 {
3528     OP *pack, *imop, *arg;
3529     SV *meth, *stashsv, **svp;
3530
3531     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3532
3533     if (!attrs)
3534         return;
3535
3536     assert(target->op_type == OP_PADSV ||
3537            target->op_type == OP_PADHV ||
3538            target->op_type == OP_PADAV);
3539
3540     /* Ensure that attributes.pm is loaded. */
3541     /* Don't force the C<use> if we don't need it. */
3542     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3543     if (svp && *svp != &PL_sv_undef)
3544         NOOP;   /* already in %INC */
3545     else
3546         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3547                                newSVpvs(ATTRSMODULE), NULL);
3548
3549     /* Need package name for method call. */
3550     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3551
3552     /* Build up the real arg-list. */
3553     stashsv = newSVhek(HvNAME_HEK(stash));
3554
3555     arg = newOP(OP_PADSV, 0);
3556     arg->op_targ = target->op_targ;
3557     arg = op_prepend_elem(OP_LIST,
3558                        newSVOP(OP_CONST, 0, stashsv),
3559                        op_prepend_elem(OP_LIST,
3560                                     newUNOP(OP_REFGEN, 0,
3561                                             arg),
3562                                     dup_attrlist(attrs)));
3563
3564     /* Fake up a method call to import */
3565     meth = newSVpvs_share("import");
3566     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3567                    op_append_elem(OP_LIST,
3568                                op_prepend_elem(OP_LIST, pack, arg),
3569                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3570
3571     /* Combine the ops. */
3572     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3573 }
3574
3575 /*
3576 =notfor apidoc apply_attrs_string
3577
3578 Attempts to apply a list of attributes specified by the C<attrstr> and
3579 C<len> arguments to the subroutine identified by the C<cv> argument which
3580 is expected to be associated with the package identified by the C<stashpv>
3581 argument (see L<attributes>).  It gets this wrong, though, in that it
3582 does not correctly identify the boundaries of the individual attribute
3583 specifications within C<attrstr>.  This is not really intended for the
3584 public API, but has to be listed here for systems such as AIX which
3585 need an explicit export list for symbols.  (It's called from XS code
3586 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3587 to respect attribute syntax properly would be welcome.
3588
3589 =cut
3590 */
3591
3592 void
3593 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3594                         const char *attrstr, STRLEN len)
3595 {
3596     OP *attrs = NULL;
3597
3598     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3599
3600     if (!len) {
3601         len = strlen(attrstr);
3602     }
3603
3604     while (len) {
3605         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3606         if (len) {
3607             const char * const sstr = attrstr;
3608             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3609             attrs = op_append_elem(OP_LIST, attrs,
3610                                 newSVOP(OP_CONST, 0,
3611                                         newSVpvn(sstr, attrstr-sstr)));
3612         }
3613     }
3614
3615     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3616                      newSVpvs(ATTRSMODULE),
3617                      NULL, op_prepend_elem(OP_LIST,
3618                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3619                                   op_prepend_elem(OP_LIST,
3620                                                newSVOP(OP_CONST, 0,
3621                                                        newRV(MUTABLE_SV(cv))),
3622                                                attrs)));
3623 }
3624
3625 STATIC void
3626 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3627 {
3628     OP *new_proto = NULL;
3629     STRLEN pvlen;
3630     char *pv;
3631     OP *o;
3632
3633     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3634
3635     if (!*attrs)
3636         return;
3637
3638     o = *attrs;
3639     if (o->op_type == OP_CONST) {
3640         pv = SvPV(cSVOPo_sv, pvlen);
3641         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3642             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3643             SV ** const tmpo = cSVOPx_svp(o);
3644             SvREFCNT_dec(cSVOPo_sv);
3645             *tmpo = tmpsv;
3646             new_proto = o;
3647             *attrs = NULL;
3648         }
3649     } else if (o->op_type == OP_LIST) {
3650         OP * lasto;
3651         assert(o->op_flags & OPf_KIDS);
3652         lasto = cLISTOPo->op_first;
3653         assert(lasto->op_type == OP_PUSHMARK);
3654         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3655             if (o->op_type == OP_CONST) {
3656                 pv = SvPV(cSVOPo_sv, pvlen);
3657                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3658                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3659                     SV ** const tmpo = cSVOPx_svp(o);
3660                     SvREFCNT_dec(cSVOPo_sv);
3661                     *tmpo = tmpsv;
3662                     if (new_proto && ckWARN(WARN_MISC)) {
3663                         STRLEN new_len;
3664                         const char * newp = SvPV(cSVOPo_sv, new_len);
3665                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3666                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3667                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3668                         op_free(new_proto);
3669                     }
3670                     else if (new_proto)
3671                         op_free(new_proto);
3672                     new_proto = o;
3673                     /* excise new_proto from the list */
3674                     op_sibling_splice(*attrs, lasto, 1, NULL);
3675                     o = lasto;
3676                     continue;
3677                 }
3678             }
3679             lasto = o;
3680         }
3681         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3682            would get pulled in with no real need */
3683         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3684             op_free(*attrs);
3685             *attrs = NULL;
3686         }
3687     }
3688
3689     if (new_proto) {
3690         SV *svname;
3691         if (isGV(name)) {
3692             svname = sv_newmortal();
3693             gv_efullname3(svname, name, NULL);
3694         }
3695         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3696             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3697         else
3698             svname = (SV *)name;
3699         if (ckWARN(WARN_ILLEGALPROTO))
3700             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3701         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3702             STRLEN old_len, new_len;
3703             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3704             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3705
3706             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3707                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3708                 " in %" SVf,
3709                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3710                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3711                 SVfARG(svname));
3712         }
3713         if (*proto)
3714             op_free(*proto);
3715         *proto = new_proto;
3716     }
3717 }
3718
3719 static void
3720 S_cant_declare(pTHX_ OP *o)
3721 {
3722     if (o->op_type == OP_NULL
3723      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3724         o = cUNOPo->op_first;
3725     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3726                              o->op_type == OP_NULL
3727                                && o->op_flags & OPf_SPECIAL
3728                                  ? "do block"
3729                                  : OP_DESC(o),
3730                              PL_parser->in_my == KEY_our   ? "our"   :
3731                              PL_parser->in_my == KEY_state ? "state" :
3732                                                              "my"));
3733 }
3734
3735 STATIC OP *
3736 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3737 {
3738     I32 type;
3739     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3740
3741     PERL_ARGS_ASSERT_MY_KID;
3742
3743     if (!o || (PL_parser && PL_parser->error_count))
3744         return o;
3745
3746     type = o->op_type;
3747
3748     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3749         OP *kid;
3750         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3751             my_kid(kid, attrs, imopsp);
3752         return o;
3753     } else if (type == OP_UNDEF || type == OP_STUB) {
3754         return o;
3755     } else if (type == OP_RV2SV ||      /* "our" declaration */
3756                type == OP_RV2AV ||
3757                type == OP_RV2HV) {
3758         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3759             S_cant_declare(aTHX_ o);
3760         } else if (attrs) {
3761             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3762             assert(PL_parser);
3763             PL_parser->in_my = FALSE;
3764             PL_parser->in_my_stash = NULL;
3765             apply_attrs(GvSTASH(gv),
3766                         (type == OP_RV2SV ? GvSV(gv) :
3767                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3768                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3769                         attrs);
3770         }
3771         o->op_private |= OPpOUR_INTRO;
3772         return o;
3773     }
3774     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3775         if (!FEATURE_MYREF_IS_ENABLED)
3776             Perl_croak(aTHX_ "The experimental declared_refs "
3777                              "feature is not enabled");
3778         Perl_ck_warner_d(aTHX_
3779              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3780             "Declaring references is experimental");
3781         /* Kid is a nulled OP_LIST, handled above.  */
3782         my_kid(cUNOPo->op_first, attrs, imopsp);
3783         return o;
3784     }
3785     else if (type != OP_PADSV &&
3786              type != OP_PADAV &&
3787              type != OP_PADHV &&
3788              type != OP_PUSHMARK)
3789     {
3790         S_cant_declare(aTHX_ o);
3791         return o;
3792     }
3793     else if (attrs && type != OP_PUSHMARK) {
3794         HV *stash;
3795
3796         assert(PL_parser);
3797         PL_parser->in_my = FALSE;
3798         PL_parser->in_my_stash = NULL;
3799
3800         /* check for C<my Dog $spot> when deciding package */
3801         stash = PAD_COMPNAME_TYPE(o->op_targ);
3802         if (!stash)
3803             stash = PL_curstash;
3804         apply_attrs_my(stash, o, attrs, imopsp);
3805     }
3806     o->op_flags |= OPf_MOD;
3807     o->op_private |= OPpLVAL_INTRO;
3808     if (stately)
3809         o->op_private |= OPpPAD_STATE;
3810     return o;
3811 }
3812
3813 OP *
3814 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3815 {
3816     OP *rops;
3817     int maybe_scalar = 0;
3818
3819     PERL_ARGS_ASSERT_MY_ATTRS;
3820
3821 /* [perl #17376]: this appears to be premature, and results in code such as
3822    C< our(%x); > executing in list mode rather than void mode */
3823 #if 0
3824     if (o->op_flags & OPf_PARENS)
3825         list(o);
3826     else
3827         maybe_scalar = 1;
3828 #else
3829     maybe_scalar = 1;
3830 #endif
3831     if (attrs)
3832         SAVEFREEOP(attrs);
3833     rops = NULL;
3834     o = my_kid(o, attrs, &rops);
3835     if (rops) {
3836         if (maybe_scalar && o->op_type == OP_PADSV) {
3837             o = scalar(op_append_list(OP_LIST, rops, o));
3838             o->op_private |= OPpLVAL_INTRO;
3839         }
3840         else {
3841             /* The listop in rops might have a pushmark at the beginning,
3842                which will mess up list assignment. */
3843             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3844             if (rops->op_type == OP_LIST &&
3845                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3846             {
3847                 OP * const pushmark = lrops->op_first;
3848                 /* excise pushmark */
3849                 op_sibling_splice(rops, NULL, 1, NULL);
3850                 op_free(pushmark);
3851             }
3852             o = op_append_list(OP_LIST, o, rops);
3853         }
3854     }
3855     PL_parser->in_my = FALSE;
3856     PL_parser->in_my_stash = NULL;
3857     return o;
3858 }
3859
3860 OP *
3861 Perl_sawparens(pTHX_ OP *o)
3862 {
3863     PERL_UNUSED_CONTEXT;
3864     if (o)
3865         o->op_flags |= OPf_PARENS;
3866     return o;
3867 }
3868
3869 OP *
3870 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3871 {
3872     OP *o;
3873     bool ismatchop = 0;
3874     const OPCODE ltype = left->op_type;
3875     const OPCODE rtype = right->op_type;
3876
3877     PERL_ARGS_ASSERT_BIND_MATCH;
3878
3879     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3880           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3881     {
3882       const char * const desc
3883           = PL_op_desc[(
3884                           rtype == OP_SUBST || rtype == OP_TRANS
3885                        || rtype == OP_TRANSR
3886                        )
3887                        ? (int)rtype : OP_MATCH];
3888       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3889       SV * const name =
3890         S_op_varname(aTHX_ left);
3891       if (name)
3892         Perl_warner(aTHX_ packWARN(WARN_MISC),
3893              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3894              desc, SVfARG(name), SVfARG(name));
3895       else {
3896         const char * const sample = (isary
3897              ? "@array" : "%hash");
3898         Perl_warner(aTHX_ packWARN(WARN_MISC),
3899              "Applying %s to %s will act on scalar(%s)",
3900              desc, sample, sample);
3901       }
3902     }
3903
3904     if (rtype == OP_CONST &&
3905         cSVOPx(right)->op_private & OPpCONST_BARE &&
3906         cSVOPx(right)->op_private & OPpCONST_STRICT)
3907     {
3908         no_bareword_allowed(right);
3909     }
3910
3911     /* !~ doesn't make sense with /r, so error on it for now */
3912     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3913         type == OP_NOT)
3914         /* diag_listed_as: Using !~ with %s doesn't make sense */
3915         yyerror("Using !~ with s///r doesn't make sense");
3916     if (rtype == OP_TRANSR && type == OP_NOT)
3917         /* diag_listed_as: Using !~ with %s doesn't make sense */
3918         yyerror("Using !~ with tr///r doesn't make sense");
3919
3920     ismatchop = (rtype == OP_MATCH ||
3921                  rtype == OP_SUBST ||
3922                  rtype == OP_TRANS || rtype == OP_TRANSR)
3923              && !(right->op_flags & OPf_SPECIAL);
3924     if (ismatchop && right->op_private & OPpTARGET_MY) {
3925         right->op_targ = 0;
3926         right->op_private &= ~OPpTARGET_MY;
3927     }
3928     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3929         if (left->op_type == OP_PADSV
3930          && !(left->op_private & OPpLVAL_INTRO))
3931         {
3932             right->op_targ = left->op_targ;
3933             op_free(left);
3934             o = right;
3935         }
3936         else {
3937             right->op_flags |= OPf_STACKED;
3938             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3939             ! (rtype == OP_TRANS &&
3940                right->op_private & OPpTRANS_IDENTICAL) &&
3941             ! (rtype == OP_SUBST &&
3942                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3943                 left = op_lvalue(left, rtype);
3944             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3945                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3946             else
3947                 o = op_prepend_elem(rtype, scalar(left), right);
3948         }
3949         if (type == OP_NOT)
3950             return newUNOP(OP_NOT, 0, scalar(o));
3951         return o;
3952     }
3953     else
3954         return bind_match(type, left,
3955                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3956 }
3957
3958 OP *
3959 Perl_invert(pTHX_ OP *o)
3960 {
3961     if (!o)
3962         return NULL;
3963     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3964 }
3965
3966 /*
3967 =for apidoc Amx|OP *|op_scope|OP *o
3968
3969 Wraps up an op tree with some additional ops so that at runtime a dynamic
3970 scope will be created.  The original ops run in the new dynamic scope,
3971 and then, provided that they exit normally, the scope will be unwound.
3972 The additional ops used to create and unwind the dynamic scope will
3973 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3974 instead if the ops are simple enough to not need the full dynamic scope
3975 structure.
3976
3977 =cut
3978 */
3979
3980 OP *
3981 Perl_op_scope(pTHX_ OP *o)
3982 {
3983     dVAR;
3984     if (o) {
3985         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3986             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3987             OpTYPE_set(o, OP_LEAVE);
3988         }
3989         else if (o->op_type == OP_LINESEQ) {
3990             OP *kid;
3991             OpTYPE_set(o, OP_SCOPE);
3992             kid = ((LISTOP*)o)->op_first;
3993             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3994                 op_null(kid);
3995
3996                 /* The following deals with things like 'do {1 for 1}' */
3997                 kid = OpSIBLING(kid);
3998                 if (kid &&
3999                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4000                     op_null(kid);
4001             }
4002         }
4003         else
4004             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4005     }
4006     return o;
4007 }
4008
4009 OP *
4010 Perl_op_unscope(pTHX_ OP *o)
4011 {
4012     if (o && o->op_type == OP_LINESEQ) {
4013         OP *kid = cLISTOPo->op_first;
4014         for(; kid; kid = OpSIBLING(kid))
4015             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4016                 op_null(kid);
4017     }
4018     return o;
4019 }
4020
4021 /*
4022 =for apidoc Am|int|block_start|int full
4023
4024 Handles compile-time scope entry.
4025 Arranges for hints to be restored on block
4026 exit and also handles pad sequence numbers to make lexical variables scope
4027 right.  Returns a savestack index for use with C<block_end>.
4028
4029 =cut
4030 */
4031
4032 int
4033 Perl_block_start(pTHX_ int full)
4034 {
4035     const int retval = PL_savestack_ix;
4036
4037     PL_compiling.cop_seq = PL_cop_seqmax;
4038     COP_SEQMAX_INC;
4039     pad_block_start(full);
4040     SAVEHINTS();
4041     PL_hints &= ~HINT_BLOCK_SCOPE;
4042     SAVECOMPILEWARNINGS();
4043     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4044     SAVEI32(PL_compiling.cop_seq);
4045     PL_compiling.cop_seq = 0;
4046
4047     CALL_BLOCK_HOOKS(bhk_start, full);
4048
4049     return retval;
4050 }
4051
4052 /*
4053 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4054
4055 Handles compile-time scope exit.  C<floor>
4056 is the savestack index returned by
4057 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4058 possibly modified.
4059
4060 =cut
4061 */
4062
4063 OP*
4064 Perl_block_end(pTHX_ I32 floor, OP *seq)
4065 {
4066     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4067     OP* retval = scalarseq(seq);
4068     OP *o;
4069
4070     /* XXX Is the null PL_parser check necessary here? */
4071     assert(PL_parser); /* Let’s find out under debugging builds.  */
4072     if (PL_parser && PL_parser->parsed_sub) {
4073         o = newSTATEOP(0, NULL, NULL);
4074         op_null(o);
4075         retval = op_append_elem(OP_LINESEQ, retval, o);
4076     }
4077
4078     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4079
4080     LEAVE_SCOPE(floor);
4081     if (needblockscope)
4082         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4083     o = pad_leavemy();
4084
4085     if (o) {
4086         /* pad_leavemy has created a sequence of introcv ops for all my
4087            subs declared in the block.  We have to replicate that list with
4088            clonecv ops, to deal with this situation:
4089
4090                sub {
4091                    my sub s1;
4092                    my sub s2;
4093                    sub s1 { state sub foo { \&s2 } }
4094                }->()
4095
4096            Originally, I was going to have introcv clone the CV and turn
4097            off the stale flag.  Since &s1 is declared before &s2, the
4098            introcv op for &s1 is executed (on sub entry) before the one for
4099            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4100            cloned, since it is a state sub) closes over &s2 and expects
4101            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4102            then &s2 is still marked stale.  Since &s1 is not active, and
4103            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4104            ble will not stay shared’ warning.  Because it is the same stub
4105            that will be used when the introcv op for &s2 is executed, clos-
4106            ing over it is safe.  Hence, we have to turn off the stale flag
4107            on all lexical subs in the block before we clone any of them.
4108            Hence, having introcv clone the sub cannot work.  So we create a
4109            list of ops like this:
4110
4111                lineseq
4112                   |
4113                   +-- introcv
4114                   |
4115                   +-- introcv
4116                   |
4117                   +-- introcv
4118                   |
4119                   .
4120                   .
4121                   .
4122                   |
4123                   +-- clonecv
4124                   |
4125                   +-- clonecv
4126                   |
4127                   +-- clonecv
4128                   |
4129                   .
4130                   .
4131                   .
4132          */
4133         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4134         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4135         for (;; kid = OpSIBLING(kid)) {
4136             OP *newkid = newOP(OP_CLONECV, 0);
4137             newkid->op_targ = kid->op_targ;
4138             o = op_append_elem(OP_LINESEQ, o, newkid);
4139             if (kid == last) break;
4140         }
4141         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4142     }
4143
4144     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4145
4146     return retval;
4147 }
4148
4149 /*
4150 =head1 Compile-time scope hooks
4151
4152 =for apidoc Aox||blockhook_register
4153
4154 Register a set of hooks to be called when the Perl lexical scope changes
4155 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4156
4157 =cut
4158 */
4159
4160 void
4161 Perl_blockhook_register(pTHX_ BHK *hk)
4162 {
4163     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4164
4165     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4166 }
4167
4168 void
4169 Perl_newPROG(pTHX_ OP *o)
4170 {
4171     PERL_ARGS_ASSERT_NEWPROG;
4172
4173     if (PL_in_eval) {
4174         PERL_CONTEXT *cx;
4175         I32 i;
4176         if (PL_eval_root)
4177                 return;
4178         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4179                                ((PL_in_eval & EVAL_KEEPERR)
4180                                 ? OPf_SPECIAL : 0), o);
4181
4182         cx = CX_CUR();
4183         assert(CxTYPE(cx) == CXt_EVAL);
4184
4185         if ((cx->blk_gimme & G_WANT) == G_VOID)
4186             scalarvoid(PL_eval_root);
4187         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4188             list(PL_eval_root);
4189         else
4190             scalar(PL_eval_root);
4191
4192         PL_eval_start = op_linklist(PL_eval_root);
4193         PL_eval_root->op_private |= OPpREFCOUNTED;
4194         OpREFCNT_set(PL_eval_root, 1);
4195         PL_eval_root->op_next = 0;
4196         i = PL_savestack_ix;
4197         SAVEFREEOP(o);
4198         ENTER;
4199         CALL_PEEP(PL_eval_start);
4200         finalize_optree(PL_eval_root);
4201         S_prune_chain_head(&PL_eval_start);
4202         LEAVE;
4203         PL_savestack_ix = i;
4204     }
4205     else {
4206         if (o->op_type == OP_STUB) {
4207             /* This block is entered if nothing is compiled for the main
4208                program. This will be the case for an genuinely empty main
4209                program, or one which only has BEGIN blocks etc, so already
4210                run and freed.
4211
4212                Historically (5.000) the guard above was !o. However, commit
4213                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4214                c71fccf11fde0068, changed perly.y so that newPROG() is now
4215                called with the output of block_end(), which returns a new
4216                OP_STUB for the case of an empty optree. ByteLoader (and
4217                maybe other things) also take this path, because they set up
4218                PL_main_start and PL_main_root directly, without generating an
4219                optree.
4220
4221                If the parsing the main program aborts (due to parse errors,
4222                or due to BEGIN or similar calling exit), then newPROG()
4223                isn't even called, and hence this code path and its cleanups
4224                are skipped. This shouldn't make a make a difference:
4225                * a non-zero return from perl_parse is a failure, and
4226                  perl_destruct() should be called immediately.
4227                * however, if exit(0) is called during the parse, then
4228                  perl_parse() returns 0, and perl_run() is called. As
4229                  PL_main_start will be NULL, perl_run() will return
4230                  promptly, and the exit code will remain 0.
4231             */
4232
4233             PL_comppad_name = 0;
4234             PL_compcv = 0;
4235             S_op_destroy(aTHX_ o);
4236             return;
4237         }
4238         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4239         PL_curcop = &PL_compiling;
4240         PL_main_start = LINKLIST(PL_main_root);
4241         PL_main_root->op_private |= OPpREFCOUNTED;
4242         OpREFCNT_set(PL_main_root, 1);
4243         PL_main_root->op_next = 0;
4244         CALL_PEEP(PL_main_start);
4245         finalize_optree(PL_main_root);
4246         S_prune_chain_head(&PL_main_start);
4247         cv_forget_slab(PL_compcv);
4248         PL_compcv = 0;
4249
4250         /* Register with debugger */
4251         if (PERLDB_INTER) {
4252             CV * const cv = get_cvs("DB::postponed", 0);
4253             if (cv) {
4254                 dSP;
4255                 PUSHMARK(SP);
4256                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4257                 PUTBACK;
4258                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4259             }
4260         }
4261     }
4262 }
4263
4264 OP *
4265 Perl_localize(pTHX_ OP *o, I32 lex)
4266 {
4267     PERL_ARGS_ASSERT_LOCALIZE;
4268
4269     if (o->op_flags & OPf_PARENS)
4270 /* [perl #17376]: this appears to be premature, and results in code such as
4271    C< our(%x); > executing in list mode rather than void mode */
4272 #if 0
4273         list(o);
4274 #else
4275         NOOP;
4276 #endif
4277     else {
4278         if ( PL_parser->bufptr > PL_parser->oldbufptr
4279             && PL_parser->bufptr[-1] == ','
4280             && ckWARN(WARN_PARENTHESIS))
4281         {
4282             char *s = PL_parser->bufptr;
4283             bool sigil = FALSE;
4284
4285             /* some heuristics to detect a potential error */
4286             while (*s && (strchr(", \t\n", *s)))
4287                 s++;
4288
4289             while (1) {
4290                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4291                        && *++s
4292                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4293                     s++;
4294                     sigil = TRUE;
4295                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4296                         s++;
4297                     while (*s && (strchr(", \t\n", *s)))
4298                         s++;
4299                 }
4300                 else
4301                     break;
4302             }
4303             if (sigil && (*s == ';' || *s == '=')) {
4304                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4305                                 "Parentheses missing around \"%s\" list",
4306                                 lex
4307                                     ? (PL_parser->in_my == KEY_our
4308                                         ? "our"
4309                                         : PL_parser->in_my == KEY_state
4310                                             ? "state"
4311                                             : "my")
4312                                     : "local");
4313             }
4314         }
4315     }
4316     if (lex)
4317         o = my(o);
4318     else
4319         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4320     PL_parser->in_my = FALSE;
4321     PL_parser->in_my_stash = NULL;
4322     return o;
4323 }
4324
4325 OP *
4326 Perl_jmaybe(pTHX_ OP *o)
4327 {
4328     PERL_ARGS_ASSERT_JMAYBE;
4329
4330     if (o->op_type == OP_LIST) {
4331         OP * const o2
4332             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4333         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4334     }
4335     return o;
4336 }
4337
4338 PERL_STATIC_INLINE OP *
4339 S_op_std_init(pTHX_ OP *o)
4340 {
4341     I32 type = o->op_type;
4342
4343     PERL_ARGS_ASSERT_OP_STD_INIT;
4344
4345     if (PL_opargs[type] & OA_RETSCALAR)
4346         scalar(o);
4347     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4348         o->op_targ = pad_alloc(type, SVs_PADTMP);
4349
4350     return o;
4351 }
4352
4353 PERL_STATIC_INLINE OP *
4354 S_op_integerize(pTHX_ OP *o)
4355 {
4356     I32 type = o->op_type;
4357
4358     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4359
4360     /* integerize op. */
4361     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4362     {
4363         dVAR;
4364         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4365     }
4366
4367     if (type == OP_NEGATE)
4368         /* XXX might want a ck_negate() for this */
4369         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4370
4371     return o;
4372 }
4373
4374 static OP *
4375 S_fold_constants(pTHX_ OP *const o)
4376 {
4377     dVAR;
4378     OP * VOL curop;
4379     OP *newop;
4380     VOL I32 type = o->op_type;
4381     bool is_stringify;
4382     SV * VOL sv = NULL;
4383     int ret = 0;
4384     OP *old_next;
4385     SV * const oldwarnhook = PL_warnhook;
4386     SV * const olddiehook  = PL_diehook;
4387     COP not_compiling;
4388     U8 oldwarn = PL_dowarn;
4389     I32 old_cxix;
4390     dJMPENV;
4391
4392     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4393
4394     if (!(PL_opargs[type] & OA_FOLDCONST))
4395         goto nope;
4396
4397     switch (type) {
4398     case OP_UCFIRST:
4399     case OP_LCFIRST:
4400     case OP_UC:
4401     case OP_LC:
4402     case OP_FC:
4403 #ifdef USE_LOCALE_CTYPE
4404         if (IN_LC_COMPILETIME(LC_CTYPE))
4405             goto nope;
4406 #endif
4407         break;
4408     case OP_SLT:
4409     case OP_SGT:
4410     case OP_SLE:
4411     case OP_SGE:
4412     case OP_SCMP:
4413 #ifdef USE_LOCALE_COLLATE
4414         if (IN_LC_COMPILETIME(LC_COLLATE))
4415             goto nope;
4416 #endif
4417         break;
4418     case OP_SPRINTF:
4419         /* XXX what about the numeric ops? */
4420 #ifdef USE_LOCALE_NUMERIC
4421         if (IN_LC_COMPILETIME(LC_NUMERIC))
4422             goto nope;
4423 #endif
4424         break;
4425     case OP_PACK:
4426         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4427           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4428             goto nope;
4429         {
4430             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4431             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4432             {
4433                 const char *s = SvPVX_const(sv);
4434                 while (s < SvEND(sv)) {
4435                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4436                     s++;
4437                 }
4438             }
4439         }
4440         break;
4441     case OP_REPEAT:
4442         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4443         break;
4444     case OP_SREFGEN:
4445         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4446          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4447             goto nope;
4448     }
4449
4450     if (PL_parser && PL_parser->error_count)
4451         goto nope;              /* Don't try to run w/ errors */
4452
4453     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4454         switch (curop->op_type) {
4455         case OP_CONST:
4456             if (   (curop->op_private & OPpCONST_BARE)
4457                 && (curop->op_private & OPpCONST_STRICT)) {
4458                 no_bareword_allowed(curop);
4459                 goto nope;
4460             }
4461             /* FALLTHROUGH */
4462         case OP_LIST:
4463         case OP_SCALAR:
4464         case OP_NULL:
4465         case OP_PUSHMARK:
4466             /* Foldable; move to next op in list */
4467             break;
4468
4469         default:
4470             /* No other op types are considered foldable */
4471             goto nope;
4472         }
4473     }
4474
4475     curop = LINKLIST(o);
4476     old_next = o->op_next;
4477     o->op_next = 0;
4478     PL_op = curop;
4479
4480     old_cxix = cxstack_ix;
4481     create_eval_scope(NULL, G_FAKINGEVAL);
4482
4483     /* Verify that we don't need to save it:  */
4484     assert(PL_curcop == &PL_compiling);
4485     StructCopy(&PL_compiling, &not_compiling, COP);
4486     PL_curcop = &not_compiling;
4487     /* The above ensures that we run with all the correct hints of the
4488        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4489     assert(IN_PERL_RUNTIME);
4490     PL_warnhook = PERL_WARNHOOK_FATAL;
4491     PL_diehook  = NULL;
4492     JMPENV_PUSH(ret);
4493
4494     /* Effective $^W=1.  */
4495     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4496         PL_dowarn |= G_WARN_ON;
4497
4498     switch (ret) {
4499     case 0:
4500         CALLRUNOPS(aTHX);
4501         sv = *(PL_stack_sp--);
4502         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4503             pad_swipe(o->op_targ,  FALSE);
4504         }
4505         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4506             SvREFCNT_inc_simple_void(sv);
4507             SvTEMP_off(sv);
4508         }
4509         else { assert(SvIMMORTAL(sv)); }
4510         break;
4511     case 3:
4512         /* Something tried to die.  Abandon constant folding.  */
4513         /* Pretend the error never happened.  */
4514         CLEAR_ERRSV();
4515         o->op_next = old_next;
4516         break;
4517     default:
4518         JMPENV_POP;
4519         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4520         PL_warnhook = oldwarnhook;
4521         PL_diehook  = olddiehook;
4522         /* XXX note that this croak may fail as we've already blown away
4523          * the stack - eg any nested evals */
4524         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4525     }
4526     JMPENV_POP;
4527     PL_dowarn   = oldwarn;
4528     PL_warnhook = oldwarnhook;
4529     PL_diehook  = olddiehook;
4530     PL_curcop = &PL_compiling;
4531
4532     /* if we croaked, depending on how we croaked the eval scope
4533      * may or may not have already been popped */
4534     if (cxstack_ix > old_cxix) {
4535         assert(cxstack_ix == old_cxix + 1);
4536         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4537         delete_eval_scope();
4538     }
4539     if (ret)
4540         goto nope;
4541
4542     /* OP_STRINGIFY and constant folding are used to implement qq.
4543        Here the constant folding is an implementation detail that we
4544        want to hide.  If the stringify op is itself already marked
4545        folded, however, then it is actually a folded join.  */
4546     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4547     op_free(o);
4548     assert(sv);
4549     if (is_stringify)
4550         SvPADTMP_off(sv);
4551     else if (!SvIMMORTAL(sv)) {
4552         SvPADTMP_on(sv);
4553         SvREADONLY_on(sv);
4554     }
4555     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4556     if (!is_stringify) newop->op_folded = 1;
4557     return newop;
4558
4559  nope:
4560     return o;
4561 }
4562
4563 static OP *
4564 S_gen_constant_list(pTHX_ OP *o)
4565 {
4566     dVAR;
4567     OP *curop;
4568     const SSize_t oldtmps_floor = PL_tmps_floor;
4569     SV **svp;
4570     AV *av;
4571
4572     list(o);
4573     if (PL_parser && PL_parser->error_count)
4574         return o;               /* Don't attempt to run with errors */
4575
4576     curop = LINKLIST(o);
4577     o->op_next = 0;
4578     CALL_PEEP(curop);
4579     S_prune_chain_head(&curop);
4580     PL_op = curop;
4581     Perl_pp_pushmark(aTHX);
4582     CALLRUNOPS(aTHX);
4583     PL_op = curop;
4584     assert (!(curop->op_flags & OPf_SPECIAL));
4585     assert(curop->op_type == OP_RANGE);
4586     Perl_pp_anonlist(aTHX);
4587     PL_tmps_floor = oldtmps_floor;
4588
4589     OpTYPE_set(o, OP_RV2AV);
4590     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4591     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4592     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4593     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4594
4595     /* replace subtree with an OP_CONST */
4596     curop = ((UNOP*)o)->op_first;
4597     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4598     op_free(curop);
4599
4600     if (AvFILLp(av) != -1)
4601         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4602         {
4603             SvPADTMP_on(*svp);
4604             SvREADONLY_on(*svp);
4605         }
4606     LINKLIST(o);
4607     return list(o);
4608 }
4609
4610 /*
4611 =head1 Optree Manipulation Functions
4612 */
4613
4614 /* List constructors */
4615
4616 /*
4617 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4618
4619 Append an item to the list of ops contained directly within a list-type
4620 op, returning the lengthened list.  C<first> is the list-type op,
4621 and C<last> is the op to append to the list.  C<optype> specifies the
4622 intended opcode for the list.  If C<first> is not already a list of the
4623 right type, it will be upgraded into one.  If either C<first> or C<last>
4624 is null, the other is returned unchanged.
4625
4626 =cut
4627 */
4628
4629 OP *
4630 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4631 {
4632     if (!first)
4633         return last;
4634
4635     if (!last)
4636         return first;
4637
4638     if (first->op_type != (unsigned)type
4639         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4640     {
4641         return newLISTOP(type, 0, first, last);
4642     }
4643
4644     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4645     first->op_flags |= OPf_KIDS;
4646     return first;
4647 }
4648
4649 /*
4650 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4651
4652 Concatenate the lists of ops contained directly within two list-type ops,
4653 returning the combined list.  C<first> and C<last> are the list-type ops
4654 to concatenate.  C<optype> specifies the intended opcode for the list.
4655 If either C<first> or C<last> is not already a list of the right type,
4656 it will be upgraded into one.  If either C<first> or C<last> is null,
4657 the other is returned unchanged.
4658
4659 =cut
4660 */
4661
4662 OP *
4663 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4664 {
4665     if (!first)
4666         return last;
4667
4668     if (!last)
4669         return first;
4670
4671     if (first->op_type != (unsigned)type)
4672         return op_prepend_elem(type, first, last);
4673
4674     if (last->op_type != (unsigned)type)
4675         return op_append_elem(type, first, last);
4676
4677     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4678     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4679     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4680     first->op_flags |= (last->op_flags & OPf_KIDS);
4681
4682     S_op_destroy(aTHX_ last);
4683
4684     return first;
4685 }
4686
4687 /*
4688 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4689
4690 Prepend an item to the list of ops contained directly within a list-type
4691 op, returning the lengthened list.  C<first> is the op to prepend to the
4692 list, and C<last> is the list-type op.  C<optype> specifies the intended
4693 opcode for the list.  If C<last> is not already a list of the right type,
4694 it will be upgraded into one.  If either C<first> or C<last> is null,
4695 the other is returned unchanged.
4696
4697 =cut
4698 */
4699
4700 OP *
4701 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4702 {
4703     if (!first)
4704         return last;
4705
4706     if (!last)
4707         return first;
4708
4709     if (last->op_type == (unsigned)type) {
4710         if (type == OP_LIST) {  /* already a PUSHMARK there */
4711             /* insert 'first' after pushmark */
4712             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4713             if (!(first->op_flags & OPf_PARENS))
4714                 last->op_flags &= ~OPf_PARENS;
4715         }
4716         else
4717             op_sibling_splice(last, NULL, 0, first);
4718         last->op_flags |= OPf_KIDS;
4719         return last;
4720     }
4721
4722     return newLISTOP(type, 0, first, last);
4723 }
4724
4725 /*
4726 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4727
4728 Converts C<o> into a list op if it is not one already, and then converts it
4729 into the specified C<type>, calling its check function, allocating a target if
4730 it needs one, and folding constants.
4731
4732 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4733 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4734 C<op_convert_list> to make it the right type.
4735
4736 =cut
4737 */
4738
4739 OP *
4740 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4741 {
4742     dVAR;
4743     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4744     if (!o || o->op_type != OP_LIST)
4745         o = force_list(o, 0);
4746     else
4747     {
4748         o->op_flags &= ~OPf_WANT;
4749         o->op_private &= ~OPpLVAL_INTRO;
4750     }
4751
4752     if (!(PL_opargs[type] & OA_MARK))
4753         op_null(cLISTOPo->op_first);
4754     else {
4755         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4756         if (kid2 && kid2->op_type == OP_COREARGS) {
4757             op_null(cLISTOPo->op_first);
4758             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4759         }
4760     }
4761
4762     if (type != OP_SPLIT)
4763         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4764          * ck_split() create a real PMOP and leave the op's type as listop
4765          * for now. Otherwise op_free() etc will crash.
4766          */
4767         OpTYPE_set(o, type);
4768
4769     o->op_flags |= flags;
4770     if (flags & OPf_FOLDED)
4771         o->op_folded = 1;
4772
4773     o = CHECKOP(type, o);
4774     if (o->op_type != (unsigned)type)
4775         return o;
4776
4777     return fold_constants(op_integerize(op_std_init(o)));
4778 }
4779
4780 /* Constructors */
4781
4782
4783 /*
4784 =head1 Optree construction
4785
4786 =for apidoc Am|OP *|newNULLLIST
4787
4788 Constructs, checks, and returns a new C<stub> op, which represents an
4789 empty list expression.
4790
4791 =cut
4792 */
4793
4794 OP *
4795 Perl_newNULLLIST(pTHX)
4796 {
4797     return newOP(OP_STUB, 0);
4798 }
4799
4800 /* promote o and any siblings to be a list if its not already; i.e.
4801  *
4802  *  o - A - B
4803  *
4804  * becomes
4805  *
4806  *  list
4807  *    |
4808  *  pushmark - o - A - B
4809  *
4810  * If nullit it true, the list op is nulled.
4811  */
4812
4813 static OP *
4814 S_force_list(pTHX_ OP *o, bool nullit)
4815 {
4816     if (!o || o->op_type != OP_LIST) {
4817         OP *rest = NULL;
4818         if (o) {
4819             /* manually detach any siblings then add them back later */
4820             rest = OpSIBLING(o);
4821             OpLASTSIB_set(o, NULL);
4822         }
4823         o = newLISTOP(OP_LIST, 0, o, NULL);
4824         if (rest)
4825             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4826     }
4827     if (nullit)
4828         op_null(o);
4829     return o;
4830 }
4831
4832 /*
4833 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4834
4835 Constructs, checks, and returns an op of any list type.  C<type> is
4836 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4837 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4838 supply up to two ops to be direct children of the list op; they are
4839 consumed by this function and become part of the constructed op tree.
4840
4841 For most list operators, the check function expects all the kid ops to be
4842 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4843 appropriate.  What you want to do in that case is create an op of type
4844 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4845 See L</op_convert_list> for more information.
4846
4847
4848 =cut
4849 */
4850
4851 OP *
4852 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4853 {
4854     dVAR;
4855     LISTOP *listop;
4856
4857     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4858         || type == OP_CUSTOM);
4859
4860     NewOp(1101, listop, 1, LISTOP);
4861
4862     OpTYPE_set(listop, type);
4863     if (first || last)
4864         flags |= OPf_KIDS;
4865     listop->op_flags = (U8)flags;
4866
4867     if (!last && first)
4868         last = first;
4869     else if (!first && last)
4870         first = last;
4871     else if (first)
4872         OpMORESIB_set(first, last);
4873     listop->op_first = first;
4874     listop->op_last = last;
4875     if (type == OP_LIST) {
4876         OP* const pushop = newOP(OP_PUSHMARK, 0);
4877         OpMORESIB_set(pushop, first);
4878         listop->op_first = pushop;
4879         listop->op_flags |= OPf_KIDS;
4880         if (!last)
4881             listop->op_last = pushop;
4882     }
4883     if (listop->op_last)
4884         OpLASTSIB_set(listop->op_last, (OP*)listop);
4885
4886     return CHECKOP(type, listop);
4887 }
4888
4889 /*
4890 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4891
4892 Constructs, checks, and returns an op of any base type (any type that
4893 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4894 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4895 of C<op_private>.
4896
4897 =cut
4898 */
4899
4900 OP *
4901 Perl_newOP(pTHX_ I32 type, I32 flags)
4902 {
4903     dVAR;
4904     OP *o;
4905
4906     if (type == -OP_ENTEREVAL) {
4907         type = OP_ENTEREVAL;
4908         flags |= OPpEVAL_BYTES<<8;
4909     }
4910
4911     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4912         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4913         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4914         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4915
4916     NewOp(1101, o, 1, OP);
4917     OpTYPE_set(o, type);
4918     o->op_flags = (U8)flags;
4919
4920     o->op_next = o;
4921     o->op_private = (U8)(0 | (flags >> 8));
4922     if (PL_opargs[type] & OA_RETSCALAR)
4923         scalar(o);
4924     if (PL_opargs[type] & OA_TARGET)
4925         o->op_targ = pad_alloc(type, SVs_PADTMP);
4926     return CHECKOP(type, o);
4927 }
4928
4929 /*
4930 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4931
4932 Constructs, checks, and returns an op of any unary type.  C<type> is
4933 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4934 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4935 bits, the eight bits of C<op_private>, except that the bit with value 1
4936 is automatically set.  C<first> supplies an optional op to be the direct
4937 child of the unary op; it is consumed by this function and become part
4938 of the constructed op tree.
4939
4940 =cut
4941 */
4942
4943 OP *
4944 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4945 {
4946     dVAR;
4947     UNOP *unop;
4948
4949     if (type == -OP_ENTEREVAL) {
4950         type = OP_ENTEREVAL;
4951         flags |= OPpEVAL_BYTES<<8;
4952     }
4953
4954     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4955         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4956         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4957         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4958         || type == OP_SASSIGN
4959         || type == OP_ENTERTRY
4960         || type == OP_CUSTOM
4961         || type == OP_NULL );
4962
4963     if (!first)
4964         first = newOP(OP_STUB, 0);
4965     if (PL_opargs[type] & OA_MARK)
4966         first = force_list(first, 1);
4967
4968     NewOp(1101, unop, 1, UNOP);
4969     OpTYPE_set(unop, type);
4970     unop->op_first = first;
4971     unop->op_flags = (U8)(flags | OPf_KIDS);
4972     unop->op_private = (U8)(1 | (flags >> 8));
4973
4974     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4975         OpLASTSIB_set(first, (OP*)unop);
4976
4977     unop = (UNOP*) CHECKOP(type, unop);
4978     if (unop->op_next)
4979         return (OP*)unop;
4980
4981     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4982 }
4983
4984 /*
4985 =for apidoc newUNOP_AUX
4986
4987 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4988 initialised to C<aux>
4989
4990 =cut
4991 */
4992
4993 OP *
4994 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4995 {
4996     dVAR;
4997     UNOP_AUX *unop;
4998
4999     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5000         || type == OP_CUSTOM);
5001
5002     NewOp(1101, unop, 1, UNOP_AUX);
5003     unop->op_type = (OPCODE)type;
5004     unop->op_ppaddr = PL_ppaddr[type];
5005     unop->op_first = first;
5006     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5007     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5008     unop->op_aux = aux;
5009
5010     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5011         OpLASTSIB_set(first, (OP*)unop);
5012
5013     unop = (UNOP_AUX*) CHECKOP(type, unop);
5014
5015     return op_std_init((OP *) unop);
5016 }
5017
5018 /*
5019 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5020
5021 Constructs, checks, and returns an op of method type with a method name
5022 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5023 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5024 and, shifted up eight bits, the eight bits of C<op_private>, except that
5025 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5026 op which evaluates method name; it is consumed by this function and
5027 become part of the constructed op tree.
5028 Supported optypes: C<OP_METHOD>.
5029
5030 =cut
5031 */
5032
5033 static OP*
5034 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5035     dVAR;
5036     METHOP *methop;
5037
5038     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5039         || type == OP_CUSTOM);
5040
5041     NewOp(1101, methop, 1, METHOP);
5042     if (dynamic_meth) {
5043         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5044         methop->op_flags = (U8)(flags | OPf_KIDS);
5045         methop->op_u.op_first = dynamic_meth;
5046         methop->op_private = (U8)(1 | (flags >> 8));
5047
5048         if (!OpHAS_SIBLING(dynamic_meth))
5049             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5050     }
5051     else {
5052         assert(const_meth);
5053         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5054         methop->op_u.op_meth_sv = const_meth;
5055         methop->op_private = (U8)(0 | (flags >> 8));
5056         methop->op_next = (OP*)methop;
5057     }
5058
5059 #ifdef USE_ITHREADS
5060     methop->op_rclass_targ = 0;
5061 #else
5062     methop->op_rclass_sv = NULL;
5063 #endif
5064
5065     OpTYPE_set(methop, type);
5066     return CHECKOP(type, methop);
5067 }
5068
5069 OP *
5070 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5071     PERL_ARGS_ASSERT_NEWMETHOP;
5072     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5073 }
5074
5075 /*
5076 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5077
5078 Constructs, checks, and returns an op of method type with a constant
5079 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5080 C<op_flags>, and, shifted up eight bits, the eight bits of
5081 C<op_private>.  C<const_meth> supplies a constant method name;
5082 it must be a shared COW string.
5083 Supported optypes: C<OP_METHOD_NAMED>.
5084
5085 =cut
5086 */
5087
5088 OP *
5089 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5090     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5091     return newMETHOP_internal(type, flags, NULL, const_meth);
5092 }
5093
5094 /*
5095 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5096
5097 Constructs, checks, and returns an op of any binary type.  C<type>
5098 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5099 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5100 the eight bits of C<op_private>, except that the bit with value 1 or
5101 2 is automatically set as required.  C<first> and C<last> supply up to
5102 two ops to be the direct children of the binary op; they are consumed
5103 by this function and become part of the constructed op tree.
5104
5105 =cut
5106 */
5107
5108 OP *
5109 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5110 {
5111     dVAR;
5112     BINOP *binop;
5113
5114     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5115         || type == OP_NULL || type == OP_CUSTOM);
5116
5117     NewOp(1101, binop, 1, BINOP);
5118
5119     if (!first)
5120         first = newOP(OP_NULL, 0);
5121
5122     OpTYPE_set(binop, type);
5123     binop->op_first = first;
5124     binop->op_flags = (U8)(flags | OPf_KIDS);
5125     if (!last) {
5126         last = first;
5127         binop->op_private = (U8)(1 | (flags >> 8));
5128     }
5129     else {
5130         binop->op_private = (U8)(2 | (flags >> 8));
5131         OpMORESIB_set(first, last);
5132     }
5133
5134     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5135         OpLASTSIB_set(last, (OP*)binop);
5136
5137     binop->op_last = OpSIBLING(binop->op_first);
5138     if (binop->op_last)
5139         OpLASTSIB_set(binop->op_last, (OP*)binop);
5140
5141     binop = (BINOP*)CHECKOP(type, binop);
5142     if (binop->op_next || binop->op_type != (OPCODE)type)
5143         return (OP*)binop;
5144
5145     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5146 }
5147
5148 static int uvcompare(const void *a, const void *b)
5149     __attribute__nonnull__(1)
5150     __attribute__nonnull__(2)
5151     __attribute__pure__;
5152 static int uvcompare(const void *a, const void *b)
5153 {
5154     if (*((const UV *)a) < (*(const UV *)b))
5155         return -1;
5156     if (*((const UV *)a) > (*(const UV *)b))
5157         return 1;
5158     if (*((const UV *)a+1) < (*(const UV *)b+1))
5159         return -1;
5160     if (*((const UV *)a+1) > (*(const UV *)b+1))
5161         return 1;
5162     return 0;
5163 }
5164
5165 static OP *
5166 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5167 {
5168     SV * const tstr = ((SVOP*)expr)->op_sv;
5169     SV * const rstr =
5170                               ((SVOP*)repl)->op_sv;
5171     STRLEN tlen;
5172     STRLEN rlen;
5173     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5174     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5175     I32 i;
5176     I32 j;
5177     I32 grows = 0;
5178     short *tbl;
5179
5180     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5181     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5182     I32 del              = o->op_private & OPpTRANS_DELETE;
5183     SV* swash;
5184
5185     PERL_ARGS_ASSERT_PMTRANS;
5186
5187     PL_hints |= HINT_BLOCK_SCOPE;
5188
5189     if (SvUTF8(tstr))
5190         o->op_private |= OPpTRANS_FROM_UTF;
5191
5192     if (SvUTF8(rstr))
5193         o->op_private |= OPpTRANS_TO_UTF;
5194
5195     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5196         SV* const listsv = newSVpvs("# comment\n");
5197         SV* transv = NULL;
5198         const U8* tend = t + tlen;
5199         const U8* rend = r + rlen;
5200         STRLEN ulen;
5201         UV tfirst = 1;
5202         UV tlast = 0;
5203         IV tdiff;
5204         STRLEN tcount = 0;
5205         UV rfirst = 1;
5206         UV rlast = 0;
5207         IV rdiff;
5208         STRLEN rcount = 0;
5209         IV diff;
5210         I32 none = 0;
5211         U32 max = 0;
5212         I32 bits;
5213         I32 havefinal = 0;
5214         U32 final = 0;
5215         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5216         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5217         U8* tsave = NULL;
5218         U8* rsave = NULL;
5219         const U32 flags = UTF8_ALLOW_DEFAULT;
5220
5221         if (!from_utf) {
5222             STRLEN len = tlen;
5223             t = tsave = bytes_to_utf8(t, &len);
5224             tend = t + len;
5225         }
5226         if (!to_utf && rlen) {
5227             STRLEN len = rlen;
5228             r = rsave = bytes_to_utf8(r, &len);
5229             rend = r + len;
5230         }
5231
5232 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5233  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5234  * odd.  */
5235
5236         if (complement) {
5237             U8 tmpbuf[UTF8_MAXBYTES+1];
5238             UV *cp;
5239             UV nextmin = 0;
5240             Newx(cp, 2*tlen, UV);
5241             i = 0;
5242             transv = newSVpvs("");
5243             while (t < tend) {
5244                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5245                 t += ulen;
5246                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5247                     t++;
5248                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5249                     t += ulen;
5250                 }
5251                 else {
5252                  cp[2*i+1] = cp[2*i];
5253                 }
5254                 i++;
5255             }
5256             qsort(cp, i, 2*sizeof(UV), uvcompare);
5257             for (j = 0; j < i; j++) {
5258                 UV  val = cp[2*j];
5259                 diff = val - nextmin;
5260                 if (diff > 0) {
5261                     t = uvchr_to_utf8(tmpbuf,nextmin);
5262                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5263                     if (diff > 1) {
5264                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5265                         t = uvchr_to_utf8(tmpbuf, val - 1);
5266                         sv_catpvn(transv, (char *)&range_mark, 1);
5267                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5268                     }
5269                 }
5270                 val = cp[2*j+1];
5271                 if (val >= nextmin)
5272                     nextmin = val + 1;
5273             }
5274             t = uvchr_to_utf8(tmpbuf,nextmin);
5275             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5276             {
5277                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5278                 sv_catpvn(transv, (char *)&range_mark, 1);
5279             }
5280             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5281             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5282             t = (const U8*)SvPVX_const(transv);
5283             tlen = SvCUR(transv);
5284             tend = t + tlen;
5285             Safefree(cp);
5286         }
5287         else if (!rlen && !del) {
5288             r = t; rlen = tlen; rend = tend;
5289         }
5290         if (!squash) {
5291                 if ((!rlen && !del) || t == r ||
5292                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5293                 {
5294                     o->op_private |= OPpTRANS_IDENTICAL;
5295                 }
5296         }
5297
5298         while (t < tend || tfirst <= tlast) {
5299             /* see if we need more "t" chars */
5300             if (tfirst > tlast) {
5301                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5302                 t += ulen;
5303                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5304                     t++;
5305                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5306                     t += ulen;
5307                 }
5308                 else
5309                     tlast = tfirst;
5310             }
5311
5312             /* now see if we need more "r" chars */
5313             if (rfirst > rlast) {
5314                 if (r < rend) {
5315                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5316                     r += ulen;
5317                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5318                         r++;
5319                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5320                         r += ulen;
5321                     }
5322                     else
5323                         rlast = rfirst;
5324                 }
5325                 else {
5326                     if (!havefinal++)
5327                         final = rlast;
5328                     rfirst = rlast = 0xffffffff;
5329                 }
5330             }
5331
5332             /* now see which range will peter out first, if either. */
5333             tdiff = tlast - tfirst;
5334             rdiff = rlast - rfirst;
5335             tcount += tdiff + 1;
5336             rcount += rdiff + 1;
5337
5338             if (tdiff <= rdiff)
5339                 diff = tdiff;
5340             else
5341                 diff = rdiff;
5342
5343             if (rfirst == 0xffffffff) {
5344                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5345                 if (diff > 0)
5346                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5347                                    (long)tfirst, (long)tlast);
5348                 else
5349                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5350             }
5351             else {
5352                 if (diff > 0)
5353                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5354                                    (long)tfirst, (long)(tfirst + diff),
5355                                    (long)rfirst);
5356                 else
5357                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5358                                    (long)tfirst, (long)rfirst);
5359
5360                 if (rfirst + diff > max)
5361                     max = rfirst + diff;
5362                 if (!grows)
5363                     grows = (tfirst < rfirst &&
5364                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5365                 rfirst += diff + 1;
5366             }
5367             tfirst += diff + 1;
5368         }
5369
5370         none = ++max;
5371         if (del)
5372             del = ++max;
5373
5374         if (max > 0xffff)
5375             bits = 32;
5376         else if (max > 0xff)
5377             bits = 16;
5378         else
5379             bits = 8;
5380
5381         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5382 #ifdef USE_ITHREADS
5383         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5384         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5385         PAD_SETSV(cPADOPo->op_padix, swash);
5386         SvPADTMP_on(swash);
5387         SvREADONLY_on(swash);
5388 #else
5389         cSVOPo->op_sv = swash;
5390 #endif
5391         SvREFCNT_dec(listsv);
5392         SvREFCNT_dec(transv);
5393
5394         if (!del && havefinal && rlen)
5395             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5396                            newSVuv((UV)final), 0);
5397
5398         Safefree(tsave);
5399         Safefree(rsave);
5400
5401         tlen = tcount;
5402         rlen = rcount;
5403         if (r < rend)
5404             rlen++;
5405         else if (rlast == 0xffffffff)
5406             rlen = 0;
5407
5408         goto warnins;
5409     }
5410
5411     tbl = (short*)PerlMemShared_calloc(
5412         (o->op_private & OPpTRANS_COMPLEMENT) &&
5413             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5414         sizeof(short));
5415     cPVOPo->op_pv = (char*)tbl;
5416     if (complement) {
5417         for (i = 0; i < (I32)tlen; i++)
5418             tbl[t[i]] = -1;
5419         for (i = 0, j = 0; i < 256; i++) {
5420             if (!tbl[i]) {
5421                 if (j >= (I32)rlen) {
5422                     if (del)
5423                         tbl[i] = -2;
5424                     else if (rlen)
5425                         tbl[i] = r[j-1];
5426                     else
5427                         tbl[i] = (short)i;
5428                 }
5429                 else {
5430                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5431                         grows = 1;
5432                     tbl[i] = r[j++];
5433                 }
5434             }
5435         }
5436         if (!del) {
5437             if (!rlen) {
5438                 j = rlen;
5439                 if (!squash)
5440                     o->op_private |= OPpTRANS_IDENTICAL;
5441             }
5442             else if (j >= (I32)rlen)
5443                 j = rlen - 1;
5444             else {
5445                 tbl =
5446                     (short *)
5447                     PerlMemShared_realloc(tbl,
5448                                           (0x101+rlen-j) * sizeof(short));
5449                 cPVOPo->op_pv = (char*)tbl;
5450             }
5451             tbl[0x100] = (short)(rlen - j);
5452             for (i=0; i < (I32)rlen - j; i++)
5453                 tbl[0x101+i] = r[j+i];
5454         }
5455     }
5456     else {
5457         if (!rlen && !del) {
5458             r = t; rlen = tlen;
5459             if (!squash)
5460                 o->op_private |= OPpTRANS_IDENTICAL;
5461         }
5462         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5463             o->op_private |= OPpTRANS_IDENTICAL;
5464         }
5465         for (i = 0; i < 256; i++)
5466             tbl[i] = -1;
5467         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5468             if (j >= (I32)rlen) {
5469                 if (del) {
5470                     if (tbl[t[i]] == -1)
5471                         tbl[t[i]] = -2;
5472                     continue;
5473                 }
5474                 --j;
5475             }
5476             if (tbl[t[i]] == -1) {
5477                 if (     UVCHR_IS_INVARIANT(t[i])
5478                     && ! UVCHR_IS_INVARIANT(r[j]))
5479                     grows = 1;
5480                 tbl[t[i]] = r[j];
5481             }
5482         }
5483     }
5484
5485   warnins:
5486     if(del && rlen == tlen) {
5487         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5488     } else if(rlen > tlen && !complement) {
5489         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5490     }
5491
5492     if (grows)
5493         o->op_private |= OPpTRANS_GROWS;
5494     op_free(expr);
5495     op_free(repl);
5496
5497     return o;
5498 }
5499
5500 /*
5501 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5502
5503 Constructs, checks, and returns an op of any pattern matching type.
5504 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5505 and, shifted up eight bits, the eight bits of C<op_private>.
5506
5507 =cut
5508 */
5509
5510 OP *
5511 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5512 {
5513     dVAR;
5514     PMOP *pmop;
5515
5516     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5517         || type == OP_CUSTOM);
5518
5519     NewOp(1101, pmop, 1, PMOP);
5520     OpTYPE_set(pmop, type);
5521     pmop->op_flags = (U8)flags;
5522     pmop->op_private = (U8)(0 | (flags >> 8));
5523     if (PL_opargs[type] & OA_RETSCALAR)
5524         scalar((OP *)pmop);
5525
5526     if (PL_hints & HINT_RE_TAINT)
5527         pmop->op_pmflags |= PMf_RETAINT;
5528 #ifdef USE_LOCALE_CTYPE
5529     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5530         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5531     }
5532     else
5533 #endif
5534          if (IN_UNI_8_BIT) {
5535         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5536     }
5537     if (PL_hints & HINT_RE_FLAGS) {
5538         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5539          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5540         );
5541         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5542         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5543          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5544         );
5545         if (reflags && SvOK(reflags)) {
5546             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5547         }
5548     }
5549
5550
5551 #ifdef USE_ITHREADS
5552     assert(SvPOK(PL_regex_pad[0]));
5553     if (SvCUR(PL_regex_pad[0])) {
5554         /* Pop off the "packed" IV from the end.  */
5555         SV *const repointer_list = PL_regex_pad[0];
5556         const char *p = SvEND(repointer_list) - sizeof(IV);
5557         const IV offset = *((IV*)p);
5558
5559         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5560
5561         SvEND_set(repointer_list, p);
5562
5563         pmop->op_pmoffset = offset;
5564         /* This slot should be free, so assert this:  */
5565         assert(PL_regex_pad[offset] == &PL_sv_undef);
5566     } else {
5567         SV * const repointer = &PL_sv_undef;
5568         av_push(PL_regex_padav, repointer);
5569         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5570         PL_regex_pad = AvARRAY(PL_regex_padav);
5571     }
5572 #endif
5573
5574     return CHECKOP(type, pmop);
5575 }
5576
5577 static void
5578 S_set_haseval(pTHX)
5579 {
5580     PADOFFSET i = 1;
5581     PL_cv_has_eval = 1;
5582     /* Any pad names in scope are potentially lvalues.  */
5583     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5584         PADNAME *pn = PAD_COMPNAME_SV(i);
5585         if (!pn || !PadnameLEN(pn))
5586             continue;
5587         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5588             S_mark_padname_lvalue(aTHX_ pn);
5589     }
5590 }
5591
5592 /* Given some sort of match op o, and an expression expr containing a
5593  * pattern, either compile expr into a regex and attach it to o (if it's
5594  * constant), or convert expr into a runtime regcomp op sequence (if it's
5595  * not)
5596  *
5597  * Flags currently has 2 bits of meaning:
5598  * 1: isreg indicates that the pattern is part of a regex construct, eg
5599  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5600  * split "pattern", which aren't. In the former case, expr will be a list
5601  * if the pattern contains more than one term (eg /a$b/).
5602  * 2: The pattern is for a split.
5603  *
5604  * When the pattern has been compiled within a new anon CV (for
5605  * qr/(?{...})/ ), then floor indicates the savestack level just before
5606  * the new sub was created
5607  */
5608
5609 OP *
5610 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5611 {
5612     PMOP *pm;
5613     LOGOP *rcop;
5614     I32 repl_has_vars = 0;
5615     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5616     bool is_compiletime;
5617     bool has_code;
5618     bool isreg    = cBOOL(flags & 1);
5619     bool is_split = cBOOL(flags & 2);
5620
5621     PERL_ARGS_ASSERT_PMRUNTIME;
5622
5623     if (is_trans) {
5624         return pmtrans(o, expr, repl);
5625     }
5626
5627     /* find whether we have any runtime or code elements;
5628      * at the same time, temporarily set the op_next of each DO block;
5629      * then when we LINKLIST, this will cause the DO blocks to be excluded
5630      * from the op_next chain (and from having LINKLIST recursively
5631      * applied to them). We fix up the DOs specially later */
5632
5633     is_compiletime = 1;
5634     has_code = 0;
5635     if (expr->op_type == OP_LIST) {
5636         OP *o;
5637         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5638             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5639                 has_code = 1;
5640                 assert(!o->op_next);
5641                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5642                     assert(PL_parser && PL_parser->error_count);
5643                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5644                        the op we were expecting to see, to avoid crashing
5645                        elsewhere.  */
5646                     op_sibling_splice(expr, o, 0,
5647                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5648                 }
5649                 o->op_next = OpSIBLING(o);
5650             }
5651             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5652                 is_compiletime = 0;
5653         }
5654     }
5655     else if (expr->op_type != OP_CONST)
5656         is_compiletime = 0;
5657
5658     LINKLIST(expr);
5659
5660     /* fix up DO blocks; treat each one as a separate little sub;
5661      * also, mark any arrays as LIST/REF */
5662
5663     if (expr->op_type == OP_LIST) {
5664         OP *o;
5665         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5666
5667             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5668                 assert( !(o->op_flags  & OPf_WANT));
5669                 /* push the array rather than its contents. The regex
5670                  * engine will retrieve and join the elements later */
5671                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5672                 continue;
5673             }
5674
5675             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5676                 continue;
5677             o->op_next = NULL; /* undo temporary hack from above */
5678             scalar(o);
5679             LINKLIST(o);
5680             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5681                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5682                 /* skip ENTER */
5683                 assert(leaveop->op_first->op_type == OP_ENTER);
5684                 assert(OpHAS_SIBLING(leaveop->op_first));
5685                 o->op_next = OpSIBLING(leaveop->op_first);
5686                 /* skip leave */
5687                 assert(leaveop->op_flags & OPf_KIDS);
5688                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5689                 leaveop->op_next = NULL; /* stop on last op */
5690                 op_null((OP*)leaveop);
5691             }
5692             else {
5693                 /* skip SCOPE */
5694                 OP *scope = cLISTOPo->op_first;
5695                 assert(scope->op_type == OP_SCOPE);
5696                 assert(scope->op_flags & OPf_KIDS);
5697                 scope->op_next = NULL; /* stop on last op */
5698                 op_null(scope);
5699             }
5700             /* have to peep the DOs individually as we've removed it from
5701              * the op_next chain */
5702             CALL_PEEP(o);
5703             S_prune_chain_head(&(o->op_next));
5704             if (is_compiletime)
5705                 /* runtime finalizes as part of finalizing whole tree */
5706                 finalize_optree(o);
5707         }
5708     }
5709     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5710         assert( !(expr->op_flags  & OPf_WANT));
5711         /* push the array rather than its contents. The regex
5712          * engine will retrieve and join the elements later */
5713         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5714     }
5715
5716     PL_hints |= HINT_BLOCK_SCOPE;
5717     pm = (PMOP*)o;
5718     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5719
5720     if (is_compiletime) {
5721         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5722         regexp_engine const *eng = current_re_engine();
5723
5724         if (is_split) {
5725             /* make engine handle split ' ' specially */
5726             pm->op_pmflags |= PMf_SPLIT;
5727             rx_flags |= RXf_SPLIT;
5728         }
5729
5730         if (!has_code || !eng->op_comp) {
5731             /* compile-time simple constant pattern */
5732
5733             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5734                 /* whoops! we guessed that a qr// had a code block, but we
5735                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5736                  * that isn't required now. Note that we have to be pretty
5737                  * confident that nothing used that CV's pad while the
5738                  * regex was parsed, except maybe op targets for \Q etc.
5739                  * If there were any op targets, though, they should have
5740                  * been stolen by constant folding.
5741                  */
5742 #ifdef DEBUGGING
5743                 SSize_t i = 0;
5744                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5745                 while (++i <= AvFILLp(PL_comppad)) {
5746 #  ifdef USE_PAD_RESET
5747                     /* under USE_PAD_RESET, pad swipe replaces a swiped
5748                      * folded constant with a fresh padtmp */
5749                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5750 #  else
5751                     assert(!PL_curpad[i]);
5752 #  endif
5753                 }
5754 #endif
5755                 /* But we know that one op is using this CV's slab. */
5756                 cv_forget_slab(PL_compcv);
5757                 LEAVE_SCOPE(floor);
5758                 pm->op_pmflags &= ~PMf_HAS_CV;
5759             }
5760
5761             PM_SETRE(pm,
5762                 eng->op_comp
5763                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5764                                         rx_flags, pm->op_pmflags)
5765                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5766                                         rx_flags, pm->op_pmflags)
5767             );
5768             op_free(expr);
5769         }
5770         else {
5771             /* compile-time pattern that includes literal code blocks */
5772             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5773                         rx_flags,
5774                         (pm->op_pmflags |
5775                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5776                     );
5777             PM_SETRE(pm, re);
5778             if (pm->op_pmflags & PMf_HAS_CV) {
5779                 CV *cv;
5780                 /* this QR op (and the anon sub we embed it in) is never
5781                  * actually executed. It's just a placeholder where we can
5782                  * squirrel away expr in op_code_list without the peephole
5783                  * optimiser etc processing it for a second time */
5784                 OP *qr = newPMOP(OP_QR, 0);
5785                 ((PMOP*)qr)->op_code_list = expr;
5786
5787                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5788                 SvREFCNT_inc_simple_void(PL_compcv);
5789                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5790                 ReANY(re)->qr_anoncv = cv;
5791
5792                 /* attach the anon CV to the pad so that
5793                  * pad_fixup_inner_anons() can find it */
5794                 (void)pad_add_anon(cv, o->op_type);
5795                 SvREFCNT_inc_simple_void(cv);
5796             }
5797             else {
5798                 pm->op_code_list = expr;
5799             }
5800         }
5801     }
5802     else {
5803         /* runtime pattern: build chain of regcomp etc ops */
5804         bool reglist;
5805         PADOFFSET cv_targ = 0;
5806
5807         reglist = isreg && expr->op_type == OP_LIST;
5808         if (reglist)
5809             op_null(expr);
5810
5811         if (has_code) {
5812             pm->op_code_list = expr;
5813             /* don't free op_code_list; its ops are embedded elsewhere too */
5814             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5815         }
5816
5817         if (is_split)
5818             /* make engine handle split ' ' specially */
5819             pm->op_pmflags |= PMf_SPLIT;
5820
5821         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5822          * to allow its op_next to be pointed past the regcomp and
5823          * preceding stacking ops;
5824          * OP_REGCRESET is there to reset taint before executing the
5825          * stacking ops */
5826         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5827             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5828
5829         if (pm->op_pmflags & PMf_HAS_CV) {
5830             /* we have a runtime qr with literal code. This means
5831              * that the qr// has been wrapped in a new CV, which
5832              * means that runtime consts, vars etc will have been compiled
5833              * against a new pad. So... we need to execute those ops
5834              * within the environment of the new CV. So wrap them in a call
5835              * to a new anon sub. i.e. for
5836              *
5837              *     qr/a$b(?{...})/,
5838              *
5839              * we build an anon sub that looks like
5840              *
5841              *     sub { "a", $b, '(?{...})' }
5842              *
5843              * and call it, passing the returned list to regcomp.
5844              * Or to put it another way, the list of ops that get executed
5845              * are:
5846              *
5847              *     normal              PMf_HAS_CV
5848              *     ------              -------------------
5849              *                         pushmark (for regcomp)
5850              *                         pushmark (for entersub)
5851              *                         anoncode
5852              *                         srefgen
5853              *                         entersub
5854              *     regcreset                  regcreset
5855              *     pushmark                   pushmark
5856              *     const("a")                 const("a")
5857              *     gvsv(b)                    gvsv(b)
5858              *     const("(?{...})")          const("(?{...})")
5859              *                                leavesub
5860              *     regcomp             regcomp
5861              */
5862
5863             SvREFCNT_inc_simple_void(PL_compcv);
5864             CvLVALUE_on(PL_compcv);
5865             /* these lines are just an unrolled newANONATTRSUB */
5866             expr = newSVOP(OP_ANONCODE, 0,
5867                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5868             cv_targ = expr->op_targ;
5869             expr = newUNOP(OP_REFGEN, 0, expr);
5870
5871             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5872         }
5873
5874         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5875         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5876                            | (reglist ? OPf_STACKED : 0);
5877         rcop->op_targ = cv_targ;
5878
5879         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5880         if (PL_hints & HINT_RE_EVAL)
5881             S_set_haseval(aTHX);
5882
5883         /* establish postfix order */
5884         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5885             LINKLIST(expr);
5886             rcop->op_next = expr;
5887             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5888         }
5889         else {
5890             rcop->op_next = LINKLIST(expr);
5891             expr->op_next = (OP*)rcop;
5892         }
5893
5894         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5895     }
5896
5897     if (repl) {
5898         OP *curop = repl;
5899         bool konst;
5900         /* If we are looking at s//.../e with a single statement, get past
5901            the implicit do{}. */
5902         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5903              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5904              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5905          {
5906             OP *sib;
5907             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5908             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5909              && !OpHAS_SIBLING(sib))
5910                 curop = sib;
5911         }
5912         if (curop->op_type == OP_CONST)
5913             konst = TRUE;
5914         else if (( (curop->op_type == OP_RV2SV ||
5915                     curop->op_type == OP_RV2AV ||
5916                     curop->op_type == OP_RV2HV ||
5917                     curop->op_type == OP_RV2GV)
5918                    && cUNOPx(curop)->op_first
5919                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5920                 || curop->op_type == OP_PADSV
5921                 || curop->op_type == OP_PADAV
5922                 || curop->op_type == OP_PADHV
5923                 || curop->op_type == OP_PADANY) {
5924             repl_has_vars = 1;
5925             konst = TRUE;
5926         }
5927         else konst = FALSE;
5928         if (konst
5929             && !(repl_has_vars
5930                  && (!PM_GETRE(pm)
5931                      || !RX_PRELEN(PM_GETRE(pm))
5932                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5933         {
5934             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5935             op_prepend_elem(o->op_type, scalar(repl), o);
5936         }
5937         else {
5938             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
5939             rcop->op_private = 1;
5940
5941             /* establish postfix order */
5942             rcop->op_next = LINKLIST(repl);
5943             repl->op_next = (OP*)rcop;
5944
5945             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5946             assert(!(pm->op_pmflags & PMf_ONCE));
5947             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5948             rcop->op_next = 0;
5949         }
5950     }
5951
5952     return (OP*)pm;
5953 }
5954
5955 /*
5956 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5957
5958 Constructs, checks, and returns an op of any type that involves an
5959 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5960 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5961 takes ownership of one reference to it.
5962
5963 =cut
5964 */
5965
5966 OP *
5967 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5968 {
5969     dVAR;
5970     SVOP *svop;
5971
5972     PERL_ARGS_ASSERT_NEWSVOP;
5973
5974     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5975         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5976         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5977         || type == OP_CUSTOM);
5978
5979     NewOp(1101, svop, 1, SVOP);
5980     OpTYPE_set(svop, type);
5981     svop->op_sv = sv;
5982     svop->op_next = (OP*)svop;
5983     svop->op_flags = (U8)flags;
5984     svop->op_private = (U8)(0 | (flags >> 8));
5985     if (PL_opargs[type] & OA_RETSCALAR)
5986         scalar((OP*)svop);
5987     if (PL_opargs[type] & OA_TARGET)
5988         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5989     return CHECKOP(type, svop);
5990 }
5991
5992 /*
5993 =for apidoc Am|OP *|newDEFSVOP|
5994
5995 Constructs and returns an op to access C<$_>.
5996
5997 =cut
5998 */
5999
6000 OP *
6001 Perl_newDEFSVOP(pTHX)
6002 {
6003         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6004 }
6005
6006 #ifdef USE_ITHREADS
6007
6008 /*
6009 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6010
6011 Constructs, checks, and returns an op of any type that involves a
6012 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
6013 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
6014 is populated with C<sv>; this function takes ownership of one reference
6015 to it.
6016
6017 This function only exists if Perl has been compiled to use ithreads.
6018
6019 =cut
6020 */
6021
6022 OP *
6023 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6024 {
6025     dVAR;
6026     PADOP *padop;
6027
6028     PERL_ARGS_ASSERT_NEWPADOP;
6029
6030     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6031         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6032         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6033         || type == OP_CUSTOM);
6034
6035     NewOp(1101, padop, 1, PADOP);
6036     OpTYPE_set(padop, type);
6037     padop->op_padix =
6038         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6039     SvREFCNT_dec(PAD_SVl(padop->op_padix));
6040     PAD_SETSV(padop->op_padix, sv);
6041     assert(sv);
6042     padop->op_next = (OP*)padop;
6043     padop->op_flags = (U8)flags;
6044     if (PL_opargs[type] & OA_RETSCALAR)
6045         scalar((OP*)padop);
6046     if (PL_opargs[type] & OA_TARGET)
6047         padop->op_targ = pad_alloc(type, SVs_PADTMP);
6048     return CHECKOP(type, padop);
6049 }
6050
6051 #endif /* USE_ITHREADS */
6052
6053 /*
6054 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6055
6056 Constructs, checks, and returns an op of any type that involves an
6057 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
6058 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
6059 reference; calling this function does not transfer ownership of any
6060 reference to it.
6061
6062 =cut
6063 */
6064
6065 OP *
6066 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6067 {
6068     PERL_ARGS_ASSERT_NEWGVOP;
6069
6070 #ifdef USE_ITHREADS
6071     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6072 #else
6073     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6074 #endif
6075 }
6076
6077 /*
6078 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6079
6080 Constructs, checks, and returns an op of any type that involves an
6081 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
6082 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
6083 must have been allocated using C<PerlMemShared_malloc>; the memory will
6084 be freed when the op is destroyed.
6085
6086 =cut
6087 */
6088
6089 OP *
6090 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6091 {
6092     dVAR;
6093     const bool utf8 = cBOOL(flags & SVf_UTF8);
6094     PVOP *pvop;
6095
6096     flags &= ~SVf_UTF8;
6097
6098     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6099         || type == OP_RUNCV || type == OP_CUSTOM
6100         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6101
6102     NewOp(1101, pvop, 1, PVOP);
6103     OpTYPE_set(pvop, type);
6104     pvop->op_pv = pv;
6105     pvop->op_next = (OP*)pvop;
6106     pvop->op_flags = (U8)flags;
6107     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6108     if (PL_opargs[type] & OA_RETSCALAR)
6109         scalar((OP*)pvop);
6110     if (PL_opargs[type] & OA_TARGET)
6111         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6112     return CHECKOP(type, pvop);
6113 }
6114
6115 void
6116 Perl_package(pTHX_ OP *o)
6117 {
6118     SV *const sv = cSVOPo->op_sv;
6119
6120     PERL_ARGS_ASSERT_PACKAGE;
6121
6122     SAVEGENERICSV(PL_curstash);
6123     save_item(PL_curstname);
6124
6125     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6126
6127     sv_setsv(PL_curstname, sv);
6128
6129     PL_hints |= HINT_BLOCK_SCOPE;
6130     PL_parser->copline = NOLINE;
6131
6132     op_free(o);
6133 }
6134
6135 void
6136 Perl_package_version( pTHX_ OP *v )
6137 {
6138     U32 savehints = PL_hints;
6139     PERL_ARGS_ASSERT_PACKAGE_VERSION;
6140     PL_hints &= ~HINT_STRICT_VARS;
6141     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6142     PL_hints = savehints;
6143     op_free(v);
6144 }
6145
6146 void
6147 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6148 {
6149     OP *pack;
6150     OP *imop;
6151     OP *veop;
6152     SV *use_version = NULL;
6153
6154     PERL_ARGS_ASSERT_UTILIZE;
6155
6156     if (idop->op_type != OP_CONST)
6157         Perl_croak(aTHX_ "Module name must be constant");
6158
6159     veop = NULL;
6160
6161     if (version) {
6162         SV * const vesv = ((SVOP*)version)->op_sv;
6163
6164         if (!arg && !SvNIOKp(vesv)) {
6165             arg = version;
6166         }
6167         else {
6168             OP *pack;
6169             SV *meth;
6170
6171             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6172                 Perl_croak(aTHX_ "Version number must be a constant number");
6173
6174             /* Make copy of idop so we don't free it twice */
6175             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6176
6177             /* Fake up a method call to VERSION */
6178             meth = newSVpvs_share("VERSION");
6179             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6180                             op_append_elem(OP_LIST,
6181                                         op_prepend_elem(OP_LIST, pack, version),
6182                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6183         }
6184     }
6185
6186     /* Fake up an import/unimport */
6187     if (arg && arg->op_type == OP_STUB) {
6188         imop = arg;             /* no import on explicit () */
6189     }
6190     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6191         imop = NULL;            /* use 5.0; */
6192         if (aver)
6193             use_version = ((SVOP*)idop)->op_sv;
6194         else
6195             idop->op_private |= OPpCONST_NOVER;
6196     }
6197     else {
6198         SV *meth;
6199
6200         /* Make copy of idop so we don't free it twice */
6201         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6202
6203         /* Fake up a method call to import/unimport */
6204         meth = aver
6205             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6206         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6207                        op_append_elem(OP_LIST,
6208                                    op_prepend_elem(OP_LIST, pack, arg),
6209                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6210                        ));
6211     }
6212
6213     /* Fake up the BEGIN {}, which does its thing immediately. */
6214     newATTRSUB(floor,
6215         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6216         NULL,
6217         NULL,
6218         op_append_elem(OP_LINESEQ,
6219             op_append_elem(OP_LINESEQ,
6220                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6221                 newSTATEOP(0, NULL, veop)),
6222             newSTATEOP(0, NULL, imop) ));
6223
6224     if (use_version) {
6225         /* Enable the
6226          * feature bundle that corresponds to the required version. */
6227         use_version = sv_2mortal(new_version(use_version));
6228         S_enable_feature_bundle(aTHX_ use_version);
6229
6230         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6231         if (vcmp(use_version,
6232                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6233             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6234                 PL_hints |= HINT_STRICT_REFS;
6235             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6236                 PL_hints |= HINT_STRICT_SUBS;
6237             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6238                 PL_hints |= HINT_STRICT_VARS;
6239         }
6240         /* otherwise they are off */
6241         else {
6242             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6243                 PL_hints &= ~HINT_STRICT_REFS;
6244             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6245                 PL_hints &= ~HINT_STRICT_SUBS;
6246             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6247                 PL_hints &= ~HINT_STRICT_VARS;
6248         }
6249     }
6250
6251     /* The "did you use incorrect case?" warning used to be here.
6252      * The problem is that on case-insensitive filesystems one
6253      * might get false positives for "use" (and "require"):
6254      * "use Strict" or "require CARP" will work.  This causes
6255      * portability problems for the script: in case-strict
6256      * filesystems the script will stop working.
6257      *
6258      * The "incorrect case" warning checked whether "use Foo"
6259      * imported "Foo" to your namespace, but that is wrong, too:
6260      * there is no requirement nor promise in the language that
6261      * a Foo.pm should or would contain anything in package "Foo".
6262      *
6263      * There is very little Configure-wise that can be done, either:
6264      * the case-sensitivity of the build filesystem of Perl does not
6265      * help in guessing the case-sensitivity of the runtime environment.
6266      */
6267
6268     PL_hints |= HINT_BLOCK_SCOPE;
6269     PL_parser->copline = NOLINE;
6270     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6271 }
6272
6273 /*
6274 =head1 Embedding Functions
6275
6276 =for apidoc load_module
6277
6278 Loads the module whose name is pointed to by the string part of C<name>.
6279 Note that the actual module name, not its filename, should be given.
6280 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
6281 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
6282 trailing arguments can be used to specify arguments to the module's C<import()>
6283 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
6284 on the flags. The flags argument is a bitwise-ORed collection of any of
6285 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6286 (or 0 for no flags).
6287
6288 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
6289 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
6290 the trailing optional arguments may be omitted entirely. Otherwise, if
6291 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
6292 exactly one C<OP*>, containing the op tree that produces the relevant import
6293 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
6294 will be used as import arguments; and the list must be terminated with C<(SV*)
6295 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
6296 set, the trailing C<NULL> pointer is needed even if no import arguments are
6297 desired. The reference count for each specified C<SV*> argument is
6298 decremented. In addition, the C<name> argument is modified.
6299
6300 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
6301 than C<use>.
6302
6303 =cut */
6304
6305 void
6306 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6307 {
6308     va_list args;
6309
6310     PERL_ARGS_ASSERT_LOAD_MODULE;
6311
6312     va_start(args, ver);
6313     vload_module(flags, name, ver, &args);
6314     va_end(args);
6315 }
6316
6317 #ifdef PERL_IMPLICIT_CONTEXT
6318 void
6319 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6320 {
6321     dTHX;
6322     va_list args;
6323     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6324     va_start(args, ver);
6325     vload_module(flags, name, ver, &args);
6326     va_end(args);
6327 }
6328 #endif
6329
6330 void
6331 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6332 {
6333     OP *veop, *imop;
6334     OP * const modname = newSVOP(OP_CONST, 0, name);
6335
6336     PERL_ARGS_ASSERT_VLOAD_MODULE;
6337
6338     modname->op_private |= OPpCONST_BARE;
6339     if (ver) {
6340         veop = newSVOP(OP_CONST, 0, ver);
6341     }
6342     else
6343         veop = NULL;
6344     if (flags & PERL_LOADMOD_NOIMPORT) {
6345         imop = sawparens(newNULLLIST());
6346     }
6347     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6348         imop = va_arg(*args, OP*);
6349     }
6350     else {
6351         SV *sv;
6352         imop = NULL;
6353         sv = va_arg(*args, SV*);
6354         while (sv) {
6355             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6356             sv = va_arg(*args, SV*);
6357         }
6358     }
6359
6360     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6361      * that it has a PL_parser to play with while doing that, and also
6362      * that it doesn't mess with any existing parser, by creating a tmp
6363      * new parser with lex_start(). This won't actually be used for much,
6364      * since pp_require() will create another parser for the real work.
6365      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6366
6367     ENTER;
6368     SAVEVPTR(PL_curcop);
6369     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6370     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6371             veop, modname, imop);
6372     LEAVE;
6373 }
6374
6375 PERL_STATIC_INLINE OP *
6376 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6377 {
6378     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6379                    newLISTOP(OP_LIST, 0, arg,
6380                              newUNOP(OP_RV2CV, 0,
6381                                      newGVOP(OP_GV, 0, gv))));
6382 }
6383
6384 OP *
6385 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6386 {
6387     OP *doop;
6388     GV *gv;
6389
6390     PERL_ARGS_ASSERT_DOFILE;
6391
6392     if (!force_builtin && (gv = gv_override("do", 2))) {
6393         doop = S_new_entersubop(aTHX_ gv, term);
6394     }
6395     else {
6396         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6397     }
6398     return doop;
6399 }
6400
6401 /*
6402 =head1 Optree construction
6403
6404 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6405
6406 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6407 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6408 be set automatically, and, shifted up eight bits, the eight bits of
6409 C<op_private>, except that the bit with value 1 or 2 is automatically
6410 set as required.  C<listval> and C<subscript> supply the parameters of
6411 the slice; they are consumed by this function and become part of the
6412 constructed op tree.
6413
6414 =cut
6415 */
6416
6417 OP *
6418 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6419 {
6420     return newBINOP(OP_LSLICE, flags,
6421             list(force_list(subscript, 1)),
6422             list(force_list(listval,   1)) );
6423 }
6424
6425 #define ASSIGN_LIST   1
6426 #define ASSIGN_REF    2
6427
6428 STATIC I32
6429 S_assignment_type(pTHX_ const OP *o)
6430 {
6431     unsigned type;
6432     U8 flags;
6433     U8 ret;
6434
6435     if (!o)
6436         return TRUE;
6437
6438     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6439         o = cUNOPo->op_first;
6440
6441     flags = o->op_flags;
6442     type = o->op_type;
6443     if (type == OP_COND_EXPR) {
6444         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6445         const I32 t = assignment_type(sib);
6446         const I32 f = assignment_type(OpSIBLING(sib));
6447
6448         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6449             return ASSIGN_LIST;
6450         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6451             yyerror("Assignment to both a list and a scalar");
6452         return FALSE;
6453     }
6454
6455     if (type == OP_SREFGEN)
6456     {
6457         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6458         type = kid->op_type;
6459         flags |= kid->op_flags;
6460         if (!(flags & OPf_PARENS)
6461           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6462               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6463             return ASSIGN_REF;
6464         ret = ASSIGN_REF;
6465     }
6466     else ret = 0;
6467
6468     if (type == OP_LIST &&
6469         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6470         o->op_private & OPpLVAL_INTRO)
6471         return ret;
6472
6473     if (type == OP_LIST || flags & OPf_PARENS ||
6474         type == OP_RV2AV || type == OP_RV2HV ||
6475         type == OP_ASLICE || type == OP_HSLICE ||
6476         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6477         return TRUE;
6478
6479     if (type == OP_PADAV || type == OP_PADHV)
6480         return TRUE;
6481
6482     if (type == OP_RV2SV)
6483         return ret;
6484
6485     return ret;
6486 }
6487
6488
6489 /*
6490 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6491
6492 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6493 supply the parameters of the assignment; they are consumed by this
6494 function and become part of the constructed op tree.
6495
6496 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6497 a suitable conditional optree is constructed.  If C<optype> is the opcode
6498 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6499 performs the binary operation and assigns the result to the left argument.
6500 Either way, if C<optype> is non-zero then C<flags> has no effect.
6501
6502 If C<optype> is zero, then a plain scalar or list assignment is
6503 constructed.  Which type of assignment it is is automatically determined.
6504 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6505 will be set automatically, and, shifted up eight bits, the eight bits
6506 of C<op_private>, except that the bit with value 1 or 2 is automatically
6507 set as required.
6508
6509 =cut
6510 */
6511
6512 OP *
6513 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6514 {
6515     OP *o;
6516     I32 assign_type;
6517
6518     if (optype) {
6519         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6520             right = scalar(right);
6521             return newLOGOP(optype, 0,
6522                 op_lvalue(scalar(left), optype),
6523                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6524         }
6525         else {
6526             return newBINOP(optype, OPf_STACKED,
6527                 op_lvalue(scalar(left), optype), scalar(right));
6528         }
6529     }
6530
6531     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6532         static const char no_list_state[] = "Initialization of state variables"
6533             " in list context currently forbidden";
6534         OP *curop;
6535
6536         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6537             left->op_private &= ~ OPpSLICEWARNING;
6538
6539         PL_modcount = 0;
6540         left = op_lvalue(left, OP_AASSIGN);
6541         curop = list(force_list(left, 1));
6542         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6543         o->op_private = (U8)(0 | (flags >> 8));
6544
6545         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6546         {
6547             OP* lop = ((LISTOP*)left)->op_first;
6548             while (lop) {
6549                 if ((lop->op_type == OP_PADSV ||
6550                      lop->op_type == OP_PADAV ||
6551                      lop->op_type == OP_PADHV ||
6552                      lop->op_type == OP_PADANY)
6553                   && (lop->op_private & OPpPAD_STATE)
6554                 )
6555                     yyerror(no_list_state);
6556                 lop = OpSIBLING(lop);
6557             }
6558         }
6559         else if (  (left->op_private & OPpLVAL_INTRO)
6560                 && (left->op_private & OPpPAD_STATE)
6561                 && (   left->op_type == OP_PADSV
6562                     || left->op_type == OP_PADAV
6563                     || left->op_type == OP_PADHV
6564                     || left->op_type == OP_PADANY)
6565         ) {
6566                 /* All single variable list context state assignments, hence
6567                    state ($a) = ...
6568                    (state $a) = ...
6569                    state @a = ...
6570                    state (@a) = ...
6571                    (state @a) = ...
6572                    state %a = ...
6573                    state (%a) = ...
6574                    (state %a) = ...
6575                 */
6576                 yyerror(no_list_state);
6577         }
6578
6579         /* optimise @a = split(...) into:
6580         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
6581         * @a, my @a, local @a:  split(...)          (where @a is attached to
6582         *                                            the split op itself)
6583         */
6584
6585         if (   right
6586             && right->op_type == OP_SPLIT
6587             /* don't do twice, e.g. @b = (@a = split) */
6588             && !(right->op_private & OPpSPLIT_ASSIGN))
6589         {
6590             OP *gvop = NULL;
6591
6592             if (   (  left->op_type == OP_RV2AV
6593                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6594                 || left->op_type == OP_PADAV)
6595             {
6596                 /* @pkg or @lex or local @pkg' or 'my @lex' */
6597                 OP *tmpop;
6598                 if (gvop) {
6599 #ifdef USE_ITHREADS
6600                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6601                         = cPADOPx(gvop)->op_padix;
6602                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
6603 #else
6604                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6605                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6606                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
6607 #endif
6608                     right->op_private |=
6609                         left->op_private & OPpOUR_INTRO;
6610                 }
6611                 else {
6612                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6613                     left->op_targ = 0;  /* steal it */
6614                     right->op_private |= OPpSPLIT_LEX;
6615                 }
6616                 right->op_private |= left->op_private & OPpLVAL_INTRO;
6617
6618               detach_split:
6619                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
6620                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6621                 assert(OpSIBLING(tmpop) == right);
6622                 assert(!OpHAS_SIBLING(right));
6623                 /* detach the split subtreee from the o tree,
6624                  * then free the residual o tree */
6625                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6626                 op_free(o);                     /* blow off assign */
6627                 right->op_private |= OPpSPLIT_ASSIGN;
6628                 right->op_flags &= ~OPf_WANT;
6629                         /* "I don't know and I don't care." */
6630                 return right;
6631             }
6632             else if (left->op_type == OP_RV2AV) {
6633                 /* @{expr} */
6634
6635                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6636                 assert(OpSIBLING(pushop) == left);
6637                 /* Detach the array ...  */
6638                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6639                 /* ... and attach it to the split.  */
6640                 op_sibling_splice(right, cLISTOPx(right)->op_last,
6641                                   0, left);
6642                 right->op_flags |= OPf_STACKED;
6643                 /* Detach split and expunge aassign as above.  */
6644                 goto detach_split;
6645             }
6646             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6647                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
6648             {
6649                 /* convert split(...,0) to split(..., PL_modcount+1) */
6650                 SV ** const svp =
6651                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6652                 SV * const sv = *svp;
6653                 if (SvIOK(sv) && SvIVX(sv) == 0)
6654                 {
6655                   if (right->op_private & OPpSPLIT_IMPLIM) {
6656                     /* our own SV, created in ck_split */
6657                     SvREADONLY_off(sv);
6658                     sv_setiv(sv, PL_modcount+1);
6659                   }
6660                   else {
6661                     /* SV may belong to someone else */
6662                     SvREFCNT_dec(sv);
6663                     *svp = newSViv(PL_modcount+1);
6664                   }
6665                 }
6666             }
6667         }
6668         return o;
6669     }
6670     if (assign_type == ASSIGN_REF)
6671         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6672     if (!right)
6673         right = newOP(OP_UNDEF, 0);
6674     if (right->op_type == OP_READLINE) {
6675         right->op_flags |= OPf_STACKED;
6676         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6677                 scalar(right));
6678     }
6679     else {
6680         o = newBINOP(OP_SASSIGN, flags,
6681             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6682     }
6683     return o;
6684 }
6685
6686 /*
6687 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6688
6689 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6690 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6691 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6692 If C<label> is non-null, it supplies the name of a label to attach to
6693 the state op; this function takes ownership of the memory pointed at by
6694 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
6695 for the state op.
6696
6697 If C<o> is null, the state op is returned.  Otherwise the state op is
6698 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
6699 is consumed by this function and becomes part of the returned op tree.
6700
6701 =cut
6702 */
6703
6704 OP *
6705 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6706 {
6707     dVAR;
6708     const U32 seq = intro_my();
6709     const U32 utf8 = flags & SVf_UTF8;
6710     COP *cop;
6711
6712     PL_parser->parsed_sub = 0;
6713
6714     flags &= ~SVf_UTF8;
6715
6716     NewOp(1101, cop, 1, COP);
6717     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6718         OpTYPE_set(cop, OP_DBSTATE);
6719     }
6720     else {
6721         OpTYPE_set(cop, OP_NEXTSTATE);
6722     }
6723     cop->op_flags = (U8)flags;
6724     CopHINTS_set(cop, PL_hints);
6725 #ifdef VMS
6726     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6727 #endif
6728     cop->op_next = (OP*)cop;
6729
6730     cop->cop_seq = seq;
6731     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6732     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6733     if (label) {
6734         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6735
6736         PL_hints |= HINT_BLOCK_SCOPE;
6737         /* It seems that we need to defer freeing this pointer, as other parts
6738            of the grammar end up wanting to copy it after this op has been
6739            created. */
6740         SAVEFREEPV(label);
6741     }
6742
6743     if (PL_parser->preambling != NOLINE) {
6744         CopLINE_set(cop, PL_parser->preambling);
6745         PL_parser->copline = NOLINE;
6746     }
6747     else if (PL_parser->copline == NOLINE)
6748         CopLINE_set(cop, CopLINE(PL_curcop));
6749     else {
6750         CopLINE_set(cop, PL_parser->copline);
6751         PL_parser->copline = NOLINE;
6752     }
6753 #ifdef USE_ITHREADS
6754     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6755 #else
6756     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6757 #endif
6758     CopSTASH_set(cop, PL_curstash);
6759
6760     if (cop->op_type == OP_DBSTATE) {
6761         /* this line can have a breakpoint - store the cop in IV */
6762         AV *av = CopFILEAVx(PL_curcop);
6763         if (av) {
6764             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6765             if (svp && *svp != &PL_sv_undef ) {
6766                 (void)SvIOK_on(*svp);
6767                 SvIV_set(*svp, PTR2IV(cop));
6768             }
6769         }
6770     }
6771
6772     if (flags & OPf_SPECIAL)
6773         op_null((OP*)cop);
6774     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6775 }
6776
6777 /*
6778 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6779
6780 Constructs, checks, and returns a logical (flow control) op.  C<type>
6781 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6782 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6783 the eight bits of C<op_private>, except that the bit with value 1 is
6784 automatically set.  C<first> supplies the expression controlling the
6785 flow, and C<other> supplies the side (alternate) chain of ops; they are
6786 consumed by this function and become part of the constructed op tree.
6787
6788 =cut
6789 */
6790
6791 OP *
6792 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6793 {
6794     PERL_ARGS_ASSERT_NEWLOGOP;
6795
6796     return new_logop(type, flags, &first, &other);
6797 }
6798
6799 STATIC OP *
6800 S_search_const(pTHX_ OP *o)
6801 {
6802     PERL_ARGS_ASSERT_SEARCH_CONST;
6803
6804     switch (o->op_type) {
6805         case OP_CONST:
6806             return o;
6807         case OP_NULL:
6808             if (o->op_flags & OPf_KIDS)
6809                 return search_const(cUNOPo->op_first);
6810             break;
6811         case OP_LEAVE:
6812         case OP_SCOPE:
6813         case OP_LINESEQ:
6814         {
6815             OP *kid;
6816             if (!(o->op_flags & OPf_KIDS))
6817                 return NULL;
6818             kid = cLISTOPo->op_first;
6819             do {
6820                 switch (kid->op_type) {
6821                     case OP_ENTER:
6822                     case OP_NULL:
6823                     case OP_NEXTSTATE:
6824                         kid = OpSIBLING(kid);
6825                         break;
6826                     default:
6827                         if (kid != cLISTOPo->op_last)
6828                             return NULL;
6829                         goto last;
6830                 }
6831             } while (kid);
6832             if (!kid)
6833                 kid = cLISTOPo->op_last;
6834           last:
6835             return search_const(kid);
6836         }
6837     }
6838
6839     return NULL;
6840 }
6841
6842 STATIC OP *
6843 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6844 {
6845     dVAR;
6846     LOGOP *logop;
6847     OP *o;
6848     OP *first;
6849     OP *other;
6850     OP *cstop = NULL;
6851     int prepend_not = 0;
6852
6853     PERL_ARGS_ASSERT_NEW_LOGOP;
6854
6855     first = *firstp;
6856     other = *otherp;
6857
6858     /* [perl #59802]: Warn about things like "return $a or $b", which
6859        is parsed as "(return $a) or $b" rather than "return ($a or
6860        $b)".  NB: This also applies to xor, which is why we do it
6861        here.
6862      */
6863     switch (first->op_type) {
6864     case OP_NEXT:
6865     case OP_LAST:
6866     case OP_REDO:
6867         /* XXX: Perhaps we should emit a stronger warning for these.
6868            Even with the high-precedence operator they don't seem to do
6869            anything sensible.
6870
6871            But until we do, fall through here.
6872          */
6873     case OP_RETURN:
6874     case OP_EXIT:
6875     case OP_DIE:
6876     case OP_GOTO:
6877         /* XXX: Currently we allow people to "shoot themselves in the
6878            foot" by explicitly writing "(return $a) or $b".
6879
6880            Warn unless we are looking at the result from folding or if
6881            the programmer explicitly grouped the operators like this.
6882            The former can occur with e.g.
6883
6884                 use constant FEATURE => ( $] >= ... );
6885                 sub { not FEATURE and return or do_stuff(); }
6886          */
6887         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6888             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6889                            "Possible precedence issue with control flow operator");
6890         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6891            the "or $b" part)?
6892         */
6893         break;
6894     }
6895
6896     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6897         return newBINOP(type, flags, scalar(first), scalar(other));
6898
6899     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6900         || type == OP_CUSTOM);
6901
6902     scalarboolean(first);
6903
6904     /* search for a constant op that could let us fold the test */
6905     if ((cstop = search_const(first))) {
6906         if (cstop->op_private & OPpCONST_STRICT)
6907             no_bareword_allowed(cstop);
6908         else if ((cstop->op_private & OPpCONST_BARE))
6909                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6910         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6911             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6912             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6913             /* Elide the (constant) lhs, since it can't affect the outcome */
6914             *firstp = NULL;
6915             if (other->op_type == OP_CONST)
6916                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6917             op_free(first);
6918             if (other->op_type == OP_LEAVE)
6919                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6920             else if (other->op_type == OP_MATCH
6921                   || other->op_type == OP_SUBST
6922                   || other->op_type == OP_TRANSR
6923                   || other->op_type == OP_TRANS)
6924                 /* Mark the op as being unbindable with =~ */
6925                 other->op_flags |= OPf_SPECIAL;
6926
6927             other->op_folded = 1;
6928             return other;
6929         }
6930         else {
6931             /* Elide the rhs, since the outcome is entirely determined by
6932              * the (constant) lhs */
6933
6934             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6935             const OP *o2 = other;
6936             if ( ! (o2->op_type == OP_LIST
6937                     && (( o2 = cUNOPx(o2)->op_first))
6938                     && o2->op_type == OP_PUSHMARK
6939                     && (( o2 = OpSIBLING(o2))) )
6940             )
6941                 o2 = other;
6942             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6943                         || o2->op_type == OP_PADHV)
6944                 && o2->op_private & OPpLVAL_INTRO
6945                 && !(o2->op_private & OPpPAD_STATE))
6946             {
6947                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6948                                  "Deprecated use of my() in false conditional");
6949             }
6950
6951             *otherp = NULL;
6952             if (cstop->op_type == OP_CONST)
6953                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6954             op_free(other);
6955             return first;
6956         }
6957     }
6958     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6959         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6960     {
6961         const OP * const k1 = ((UNOP*)first)->op_first;
6962         const OP * const k2 = OpSIBLING(k1);
6963         OPCODE warnop = 0;
6964         switch (first->op_type)
6965         {
6966         case OP_NULL:
6967             if (k2 && k2->op_type == OP_READLINE
6968                   && (k2->op_flags & OPf_STACKED)
6969                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6970             {
6971                 warnop = k2->op_type;
6972             }
6973             break;
6974
6975         case OP_SASSIGN:
6976             if (k1->op_type == OP_READDIR
6977                   || k1->op_type == OP_GLOB
6978                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6979                  || k1->op_type == OP_EACH
6980                  || k1->op_type == OP_AEACH)
6981             {
6982                 warnop = ((k1->op_type == OP_NULL)
6983                           ? (OPCODE)k1->op_targ : k1->op_type);
6984             }
6985             break;
6986         }
6987         if (warnop) {
6988             const line_t oldline = CopLINE(PL_curcop);
6989             /* This ensures that warnings are reported at the first line
6990                of the construction, not the last.  */
6991             CopLINE_set(PL_curcop, PL_parser->copline);
6992             Perl_warner(aTHX_ packWARN(WARN_MISC),
6993                  "Value of %s%s can be \"0\"; test with defined()",
6994                  PL_op_desc[warnop],
6995                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6996                   ? " construct" : "() operator"));
6997             CopLINE_set(PL_curcop, oldline);
6998         }
6999     }
7000
7001     /* optimize AND and OR ops that have NOTs as children */
7002     if (first->op_type == OP_NOT
7003         && (first->op_flags & OPf_KIDS)
7004         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
7005             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
7006         ) {
7007         if (type == OP_AND || type == OP_OR) {
7008             if (type == OP_AND)
7009                 type = OP_OR;
7010             else
7011                 type = OP_AND;
7012             op_null(first);
7013             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7014                 op_null(other);
7015                 prepend_not = 1; /* prepend a NOT op later */
7016             }
7017         }
7018     }
7019
7020     logop = alloc_LOGOP(type, first, LINKLIST(other));
7021     logop->op_flags |= (U8)flags;
7022     logop->op_private = (U8)(1 | (flags >> 8));
7023
7024     /* establish postfix order */
7025     logop->op_next = LINKLIST(first);
7026     first->op_next = (OP*)logop;
7027     assert(!OpHAS_SIBLING(first));
7028     op_sibling_splice((OP*)logop, first, 0, other);
7029
7030     CHECKOP(type,logop);
7031
7032     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7033                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7034                 (OP*)logop);
7035     other->op_next = o;
7036
7037     return o;
7038 }
7039
7040 /*
7041 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7042
7043 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7044 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7045 will be set automatically, and, shifted up eight bits, the eight bits of
7046 C<op_private>, except that the bit with value 1 is automatically set.
7047 C<first> supplies the expression selecting between the two branches,
7048 and C<trueop> and C<falseop> supply the branches; they are consumed by
7049 this function and become part of the constructed op tree.
7050
7051 =cut
7052 */
7053
7054 OP *
7055 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7056 {
7057     dVAR;
7058     LOGOP *logop;
7059     OP *start;
7060     OP *o;
7061     OP *cstop;
7062
7063     PERL_ARGS_ASSERT_NEWCONDOP;
7064
7065     if (!falseop)
7066         return newLOGOP(OP_AND, 0, first, trueop);
7067     if (!trueop)
7068         return newLOGOP(OP_OR, 0, first, falseop);
7069
7070     scalarboolean(first);
7071     if ((cstop = search_const(first))) {
7072         /* Left or right arm of the conditional?  */
7073         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7074         OP *live = left ? trueop : falseop;
7075         OP *const dead = left ? falseop : trueop;
7076         if (cstop->op_private & OPpCONST_BARE &&
7077             cstop->op_private & OPpCONST_STRICT) {
7078             no_bareword_allowed(cstop);
7079         }
7080         op_free(first);
7081         op_free(dead);
7082         if (live->op_type == OP_LEAVE)
7083             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7084         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7085               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7086             /* Mark the op as being unbindable with =~ */
7087             live->op_flags |= OPf_SPECIAL;
7088         live->op_folded = 1;
7089         return live;
7090     }
7091     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7092     logop->op_flags |= (U8)flags;
7093     logop->op_private = (U8)(1 | (flags >> 8));
7094     logop->op_next = LINKLIST(falseop);
7095
7096     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7097             logop);
7098
7099     /* establish postfix order */
7100     start = LINKLIST(first);
7101     first->op_next = (OP*)logop;
7102
7103     /* make first, trueop, falseop siblings */
7104     op_sibling_splice((OP*)logop, first,  0, trueop);
7105     op_sibling_splice((OP*)logop, trueop, 0, falseop);
7106
7107     o = newUNOP(OP_NULL, 0, (OP*)logop);
7108
7109     trueop->op_next = falseop->op_next = o;
7110
7111     o->op_next = start;
7112     return o;
7113 }
7114
7115 /*
7116 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7117
7118 Constructs and returns a C<range> op, with subordinate C<flip> and
7119 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
7120 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7121 for both the C<flip> and C<range> ops, except that the bit with value
7122 1 is automatically set.  C<left> and C<right> supply the expressions
7123 controlling the endpoints of the range; they are consumed by this function
7124 and become part of the constructed op tree.
7125
7126 =cut
7127 */
7128
7129 OP *
7130 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7131 {
7132     LOGOP *range;
7133     OP *flip;
7134     OP *flop;
7135     OP *leftstart;
7136     OP *o;
7137
7138     PERL_ARGS_ASSERT_NEWRANGE;
7139
7140     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7141     range->op_flags = OPf_KIDS;
7142     leftstart = LINKLIST(left);
7143     range->op_private = (U8)(1 | (flags >> 8));
7144
7145     /* make left and right siblings */
7146     op_sibling_splice((OP*)range, left, 0, right);
7147
7148     range->op_next = (OP*)range;
7149     flip = newUNOP(OP_FLIP, flags, (OP*)range);
7150     flop = newUNOP(OP_FLOP, 0, flip);
7151     o = newUNOP(OP_NULL, 0, flop);
7152     LINKLIST(flop);
7153     range->op_next = leftstart;
7154
7155     left->op_next = flip;
7156     right->op_next = flop;
7157
7158     range->op_targ =
7159         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7160     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7161     flip->op_targ =
7162         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7163     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7164     SvPADTMP_on(PAD_SV(flip->op_targ));
7165
7166     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7167     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7168
7169     /* check barewords before they might be optimized aways */
7170     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7171         no_bareword_allowed(left);
7172     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7173         no_bareword_allowed(right);
7174
7175     flip->op_next = o;
7176     if (!flip->op_private || !flop->op_private)
7177         LINKLIST(o);            /* blow off optimizer unless constant */
7178
7179     return o;
7180 }
7181
7182 /*
7183 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7184
7185 Constructs, checks, and returns an op tree expressing a loop.  This is
7186 only a loop in the control flow through the op tree; it does not have
7187 the heavyweight loop structure that allows exiting the loop by C<last>
7188 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
7189 top-level op, except that some bits will be set automatically as required.
7190 C<expr> supplies the expression controlling loop iteration, and C<block>
7191 supplies the body of the loop; they are consumed by this function and
7192 become part of the constructed op tree.  C<debuggable> is currently
7193 unused and should always be 1.
7194
7195 =cut
7196 */
7197
7198 OP *
7199 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7200 {
7201     OP* listop;
7202     OP* o;
7203     const bool once = block && block->op_flags & OPf_SPECIAL &&
7204                       block->op_type == OP_NULL;
7205
7206     PERL_UNUSED_ARG(debuggable);
7207
7208     if (expr) {
7209         if (once && (
7210               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7211            || (  expr->op_type == OP_NOT
7212               && cUNOPx(expr)->op_first->op_type == OP_CONST
7213               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7214               )
7215            ))
7216             /* Return the block now, so that S_new_logop does not try to
7217                fold it away. */
7218             return block;       /* do {} while 0 does once */
7219         if (expr->op_type == OP_READLINE
7220             || expr->op_type == OP_READDIR
7221             || expr->op_type == OP_GLOB
7222             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7223             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7224             expr = newUNOP(OP_DEFINED, 0,
7225                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7226         } else if (expr->op_flags & OPf_KIDS) {
7227             const OP * const k1 = ((UNOP*)expr)->op_first;
7228             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7229             switch (expr->op_type) {
7230               case OP_NULL:
7231                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7232                       && (k2->op_flags & OPf_STACKED)
7233                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7234                     expr = newUNOP(OP_DEFINED, 0, expr);
7235                 break;
7236
7237               case OP_SASSIGN:
7238                 if (k1 && (k1->op_type == OP_READDIR
7239                       || k1->op_type == OP_GLOB
7240                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7241                      || k1->op_type == OP_EACH
7242                      || k1->op_type == OP_AEACH))
7243                     expr = newUNOP(OP_DEFINED, 0, expr);
7244                 break;
7245             }
7246         }
7247     }
7248
7249     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7250      * op, in listop. This is wrong. [perl #27024] */
7251     if (!block)
7252         block = newOP(OP_NULL, 0);
7253     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7254     o = new_logop(OP_AND, 0, &expr, &listop);
7255
7256     if (once) {
7257         ASSUME(listop);
7258     }
7259
7260     if (listop)
7261         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7262
7263     if (once && o != listop)
7264     {
7265         assert(cUNOPo->op_first->op_type == OP_AND
7266             || cUNOPo->op_first->op_type == OP_OR);
7267         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7268     }
7269
7270     if (o == listop)
7271         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
7272
7273     o->op_flags |= flags;
7274     o = op_scope(o);
7275     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7276     return o;
7277 }
7278
7279 /*
7280 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7281
7282 Constructs, checks, and returns an op tree expressing a C<while> loop.
7283 This is a heavyweight loop, with structure that allows exiting the loop
7284 by C<last> and suchlike.
7285
7286 C<loop> is an optional preconstructed C<enterloop> op to use in the
7287 loop; if it is null then a suitable op will be constructed automatically.
7288 C<expr> supplies the loop's controlling expression.  C<block> supplies the
7289 main body of the loop, and C<cont> optionally supplies a C<continue> block
7290 that operates as a second half of the body.  All of these optree inputs
7291 are consumed by this function and become part of the constructed op tree.
7292
7293 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7294 op and, shifted up eight bits, the eight bits of C<op_private> for
7295 the C<leaveloop> op, except that (in both cases) some bits will be set
7296 automatically.  C<debuggable> is currently unused and should always be 1.
7297 C<has_my> can be supplied as true to force the
7298 loop body to be enclosed in its own scope.
7299
7300 =cut
7301 */
7302
7303 OP *
7304 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7305         OP *expr, OP *block, OP *cont, I32 has_my)
7306 {
7307     dVAR;
7308     OP *redo;
7309     OP *next = NULL;
7310     OP *listop;
7311     OP *o;
7312     U8 loopflags = 0;
7313
7314     PERL_UNUSED_ARG(debuggable);
7315
7316     if (expr) {
7317         if (expr->op_type == OP_READLINE
7318          || expr->op_type == OP_READDIR
7319          || expr->op_type == OP_GLOB
7320          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7321                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7322             expr = newUNOP(OP_DEFINED, 0,
7323                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7324         } else if (expr->op_flags & OPf_KIDS) {
7325             const OP * const k1 = ((UNOP*)expr)->op_first;
7326             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7327             switch (expr->op_type) {
7328               case OP_NULL:
7329                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7330                       && (k2->op_flags & OPf_STACKED)
7331                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7332                     expr = newUNOP(OP_DEFINED, 0, expr);
7333                 break;
7334
7335               case OP_SASSIGN:
7336                 if (k1 && (k1->op_type == OP_READDIR
7337                       || k1->op_type == OP_GLOB
7338                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7339                      || k1->op_type == OP_EACH
7340                      || k1->op_type == OP_AEACH))
7341                     expr = newUNOP(OP_DEFINED, 0, expr);
7342                 break;
7343             }
7344         }
7345     }
7346
7347     if (!block)
7348         block = newOP(OP_NULL, 0);
7349     else if (cont || has_my) {
7350         block = op_scope(block);
7351     }
7352
7353     if (cont) {
7354         next = LINKLIST(cont);
7355     }
7356     if (expr) {
7357         OP * const unstack = newOP(OP_UNSTACK, 0);
7358         if (!next)
7359             next = unstack;
7360         cont = op_append_elem(OP_LINESEQ, cont, unstack);
7361     }
7362
7363     assert(block);
7364     listop = op_append_list(OP_LINESEQ, block, cont);
7365     assert(listop);
7366     redo = LINKLIST(listop);
7367
7368     if (expr) {
7369         scalar(listop);
7370         o = new_logop(OP_AND, 0, &expr, &listop);
7371         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7372             op_free((OP*)loop);
7373             return expr;                /* listop already freed by new_logop */
7374         }
7375         if (listop)
7376             ((LISTOP*)listop)->op_last->op_next =
7377                 (o == listop ? redo : LINKLIST(o));
7378     }
7379     else
7380         o = listop;
7381
7382     if (!loop) {
7383         NewOp(1101,loop,1,LOOP);
7384         OpTYPE_set(loop, OP_ENTERLOOP);
7385         loop->op_private = 0;
7386         loop->op_next = (OP*)loop;
7387     }
7388
7389     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7390
7391     loop->op_redoop = redo;
7392     loop->op_lastop = o;
7393     o->op_private |= loopflags;
7394
7395     if (next)
7396         loop->op_nextop = next;
7397     else
7398         loop->op_nextop = o;
7399
7400     o->op_flags |= flags;
7401     o->op_private |= (flags >> 8);
7402     return o;
7403 }
7404
7405 /*
7406 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7407
7408 Constructs, checks, and returns an op tree expressing a C<foreach>
7409 loop (iteration through a list of values).  This is a heavyweight loop,
7410 with structure that allows exiting the loop by C<last> and suchlike.
7411
7412 C<sv> optionally supplies the variable that will be aliased to each
7413 item in turn; if null, it defaults to C<$_>.
7414 C<expr> supplies the list of values to iterate over.  C<block> supplies
7415 the main body of the loop, and C<cont> optionally supplies a C<continue>
7416 block that operates as a second half of the body.  All of these optree
7417 inputs are consumed by this function and become part of the constructed
7418 op tree.
7419
7420 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7421 op and, shifted up eight bits, the eight bits of C<op_private> for
7422 the C<leaveloop> op, except that (in both cases) some bits will be set
7423 automatically.
7424
7425 =cut
7426 */
7427
7428 OP *
7429 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7430 {
7431     dVAR;
7432     LOOP *loop;
7433     OP *wop;
7434     PADOFFSET padoff = 0;
7435     I32 iterflags = 0;
7436     I32 iterpflags = 0;
7437
7438     PERL_ARGS_ASSERT_NEWFOROP;
7439
7440     if (sv) {
7441         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
7442             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7443             OpTYPE_set(sv, OP_RV2GV);
7444
7445             /* The op_type check is needed to prevent a possible segfault
7446              * if the loop variable is undeclared and 'strict vars' is in
7447              * effect. This is illegal but is nonetheless parsed, so we
7448              * may reach this point with an OP_CONST where we're expecting
7449              * an OP_GV.
7450              */
7451             if (cUNOPx(sv)->op_first->op_type == OP_GV
7452              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7453                 iterpflags |= OPpITER_DEF;
7454         }
7455         else if (sv->op_type == OP_PADSV) { /* private variable */
7456             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7457             padoff = sv->op_targ;
7458             sv->op_targ = 0;
7459             op_free(sv);
7460             sv = NULL;
7461             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7462         }
7463         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7464             NOOP;
7465         else
7466             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7467         if (padoff) {
7468             PADNAME * const pn = PAD_COMPNAME(padoff);
7469             const char * const name = PadnamePV(pn);
7470
7471             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7472                 iterpflags |= OPpITER_DEF;
7473         }
7474     }
7475     else {
7476         sv = newGVOP(OP_GV, 0, PL_defgv);
7477         iterpflags |= OPpITER_DEF;
7478     }
7479
7480     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7481         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7482         iterflags |= OPf_STACKED;
7483     }
7484     else if (expr->op_type == OP_NULL &&
7485              (expr->op_flags & OPf_KIDS) &&
7486              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7487     {
7488         /* Basically turn for($x..$y) into the same as for($x,$y), but we
7489          * set the STACKED flag to indicate that these values are to be
7490          * treated as min/max values by 'pp_enteriter'.
7491          */
7492         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7493         LOGOP* const range = (LOGOP*) flip->op_first;
7494         OP* const left  = range->op_first;
7495         OP* const right = OpSIBLING(left);
7496         LISTOP* listop;
7497
7498         range->op_flags &= ~OPf_KIDS;
7499         /* detach range's children */
7500         op_sibling_splice((OP*)range, NULL, -1, NULL);
7501
7502         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7503         listop->op_first->op_next = range->op_next;
7504         left->op_next = range->op_other;
7505         right->op_next = (OP*)listop;
7506         listop->op_next = listop->op_first;
7507
7508         op_free(expr);
7509         expr = (OP*)(listop);
7510         op_null(expr);
7511         iterflags |= OPf_STACKED;
7512     }
7513     else {
7514         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7515     }
7516
7517     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7518                                   op_append_elem(OP_LIST, list(expr),
7519                                                  scalar(sv)));
7520     assert(!loop->op_next);
7521     /* for my  $x () sets OPpLVAL_INTRO;
7522      * for our $x () sets OPpOUR_INTRO */
7523     loop->op_private = (U8)iterpflags;
7524     if (loop->op_slabbed
7525      && DIFF(loop, OpSLOT(loop)->opslot_next)
7526          < SIZE_TO_PSIZE(sizeof(LOOP)))
7527     {
7528         LOOP *tmp;
7529         NewOp(1234,tmp,1,LOOP);
7530         Copy(loop,tmp,1,LISTOP);
7531 #ifdef PERL_OP_PARENT
7532         assert(loop->op_last->op_sibparent == (OP*)loop);
7533         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7534 #endif
7535         S_op_destroy(aTHX_ (OP*)loop);
7536         loop = tmp;
7537     }
7538     else if (!loop->op_slabbed)
7539     {
7540         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7541 #ifdef PERL_OP_PARENT
7542         OpLASTSIB_set(loop->op_last, (OP*)loop);
7543 #endif
7544     }
7545     loop->op_targ = padoff;
7546     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7547     return wop;
7548 }
7549
7550 /*
7551 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7552
7553 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7554 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
7555 determining the target of the op; it is consumed by this function and
7556 becomes part of the constructed op tree.
7557
7558 =cut
7559 */
7560
7561 OP*
7562 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7563 {
7564     OP *o = NULL;
7565
7566     PERL_ARGS_ASSERT_NEWLOOPEX;
7567
7568     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7569         || type == OP_CUSTOM);
7570
7571     if (type != OP_GOTO) {
7572         /* "last()" means "last" */
7573         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7574             o = newOP(type, OPf_SPECIAL);
7575         }
7576     }
7577     else {
7578         /* Check whether it's going to be a goto &function */
7579         if (label->op_type == OP_ENTERSUB
7580                 && !(label->op_flags & OPf_STACKED))
7581             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7582     }
7583
7584     /* Check for a constant argument */
7585     if (label->op_type == OP_CONST) {
7586             SV * const sv = ((SVOP *)label)->op_sv;
7587             STRLEN l;
7588             const char *s = SvPV_const(sv,l);
7589             if (l == strlen(s)) {
7590                 o = newPVOP(type,
7591                             SvUTF8(((SVOP*)label)->op_sv),
7592                             savesharedpv(
7593                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7594             }
7595     }
7596
7597     /* If we have already created an op, we do not need the label. */
7598     if (o)
7599                 op_free(label);
7600     else o = newUNOP(type, OPf_STACKED, label);
7601
7602     PL_hints |= HINT_BLOCK_SCOPE;
7603     return o;
7604 }
7605
7606 /* if the condition is a literal array or hash
7607    (or @{ ... } etc), make a reference to it.
7608  */
7609 STATIC OP *
7610 S_ref_array_or_hash(pTHX_ OP *cond)
7611 {
7612     if (cond
7613     && (cond->op_type == OP_RV2AV
7614     ||  cond->op_type == OP_PADAV
7615     ||  cond->op_type == OP_RV2HV
7616     ||  cond->op_type == OP_PADHV))
7617
7618         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7619
7620     else if(cond
7621     && (cond->op_type == OP_ASLICE
7622     ||  cond->op_type == OP_KVASLICE
7623     ||  cond->op_type == OP_HSLICE
7624     ||  cond->op_type == OP_KVHSLICE)) {
7625
7626         /* anonlist now needs a list from this op, was previously used in
7627          * scalar context */
7628         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7629         cond->op_flags |= OPf_WANT_LIST;
7630
7631         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7632     }
7633
7634     else
7635         return cond;
7636 }
7637
7638 /* These construct the optree fragments representing given()
7639    and when() blocks.
7640
7641    entergiven and enterwhen are LOGOPs; the op_other pointer
7642    points up to the associated leave op. We need this so we
7643    can put it in the context and make break/continue work.
7644    (Also, of course, pp_enterwhen will jump straight to
7645    op_other if the match fails.)
7646  */
7647
7648 STATIC OP *
7649 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7650                    I32 enter_opcode, I32 leave_opcode,
7651                    PADOFFSET entertarg)
7652 {
7653     dVAR;
7654     LOGOP *enterop;
7655     OP *o;
7656
7657     PERL_ARGS_ASSERT_NEWGIVWHENOP;
7658     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7659
7660     enterop = alloc_LOGOP(enter_opcode, block, NULL);
7661     enterop->op_targ = 0;
7662     enterop->op_private = 0;
7663
7664     o = newUNOP(leave_opcode, 0, (OP *) enterop);
7665
7666     if (cond) {
7667         /* prepend cond if we have one */
7668         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7669
7670         o->op_next = LINKLIST(cond);
7671         cond->op_next = (OP *) enterop;
7672     }
7673     else {
7674         /* This is a default {} block */
7675         enterop->op_flags |= OPf_SPECIAL;
7676         o      ->op_flags |= OPf_SPECIAL;
7677
7678         o->op_next = (OP *) enterop;
7679     }
7680
7681     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7682                                        entergiven and enterwhen both
7683                                        use ck_null() */
7684
7685     enterop->op_next = LINKLIST(block);
7686     block->op_next = enterop->op_other = o;
7687
7688     return o;
7689 }
7690
7691 /* Does this look like a boolean operation? For these purposes
7692    a boolean operation is:
7693      - a subroutine call [*]
7694      - a logical connective
7695      - a comparison operator
7696      - a filetest operator, with the exception of -s -M -A -C
7697      - defined(), exists() or eof()
7698      - /$re/ or $foo =~ /$re/
7699
7700    [*] possibly surprising
7701  */
7702 STATIC bool
7703 S_looks_like_bool(pTHX_ const OP *o)
7704 {
7705     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7706
7707     switch(o->op_type) {
7708         case OP_OR:
7709         case OP_DOR:
7710             return looks_like_bool(cLOGOPo->op_first);
7711
7712         case OP_AND:
7713         {
7714             OP* sibl = OpSIBLING(cLOGOPo->op_first);
7715             ASSUME(sibl);
7716             return (
7717                 looks_like_bool(cLOGOPo->op_first)
7718              && looks_like_bool(sibl));
7719         }
7720
7721         case OP_NULL:
7722         case OP_SCALAR:
7723             return (
7724                 o->op_flags & OPf_KIDS
7725             && looks_like_bool(cUNOPo->op_first));
7726
7727         case OP_ENTERSUB:
7728
7729         case OP_NOT:    case OP_XOR:
7730
7731         case OP_EQ:     case OP_NE:     case OP_LT:
7732         case OP_GT:     case OP_LE:     case OP_GE:
7733
7734         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
7735         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
7736
7737         case OP_SEQ:    case OP_SNE:    case OP_SLT:
7738         case OP_SGT:    case OP_SLE:    case OP_SGE:
7739
7740         case OP_SMARTMATCH:
7741
7742         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7743         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7744         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7745         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7746         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7747         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7748         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7749         case OP_FTTEXT:   case OP_FTBINARY:
7750
7751         case OP_DEFINED: case OP_EXISTS:
7752         case OP_MATCH:   case OP_EOF:
7753
7754         case OP_FLOP:
7755
7756             return TRUE;
7757
7758         case OP_CONST:
7759             /* Detect comparisons that have been optimized away */
7760             if (cSVOPo->op_sv == &PL_sv_yes
7761             ||  cSVOPo->op_sv == &PL_sv_no)
7762
7763                 return TRUE;
7764             else
7765                 return FALSE;
7766
7767         /* FALLTHROUGH */
7768         default:
7769             return FALSE;
7770     }
7771 }
7772
7773 /*
7774 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7775
7776 Constructs, checks, and returns an op tree expressing a C<given> block.
7777 C<cond> supplies the expression that will be locally assigned to a lexical
7778 variable, and C<block> supplies the body of the C<given> construct; they
7779 are consumed by this function and become part of the constructed op tree.
7780 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7781
7782 =cut
7783 */
7784
7785 OP *
7786 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7787 {
7788     PERL_ARGS_ASSERT_NEWGIVENOP;
7789     PERL_UNUSED_ARG(defsv_off);
7790
7791     assert(!defsv_off);
7792     return newGIVWHENOP(
7793         ref_array_or_hash(cond),
7794         block,
7795         OP_ENTERGIVEN, OP_LEAVEGIVEN,
7796         0);
7797 }
7798
7799 /*
7800 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7801
7802 Constructs, checks, and returns an op tree expressing a C<when> block.
7803 C<cond> supplies the test expression, and C<block> supplies the block
7804 that will be executed if the test evaluates to true; they are consumed
7805 by this function and become part of the constructed op tree.  C<cond>
7806 will be interpreted DWIMically, often as a comparison against C<$_>,
7807 and may be null to generate a C<default> block.
7808
7809 =cut
7810 */
7811
7812 OP *
7813 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7814 {
7815     const bool cond_llb = (!cond || looks_like_bool(cond));
7816     OP *cond_op;
7817
7818     PERL_ARGS_ASSERT_NEWWHENOP;
7819
7820     if (cond_llb)
7821         cond_op = cond;
7822     else {
7823         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7824                 newDEFSVOP(),
7825                 scalar(ref_array_or_hash(cond)));
7826     }
7827
7828     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7829 }
7830
7831 /* must not conflict with SVf_UTF8 */
7832 #define CV_CKPROTO_CURSTASH     0x1
7833
7834 void
7835 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7836                     const STRLEN len, const U32 flags)
7837 {
7838     SV *name = NULL, *msg;
7839     const char * cvp = SvROK(cv)
7840                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7841                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7842                            : ""
7843                         : CvPROTO(cv);
7844     STRLEN clen = CvPROTOLEN(cv), plen = len;
7845
7846     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7847
7848     if (p == NULL && cvp == NULL)
7849         return;
7850
7851     if (!ckWARN_d(WARN_PROTOTYPE))
7852         return;
7853
7854     if (p && cvp) {
7855         p = S_strip_spaces(aTHX_ p, &plen);
7856         cvp = S_strip_spaces(aTHX_ cvp, &clen);
7857         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7858             if (plen == clen && memEQ(cvp, p, plen))
7859                 return;
7860         } else {
7861             if (flags & SVf_UTF8) {
7862                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7863                     return;
7864             }
7865             else {
7866                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7867                     return;
7868             }
7869         }
7870     }
7871
7872     msg = sv_newmortal();
7873
7874     if (gv)
7875     {
7876         if (isGV(gv))
7877             gv_efullname3(name = sv_newmortal(), gv, NULL);
7878         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7879             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7880         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7881             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7882             sv_catpvs(name, "::");
7883             if (SvROK(gv)) {
7884                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7885                 assert (CvNAMED(SvRV_const(gv)));
7886                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7887             }
7888             else sv_catsv(name, (SV *)gv);
7889         }
7890         else name = (SV *)gv;
7891     }
7892     sv_setpvs(msg, "Prototype mismatch:");
7893     if (name)
7894         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
7895     if (cvp)
7896         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
7897             UTF8fARG(SvUTF8(cv),clen,cvp)
7898         );
7899     else
7900         sv_catpvs(msg, ": none");
7901     sv_catpvs(msg, " vs ");
7902     if (p)
7903         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
7904     else
7905         sv_catpvs(msg, "none");
7906     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
7907 }
7908
7909 static void const_sv_xsub(pTHX_ CV* cv);
7910 static void const_av_xsub(pTHX_ CV* cv);
7911
7912 /*
7913
7914 =head1 Optree Manipulation Functions
7915
7916 =for apidoc cv_const_sv
7917
7918 If C<cv> is a constant sub eligible for inlining, returns the constant
7919 value returned by the sub.  Otherwise, returns C<NULL>.
7920
7921 Constant subs can be created with C<newCONSTSUB> or as described in
7922 L<perlsub/"Constant Functions">.
7923
7924 =cut
7925 */
7926 SV *
7927 Perl_cv_const_sv(const CV *const cv)
7928 {
7929     SV *sv;
7930     if (!cv)
7931         return NULL;
7932     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7933         return NULL;
7934     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7935     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7936     return sv;
7937 }
7938
7939 SV *
7940 Perl_cv_const_sv_or_av(const CV * const cv)
7941 {
7942     if (!cv)
7943         return NULL;
7944     if (SvROK(cv)) return SvRV((SV *)cv);
7945     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7946     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7947 }
7948
7949 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7950  * Can be called in 2 ways:
7951  *
7952  * !allow_lex
7953  *      look for a single OP_CONST with attached value: return the value
7954  *
7955  * allow_lex && !CvCONST(cv);
7956  *
7957  *      examine the clone prototype, and if contains only a single
7958  *      OP_CONST, return the value; or if it contains a single PADSV ref-
7959  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
7960  *      a candidate for "constizing" at clone time, and return NULL.
7961  */
7962
7963 static SV *
7964 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7965 {
7966     SV *sv = NULL;
7967     bool padsv = FALSE;
7968
7969     assert(o);
7970     assert(cv);
7971
7972     for (; o; o = o->op_next) {
7973         const OPCODE type = o->op_type;
7974
7975         if (type == OP_NEXTSTATE || type == OP_LINESEQ
7976              || type == OP_NULL
7977              || type == OP_PUSHMARK)
7978                 continue;
7979         if (type == OP_DBSTATE)
7980                 continue;
7981         if (type == OP_LEAVESUB)
7982             break;
7983         if (sv)
7984             return NULL;
7985         if (type == OP_CONST && cSVOPo->op_sv)
7986             sv = cSVOPo->op_sv;
7987         else if (type == OP_UNDEF && !o->op_private) {
7988             sv = newSV(0);
7989             SAVEFREESV(sv);
7990         }
7991         else if (allow_lex && type == OP_PADSV) {
7992                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7993                 {
7994                     sv = &PL_sv_undef; /* an arbitrary non-null value */
7995                     padsv = TRUE;
7996                 }
7997                 else
7998                     return NULL;
7999         }
8000         else {
8001             return NULL;
8002         }
8003     }
8004     if (padsv) {
8005         CvCONST_on(cv);
8006         return NULL;
8007     }
8008     return sv;
8009 }
8010
8011 static void
8012 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8013                         PADNAME * const name, SV ** const const_svp)
8014 {
8015     assert (cv);
8016     assert (o || name);
8017     assert (const_svp);
8018     if (!block) {
8019         if (CvFLAGS(PL_compcv)) {
8020             /* might have had built-in attrs applied */
8021             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8022             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8023              && ckWARN(WARN_MISC))
8024             {
8025                 /* protect against fatal warnings leaking compcv */
8026                 SAVEFREESV(PL_compcv);
8027                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8028                 SvREFCNT_inc_simple_void_NN(PL_compcv);
8029             }
8030             CvFLAGS(cv) |=
8031                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8032                   & ~(CVf_LVALUE * pureperl));
8033         }
8034         return;
8035     }
8036
8037     /* redundant check for speed: */
8038     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8039         const line_t oldline = CopLINE(PL_curcop);
8040         SV *namesv = o
8041             ? cSVOPo->op_sv
8042             : sv_2mortal(newSVpvn_utf8(
8043                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8044               ));
8045         if (PL_parser && PL_parser->copline != NOLINE)
8046             /* This ensures that warnings are reported at the first
8047                line of a redefinition, not the last.  */
8048             CopLINE_set(PL_curcop, PL_parser->copline);
8049         /* protect against fatal warnings leaking compcv */
8050         SAVEFREESV(PL_compcv);
8051         report_redefined_cv(namesv, cv, const_svp);
8052         SvREFCNT_inc_simple_void_NN(PL_compcv);
8053         CopLINE_set(PL_curcop, oldline);
8054     }
8055     SAVEFREESV(cv);
8056     return;
8057 }
8058
8059 CV *
8060 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8061 {
8062     CV **spot;
8063     SV **svspot;
8064     const char *ps;
8065     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8066     U32 ps_utf8 = 0;
8067     CV *cv = NULL;
8068     CV *compcv = PL_compcv;
8069     SV *const_sv;
8070     PADNAME *name;
8071     PADOFFSET pax = o->op_targ;
8072     CV *outcv = CvOUTSIDE(PL_compcv);
8073     CV *clonee = NULL;
8074     HEK *hek = NULL;
8075     bool reusable = FALSE;
8076     OP *start = NULL;
8077 #ifdef PERL_DEBUG_READONLY_OPS
8078     OPSLAB *slab = NULL;
8079 #endif
8080
8081     PERL_ARGS_ASSERT_NEWMYSUB;
8082
8083     /* Find the pad slot for storing the new sub.
8084        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
8085        need to look in CvOUTSIDE and find the pad belonging to the enclos-
8086        ing sub.  And then we need to dig deeper if this is a lexical from
8087        outside, as in:
8088            my sub foo; sub { sub foo { } }
8089      */
8090   redo:
8091     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8092     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8093         pax = PARENT_PAD_INDEX(name);
8094         outcv = CvOUTSIDE(outcv);
8095         assert(outcv);
8096         goto redo;
8097     }
8098     svspot =
8099         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8100                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8101     spot = (CV **)svspot;
8102
8103     if (!(PL_parser && PL_parser->error_count))
8104         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8105
8106     if (proto) {
8107         assert(proto->op_type == OP_CONST);
8108         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8109         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8110     }
8111     else
8112         ps = NULL;
8113
8114     if (proto)
8115         SAVEFREEOP(proto);
8116     if (attrs)
8117         SAVEFREEOP(attrs);
8118
8119     if (PL_parser && PL_parser->error_count) {
8120         op_free(block);
8121         SvREFCNT_dec(PL_compcv);
8122         PL_compcv = 0;
8123         goto done;
8124     }
8125
8126     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8127         cv = *spot;
8128         svspot = (SV **)(spot = &clonee);
8129     }
8130     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8131         cv = *spot;
8132     else {
8133         assert (SvTYPE(*spot) == SVt_PVCV);
8134         if (CvNAMED(*spot))
8135             hek = CvNAME_HEK(*spot);
8136         else {
8137             dVAR;
8138             U32 hash;
8139             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8140             CvNAME_HEK_set(*spot, hek =
8141                 share_hek(
8142                     PadnamePV(name)+1,
8143                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8144                     hash
8145                 )
8146             );
8147             CvLEXICAL_on(*spot);
8148         }
8149         cv = PadnamePROTOCV(name);
8150         svspot = (SV **)(spot = &PadnamePROTOCV(name));
8151     }
8152
8153     if (block) {
8154         /* This makes sub {}; work as expected.  */
8155         if (block->op_type == OP_STUB) {
8156             const line_t l = PL_parser->copline;
8157             op_free(block);
8158             block = newSTATEOP(0, NULL, 0);
8159             PL_parser->copline = l;
8160         }
8161         block = CvLVALUE(compcv)
8162              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8163                    ? newUNOP(OP_LEAVESUBLV, 0,
8164                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8165                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8166         start = LINKLIST(block);
8167         block->op_next = 0;
8168         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8169             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8170         else
8171             const_sv = NULL;
8172     }
8173     else
8174         const_sv = NULL;
8175
8176     if (cv) {
8177         const bool exists = CvROOT(cv) || CvXSUB(cv);
8178
8179         /* if the subroutine doesn't exist and wasn't pre-declared
8180          * with a prototype, assume it will be AUTOLOADed,
8181          * skipping the prototype check
8182          */
8183         if (exists || SvPOK(cv))
8184             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8185                                  ps_utf8);
8186         /* already defined? */
8187         if (exists) {
8188             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8189             if (block)
8190                 cv = NULL;
8191             else {
8192                 if (attrs)
8193                     goto attrs;
8194                 /* just a "sub foo;" when &foo is already defined */
8195                 SAVEFREESV(compcv);
8196                 goto done;
8197             }
8198         }
8199         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8200             cv = NULL;
8201             reusable = TRUE;
8202         }
8203     }
8204
8205     if (const_sv) {
8206         SvREFCNT_inc_simple_void_NN(const_sv);
8207         SvFLAGS(const_sv) |= SVs_PADTMP;
8208         if (cv) {
8209             assert(!CvROOT(cv) && !CvCONST(cv));
8210             cv_forget_slab(cv);
8211         }
8212         else {
8213             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8214             CvFILE_set_from_cop(cv, PL_curcop);
8215             CvSTASH_set(cv, PL_curstash);
8216             *spot = cv;
8217         }
8218         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
8219         CvXSUBANY(cv).any_ptr = const_sv;
8220         CvXSUB(cv) = const_sv_xsub;
8221         CvCONST_on(cv);
8222         CvISXSUB_on(cv);
8223         PoisonPADLIST(cv);
8224         CvFLAGS(cv) |= CvMETHOD(compcv);
8225         op_free(block);
8226         SvREFCNT_dec(compcv);
8227         PL_compcv = NULL;
8228         goto setname;
8229     }
8230
8231     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8232        determine whether this sub definition is in the same scope as its
8233        declaration.  If this sub definition is inside an inner named pack-
8234        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8235        the package sub.  So check PadnameOUTER(name) too.
8236      */
8237     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8238         assert(!CvWEAKOUTSIDE(compcv));
8239         SvREFCNT_dec(CvOUTSIDE(compcv));
8240         CvWEAKOUTSIDE_on(compcv);
8241     }
8242     /* XXX else do we have a circular reference? */
8243
8244     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
8245         /* transfer PL_compcv to cv */
8246         if (block) {
8247             cv_flags_t preserved_flags =
8248                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8249             PADLIST *const temp_padl = CvPADLIST(cv);
8250             CV *const temp_cv = CvOUTSIDE(cv);
8251             const cv_flags_t other_flags =
8252                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8253             OP * const cvstart = CvSTART(cv);
8254
8255             SvPOK_off(cv);
8256             CvFLAGS(cv) =
8257                 CvFLAGS(compcv) | preserved_flags;
8258             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8259             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8260             CvPADLIST_set(cv, CvPADLIST(compcv));
8261             CvOUTSIDE(compcv) = temp_cv;
8262             CvPADLIST_set(compcv, temp_padl);
8263             CvSTART(cv) = CvSTART(compcv);
8264             CvSTART(compcv) = cvstart;
8265             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8266             CvFLAGS(compcv) |= other_flags;
8267
8268             if (CvFILE(cv) && CvDYNFILE(cv)) {
8269                 Safefree(CvFILE(cv));
8270             }
8271
8272             /* inner references to compcv must be fixed up ... */
8273             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8274             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8275                 ++PL_sub_generation;
8276         }
8277         else {
8278             /* Might have had built-in attributes applied -- propagate them. */
8279             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8280         }
8281         /* ... before we throw it away */
8282         SvREFCNT_dec(compcv);
8283         PL_compcv = compcv = cv;
8284     }
8285     else {
8286         cv = compcv;
8287         *spot = cv;
8288     }
8289
8290   setname:
8291     CvLEXICAL_on(cv);
8292     if (!CvNAME_HEK(cv)) {
8293         if (hek) (void)share_hek_hek(hek);
8294         else {
8295             dVAR;
8296             U32 hash;
8297             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8298             hek = share_hek(PadnamePV(name)+1,
8299                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8300                       hash);
8301         }
8302         CvNAME_HEK_set(cv, hek);
8303     }
8304
8305     if (const_sv)
8306         goto clone;
8307
8308     CvFILE_set_from_cop(cv, PL_curcop);
8309     CvSTASH_set(cv, PL_curstash);
8310
8311     if (ps) {
8312         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8313         if (ps_utf8)
8314             SvUTF8_on(MUTABLE_SV(cv));
8315     }
8316
8317     if (block) {
8318         /* If we assign an optree to a PVCV, then we've defined a
8319          * subroutine that the debugger could be able to set a breakpoint
8320          * in, so signal to pp_entereval that it should not throw away any
8321          * saved lines at scope exit.  */
8322
8323         PL_breakable_sub_gen++;
8324         CvROOT(cv) = block;
8325         CvROOT(cv)->op_private |= OPpREFCOUNTED;
8326         OpREFCNT_set(CvROOT(cv), 1);
8327         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8328            itself has a refcount. */
8329         CvSLABBED_off(cv);
8330         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8331 #ifdef PERL_DEBUG_READONLY_OPS
8332         slab = (OPSLAB *)CvSTART(cv);
8333 #endif
8334         CvSTART(cv) = start;
8335         CALL_PEEP(start);
8336         finalize_optree(CvROOT(cv));
8337         S_prune_chain_head(&CvSTART(cv));
8338
8339         /* now that optimizer has done its work, adjust pad values */
8340
8341         pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8342     }
8343
8344   attrs:
8345     if (attrs) {
8346         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8347         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8348     }
8349
8350     if (block) {
8351         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8352             SV * const tmpstr = sv_newmortal();
8353             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8354                                                   GV_ADDMULTI, SVt_PVHV);
8355             HV *hv;
8356             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8357                                           CopFILE(PL_curcop),
8358                                           (long)PL_subline,
8359                                           (long)CopLINE(PL_curcop));
8360             if (HvNAME_HEK(PL_curstash)) {
8361                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8362                 sv_catpvs(tmpstr, "::");
8363             }
8364             else
8365                 sv_setpvs(tmpstr, "__ANON__::");
8366
8367             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8368                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8369             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8370                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8371             hv = GvHVn(db_postponed);
8372             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8373                 CV * const pcv = GvCV(db_postponed);
8374                 if (pcv) {
8375                     dSP;
8376                     PUSHMARK(SP);
8377                     XPUSHs(tmpstr);
8378                     PUTBACK;
8379                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8380                 }
8381             }
8382         }
8383     }
8384
8385   clone:
8386     if (clonee) {
8387         assert(CvDEPTH(outcv));
8388         spot = (CV **)
8389             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8390         if (reusable)
8391             cv_clone_into(clonee, *spot);
8392         else *spot = cv_clone(clonee);
8393         SvREFCNT_dec_NN(clonee);
8394         cv = *spot;
8395     }
8396
8397     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8398         PADOFFSET depth = CvDEPTH(outcv);
8399         while (--depth) {
8400             SV *oldcv;
8401             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8402             oldcv = *svspot;
8403             *svspot = SvREFCNT_inc_simple_NN(cv);
8404             SvREFCNT_dec(oldcv);
8405         }
8406     }
8407
8408   done:
8409     if (PL_parser)
8410         PL_parser->copline = NOLINE;
8411     LEAVE_SCOPE(floor);
8412 #ifdef PERL_DEBUG_READONLY_OPS
8413     if (slab)
8414         Slab_to_ro(slab);
8415 #endif
8416     op_free(o);
8417     return cv;
8418 }
8419
8420
8421 /* _x = extended */
8422 CV *
8423 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8424                             OP *block, bool o_is_gv)
8425 {
8426     GV *gv;
8427     const char *ps;
8428     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8429     U32 ps_utf8 = 0;
8430     CV *cv = NULL;     /* the previous CV with this name, if any */
8431     SV *const_sv;
8432     const bool ec = PL_parser && PL_parser->error_count;
8433     /* If the subroutine has no body, no attributes, and no builtin attributes
8434        then it's just a sub declaration, and we may be able to get away with
8435        storing with a placeholder scalar in the symbol table, rather than a
8436        full CV.  If anything is present then it will take a full CV to
8437        store it.  */
8438     const I32 gv_fetch_flags
8439         = ec ? GV_NOADD_NOINIT :
8440         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8441         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8442     STRLEN namlen = 0;
8443     const char * const name =
8444          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8445     bool has_name;
8446     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8447     bool evanescent = FALSE;
8448     OP *start = NULL;
8449 #ifdef PERL_DEBUG_READONLY_OPS
8450     OPSLAB *slab = NULL;
8451 #endif
8452
8453     if (o_is_gv) {
8454         gv = (GV*)o;
8455         o = NULL;
8456         has_name = TRUE;
8457     } else if (name) {
8458         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
8459            hek and CvSTASH pointer together can imply the GV.  If the name
8460            contains a package name, then GvSTASH(CvGV(cv)) may differ from
8461            CvSTASH, so forego the optimisation if we find any.
8462            Also, we may be called from load_module at run time, so
8463            PL_curstash (which sets CvSTASH) may not point to the stash the
8464            sub is stored in.  */
8465         const I32 flags =
8466            ec ? GV_NOADD_NOINIT
8467               :   PL_curstash != CopSTASH(PL_curcop)
8468                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8469                     ? gv_fetch_flags
8470                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8471         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8472         has_name = TRUE;
8473     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8474         SV * const sv = sv_newmortal();
8475         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
8476                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8477                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8478         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8479         has_name = TRUE;
8480     } else if (PL_curstash) {
8481         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8482         has_name = FALSE;
8483     } else {
8484         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8485         has_name = FALSE;
8486     }
8487
8488     if (!ec) {
8489         if (isGV(gv)) {
8490             move_proto_attr(&proto, &attrs, gv);
8491         } else {
8492             assert(cSVOPo);
8493             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8494         }
8495     }
8496
8497     if (proto) {
8498         assert(proto->op_type == OP_CONST);
8499         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8500         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8501     }
8502     else
8503         ps = NULL;
8504
8505     if (o)
8506         SAVEFREEOP(o);
8507     if (proto)
8508         SAVEFREEOP(proto);
8509     if (attrs)
8510         SAVEFREEOP(attrs);
8511
8512     if (ec) {
8513         op_free(block);
8514
8515         if (name)
8516             SvREFCNT_dec(PL_compcv);
8517         else
8518             cv = PL_compcv;
8519
8520         PL_compcv = 0;
8521         if (name && block) {
8522             const char *s = strrchr(name, ':');
8523             s = s ? s+1 : name;
8524             if (strEQ(s, "BEGIN")) {
8525                 if (PL_in_eval & EVAL_KEEPERR)
8526                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8527                 else {
8528                     SV * const errsv = ERRSV;
8529                     /* force display of errors found but not reported */
8530                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8531                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
8532                 }
8533             }
8534         }
8535         goto done;
8536     }
8537
8538     if (!block && SvTYPE(gv) != SVt_PVGV) {
8539         /* If we are not defining a new sub and the existing one is not a
8540            full GV + CV... */
8541         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8542             /* We are applying attributes to an existing sub, so we need it
8543                upgraded if it is a constant.  */
8544             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8545                 gv_init_pvn(gv, PL_curstash, name, namlen,
8546                             SVf_UTF8 * name_is_utf8);
8547         }
8548         else {                  /* Maybe prototype now, and had at maximum
8549                                    a prototype or const/sub ref before.  */
8550             if (SvTYPE(gv) > SVt_NULL) {
8551                 cv_ckproto_len_flags((const CV *)gv,
8552                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8553                                     ps_len, ps_utf8);
8554             }
8555
8556             if (!SvROK(gv)) {
8557                 if (ps) {
8558                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8559                     if (ps_utf8)
8560                         SvUTF8_on(MUTABLE_SV(gv));
8561                 }
8562                 else
8563                     sv_setiv(MUTABLE_SV(gv), -1);
8564             }
8565
8566             SvREFCNT_dec(PL_compcv);
8567             cv = PL_compcv = NULL;
8568             goto done;
8569         }
8570     }
8571
8572     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8573         ? NULL
8574         : isGV(gv)
8575             ? GvCV(gv)
8576             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8577                 ? (CV *)SvRV(gv)
8578                 : NULL;
8579
8580     if (block) {
8581         assert(PL_parser);
8582         /* This makes sub {}; work as expected.  */
8583         if (block->op_type == OP_STUB) {
8584             const line_t l = PL_parser->copline;
8585             op_free(block);
8586             block = newSTATEOP(0, NULL, 0);
8587             PL_parser->copline = l;
8588         }
8589         block = CvLVALUE(PL_compcv)
8590              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8591                     && (!isGV(gv) || !GvASSUMECV(gv)))
8592                    ? newUNOP(OP_LEAVESUBLV, 0,
8593                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8594                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8595         start = LINKLIST(block);
8596         block->op_next = 0;
8597         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8598             const_sv =
8599                 S_op_const_sv(aTHX_ start, PL_compcv,
8600                                         cBOOL(CvCLONE(PL_compcv)));
8601         else
8602             const_sv = NULL;
8603     }
8604     else
8605         const_sv = NULL;
8606
8607     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8608         cv_ckproto_len_flags((const CV *)gv,
8609                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8610                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8611         if (SvROK(gv)) {
8612             /* All the other code for sub redefinition warnings expects the
8613                clobbered sub to be a CV.  Instead of making all those code
8614                paths more complex, just inline the RV version here.  */
8615             const line_t oldline = CopLINE(PL_curcop);
8616             assert(IN_PERL_COMPILETIME);
8617             if (PL_parser && PL_parser->copline != NOLINE)
8618                 /* This ensures that warnings are reported at the first
8619                    line of a redefinition, not the last.  */
8620                 CopLINE_set(PL_curcop, PL_parser->copline);
8621             /* protect against fatal warnings leaking compcv */
8622             SAVEFREESV(PL_compcv);
8623
8624             if (ckWARN(WARN_REDEFINE)
8625              || (  ckWARN_d(WARN_REDEFINE)
8626                 && (  !const_sv || SvRV(gv) == const_sv
8627                    || sv_cmp(SvRV(gv), const_sv)  ))) {
8628                 assert(cSVOPo);
8629                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8630                           "Constant subroutine %" SVf " redefined",
8631                           SVfARG(cSVOPo->op_sv));
8632             }
8633
8634             SvREFCNT_inc_simple_void_NN(PL_compcv);
8635             CopLINE_set(PL_curcop, oldline);
8636             SvREFCNT_dec(SvRV(gv));
8637         }
8638     }
8639
8640     if (cv) {
8641         const bool exists = CvROOT(cv) || CvXSUB(cv);
8642
8643         /* if the subroutine doesn't exist and wasn't pre-declared
8644          * with a prototype, assume it will be AUTOLOADed,
8645          * skipping the prototype check
8646          */
8647         if (exists || SvPOK(cv))
8648             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8649         /* already defined (or promised)? */
8650         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8651             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8652             if (block)
8653                 cv = NULL;
8654             else {
8655                 if (attrs)
8656                     goto attrs;
8657                 /* just a "sub foo;" when &foo is already defined */
8658                 SAVEFREESV(PL_compcv);
8659                 goto done;
8660             }
8661         }
8662     }
8663
8664     if (const_sv) {
8665         SvREFCNT_inc_simple_void_NN(const_sv);
8666         SvFLAGS(const_sv) |= SVs_PADTMP;
8667         if (cv) {
8668             assert(!CvROOT(cv) && !CvCONST(cv));
8669             cv_forget_slab(cv);
8670             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
8671             CvXSUBANY(cv).any_ptr = const_sv;
8672             CvXSUB(cv) = const_sv_xsub;
8673             CvCONST_on(cv);
8674             CvISXSUB_on(cv);
8675             PoisonPADLIST(cv);
8676             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8677         }
8678         else {
8679             if (isGV(gv) || CvMETHOD(PL_compcv)) {
8680                 if (name && isGV(gv))
8681                     GvCV_set(gv, NULL);
8682                 cv = newCONSTSUB_flags(
8683                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8684                     const_sv
8685                 );
8686                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8687             }
8688             else {
8689                 if (!SvROK(gv)) {
8690                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8691                     prepare_SV_for_RV((SV *)gv);
8692                     SvOK_off((SV *)gv);
8693                     SvROK_on(gv);
8694                 }
8695                 SvRV_set(gv, const_sv);
8696             }
8697         }
8698         op_free(block);
8699         SvREFCNT_dec(PL_compcv);
8700         PL_compcv = NULL;
8701         goto done;
8702     }
8703
8704     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8705     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8706         cv = NULL;
8707
8708     if (cv) {                           /* must reuse cv if autoloaded */
8709         /* transfer PL_compcv to cv */
8710         if (block) {
8711             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8712             PADLIST *const temp_av = CvPADLIST(cv);
8713             CV *const temp_cv = CvOUTSIDE(cv);
8714             const cv_flags_t other_flags =
8715                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8716             OP * const cvstart = CvSTART(cv);
8717
8718             if (isGV(gv)) {
8719                 CvGV_set(cv,gv);
8720                 assert(!CvCVGV_RC(cv));
8721                 assert(CvGV(cv) == gv);
8722             }
8723             else {
8724                 dVAR;
8725                 U32 hash;
8726                 PERL_HASH(hash, name, namlen);
8727                 CvNAME_HEK_set(cv,
8728                                share_hek(name,
8729                                          name_is_utf8
8730                                             ? -(SSize_t)namlen
8731                                             :  (SSize_t)namlen,
8732                                          hash));
8733             }
8734
8735             SvPOK_off(cv);
8736             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8737                                              | CvNAMED(cv);
8738             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8739             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8740             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8741             CvOUTSIDE(PL_compcv) = temp_cv;
8742             CvPADLIST_set(PL_compcv, temp_av);
8743             CvSTART(cv) = CvSTART(PL_compcv);
8744             CvSTART(PL_compcv) = cvstart;
8745             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8746             CvFLAGS(PL_compcv) |= other_flags;
8747
8748             if (CvFILE(cv) && CvDYNFILE(cv)) {
8749                 Safefree(CvFILE(cv));
8750             }
8751             CvFILE_set_from_cop(cv, PL_curcop);
8752             CvSTASH_set(cv, PL_curstash);
8753
8754             /* inner references to PL_compcv must be fixed up ... */
8755             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8756             if (PERLDB_INTER)/* Advice debugger on the new sub. */
8757                 ++PL_sub_generation;
8758         }
8759         else {
8760             /* Might have had built-in attributes applied -- propagate them. */
8761             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8762         }
8763         /* ... before we throw it away */
8764         SvREFCNT_dec(PL_compcv);
8765         PL_compcv = cv;
8766     }
8767     else {
8768         cv = PL_compcv;
8769         if (name && isGV(gv)) {
8770             GvCV_set(gv, cv);
8771             GvCVGEN(gv) = 0;
8772             if (HvENAME_HEK(GvSTASH(gv)))
8773                 /* sub Foo::bar { (shift)+1 } */
8774                 gv_method_changed(gv);
8775         }
8776         else if (name) {
8777             if (!SvROK(gv)) {
8778                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8779                 prepare_SV_for_RV((SV *)gv);
8780                 SvOK_off((SV *)gv);
8781                 SvROK_on(gv);
8782             }
8783             SvRV_set(gv, (SV *)cv);
8784         }
8785     }
8786
8787     if (!CvHASGV(cv)) {
8788         if (isGV(gv))
8789             CvGV_set(cv, gv);
8790         else {
8791             dVAR;
8792             U32 hash;
8793             PERL_HASH(hash, name, namlen);
8794             CvNAME_HEK_set(cv, share_hek(name,
8795                                          name_is_utf8
8796                                             ? -(SSize_t)namlen
8797                                             :  (SSize_t)namlen,
8798                                          hash));
8799         }
8800         CvFILE_set_from_cop(cv, PL_curcop);
8801         CvSTASH_set(cv, PL_curstash);
8802     }
8803
8804     if (ps) {
8805         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8806         if ( ps_utf8 )
8807             SvUTF8_on(MUTABLE_SV(cv));
8808     }
8809
8810     if (block) {
8811         /* If we assign an optree to a PVCV, then we've defined a
8812          * subroutine that the debugger could be able to set a breakpoint
8813          * in, so signal to pp_entereval that it should not throw away any
8814          * saved lines at scope exit.  */
8815
8816         PL_breakable_sub_gen++;
8817         CvROOT(cv) = block;
8818         CvROOT(cv)->op_private |= OPpREFCOUNTED;
8819         OpREFCNT_set(CvROOT(cv), 1);
8820         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8821            itself has a refcount. */
8822         CvSLABBED_off(cv);
8823         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8824 #ifdef PERL_DEBUG_READONLY_OPS
8825         slab = (OPSLAB *)CvSTART(cv);
8826 #endif
8827         CvSTART(cv) = start;
8828         CALL_PEEP(start);
8829         finalize_optree(CvROOT(cv));
8830         S_prune_chain_head(&CvSTART(cv));
8831
8832         /* now that optimizer has done its work, adjust pad values */
8833
8834         pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8835     }
8836
8837   attrs:
8838     if (attrs) {
8839         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8840         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8841                         ? GvSTASH(CvGV(cv))
8842                         : PL_curstash;
8843         if (!name)
8844             SAVEFREESV(cv);
8845         apply_attrs(stash, MUTABLE_SV(cv), attrs);
8846         if (!name)
8847             SvREFCNT_inc_simple_void_NN(cv);
8848     }
8849
8850     if (block && has_name) {
8851         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8852             SV * const tmpstr = cv_name(cv,NULL,0);
8853             GV * const db_postponed = gv_fetchpvs("DB::postponed",
8854                                                   GV_ADDMULTI, SVt_PVHV);
8855             HV *hv;
8856             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8857                                           CopFILE(PL_curcop),
8858                                           (long)PL_subline,
8859                                           (long)CopLINE(PL_curcop));
8860             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8861                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8862             hv = GvHVn(db_postponed);
8863             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8864                 CV * const pcv = GvCV(db_postponed);
8865                 if (pcv) {
8866                     dSP;
8867                     PUSHMARK(SP);
8868                     XPUSHs(tmpstr);
8869                     PUTBACK;
8870                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
8871                 }
8872             }
8873         }
8874
8875         if (name) {
8876             if (PL_parser && PL_parser->error_count)
8877                 clear_special_blocks(name, gv, cv);
8878             else
8879                 evanescent =
8880                     process_special_blocks(floor, name, gv, cv);
8881         }
8882     }
8883
8884   done:
8885     if (PL_parser)
8886         PL_parser->copline = NOLINE;
8887     LEAVE_SCOPE(floor);
8888
8889     if (!evanescent) {
8890 #ifdef PERL_DEBUG_READONLY_OPS
8891     if (slab)
8892         Slab_to_ro(slab);
8893 #endif
8894     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8895         pad_add_weakref(cv);
8896     }
8897     return cv;
8898 }
8899
8900 STATIC void
8901 S_clear_special_blocks(pTHX_ const char *const fullname,
8902                        GV *const gv, CV *const cv) {
8903     const char *colon;
8904     const char *name;
8905
8906     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8907
8908     colon = strrchr(fullname,':');
8909     name = colon ? colon + 1 : fullname;
8910
8911     if ((*name == 'B' && strEQ(name, "BEGIN"))
8912         || (*name == 'E' && strEQ(name, "END"))
8913         || (*name == 'U' && strEQ(name, "UNITCHECK"))
8914         || (*name == 'C' && strEQ(name, "CHECK"))
8915         || (*name == 'I' && strEQ(name, "INIT"))) {
8916         if (!isGV(gv)) {
8917             (void)CvGV(cv);
8918             assert(isGV(gv));
8919         }
8920         GvCV_set(gv, NULL);
8921         SvREFCNT_dec_NN(MUTABLE_SV(cv));
8922     }
8923 }
8924
8925 /* Returns true if the sub has been freed.  */
8926 STATIC bool
8927 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8928                          GV *const gv,
8929                          CV *const cv)
8930 {
8931     const char *const colon = strrchr(fullname,':');
8932     const char *const name = colon ? colon + 1 : fullname;
8933
8934     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8935
8936     if (*name == 'B') {
8937         if (strEQ(name, "BEGIN")) {
8938             const I32 oldscope = PL_scopestack_ix;
8939             dSP;
8940             (void)CvGV(cv);
8941             if (floor) LEAVE_SCOPE(floor);
8942             ENTER;
8943             PUSHSTACKi(PERLSI_REQUIRE);
8944             SAVECOPFILE(&PL_compiling);
8945             SAVECOPLINE(&PL_compiling);
8946             SAVEVPTR(PL_curcop);
8947
8948             DEBUG_x( dump_sub(gv) );
8949             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8950             GvCV_set(gv,0);             /* cv has been hijacked */
8951             call_list(oldscope, PL_beginav);
8952
8953             POPSTACK;
8954             LEAVE;
8955             return !PL_savebegin;
8956         }
8957         else
8958             return FALSE;
8959     } else {
8960         if (*name == 'E') {
8961             if strEQ(name, "END") {
8962                 DEBUG_x( dump_sub(gv) );
8963                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8964             } else
8965                 return FALSE;
8966         } else if (*name == 'U') {
8967             if (strEQ(name, "UNITCHECK")) {
8968                 /* It's never too late to run a unitcheck block */
8969                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8970             }
8971             else
8972                 return FALSE;
8973         } else if (*name == 'C') {
8974             if (strEQ(name, "CHECK")) {
8975                 if (PL_main_start)
8976                     /* diag_listed_as: Too late to run %s block */
8977                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8978                                    "Too late to run CHECK block");
8979                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8980             }
8981             else
8982                 return FALSE;
8983         } else if (*name == 'I') {
8984             if (strEQ(name, "INIT")) {
8985                 if (PL_main_start)
8986                     /* diag_listed_as: Too late to run %s block */
8987                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8988                                    "Too late to run INIT block");
8989                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8990             }
8991             else
8992                 return FALSE;
8993         } else
8994             return FALSE;
8995         DEBUG_x( dump_sub(gv) );
8996         (void)CvGV(cv);
8997         GvCV_set(gv,0);         /* cv has been hijacked */
8998         return FALSE;
8999     }
9000 }
9001
9002 /*
9003 =for apidoc newCONSTSUB
9004
9005 See L</newCONSTSUB_flags>.
9006
9007 =cut
9008 */
9009
9010 CV *
9011 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9012 {
9013     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9014 }
9015
9016 /*
9017 =for apidoc newCONSTSUB_flags
9018
9019 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9020 eligible for inlining at compile-time.
9021
9022 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9023
9024 The newly created subroutine takes ownership of a reference to the passed in
9025 SV.
9026
9027 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9028 which won't be called if used as a destructor, but will suppress the overhead
9029 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
9030 compile time.)
9031
9032 =cut
9033 */
9034
9035 CV *
9036 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9037                              U32 flags, SV *sv)
9038 {
9039     CV* cv;
9040     const char *const file = CopFILE(PL_curcop);
9041
9042     ENTER;
9043
9044     if (IN_PERL_RUNTIME) {
9045         /* at runtime, it's not safe to manipulate PL_curcop: it may be
9046          * an op shared between threads. Use a non-shared COP for our
9047          * dirty work */
9048          SAVEVPTR(PL_curcop);
9049          SAVECOMPILEWARNINGS();
9050          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9051          PL_curcop = &PL_compiling;
9052     }
9053     SAVECOPLINE(PL_curcop);
9054     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9055
9056     SAVEHINTS();
9057     PL_hints &= ~HINT_BLOCK_SCOPE;
9058
9059     if (stash) {
9060         SAVEGENERICSV(PL_curstash);
9061         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9062     }
9063
9064     /* Protect sv against leakage caused by fatal warnings. */
9065     if (sv) SAVEFREESV(sv);
9066
9067     /* file becomes the CvFILE. For an XS, it's usually static storage,
9068        and so doesn't get free()d.  (It's expected to be from the C pre-
9069        processor __FILE__ directive). But we need a dynamically allocated one,
9070        and we need it to get freed.  */
9071     cv = newXS_len_flags(name, len,
9072                          sv && SvTYPE(sv) == SVt_PVAV
9073                              ? const_av_xsub
9074                              : const_sv_xsub,
9075                          file ? file : "", "",
9076                          &sv, XS_DYNAMIC_FILENAME | flags);
9077     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9078     CvCONST_on(cv);
9079
9080     LEAVE;
9081
9082     return cv;
9083 }
9084
9085 /*
9086 =for apidoc U||newXS
9087
9088 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
9089 static storage, as it is used directly as CvFILE(), without a copy being made.
9090
9091 =cut
9092 */
9093
9094 CV *
9095 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9096 {
9097     PERL_ARGS_ASSERT_NEWXS;
9098     return newXS_len_flags(
9099         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9100     );
9101 }
9102
9103 CV *
9104 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9105                  const char *const filename, const char *const proto,
9106                  U32 flags)
9107 {
9108     PERL_ARGS_ASSERT_NEWXS_FLAGS;
9109     return newXS_len_flags(
9110        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9111     );
9112 }
9113
9114 CV *
9115 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9116 {
9117     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9118     return newXS_len_flags(
9119         name, strlen(name), subaddr, NULL, NULL, NULL, 0
9120     );
9121 }
9122
9123 CV *
9124 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9125                            XSUBADDR_t subaddr, const char *const filename,
9126                            const char *const proto, SV **const_svp,
9127                            U32 flags)
9128 {
9129     CV *cv;
9130     bool interleave = FALSE;
9131
9132     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9133
9134     {
9135         GV * const gv = gv_fetchpvn(
9136                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9137                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9138                                 sizeof("__ANON__::__ANON__") - 1,
9139                             GV_ADDMULTI | flags, SVt_PVCV);
9140
9141         if ((cv = (name ? GvCV(gv) : NULL))) {
9142             if (GvCVGEN(gv)) {
9143                 /* just a cached method */
9144                 SvREFCNT_dec(cv);
9145                 cv = NULL;
9146             }
9147             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9148                 /* already defined (or promised) */
9149                 /* Redundant check that allows us to avoid creating an SV
9150                    most of the time: */
9151                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9152                     report_redefined_cv(newSVpvn_flags(
9153                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
9154                                         ),
9155                                         cv, const_svp);
9156                 }
9157                 interleave = TRUE;
9158                 ENTER;
9159                 SAVEFREESV(cv);
9160                 cv = NULL;
9161             }
9162         }
9163
9164         if (cv)                         /* must reuse cv if autoloaded */
9165             cv_undef(cv);
9166         else {
9167             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9168             if (name) {
9169                 GvCV_set(gv,cv);
9170                 GvCVGEN(gv) = 0;
9171                 if (HvENAME_HEK(GvSTASH(gv)))
9172                     gv_method_changed(gv); /* newXS */
9173             }
9174         }
9175
9176         CvGV_set(cv, gv);
9177         if(filename) {
9178             /* XSUBs can't be perl lang/perl5db.pl debugged
9179             if (PERLDB_LINE_OR_SAVESRC)
9180                 (void)gv_fetchfile(filename); */
9181             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9182             if (flags & XS_DYNAMIC_FILENAME) {
9183                 CvDYNFILE_on(cv);
9184                 CvFILE(cv) = savepv(filename);
9185             } else {
9186             /* NOTE: not copied, as it is expected to be an external constant string */
9187                 CvFILE(cv) = (char *)filename;
9188             }
9189         } else {
9190             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9191             CvFILE(cv) = (char*)PL_xsubfilename;
9192         }
9193         CvISXSUB_on(cv);
9194         CvXSUB(cv) = subaddr;
9195 #ifndef PERL_IMPLICIT_CONTEXT
9196         CvHSCXT(cv) = &PL_stack_sp;
9197 #else
9198         PoisonPADLIST(cv);
9199 #endif
9200
9201         if (name)
9202             process_special_blocks(0, name, gv, cv);
9203         else
9204             CvANON_on(cv);
9205     } /* <- not a conditional branch */
9206
9207
9208     sv_setpv(MUTABLE_SV(cv), proto);
9209     if (interleave) LEAVE;
9210     return cv;
9211 }
9212
9213 CV *
9214 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9215 {
9216     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9217     GV *cvgv;
9218     PERL_ARGS_ASSERT_NEWSTUB;
9219     assert(!GvCVu(gv));
9220     GvCV_set(gv, cv);
9221     GvCVGEN(gv) = 0;
9222     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9223         gv_method_changed(gv);
9224     if (SvFAKE(gv)) {
9225         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9226         SvFAKE_off(cvgv);
9227     }
9228     else cvgv = gv;
9229     CvGV_set(cv, cvgv);
9230     CvFILE_set_from_cop(cv, PL_curcop);
9231     CvSTASH_set(cv, PL_curstash);
9232     GvMULTI_on(gv);
9233     return cv;
9234 }
9235
9236 void
9237 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9238 {
9239     CV *cv;
9240
9241     GV *gv;
9242
9243     if (PL_parser && PL_parser->error_count) {
9244         op_free(block);
9245         goto finish;
9246     }
9247
9248     gv = o
9249         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9250         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9251
9252     GvMULTI_on(gv);
9253     if ((cv = GvFORM(gv))) {
9254         if (ckWARN(WARN_REDEFINE)) {
9255             const line_t oldline = CopLINE(PL_curcop);
9256             if (PL_parser && PL_parser->copline != NOLINE)
9257                 CopLINE_set(PL_curcop, PL_parser->copline);
9258             if (o) {
9259                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9260                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
9261             } else {
9262                 /* diag_listed_as: Format %s redefined */
9263                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9264                             "Format STDOUT redefined");
9265             }
9266             CopLINE_set(PL_curcop, oldline);
9267         }
9268         SvREFCNT_dec(cv);
9269     }
9270     cv = PL_compcv;
9271     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9272     CvGV_set(cv, gv);
9273     CvFILE_set_from_cop(cv, PL_curcop);
9274
9275
9276     pad_tidy(padtidy_FORMAT);
9277     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9278     CvROOT(cv)->op_private |= OPpREFCOUNTED;
9279     OpREFCNT_set(CvROOT(cv), 1);
9280     CvSTART(cv) = LINKLIST(CvROOT(cv));
9281     CvROOT(cv)->op_next = 0;
9282     CALL_PEEP(CvSTART(cv));
9283     finalize_optree(CvROOT(cv));
9284     S_prune_chain_head(&CvSTART(cv));
9285     cv_forget_slab(cv);
9286
9287   finish:
9288     op_free(o);
9289     if (PL_parser)
9290         PL_parser->copline = NOLINE;
9291     LEAVE_SCOPE(floor);
9292     PL_compiling.cop_seq = 0;
9293 }
9294
9295 OP *
9296 Perl_newANONLIST(pTHX_ OP *o)
9297 {
9298     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9299 }
9300
9301 OP *
9302 Perl_newANONHASH(pTHX_ OP *o)
9303 {
9304     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9305 }
9306
9307 OP *
9308 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9309 {
9310     return newANONATTRSUB(floor, proto, NULL, block);
9311 }
9312
9313 OP *
9314 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9315 {
9316     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9317     OP * anoncode =
9318         newSVOP(OP_ANONCODE, 0,
9319                 cv);
9320     if (CvANONCONST(cv))
9321         anoncode = newUNOP(OP_ANONCONST, 0,
9322                            op_convert_list(OP_ENTERSUB,
9323                                            OPf_STACKED|OPf_WANT_SCALAR,
9324                                            anoncode));
9325     return newUNOP(OP_REFGEN, 0, anoncode);
9326 }
9327
9328 OP *
9329 Perl_oopsAV(pTHX_ OP *o)
9330 {
9331     dVAR;
9332
9333     PERL_ARGS_ASSERT_OOPSAV;
9334
9335     switch (o->op_type) {
9336     case OP_PADSV:
9337     case OP_PADHV:
9338         OpTYPE_set(o, OP_PADAV);
9339         return ref(o, OP_RV2AV);
9340
9341     case OP_RV2SV:
9342     case OP_RV2HV:
9343         OpTYPE_set(o, OP_RV2AV);
9344         ref(o, OP_RV2AV);
9345         break;
9346
9347     default:
9348         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9349         break;
9350     }
9351     return o;
9352 }
9353
9354 OP *
9355 Perl_oopsHV(pTHX_ OP *o)
9356 {
9357     dVAR;
9358
9359     PERL_ARGS_ASSERT_OOPSHV;
9360
9361     switch (o->op_type) {
9362     case OP_PADSV:
9363     case OP_PADAV:
9364         OpTYPE_set(o, OP_PADHV);
9365         return ref(o, OP_RV2HV);
9366
9367     case OP_RV2SV:
9368     case OP_RV2AV:
9369         OpTYPE_set(o, OP_RV2HV);
9370         ref(o, OP_RV2HV);
9371         break;
9372
9373     default:
9374         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9375         break;
9376     }
9377     return o;
9378 }
9379
9380 OP *
9381 Perl_newAVREF(pTHX_ OP *o)
9382 {
9383     dVAR;
9384
9385     PERL_ARGS_ASSERT_NEWAVREF;
9386
9387     if (o->op_type == OP_PADANY) {
9388         OpTYPE_set(o, OP_PADAV);
9389         return o;
9390     }
9391     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9392         Perl_croak(aTHX_ "Can't use an array as a reference");
9393     }
9394     return newUNOP(OP_RV2AV, 0, scalar(o));
9395 }
9396
9397 OP *
9398 Perl_newGVREF(pTHX_ I32 type, OP *o)
9399 {
9400     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9401         return newUNOP(OP_NULL, 0, o);
9402     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9403 }
9404
9405 OP *
9406 Perl_newHVREF(pTHX_ OP *o)
9407 {
9408     dVAR;
9409
9410     PERL_ARGS_ASSERT_NEWHVREF;
9411
9412     if (o->op_type == OP_PADANY) {
9413         OpTYPE_set(o, OP_PADHV);
9414         return o;
9415     }
9416     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9417         Perl_croak(aTHX_ "Can't use a hash as a reference");
9418     }
9419     return newUNOP(OP_RV2HV, 0, scalar(o));
9420 }
9421
9422 OP *
9423 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9424 {
9425     if (o->op_type == OP_PADANY) {
9426         dVAR;
9427         OpTYPE_set(o, OP_PADCV);
9428     }
9429     return newUNOP(OP_RV2CV, flags, scalar(o));
9430 }
9431
9432 OP *
9433 Perl_newSVREF(pTHX_ OP *o)
9434 {
9435     dVAR;
9436
9437     PERL_ARGS_ASSERT_NEWSVREF;
9438
9439     if (o->op_type == OP_PADANY) {
9440         OpTYPE_set(o, OP_PADSV);
9441         scalar(o);
9442         return o;
9443     }
9444     return newUNOP(OP_RV2SV, 0, scalar(o));
9445 }
9446
9447 /* Check routines. See the comments at the top of this file for details
9448  * on when these are called */
9449
9450 OP *
9451 Perl_ck_anoncode(pTHX_ OP *o)
9452 {
9453     PERL_ARGS_ASSERT_CK_ANONCODE;
9454
9455     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9456     cSVOPo->op_sv = NULL;
9457     return o;
9458 }
9459
9460 static void
9461 S_io_hints(pTHX_ OP *o)
9462 {
9463 #if O_BINARY != 0 || O_TEXT != 0
9464     HV * const table =
9465         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9466     if (table) {
9467         SV **svp = hv_fetchs(table, "open_IN", FALSE);
9468         if (svp && *svp) {
9469             STRLEN len = 0;
9470             const char *d = SvPV_const(*svp, len);
9471             const I32 mode = mode_from_discipline(d, len);
9472             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9473 #  if O_BINARY != 0
9474             if (mode & O_BINARY)
9475                 o->op_private |= OPpOPEN_IN_RAW;
9476 #  endif
9477 #  if O_TEXT != 0
9478             if (mode & O_TEXT)
9479                 o->op_private |= OPpOPEN_IN_CRLF;
9480 #  endif
9481         }
9482
9483         svp = hv_fetchs(table, "open_OUT", FALSE);
9484         if (svp && *svp) {
9485             STRLEN len = 0;
9486             const char *d = SvPV_const(*svp, len);
9487             const I32 mode = mode_from_discipline(d, len);
9488             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9489 #  if O_BINARY != 0
9490             if (mode & O_BINARY)
9491                 o->op_private |= OPpOPEN_OUT_RAW;
9492 #  endif
9493 #  if O_TEXT != 0
9494             if (mode & O_TEXT)
9495                 o->op_private |= OPpOPEN_OUT_CRLF;
9496 #  endif
9497         }
9498     }
9499 #else
9500     PERL_UNUSED_CONTEXT;
9501     PERL_UNUSED_ARG(o);
9502 #endif
9503 }
9504
9505 OP *
9506 Perl_ck_backtick(pTHX_ OP *o)
9507 {
9508     GV *gv;
9509     OP *newop = NULL;
9510     OP *sibl;
9511     PERL_ARGS_ASSERT_CK_BACKTICK;
9512     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9513     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9514      && (gv = gv_override("readpipe",8)))
9515     {
9516         /* detach rest of siblings from o and its first child */
9517         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9518         newop = S_new_entersubop(aTHX_ gv, sibl);
9519     }
9520     else if (!(o->op_flags & OPf_KIDS))
9521         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9522     if (newop) {
9523         op_free(o);
9524         return newop;
9525     }
9526     S_io_hints(aTHX_ o);
9527     return o;
9528 }
9529
9530 OP *
9531 Perl_ck_bitop(pTHX_ OP *o)
9532 {
9533     PERL_ARGS_ASSERT_CK_BITOP;
9534
9535     o->op_private = (U8)(PL_hints & HINT_INTEGER);
9536
9537     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
9538      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
9539      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
9540      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9541         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9542                               "The bitwise feature is experimental");
9543     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9544             && OP_IS_INFIX_BIT(o->op_type))
9545     {
9546         const OP * const left = cBINOPo->op_first;
9547         const OP * const right = OpSIBLING(left);
9548         if ((OP_IS_NUMCOMPARE(left->op_type) &&
9549                 (left->op_flags & OPf_PARENS) == 0) ||
9550             (OP_IS_NUMCOMPARE(right->op_type) &&
9551                 (right->op_flags & OPf_PARENS) == 0))
9552             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9553                           "Possible precedence problem on bitwise %s operator",
9554                            o->op_type ==  OP_BIT_OR
9555                          ||o->op_type == OP_NBIT_OR  ? "|"
9556                         :  o->op_type ==  OP_BIT_AND
9557                          ||o->op_type == OP_NBIT_AND ? "&"
9558                         :  o->op_type ==  OP_BIT_XOR
9559                          ||o->op_type == OP_NBIT_XOR ? "^"
9560                         :  o->op_type == OP_SBIT_OR  ? "|."
9561                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
9562                            );
9563     }
9564     return o;
9565 }
9566
9567 PERL_STATIC_INLINE bool
9568 is_dollar_bracket(pTHX_ const OP * const o)
9569 {
9570     const OP *kid;
9571     PERL_UNUSED_CONTEXT;
9572     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9573         && (kid = cUNOPx(o)->op_first)
9574         && kid->op_type == OP_GV
9575         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9576 }
9577
9578 OP *
9579 Perl_ck_cmp(pTHX_ OP *o)
9580 {
9581     PERL_ARGS_ASSERT_CK_CMP;
9582     if (ckWARN(WARN_SYNTAX)) {
9583         const OP *kid = cUNOPo->op_first;
9584         if (kid &&
9585             (
9586                 (   is_dollar_bracket(aTHX_ kid)
9587                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9588                 )
9589              || (   kid->op_type == OP_CONST
9590                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9591                 )
9592            )
9593         )
9594             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9595                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9596     }
9597     return o;
9598 }
9599
9600 OP *
9601 Perl_ck_concat(pTHX_ OP *o)
9602 {
9603     const OP * const kid = cUNOPo->op_first;
9604
9605     PERL_ARGS_ASSERT_CK_CONCAT;
9606     PERL_UNUSED_CONTEXT;
9607
9608     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9609             !(kUNOP->op_first->op_flags & OPf_MOD))
9610         o->op_flags |= OPf_STACKED;
9611     return o;
9612 }
9613
9614 OP *
9615 Perl_ck_spair(pTHX_ OP *o)
9616 {
9617     dVAR;
9618
9619     PERL_ARGS_ASSERT_CK_SPAIR;
9620
9621     if (o->op_flags & OPf_KIDS) {
9622         OP* newop;
9623         OP* kid;
9624         OP* kidkid;
9625         const OPCODE type = o->op_type;
9626         o = modkids(ck_fun(o), type);
9627         kid    = cUNOPo->op_first;
9628         kidkid = kUNOP->op_first;
9629         newop = OpSIBLING(kidkid);
9630         if (newop) {
9631             const OPCODE type = newop->op_type;
9632             if (OpHAS_SIBLING(newop))
9633                 return o;
9634             if (o->op_type == OP_REFGEN
9635              && (  type == OP_RV2CV
9636                 || (  !(newop->op_flags & OPf_PARENS)
9637                    && (  type == OP_RV2AV || type == OP_PADAV
9638                       || type == OP_RV2HV || type == OP_PADHV))))
9639                 NOOP; /* OK (allow srefgen for \@a and \%h) */
9640             else if (OP_GIMME(newop,0) != G_SCALAR)
9641                 return o;
9642         }
9643         /* excise first sibling */
9644         op_sibling_splice(kid, NULL, 1, NULL);
9645         op_free(kidkid);
9646     }
9647     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9648      * and OP_CHOMP into OP_SCHOMP */
9649     o->op_ppaddr = PL_ppaddr[++o->op_type];
9650     return ck_fun(o);
9651 }
9652
9653 OP *
9654 Perl_ck_delete(pTHX_ OP *o)
9655 {
9656     PERL_ARGS_ASSERT_CK_DELETE;
9657
9658     o = ck_fun(o);
9659     o->op_private = 0;
9660     if (o->op_flags & OPf_KIDS) {
9661         OP * const kid = cUNOPo->op_first;
9662         switch (kid->op_type) {
9663         case OP_ASLICE:
9664             o->op_flags |= OPf_SPECIAL;
9665             /* FALLTHROUGH */
9666         case OP_HSLICE:
9667             o->op_private |= OPpSLICE;
9668             break;
9669         case OP_AELEM:
9670             o->op_flags |= OPf_SPECIAL;
9671             /* FALLTHROUGH */
9672         case OP_HELEM:
9673             break;
9674         case OP_KVASLICE:
9675             Perl_croak(aTHX_ "delete argument is index/value array slice,"
9676                              " use array slice");
9677         case OP_KVHSLICE:
9678             Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9679                              " hash slice");
9680         default:
9681             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9682                              "element or slice");
9683         }
9684         if (kid->op_private & OPpLVAL_INTRO)
9685             o->op_private |= OPpLVAL_INTRO;
9686         op_null(kid);
9687     }
9688     return o;
9689 }
9690
9691 OP *
9692 Perl_ck_eof(pTHX_ OP *o)
9693 {
9694     PERL_ARGS_ASSERT_CK_EOF;
9695
9696     if (o->op_flags & OPf_KIDS) {
9697         OP *kid;
9698         if (cLISTOPo->op_first->op_type == OP_STUB) {
9699             OP * const newop
9700                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9701             op_free(o);
9702             o = newop;
9703         }
9704         o = ck_fun(o);
9705         kid = cLISTOPo->op_first;
9706         if (kid->op_type == OP_RV2GV)
9707             kid->op_private |= OPpALLOW_FAKE;
9708     }
9709     return o;
9710 }
9711
9712 OP *
9713 Perl_ck_eval(pTHX_ OP *o)
9714 {
9715     dVAR;
9716
9717     PERL_ARGS_ASSERT_CK_EVAL;
9718
9719     PL_hints |= HINT_BLOCK_SCOPE;
9720     if (o->op_flags & OPf_KIDS) {
9721         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9722         assert(kid);
9723
9724         if (o->op_type == OP_ENTERTRY) {
9725             LOGOP *enter;
9726
9727             /* cut whole sibling chain free from o */
9728             op_sibling_splice(o, NULL, -1, NULL);
9729             op_free(o);
9730
9731             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9732
9733             /* establish postfix order */
9734             enter->op_next = (OP*)enter;
9735
9736             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9737             OpTYPE_set(o, OP_LEAVETRY);
9738             enter->op_other = o;
9739             return o;
9740         }
9741         else {
9742             scalar((OP*)kid);
9743             S_set_haseval(aTHX);
9744         }
9745     }
9746     else {
9747         const U8 priv = o->op_private;
9748         op_free(o);
9749         /* the newUNOP will recursively call ck_eval(), which will handle
9750          * all the stuff at the end of this function, like adding
9751          * OP_HINTSEVAL
9752          */
9753         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9754     }
9755     o->op_targ = (PADOFFSET)PL_hints;
9756     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9757     if ((PL_hints & HINT_LOCALIZE_HH) != 0
9758      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9759         /* Store a copy of %^H that pp_entereval can pick up. */
9760         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9761                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9762         /* append hhop to only child  */
9763         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9764
9765         o->op_private |= OPpEVAL_HAS_HH;
9766     }
9767     if (!(o->op_private & OPpEVAL_BYTES)
9768          && FEATURE_UNIEVAL_IS_ENABLED)
9769             o->op_private |= OPpEVAL_UNICODE;
9770     return o;
9771 }
9772
9773 OP *
9774 Perl_ck_exec(pTHX_ OP *o)
9775 {
9776     PERL_ARGS_ASSERT_CK_EXEC;
9777
9778     if (o->op_flags & OPf_STACKED) {
9779         OP *kid;
9780         o = ck_fun(o);
9781         kid = OpSIBLING(cUNOPo->op_first);
9782         if (kid->op_type == OP_RV2GV)
9783             op_null(kid);
9784     }
9785     else
9786         o = listkids(o);
9787     return o;
9788 }
9789
9790 OP *
9791 Perl_ck_exists(pTHX_ OP *o)
9792 {
9793     PERL_ARGS_ASSERT_CK_EXISTS;
9794
9795     o = ck_fun(o);
9796     if (o->op_flags & OPf_KIDS) {
9797         OP * const kid = cUNOPo->op_first;
9798         if (kid->op_type == OP_ENTERSUB) {
9799             (void) ref(kid, o->op_type);
9800             if (kid->op_type != OP_RV2CV
9801                         && !(PL_parser && PL_parser->error_count))
9802                 Perl_croak(aTHX_
9803                           "exists argument is not a subroutine name");
9804             o->op_private |= OPpEXISTS_SUB;
9805         }
9806         else if (kid->op_type == OP_AELEM)
9807             o->op_flags |= OPf_SPECIAL;
9808         else if (kid->op_type != OP_HELEM)
9809             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9810                              "element or a subroutine");
9811         op_null(kid);
9812     }
9813     return o;
9814 }
9815
9816 OP *
9817 Perl_ck_rvconst(pTHX_ OP *o)
9818 {
9819     dVAR;
9820     SVOP * const kid = (SVOP*)cUNOPo->op_first;
9821
9822     PERL_ARGS_ASSERT_CK_RVCONST;
9823
9824     o->op_private |= (PL_hints & HINT_STRICT_REFS);
9825
9826     if (kid->op_type == OP_CONST) {
9827         int iscv;
9828         GV *gv;
9829         SV * const kidsv = kid->op_sv;
9830
9831         /* Is it a constant from cv_const_sv()? */
9832         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9833             return o;
9834         }
9835         if (SvTYPE(kidsv) == SVt_PVAV) return o;
9836         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9837             const char *badthing;
9838             switch (o->op_type) {
9839             case OP_RV2SV:
9840                 badthing = "a SCALAR";
9841                 break;
9842             case OP_RV2AV:
9843                 badthing = "an ARRAY";
9844                 break;
9845             case OP_RV2HV:
9846                 badthing = "a HASH";
9847                 break;
9848             default:
9849                 badthing = NULL;
9850                 break;
9851             }
9852             if (badthing)
9853                 Perl_croak(aTHX_
9854                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
9855                            SVfARG(kidsv), badthing);
9856         }
9857         /*
9858          * This is a little tricky.  We only want to add the symbol if we
9859          * didn't add it in the lexer.  Otherwise we get duplicate strict
9860          * warnings.  But if we didn't add it in the lexer, we must at
9861          * least pretend like we wanted to add it even if it existed before,
9862          * or we get possible typo warnings.  OPpCONST_ENTERED says
9863          * whether the lexer already added THIS instance of this symbol.
9864          */
9865         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9866         gv = gv_fetchsv(kidsv,
9867                 o->op_type == OP_RV2CV
9868                         && o->op_private & OPpMAY_RETURN_CONSTANT
9869                     ? GV_NOEXPAND
9870                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
9871                 iscv
9872                     ? SVt_PVCV
9873                     : o->op_type == OP_RV2SV
9874                         ? SVt_PV
9875                         : o->op_type == OP_RV2AV
9876                             ? SVt_PVAV
9877                             : o->op_type == OP_RV2HV
9878                                 ? SVt_PVHV
9879                                 : SVt_PVGV);
9880         if (gv) {
9881             if (!isGV(gv)) {
9882                 assert(iscv);
9883                 assert(SvROK(gv));
9884                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9885                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
9886                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9887             }
9888             OpTYPE_set(kid, OP_GV);
9889             SvREFCNT_dec(kid->op_sv);
9890 #ifdef USE_ITHREADS
9891             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9892             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9893             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9894             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9895             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9896 #else
9897             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9898 #endif
9899             kid->op_private = 0;
9900             /* FAKE globs in the symbol table cause weird bugs (#77810) */
9901             SvFAKE_off(gv);
9902         }
9903     }
9904     return o;
9905 }
9906
9907 OP *
9908 Perl_ck_ftst(pTHX_ OP *o)
9909 {
9910     dVAR;
9911     const I32 type = o->op_type;
9912
9913     PERL_ARGS_ASSERT_CK_FTST;
9914
9915     if (o->op_flags & OPf_REF) {
9916         NOOP;
9917     }
9918     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9919         SVOP * const kid = (SVOP*)cUNOPo->op_first;
9920         const OPCODE kidtype = kid->op_type;
9921
9922         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9923          && !kid->op_folded) {
9924             OP * const newop = newGVOP(type, OPf_REF,
9925                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9926             op_free(o);
9927             return newop;
9928         }
9929
9930         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9931             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9932             if (name) {
9933                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9934                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9935                             array_passed_to_stat, name);
9936             }
9937             else {
9938                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9939                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9940             }
9941        }
9942         scalar((OP *) kid);
9943         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9944             o->op_private |= OPpFT_ACCESS;
9945         if (type != OP_STAT && type != OP_LSTAT
9946             && PL_check[kidtype] == Perl_ck_ftst
9947             && kidtype != OP_STAT && kidtype != OP_LSTAT
9948         ) {
9949             o->op_private |= OPpFT_STACKED;
9950             kid->op_private |= OPpFT_STACKING;
9951             if (kidtype == OP_FTTTY && (
9952                    !(kid->op_private & OPpFT_STACKED)
9953                 || kid->op_private & OPpFT_AFTER_t
9954                ))
9955                 o->op_private |= OPpFT_AFTER_t;
9956         }
9957     }
9958     else {
9959         op_free(o);
9960         if (type == OP_FTTTY)
9961             o = newGVOP(type, OPf_REF, PL_stdingv);
9962         else
9963             o = newUNOP(type, 0, newDEFSVOP());
9964     }
9965     return o;
9966 }
9967
9968 OP *
9969 Perl_ck_fun(pTHX_ OP *o)
9970 {
9971     const int type = o->op_type;
9972     I32 oa = PL_opargs[type] >> OASHIFT;
9973
9974     PERL_ARGS_ASSERT_CK_FUN;
9975
9976     if (o->op_flags & OPf_STACKED) {
9977         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9978             oa &= ~OA_OPTIONAL;
9979         else
9980             return no_fh_allowed(o);
9981     }
9982
9983     if (o->op_flags & OPf_KIDS) {
9984         OP *prev_kid = NULL;
9985         OP *kid = cLISTOPo->op_first;
9986         I32 numargs = 0;
9987         bool seen_optional = FALSE;
9988
9989         if (kid->op_type == OP_PUSHMARK ||
9990             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9991         {
9992             prev_kid = kid;
9993             kid = OpSIBLING(kid);
9994         }
9995         if (kid && kid->op_type == OP_COREARGS) {
9996             bool optional = FALSE;
9997             while (oa) {
9998                 numargs++;
9999                 if (oa & OA_OPTIONAL) optional = TRUE;
10000                 oa = oa >> 4;
10001             }
10002             if (optional) o->op_private |= numargs;
10003             return o;
10004         }
10005
10006         while (oa) {
10007             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
10008                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10009                     kid = newDEFSVOP();
10010                     /* append kid to chain */
10011                     op_sibling_splice(o, prev_kid, 0, kid);
10012                 }
10013                 seen_optional = TRUE;
10014             }
10015             if (!kid) break;
10016
10017             numargs++;
10018             switch (oa & 7) {
10019             case OA_SCALAR:
10020                 /* list seen where single (scalar) arg expected? */
10021                 if (numargs == 1 && !(oa >> 4)
10022                     && kid->op_type == OP_LIST && type != OP_SCALAR)
10023                 {
10024                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10025                 }
10026                 if (type != OP_DELETE) scalar(kid);
10027                 break;
10028             case OA_LIST:
10029                 if (oa < 16) {
10030                     kid = 0;
10031                     continue;
10032                 }
10033                 else
10034                     list(kid);
10035                 break;
10036             case OA_AVREF:
10037                 if ((type == OP_PUSH || type == OP_UNSHIFT)
10038                     && !OpHAS_SIBLING(kid))
10039                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10040                                    "Useless use of %s with no values",
10041                                    PL_op_desc[type]);
10042
10043                 if (kid->op_type == OP_CONST
10044                       && (  !SvROK(cSVOPx_sv(kid))
10045                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
10046                         )
10047                     bad_type_pv(numargs, "array", o, kid);
10048                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10049                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10050                                          PL_op_desc[type]), 0);
10051                 }
10052                 else {
10053                     op_lvalue(kid, type);
10054                 }
10055                 break;
10056             case OA_HVREF:
10057                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10058                     bad_type_pv(numargs, "hash", o, kid);
10059                 op_lvalue(kid, type);
10060                 break;
10061             case OA_CVREF:
10062                 {
10063                     /* replace kid with newop in chain */
10064                     OP * const newop =
10065                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10066                     newop->op_next = newop;
10067                     kid = newop;
10068                 }
10069                 break;
10070             case OA_FILEREF:
10071                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10072                     if (kid->op_type == OP_CONST &&
10073                         (kid->op_private & OPpCONST_BARE))
10074                     {
10075                         OP * const newop = newGVOP(OP_GV, 0,
10076                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10077                         /* replace kid with newop in chain */
10078                         op_sibling_splice(o, prev_kid, 1, newop);
10079                         op_free(kid);
10080                         kid = newop;
10081                     }
10082                     else if (kid->op_type == OP_READLINE) {
10083                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10084                         bad_type_pv(numargs, "HANDLE", o, kid);
10085                     }
10086                     else {
10087                         I32 flags = OPf_SPECIAL;
10088                         I32 priv = 0;
10089                         PADOFFSET targ = 0;
10090
10091                         /* is this op a FH constructor? */
10092                         if (is_handle_constructor(o,numargs)) {
10093                             const char *name = NULL;
10094                             STRLEN len = 0;
10095                             U32 name_utf8 = 0;
10096                             bool want_dollar = TRUE;
10097
10098                             flags = 0;
10099                             /* Set a flag to tell rv2gv to vivify
10100                              * need to "prove" flag does not mean something
10101                              * else already - NI-S 1999/05/07
10102                              */
10103                             priv = OPpDEREF;
10104                             if (kid->op_type == OP_PADSV) {
10105                                 PADNAME * const pn
10106                                     = PAD_COMPNAME_SV(kid->op_targ);
10107                                 name = PadnamePV (pn);
10108                                 len  = PadnameLEN(pn);
10109                                 name_utf8 = PadnameUTF8(pn);
10110                             }
10111                             else if (kid->op_type == OP_RV2SV
10112                                      && kUNOP->op_first->op_type == OP_GV)
10113                             {
10114                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10115                                 name = GvNAME(gv);
10116                                 len = GvNAMELEN(gv);
10117                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10118                             }
10119                             else if (kid->op_type == OP_AELEM
10120                                      || kid->op_type == OP_HELEM)
10121                             {
10122                                  OP *firstop;
10123                                  OP *op = ((BINOP*)kid)->op_first;
10124                                  name = NULL;
10125                                  if (op) {
10126                                       SV *tmpstr = NULL;
10127                                       const char * const a =
10128                                            kid->op_type == OP_AELEM ?
10129                                            "[]" : "{}";
10130                                       if (((op->op_type == OP_RV2AV) ||
10131                                            (op->op_type == OP_RV2HV)) &&
10132                                           (firstop = ((UNOP*)op)->op_first) &&
10133                                           (firstop->op_type == OP_GV)) {
10134                                            /* packagevar $a[] or $h{} */
10135                                            GV * const gv = cGVOPx_gv(firstop);
10136                                            if (gv)
10137                                                 tmpstr =
10138                                                      Perl_newSVpvf(aTHX_
10139                                                                    "%s%c...%c",
10140                                                                    GvNAME(gv),
10141                                                                    a[0], a[1]);
10142                                       }
10143                                       else if (op->op_type == OP_PADAV
10144                                                || op->op_type == OP_PADHV) {
10145                                            /* lexicalvar $a[] or $h{} */
10146                                            const char * const padname =
10147                                                 PAD_COMPNAME_PV(op->op_targ);
10148                                            if (padname)
10149                                                 tmpstr =
10150                                                      Perl_newSVpvf(aTHX_
10151                                                                    "%s%c...%c",
10152                                                                    padname + 1,
10153                                                                    a[0], a[1]);
10154                                       }
10155                                       if (tmpstr) {
10156                                            name = SvPV_const(tmpstr, len);
10157                                            name_utf8 = SvUTF8(tmpstr);
10158                                            sv_2mortal(tmpstr);
10159                                       }
10160                                  }
10161                                  if (!name) {
10162                                       name = "__ANONIO__";
10163                                       len = 10;
10164                                       want_dollar = FALSE;
10165                                  }
10166                                  op_lvalue(kid, type);
10167                             }
10168                             if (name) {
10169                                 SV *namesv;
10170                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10171                                 namesv = PAD_SVl(targ);
10172                                 if (want_dollar && *name != '$')
10173                                     sv_setpvs(namesv, "$");
10174                                 else
10175                                     SvPVCLEAR(namesv);
10176                                 sv_catpvn(namesv, name, len);
10177                                 if ( name_utf8 ) SvUTF8_on(namesv);
10178                             }
10179                         }
10180                         scalar(kid);
10181                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10182                                     OP_RV2GV, flags);
10183                         kid->op_targ = targ;
10184                         kid->op_private |= priv;
10185                     }
10186                 }
10187                 scalar(kid);
10188                 break;
10189             case OA_SCALARREF:
10190                 if ((type == OP_UNDEF || type == OP_POS)
10191                     && numargs == 1 && !(oa >> 4)
10192                     && kid->op_type == OP_LIST)
10193                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
10194                 op_lvalue(scalar(kid), type);
10195                 break;
10196             }
10197             oa >>= 4;
10198             prev_kid = kid;
10199             kid = OpSIBLING(kid);
10200         }
10201         /* FIXME - should the numargs or-ing move after the too many
10202          * arguments check? */
10203         o->op_private |= numargs;
10204         if (kid)
10205             return too_many_arguments_pv(o,OP_DESC(o), 0);
10206         listkids(o);
10207     }
10208     else if (PL_opargs[type] & OA_DEFGV) {
10209         /* Ordering of these two is important to keep f_map.t passing.  */
10210         op_free(o);
10211         return newUNOP(type, 0, newDEFSVOP());
10212     }
10213
10214     if (oa) {
10215         while (oa & OA_OPTIONAL)
10216             oa >>= 4;
10217         if (oa && oa != OA_LIST)
10218             return too_few_arguments_pv(o,OP_DESC(o), 0);
10219     }
10220     return o;
10221 }
10222
10223 OP *
10224 Perl_ck_glob(pTHX_ OP *o)
10225 {
10226     GV *gv;
10227
10228     PERL_ARGS_ASSERT_CK_GLOB;
10229
10230     o = ck_fun(o);
10231     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10232         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10233
10234     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10235     {
10236         /* convert
10237          *     glob
10238          *       \ null - const(wildcard)
10239          * into
10240          *     null
10241          *       \ enter
10242          *            \ list
10243          *                 \ mark - glob - rv2cv
10244          *                             |        \ gv(CORE::GLOBAL::glob)
10245          *                             |
10246          *                              \ null - const(wildcard)
10247          */
10248         o->op_flags |= OPf_SPECIAL;
10249         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10250         o = S_new_entersubop(aTHX_ gv, o);
10251         o = newUNOP(OP_NULL, 0, o);
10252         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10253         return o;
10254     }
10255     else o->op_flags &= ~OPf_SPECIAL;
10256 #if !defined(PERL_EXTERNAL_GLOB)
10257     if (!PL_globhook) {
10258         ENTER;
10259         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10260                                newSVpvs("File::Glob"), NULL, NULL, NULL);
10261         LEAVE;
10262     }
10263 #endif /* !PERL_EXTERNAL_GLOB */
10264     gv = (GV *)newSV(0);
10265     gv_init(gv, 0, "", 0, 0);
10266     gv_IOadd(gv);
10267     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10268     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10269     scalarkids(o);
10270     return o;
10271 }
10272
10273 OP *
10274 Perl_ck_grep(pTHX_ OP *o)
10275 {
10276     LOGOP *gwop;
10277     OP *kid;
10278     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10279
10280     PERL_ARGS_ASSERT_CK_GREP;
10281
10282     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10283
10284     if (o->op_flags & OPf_STACKED) {
10285         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10286         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10287             return no_fh_allowed(o);
10288         o->op_flags &= ~OPf_STACKED;
10289     }
10290     kid = OpSIBLING(cLISTOPo->op_first);
10291     if (type == OP_MAPWHILE)
10292         list(kid);
10293     else
10294         scalar(kid);
10295     o = ck_fun(o);
10296     if (PL_parser && PL_parser->error_count)
10297         return o;
10298     kid = OpSIBLING(cLISTOPo->op_first);
10299     if (kid->op_type != OP_NULL)
10300         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10301     kid = kUNOP->op_first;
10302
10303     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10304     kid->op_next = (OP*)gwop;
10305     o->op_private = gwop->op_private = 0;
10306     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10307
10308     kid = OpSIBLING(cLISTOPo->op_first);
10309     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10310         op_lvalue(kid, OP_GREPSTART);
10311
10312     return (OP*)gwop;
10313 }
10314
10315 OP *
10316 Perl_ck_index(pTHX_ OP *o)
10317 {
10318     PERL_ARGS_ASSERT_CK_INDEX;
10319
10320     if (o->op_flags & OPf_KIDS) {
10321         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
10322         if (kid)
10323             kid = OpSIBLING(kid);                       /* get past "big" */
10324         if (kid && kid->op_type == OP_CONST) {
10325             const bool save_taint = TAINT_get;
10326             SV *sv = kSVOP->op_sv;
10327             if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10328                 sv = newSV(0);
10329                 sv_copypv(sv, kSVOP->op_sv);
10330                 SvREFCNT_dec_NN(kSVOP->op_sv);
10331                 kSVOP->op_sv = sv;
10332             }
10333             if (SvOK(sv)) fbm_compile(sv, 0);
10334             TAINT_set(save_taint);
10335 #ifdef NO_TAINT_SUPPORT
10336             PERL_UNUSED_VAR(save_taint);
10337 #endif
10338         }
10339     }
10340     return ck_fun(o);
10341 }
10342
10343 OP *
10344 Perl_ck_lfun(pTHX_ OP *o)
10345 {
10346     const OPCODE type = o->op_type;
10347
10348     PERL_ARGS_ASSERT_CK_LFUN;
10349
10350     return modkids(ck_fun(o), type);
10351 }
10352
10353 OP *
10354 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
10355 {
10356     PERL_ARGS_ASSERT_CK_DEFINED;
10357
10358     if ((o->op_flags & OPf_KIDS)) {
10359         switch (cUNOPo->op_first->op_type) {
10360         case OP_RV2AV:
10361         case OP_PADAV:
10362             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10363                              " (Maybe you should just omit the defined()?)");
10364             NOT_REACHED; /* NOTREACHED */
10365             break;
10366         case OP_RV2HV:
10367         case OP_PADHV:
10368             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10369                              " (Maybe you should just omit the defined()?)");
10370             NOT_REACHED; /* NOTREACHED */
10371             break;
10372         default:
10373             /* no warning */
10374             break;
10375         }
10376     }
10377     return ck_rfun(o);
10378 }
10379
10380 OP *
10381 Perl_ck_readline(pTHX_ OP *o)
10382 {
10383     PERL_ARGS_ASSERT_CK_READLINE;
10384
10385     if (o->op_flags & OPf_KIDS) {
10386          OP *kid = cLISTOPo->op_first;
10387          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10388     }
10389     else {
10390         OP * const newop
10391             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10392         op_free(o);
10393         return newop;
10394     }
10395     return o;
10396 }
10397
10398 OP *
10399 Perl_ck_rfun(pTHX_ OP *o)
10400 {
10401     const OPCODE type = o->op_type;
10402
10403     PERL_ARGS_ASSERT_CK_RFUN;
10404
10405     return refkids(ck_fun(o), type);
10406 }
10407
10408 OP *
10409 Perl_ck_listiob(pTHX_ OP *o)
10410 {
10411     OP *kid;
10412
10413     PERL_ARGS_ASSERT_CK_LISTIOB;
10414
10415     kid = cLISTOPo->op_first;
10416     if (!kid) {
10417         o = force_list(o, 1);
10418         kid = cLISTOPo->op_first;
10419     }
10420     if (kid->op_type == OP_PUSHMARK)
10421         kid = OpSIBLING(kid);
10422     if (kid && o->op_flags & OPf_STACKED)
10423         kid = OpSIBLING(kid);
10424     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
10425         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10426          && !kid->op_folded) {
10427             o->op_flags |= OPf_STACKED; /* make it a filehandle */
10428             scalar(kid);
10429             /* replace old const op with new OP_RV2GV parent */
10430             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10431                                         OP_RV2GV, OPf_REF);
10432             kid = OpSIBLING(kid);
10433         }
10434     }
10435
10436     if (!kid)
10437         op_append_elem(o->op_type, o, newDEFSVOP());
10438
10439     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10440     return listkids(o);
10441 }
10442
10443 OP *
10444 Perl_ck_smartmatch(pTHX_ OP *o)
10445 {
10446     dVAR;
10447     PERL_ARGS_ASSERT_CK_SMARTMATCH;
10448     if (0 == (o->op_flags & OPf_SPECIAL)) {
10449         OP *first  = cBINOPo->op_first;
10450         OP *second = OpSIBLING(first);
10451
10452         /* Implicitly take a reference to an array or hash */
10453
10454         /* remove the original two siblings, then add back the
10455          * (possibly different) first and second sibs.
10456          */
10457         op_sibling_splice(o, NULL, 1, NULL);
10458         op_sibling_splice(o, NULL, 1, NULL);
10459         first  = ref_array_or_hash(first);
10460         second = ref_array_or_hash(second);
10461         op_sibling_splice(o, NULL, 0, second);
10462         op_sibling_splice(o, NULL, 0, first);
10463
10464         /* Implicitly take a reference to a regular expression */
10465         if (first->op_type == OP_MATCH) {
10466             OpTYPE_set(first, OP_QR);
10467         }
10468         if (second->op_type == OP_MATCH) {
10469             OpTYPE_set(second, OP_QR);
10470         }
10471     }
10472
10473     return o;
10474 }
10475
10476
10477 static OP *
10478 S_maybe_targlex(pTHX_ OP *o)
10479 {
10480     OP * const kid = cLISTOPo->op_first;
10481     /* has a disposable target? */
10482     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10483         && !(kid->op_flags & OPf_STACKED)
10484         /* Cannot steal the second time! */
10485         && !(kid->op_private & OPpTARGET_MY)
10486         )
10487     {
10488         OP * const kkid = OpSIBLING(kid);
10489
10490         /* Can just relocate the target. */
10491         if (kkid && kkid->op_type == OP_PADSV
10492             && (!(kkid->op_private & OPpLVAL_INTRO)
10493                || kkid->op_private & OPpPAD_STATE))
10494         {
10495             kid->op_targ = kkid->op_targ;
10496             kkid->op_targ = 0;
10497             /* Now we do not need PADSV and SASSIGN.
10498              * Detach kid and free the rest. */
10499             op_sibling_splice(o, NULL, 1, NULL);
10500             op_free(o);
10501             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
10502             return kid;
10503         }
10504     }
10505     return o;
10506 }
10507
10508 OP *
10509 Perl_ck_sassign(pTHX_ OP *o)
10510 {
10511     dVAR;
10512     OP * const kid = cBINOPo->op_first;
10513
10514     PERL_ARGS_ASSERT_CK_SASSIGN;
10515
10516     if (OpHAS_SIBLING(kid)) {
10517         OP *kkid = OpSIBLING(kid);
10518         /* For state variable assignment with attributes, kkid is a list op
10519            whose op_last is a padsv. */
10520         if ((kkid->op_type == OP_PADSV ||
10521              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10522               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10523              )
10524             )
10525                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10526                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10527             const PADOFFSET target = kkid->op_targ;
10528             OP *const other = newOP(OP_PADSV,
10529                                     kkid->op_flags
10530                                     | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10531             OP *const first = newOP(OP_NULL, 0);
10532             OP *const nullop =
10533                 newCONDOP(0, first, o, other);
10534             /* XXX targlex disabled for now; see ticket #124160
10535                 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10536              */
10537             OP *const condop = first->op_next;
10538
10539             OpTYPE_set(condop, OP_ONCE);
10540             other->op_targ = target;
10541             nullop->op_flags |= OPf_WANT_SCALAR;
10542
10543             /* Store the initializedness of state vars in a separate
10544                pad entry.  */
10545             condop->op_targ =
10546               pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10547             /* hijacking PADSTALE for uninitialized state variables */
10548             SvPADSTALE_on(PAD_SVl(condop->op_targ));
10549
10550             return nullop;
10551         }
10552     }
10553     return S_maybe_targlex(aTHX_ o);
10554 }
10555
10556 OP *
10557 Perl_ck_match(pTHX_ OP *o)
10558 {
10559     PERL_UNUSED_CONTEXT;
10560     PERL_ARGS_ASSERT_CK_MATCH;
10561
10562     return o;
10563 }
10564
10565 OP *
10566 Perl_ck_method(pTHX_ OP *o)
10567 {
10568     SV *sv, *methsv, *rclass;
10569     const char* method;
10570     char* compatptr;
10571     int utf8;
10572     STRLEN len, nsplit = 0, i;
10573     OP* new_op;
10574     OP * const kid = cUNOPo->op_first;
10575
10576     PERL_ARGS_ASSERT_CK_METHOD;
10577     if (kid->op_type != OP_CONST) return o;
10578
10579     sv = kSVOP->op_sv;
10580
10581     /* replace ' with :: */
10582     while ((compatptr = strchr(SvPVX(sv), '\''))) {
10583         *compatptr = ':';
10584         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10585     }
10586
10587     method = SvPVX_const(sv);
10588     len = SvCUR(sv);
10589     utf8 = SvUTF8(sv) ? -1 : 1;
10590
10591     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10592         nsplit = i+1;
10593         break;
10594     }
10595
10596     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10597
10598     if (!nsplit) { /* $proto->method() */
10599         op_free(o);
10600         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10601     }
10602
10603     if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10604         op_free(o);
10605         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10606     }
10607
10608     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10609     if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10610         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10611         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10612     } else {
10613         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10614         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10615     }
10616 #ifdef USE_ITHREADS
10617     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10618 #else
10619     cMETHOPx(new_op)->op_rclass_sv = rclass;
10620 #endif
10621     op_free(o);
10622     return new_op;
10623 }
10624
10625 OP *
10626 Perl_ck_null(pTHX_ OP *o)
10627 {
10628     PERL_ARGS_ASSERT_CK_NULL;
10629     PERL_UNUSED_CONTEXT;
10630     return o;
10631 }
10632
10633 OP *
10634 Perl_ck_open(pTHX_ OP *o)
10635 {
10636     PERL_ARGS_ASSERT_CK_OPEN;
10637
10638     S_io_hints(aTHX_ o);
10639     {
10640          /* In case of three-arg dup open remove strictness
10641           * from the last arg if it is a bareword. */
10642          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10643          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
10644          OP *oa;
10645          const char *mode;
10646
10647          if ((last->op_type == OP_CONST) &&             /* The bareword. */
10648              (last->op_private & OPpCONST_BARE) &&
10649              (last->op_private & OPpCONST_STRICT) &&
10650              (oa = OpSIBLING(first)) &&         /* The fh. */
10651              (oa = OpSIBLING(oa)) &&                    /* The mode. */
10652              (oa->op_type == OP_CONST) &&
10653              SvPOK(((SVOP*)oa)->op_sv) &&
10654              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10655              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
10656              (last == OpSIBLING(oa)))                   /* The bareword. */
10657               last->op_private &= ~OPpCONST_STRICT;
10658     }
10659     return ck_fun(o);
10660 }
10661
10662 OP *
10663 Perl_ck_prototype(pTHX_ OP *o)
10664 {
10665     PERL_ARGS_ASSERT_CK_PROTOTYPE;
10666     if (!(o->op_flags & OPf_KIDS)) {
10667         op_free(o);
10668         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10669     }
10670     return o;
10671 }
10672
10673 OP *
10674 Perl_ck_refassign(pTHX_ OP *o)
10675 {
10676     OP * const right = cLISTOPo->op_first;
10677     OP * const left = OpSIBLING(right);
10678     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10679     bool stacked = 0;
10680
10681     PERL_ARGS_ASSERT_CK_REFASSIGN;
10682     assert (left);
10683     assert (left->op_type == OP_SREFGEN);
10684
10685     o->op_private = 0;
10686     /* we use OPpPAD_STATE in refassign to mean either of those things,
10687      * and the code assumes the two flags occupy the same bit position
10688      * in the various ops below */
10689     assert(OPpPAD_STATE == OPpOUR_INTRO);
10690
10691     switch (varop->op_type) {
10692     case OP_PADAV:
10693         o->op_private |= OPpLVREF_AV;
10694         goto settarg;
10695     case OP_PADHV:
10696         o->op_private |= OPpLVREF_HV;
10697         /* FALLTHROUGH */
10698     case OP_PADSV:
10699       settarg:
10700         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10701         o->op_targ = varop->op_targ;
10702         varop->op_targ = 0;
10703         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10704         break;
10705
10706     case OP_RV2AV:
10707         o->op_private |= OPpLVREF_AV;
10708         goto checkgv;
10709         NOT_REACHED; /* NOTREACHED */
10710     case OP_RV2HV:
10711         o->op_private |= OPpLVREF_HV;
10712         /* FALLTHROUGH */
10713     case OP_RV2SV:
10714       checkgv:
10715         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10716         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10717       detach_and_stack:
10718         /* Point varop to its GV kid, detached.  */
10719         varop = op_sibling_splice(varop, NULL, -1, NULL);
10720         stacked = TRUE;
10721         break;
10722     case OP_RV2CV: {
10723         OP * const kidparent =
10724             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10725         OP * const kid = cUNOPx(kidparent)->op_first;
10726         o->op_private |= OPpLVREF_CV;
10727         if (kid->op_type == OP_GV) {
10728             varop = kidparent;
10729             goto detach_and_stack;
10730         }
10731         if (kid->op_type != OP_PADCV)   goto bad;
10732         o->op_targ = kid->op_targ;
10733         kid->op_targ = 0;
10734         break;
10735     }
10736     case OP_AELEM:
10737     case OP_HELEM:
10738         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10739         o->op_private |= OPpLVREF_ELEM;
10740         op_null(varop);
10741         stacked = TRUE;
10742         /* Detach varop.  */
10743         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10744         break;
10745     default:
10746       bad:
10747         /* diag_listed_as: Can't modify reference to %s in %s assignment */
10748         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10749                                 "assignment",
10750                                  OP_DESC(varop)));
10751         return o;
10752     }
10753     if (!FEATURE_REFALIASING_IS_ENABLED)
10754         Perl_croak(aTHX_
10755                   "Experimental aliasing via reference not enabled");
10756     Perl_ck_warner_d(aTHX_
10757                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
10758                     "Aliasing via reference is experimental");
10759     if (stacked) {
10760         o->op_flags |= OPf_STACKED;
10761         op_sibling_splice(o, right, 1, varop);
10762     }
10763     else {
10764         o->op_flags &=~ OPf_STACKED;
10765         op_sibling_splice(o, right, 1, NULL);
10766     }
10767     op_free(left);
10768     return o;
10769 }
10770
10771 OP *
10772 Perl_ck_repeat(pTHX_ OP *o)
10773 {
10774     PERL_ARGS_ASSERT_CK_REPEAT;
10775
10776     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10777         OP* kids;
10778         o->op_private |= OPpREPEAT_DOLIST;
10779         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10780         kids = force_list(kids, 1); /* promote it to a list */
10781         op_sibling_splice(o, NULL, 0, kids); /* and add back */
10782     }
10783     else
10784         scalar(o);
10785     return o;
10786 }
10787
10788 OP *
10789 Perl_ck_require(pTHX_ OP *o)
10790 {
10791     GV* gv;
10792
10793     PERL_ARGS_ASSERT_CK_REQUIRE;
10794
10795     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
10796         SVOP * const kid = (SVOP*)cUNOPo->op_first;
10797         HEK *hek;
10798         U32 hash;
10799         char *s;
10800         STRLEN len;
10801         if (kid->op_type == OP_CONST) {
10802           SV * const sv = kid->op_sv;
10803           U32 const was_readonly = SvREADONLY(sv);
10804           if (kid->op_private & OPpCONST_BARE) {
10805             dVAR;
10806             const char *end;
10807
10808             if (was_readonly) {
10809                     SvREADONLY_off(sv);
10810             }
10811             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10812
10813             s = SvPVX(sv);
10814             len = SvCUR(sv);
10815             end = s + len;
10816             /* treat ::foo::bar as foo::bar */
10817             if (len >= 2 && s[0] == ':' && s[1] == ':')
10818                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10819             if (s == end)
10820                 DIE(aTHX_ "Bareword in require maps to empty filename");
10821
10822             for (; s < end; s++) {
10823                 if (*s == ':' && s[1] == ':') {
10824                     *s = '/';
10825                     Move(s+2, s+1, end - s - 1, char);
10826                     --end;
10827                 }
10828             }
10829             SvEND_set(sv, end);
10830             sv_catpvs(sv, ".pm");
10831             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10832             hek = share_hek(SvPVX(sv),
10833                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10834                             hash);
10835             sv_sethek(sv, hek);
10836             unshare_hek(hek);
10837             SvFLAGS(sv) |= was_readonly;
10838           }
10839           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10840                 && !SvVOK(sv)) {
10841             s = SvPV(sv, len);
10842             if (SvREFCNT(sv) > 1) {
10843                 kid->op_sv = newSVpvn_share(
10844                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10845                 SvREFCNT_dec_NN(sv);
10846             }
10847             else {
10848                 dVAR;
10849                 if (was_readonly) SvREADONLY_off(sv);
10850                 PERL_HASH(hash, s, len);
10851                 hek = share_hek(s,
10852                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10853                                 hash);
10854                 sv_sethek(sv, hek);
10855                 unshare_hek(hek);
10856                 SvFLAGS(sv) |= was_readonly;
10857             }
10858           }
10859         }
10860     }
10861
10862     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10863         /* handle override, if any */
10864      && (gv = gv_override("require", 7))) {
10865         OP *kid, *newop;
10866         if (o->op_flags & OPf_KIDS) {
10867             kid = cUNOPo->op_first;
10868             op_sibling_splice(o, NULL, -1, NULL);
10869         }
10870         else {
10871             kid = newDEFSVOP();
10872         }
10873         op_free(o);
10874         newop = S_new_entersubop(aTHX_ gv, kid);
10875         return newop;
10876     }
10877
10878     return ck_fun(o);
10879 }
10880
10881 OP *
10882 Perl_ck_return(pTHX_ OP *o)
10883 {
10884     OP *kid;
10885
10886     PERL_ARGS_ASSERT_CK_RETURN;
10887
10888     kid = OpSIBLING(cLISTOPo->op_first);
10889     if (CvLVALUE(PL_compcv)) {
10890         for (; kid; kid = OpSIBLING(kid))
10891             op_lvalue(kid, OP_LEAVESUBLV);
10892     }
10893
10894     return o;
10895 }
10896
10897 OP *
10898 Perl_ck_select(pTHX_ OP *o)
10899 {
10900     dVAR;
10901     OP* kid;
10902
10903     PERL_ARGS_ASSERT_CK_SELECT;
10904
10905     if (o->op_flags & OPf_KIDS) {
10906         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
10907         if (kid && OpHAS_SIBLING(kid)) {
10908             OpTYPE_set(o, OP_SSELECT);
10909             o = ck_fun(o);
10910             return fold_constants(op_integerize(op_std_init(o)));
10911         }
10912     }
10913     o = ck_fun(o);
10914     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
10915     if (kid && kid->op_type == OP_RV2GV)
10916         kid->op_private &= ~HINT_STRICT_REFS;
10917     return o;
10918 }
10919
10920 OP *
10921 Perl_ck_shift(pTHX_ OP *o)
10922 {
10923     const I32 type = o->op_type;
10924
10925     PERL_ARGS_ASSERT_CK_SHIFT;
10926
10927     if (!(o->op_flags & OPf_KIDS)) {
10928         OP *argop;
10929
10930         if (!CvUNIQUE(PL_compcv)) {
10931             o->op_flags |= OPf_SPECIAL;
10932             return o;
10933         }
10934
10935         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10936         op_free(o);
10937         return newUNOP(type, 0, scalar(argop));
10938     }
10939     return scalar(ck_fun(o));
10940 }
10941
10942 OP *
10943 Perl_ck_sort(pTHX_ OP *o)
10944 {
10945     OP *firstkid;
10946     OP *kid;
10947     HV * const hinthv =
10948         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10949     U8 stacked;
10950
10951     PERL_ARGS_ASSERT_CK_SORT;
10952
10953     if (hinthv) {
10954             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10955             if (svp) {
10956                 const I32 sorthints = (I32)SvIV(*svp);
10957                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10958                     o->op_private |= OPpSORT_QSORT;
10959                 if ((sorthints & HINT_SORT_STABLE) != 0)
10960                     o->op_private |= OPpSORT_STABLE;
10961             }
10962     }
10963
10964     if (o->op_flags & OPf_STACKED)
10965         simplify_sort(o);
10966     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
10967
10968     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
10969         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
10970
10971         /* if the first arg is a code block, process it and mark sort as
10972          * OPf_SPECIAL */
10973         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10974             LINKLIST(kid);
10975             if (kid->op_type == OP_LEAVE)
10976                     op_null(kid);                       /* wipe out leave */
10977             /* Prevent execution from escaping out of the sort block. */
10978             kid->op_next = 0;
10979
10980             /* provide scalar context for comparison function/block */
10981             kid = scalar(firstkid);
10982             kid->op_next = kid;
10983             o->op_flags |= OPf_SPECIAL;
10984         }
10985         else if (kid->op_type == OP_CONST
10986               && kid->op_private & OPpCONST_BARE) {
10987             char tmpbuf[256];
10988             STRLEN len;
10989             PADOFFSET off;
10990             const char * const name = SvPV(kSVOP_sv, len);
10991             *tmpbuf = '&';
10992             assert (len < 256);
10993             Copy(name, tmpbuf+1, len, char);
10994             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10995             if (off != NOT_IN_PAD) {
10996                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10997                     SV * const fq =
10998                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10999                     sv_catpvs(fq, "::");
11000                     sv_catsv(fq, kSVOP_sv);
11001                     SvREFCNT_dec_NN(kSVOP_sv);
11002                     kSVOP->op_sv = fq;
11003                 }
11004                 else {
11005                     OP * const padop = newOP(OP_PADCV, 0);
11006                     padop->op_targ = off;
11007                     /* replace the const op with the pad op */
11008                     op_sibling_splice(firstkid, NULL, 1, padop);
11009                     op_free(kid);
11010                 }
11011             }
11012         }
11013
11014         firstkid = OpSIBLING(firstkid);
11015     }
11016
11017     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11018         /* provide list context for arguments */
11019         list(kid);
11020         if (stacked)
11021             op_lvalue(kid, OP_GREPSTART);
11022     }
11023
11024     return o;
11025 }
11026
11027 /* for sort { X } ..., where X is one of
11028  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
11029  * elide the second child of the sort (the one containing X),
11030  * and set these flags as appropriate
11031         OPpSORT_NUMERIC;
11032         OPpSORT_INTEGER;
11033         OPpSORT_DESCEND;
11034  * Also, check and warn on lexical $a, $b.
11035  */
11036
11037 STATIC void
11038 S_simplify_sort(pTHX_ OP *o)
11039 {
11040     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
11041     OP *k;
11042     int descending;
11043     GV *gv;
11044     const char *gvname;
11045     bool have_scopeop;
11046
11047     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11048
11049     kid = kUNOP->op_first;                              /* get past null */
11050     if (!(have_scopeop = kid->op_type == OP_SCOPE)
11051      && kid->op_type != OP_LEAVE)
11052         return;
11053     kid = kLISTOP->op_last;                             /* get past scope */
11054     switch(kid->op_type) {
11055         case OP_NCMP:
11056         case OP_I_NCMP:
11057         case OP_SCMP:
11058             if (!have_scopeop) goto padkids;
11059             break;
11060         default:
11061             return;
11062     }
11063     k = kid;                                            /* remember this node*/
11064     if (kBINOP->op_first->op_type != OP_RV2SV
11065      || kBINOP->op_last ->op_type != OP_RV2SV)
11066     {
11067         /*
11068            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11069            then used in a comparison.  This catches most, but not
11070            all cases.  For instance, it catches
11071                sort { my($a); $a <=> $b }
11072            but not
11073                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11074            (although why you'd do that is anyone's guess).
11075         */
11076
11077        padkids:
11078         if (!ckWARN(WARN_SYNTAX)) return;
11079         kid = kBINOP->op_first;
11080         do {
11081             if (kid->op_type == OP_PADSV) {
11082                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11083                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11084                  && (  PadnamePV(name)[1] == 'a'
11085                     || PadnamePV(name)[1] == 'b'  ))
11086                     /* diag_listed_as: "my %s" used in sort comparison */
11087                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11088                                      "\"%s %s\" used in sort comparison",
11089                                       PadnameIsSTATE(name)
11090                                         ? "state"
11091                                         : "my",
11092                                       PadnamePV(name));
11093             }
11094         } while ((kid = OpSIBLING(kid)));
11095         return;
11096     }
11097     kid = kBINOP->op_first;                             /* get past cmp */
11098     if (kUNOP->op_first->op_type != OP_GV)
11099         return;
11100     kid = kUNOP->op_first;                              /* get past rv2sv */
11101     gv = kGVOP_gv;
11102     if (GvSTASH(gv) != PL_curstash)
11103         return;
11104     gvname = GvNAME(gv);
11105     if (*gvname == 'a' && gvname[1] == '\0')
11106         descending = 0;
11107     else if (*gvname == 'b' && gvname[1] == '\0')
11108         descending = 1;
11109     else
11110         return;
11111
11112     kid = k;                                            /* back to cmp */
11113     /* already checked above that it is rv2sv */
11114     kid = kBINOP->op_last;                              /* down to 2nd arg */
11115     if (kUNOP->op_first->op_type != OP_GV)
11116         return;
11117     kid = kUNOP->op_first;                              /* get past rv2sv */
11118     gv = kGVOP_gv;
11119     if (GvSTASH(gv) != PL_curstash)
11120         return;
11121     gvname = GvNAME(gv);
11122     if ( descending
11123          ? !(*gvname == 'a' && gvname[1] == '\0')
11124          : !(*gvname == 'b' && gvname[1] == '\0'))
11125         return;
11126     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11127     if (descending)
11128         o->op_private |= OPpSORT_DESCEND;
11129     if (k->op_type == OP_NCMP)
11130         o->op_private |= OPpSORT_NUMERIC;
11131     if (k->op_type == OP_I_NCMP)
11132         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11133     kid = OpSIBLING(cLISTOPo->op_first);
11134     /* cut out and delete old block (second sibling) */
11135     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11136     op_free(kid);
11137 }
11138
11139 OP *
11140 Perl_ck_split(pTHX_ OP *o)
11141 {
11142     dVAR;
11143     OP *kid;
11144     OP *sibs;
11145
11146     PERL_ARGS_ASSERT_CK_SPLIT;
11147
11148     assert(o->op_type == OP_LIST);
11149
11150     if (o->op_flags & OPf_STACKED)
11151         return no_fh_allowed(o);
11152
11153     kid = cLISTOPo->op_first;
11154     /* delete leading NULL node, then add a CONST if no other nodes */
11155     assert(kid->op_type == OP_NULL);
11156     op_sibling_splice(o, NULL, 1,
11157         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11158     op_free(kid);
11159     kid = cLISTOPo->op_first;
11160
11161     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11162         /* remove match expression, and replace with new optree with
11163          * a match op at its head */
11164         op_sibling_splice(o, NULL, 1, NULL);
11165         /* pmruntime will handle split " " behavior with flag==2 */
11166         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11167         op_sibling_splice(o, NULL, 0, kid);
11168     }
11169
11170     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11171
11172     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11173       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11174                      "Use of /g modifier is meaningless in split");
11175     }
11176
11177     /* eliminate the split op, and move the match op (plus any children)
11178      * into its place, then convert the match op into a split op. i.e.
11179      *
11180      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
11181      *    |                        |                     |
11182      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
11183      *    |                        |                     |
11184      *    R                        X - Y                 X - Y
11185      *    |
11186      *    X - Y
11187      *
11188      * (R, if it exists, will be a regcomp op)
11189      */
11190
11191     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11192     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11193     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11194     OpTYPE_set(kid, OP_SPLIT);
11195     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
11196     kid->op_private = o->op_private;
11197     op_free(o);
11198     o = kid;
11199     kid = sibs; /* kid is now the string arg of the split */
11200
11201     if (!kid) {
11202         kid = newDEFSVOP();
11203         op_append_elem(OP_SPLIT, o, kid);
11204     }
11205     scalar(kid);
11206
11207     kid = OpSIBLING(kid);
11208     if (!kid) {
11209         kid = newSVOP(OP_CONST, 0, newSViv(0));
11210         op_append_elem(OP_SPLIT, o, kid);
11211         o->op_private |= OPpSPLIT_IMPLIM;
11212     }
11213     scalar(kid);
11214
11215     if (OpHAS_SIBLING(kid))
11216         return too_many_arguments_pv(o,OP_DESC(o), 0);
11217
11218     return o;
11219 }
11220
11221 OP *
11222 Perl_ck_stringify(pTHX_ OP *o)
11223 {
11224     OP * const kid = OpSIBLING(cUNOPo->op_first);
11225     PERL_ARGS_ASSERT_CK_STRINGIFY;
11226     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11227          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
11228          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
11229         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11230     {
11231         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11232         op_free(o);
11233         return kid;
11234     }
11235     return ck_fun(o);
11236 }
11237
11238 OP *
11239 Perl_ck_join(pTHX_ OP *o)
11240 {
11241     OP * const kid = OpSIBLING(cLISTOPo->op_first);
11242
11243     PERL_ARGS_ASSERT_CK_JOIN;
11244
11245     if (kid && kid->op_type == OP_MATCH) {
11246         if (ckWARN(WARN_SYNTAX)) {
11247             const REGEXP *re = PM_GETRE(kPMOP);
11248             const SV *msg = re
11249                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11250                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11251                     : newSVpvs_flags( "STRING", SVs_TEMP );
11252             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11253                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
11254                         SVfARG(msg), SVfARG(msg));
11255         }
11256     }
11257     if (kid
11258      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11259         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11260         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11261            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11262     {
11263         const OP * const bairn = OpSIBLING(kid); /* the list */
11264         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11265          && OP_GIMME(bairn,0) == G_SCALAR)
11266         {
11267             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11268                                      op_sibling_splice(o, kid, 1, NULL));
11269             op_free(o);
11270             return ret;
11271         }
11272     }
11273
11274     return ck_fun(o);
11275 }
11276
11277 /*
11278 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11279
11280 Examines an op, which is expected to identify a subroutine at runtime,
11281 and attempts to determine at compile time which subroutine it identifies.
11282 This is normally used during Perl compilation to determine whether
11283 a prototype can be applied to a function call.  C<cvop> is the op
11284 being considered, normally an C<rv2cv> op.  A pointer to the identified
11285 subroutine is returned, if it could be determined statically, and a null
11286 pointer is returned if it was not possible to determine statically.
11287
11288 Currently, the subroutine can be identified statically if the RV that the
11289 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11290 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
11291 suitable if the constant value must be an RV pointing to a CV.  Details of
11292 this process may change in future versions of Perl.  If the C<rv2cv> op
11293 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11294 the subroutine statically: this flag is used to suppress compile-time
11295 magic on a subroutine call, forcing it to use default runtime behaviour.
11296
11297 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11298 of a GV reference is modified.  If a GV was examined and its CV slot was
11299 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11300 If the op is not optimised away, and the CV slot is later populated with
11301 a subroutine having a prototype, that flag eventually triggers the warning
11302 "called too early to check prototype".
11303
11304 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11305 of returning a pointer to the subroutine it returns a pointer to the
11306 GV giving the most appropriate name for the subroutine in this context.
11307 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11308 (C<CvANON>) subroutine that is referenced through a GV it will be the
11309 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
11310 A null pointer is returned as usual if there is no statically-determinable
11311 subroutine.
11312
11313 =cut
11314 */
11315
11316 /* shared by toke.c:yylex */
11317 CV *
11318 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11319 {
11320     PADNAME *name = PAD_COMPNAME(off);
11321     CV *compcv = PL_compcv;
11322     while (PadnameOUTER(name)) {
11323         assert(PARENT_PAD_INDEX(name));
11324         compcv = CvOUTSIDE(compcv);
11325         name = PadlistNAMESARRAY(CvPADLIST(compcv))
11326                 [off = PARENT_PAD_INDEX(name)];
11327     }
11328     assert(!PadnameIsOUR(name));
11329     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11330         return PadnamePROTOCV(name);
11331     }
11332     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11333 }
11334
11335 CV *
11336 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11337 {
11338     OP *rvop;
11339     CV *cv;
11340     GV *gv;
11341     PERL_ARGS_ASSERT_RV2CV_OP_CV;
11342     if (flags & ~RV2CVOPCV_FLAG_MASK)
11343         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11344     if (cvop->op_type != OP_RV2CV)
11345         return NULL;
11346     if (cvop->op_private & OPpENTERSUB_AMPER)
11347         return NULL;
11348     if (!(cvop->op_flags & OPf_KIDS))
11349         return NULL;
11350     rvop = cUNOPx(cvop)->op_first;
11351     switch (rvop->op_type) {
11352         case OP_GV: {
11353             gv = cGVOPx_gv(rvop);
11354             if (!isGV(gv)) {
11355                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11356                     cv = MUTABLE_CV(SvRV(gv));
11357                     gv = NULL;
11358                     break;
11359                 }
11360                 if (flags & RV2CVOPCV_RETURN_STUB)
11361                     return (CV *)gv;
11362                 else return NULL;
11363             }
11364             cv = GvCVu(gv);
11365             if (!cv) {
11366                 if (flags & RV2CVOPCV_MARK_EARLY)
11367                     rvop->op_private |= OPpEARLY_CV;
11368                 return NULL;
11369             }
11370         } break;
11371         case OP_CONST: {
11372             SV *rv = cSVOPx_sv(rvop);
11373             if (!SvROK(rv))
11374                 return NULL;
11375             cv = (CV*)SvRV(rv);
11376             gv = NULL;
11377         } break;
11378         case OP_PADCV: {
11379             cv = find_lexical_cv(rvop->op_targ);
11380             gv = NULL;
11381         } break;
11382         default: {
11383             return NULL;
11384         } NOT_REACHED; /* NOTREACHED */
11385     }
11386     if (SvTYPE((SV*)cv) != SVt_PVCV)
11387         return NULL;
11388     if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11389         if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11390          && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11391             gv = CvGV(cv);
11392         return (CV*)gv;
11393     } else {
11394         return cv;
11395     }
11396 }
11397
11398 /*
11399 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11400
11401 Performs the default fixup of the arguments part of an C<entersub>
11402 op tree.  This consists of applying list context to each of the
11403 argument ops.  This is the standard treatment used on a call marked
11404 with C<&>, or a method call, or a call through a subroutine reference,
11405 or any other call where the callee can't be identified at compile time,
11406 or a call where the callee has no prototype.
11407
11408 =cut
11409 */
11410
11411 OP *
11412 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11413 {
11414     OP *aop;
11415
11416     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11417
11418     aop = cUNOPx(entersubop)->op_first;
11419     if (!OpHAS_SIBLING(aop))
11420         aop = cUNOPx(aop)->op_first;
11421     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11422         /* skip the extra attributes->import() call implicitly added in
11423          * something like foo(my $x : bar)
11424          */
11425         if (   aop->op_type == OP_ENTERSUB
11426             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11427         )
11428             continue;
11429         list(aop);
11430         op_lvalue(aop, OP_ENTERSUB);
11431     }
11432     return entersubop;
11433 }
11434
11435 /*
11436 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11437
11438 Performs the fixup of the arguments part of an C<entersub> op tree
11439 based on a subroutine prototype.  This makes various modifications to
11440 the argument ops, from applying context up to inserting C<refgen> ops,
11441 and checking the number and syntactic types of arguments, as directed by
11442 the prototype.  This is the standard treatment used on a subroutine call,
11443 not marked with C<&>, where the callee can be identified at compile time
11444 and has a prototype.
11445
11446 C<protosv> supplies the subroutine prototype to be applied to the call.
11447 It may be a normal defined scalar, of which the string value will be used.
11448 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11449 that has been cast to C<SV*>) which has a prototype.  The prototype
11450 supplied, in whichever form, does not need to match the actual callee
11451 referenced by the op tree.
11452
11453 If the argument ops disagree with the prototype, for example by having
11454 an unacceptable number of arguments, a valid op tree is returned anyway.
11455 The error is reflected in the parser state, normally resulting in a single
11456 exception at the top level of parsing which covers all the compilation
11457 errors that occurred.  In the error message, the callee is referred to
11458 by the name defined by the C<namegv> parameter.
11459
11460 =cut
11461 */
11462
11463 OP *
11464 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11465 {
11466     STRLEN proto_len;
11467     const char *proto, *proto_end;
11468     OP *aop, *prev, *cvop, *parent;
11469     int optional = 0;
11470     I32 arg = 0;
11471     I32 contextclass = 0;
11472     const char *e = NULL;
11473     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11474     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11475         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11476                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
11477     if (SvTYPE(protosv) == SVt_PVCV)
11478          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11479     else proto = SvPV(protosv, proto_len);
11480     proto = S_strip_spaces(aTHX_ proto, &proto_len);
11481     proto_end = proto + proto_len;
11482     parent = entersubop;
11483     aop = cUNOPx(entersubop)->op_first;
11484     if (!OpHAS_SIBLING(aop)) {
11485         parent = aop;
11486         aop = cUNOPx(aop)->op_first;
11487     }
11488     prev = aop;
11489     aop = OpSIBLING(aop);
11490     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11491     while (aop != cvop) {
11492         OP* o3 = aop;
11493
11494         if (proto >= proto_end)
11495         {
11496             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11497             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11498                                         SVfARG(namesv)), SvUTF8(namesv));
11499             return entersubop;
11500         }
11501
11502         switch (*proto) {
11503             case ';':
11504                 optional = 1;
11505                 proto++;
11506                 continue;
11507             case '_':
11508                 /* _ must be at the end */
11509                 if (proto[1] && !strchr(";@%", proto[1]))
11510                     goto oops;
11511                 /* FALLTHROUGH */
11512             case '$':
11513                 proto++;
11514                 arg++;
11515                 scalar(aop);
11516                 break;
11517             case '%':
11518             case '@':
11519                 list(aop);
11520                 arg++;
11521                 break;
11522             case '&':
11523                 proto++;
11524                 arg++;
11525                 if (    o3->op_type != OP_UNDEF
11526                     && (o3->op_type != OP_SREFGEN
11527                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11528                                 != OP_ANONCODE
11529                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11530                                 != OP_RV2CV)))
11531                     bad_type_gv(arg, namegv, o3,
11532                             arg == 1 ? "block or sub {}" : "sub {}");
11533                 break;
11534             case '*':
11535                 /* '*' allows any scalar type, including bareword */
11536                 proto++;
11537                 arg++;
11538                 if (o3->op_type == OP_RV2GV)
11539                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
11540                 else if (o3->op_type == OP_CONST)
11541                     o3->op_private &= ~OPpCONST_STRICT;
11542                 scalar(aop);
11543                 break;
11544             case '+':
11545                 proto++;
11546                 arg++;
11547                 if (o3->op_type == OP_RV2AV ||
11548                     o3->op_type == OP_PADAV ||
11549                     o3->op_type == OP_RV2HV ||
11550                     o3->op_type == OP_PADHV
11551                 ) {
11552                     goto wrapref;
11553                 }
11554                 scalar(aop);
11555                 break;
11556             case '[': case ']':
11557                 goto oops;
11558
11559             case '\\':
11560                 proto++;
11561                 arg++;
11562             again:
11563                 switch (*proto++) {
11564                     case '[':
11565                         if (contextclass++ == 0) {
11566                             e = strchr(proto, ']');
11567                             if (!e || e == proto)
11568                                 goto oops;
11569                         }
11570                         else
11571                             goto oops;
11572                         goto again;
11573
11574                     case ']':
11575                         if (contextclass) {
11576                             const char *p = proto;
11577                             const char *const end = proto;
11578                             contextclass = 0;
11579                             while (*--p != '[')
11580                                 /* \[$] accepts any scalar lvalue */
11581                                 if (*p == '$'
11582                                  && Perl_op_lvalue_flags(aTHX_
11583                                      scalar(o3),
11584                                      OP_READ, /* not entersub */
11585                                      OP_LVALUE_NO_CROAK
11586                                     )) goto wrapref;
11587                             bad_type_gv(arg, namegv, o3,
11588                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11589                         } else
11590                             goto oops;
11591                         break;
11592                     case '*':
11593                         if (o3->op_type == OP_RV2GV)
11594                             goto wrapref;
11595                         if (!contextclass)
11596                             bad_type_gv(arg, namegv, o3, "symbol");
11597                         break;
11598                     case '&':
11599                         if (o3->op_type == OP_ENTERSUB
11600                          && !(o3->op_flags & OPf_STACKED))
11601                             goto wrapref;
11602                         if (!contextclass)
11603                             bad_type_gv(arg, namegv, o3, "subroutine");
11604                         break;
11605                     case '$':
11606                         if (o3->op_type == OP_RV2SV ||
11607                                 o3->op_type == OP_PADSV ||
11608                                 o3->op_type == OP_HELEM ||
11609                                 o3->op_type == OP_AELEM)
11610                             goto wrapref;
11611                         if (!contextclass) {
11612                             /* \$ accepts any scalar lvalue */
11613                             if (Perl_op_lvalue_flags(aTHX_
11614                                     scalar(o3),
11615                                     OP_READ,  /* not entersub */
11616                                     OP_LVALUE_NO_CROAK
11617                                )) goto wrapref;
11618                             bad_type_gv(arg, namegv, o3, "scalar");
11619                         }
11620                         break;
11621                     case '@':
11622                         if (o3->op_type == OP_RV2AV ||
11623                                 o3->op_type == OP_PADAV)
11624                         {
11625                             o3->op_flags &=~ OPf_PARENS;
11626                             goto wrapref;
11627                         }
11628                         if (!contextclass)
11629                             bad_type_gv(arg, namegv, o3, "array");
11630                         break;
11631                     case '%':
11632                         if (o3->op_type == OP_RV2HV ||
11633                                 o3->op_type == OP_PADHV)
11634                         {
11635                             o3->op_flags &=~ OPf_PARENS;
11636                             goto wrapref;
11637                         }
11638                         if (!contextclass)
11639                             bad_type_gv(arg, namegv, o3, "hash");
11640                         break;
11641                     wrapref:
11642                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11643                                                 OP_REFGEN, 0);
11644                         if (contextclass && e) {
11645                             proto = e + 1;
11646                             contextclass = 0;
11647                         }
11648                         break;
11649                     default: goto oops;
11650                 }
11651                 if (contextclass)
11652                     goto again;
11653                 break;
11654             case ' ':
11655                 proto++;
11656                 continue;
11657             default:
11658             oops: {
11659                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
11660                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
11661                                   SVfARG(protosv));
11662             }
11663         }
11664
11665         op_lvalue(aop, OP_ENTERSUB);
11666         prev = aop;
11667         aop = OpSIBLING(aop);
11668     }
11669     if (aop == cvop && *proto == '_') {
11670         /* generate an access to $_ */
11671         op_sibling_splice(parent, prev, 0, newDEFSVOP());
11672     }
11673     if (!optional && proto_end > proto &&
11674         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11675     {
11676         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11677         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
11678                                     SVfARG(namesv)), SvUTF8(namesv));
11679     }
11680     return entersubop;
11681 }
11682
11683 /*
11684 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11685
11686 Performs the fixup of the arguments part of an C<entersub> op tree either
11687 based on a subroutine prototype or using default list-context processing.
11688 This is the standard treatment used on a subroutine call, not marked
11689 with C<&>, where the callee can be identified at compile time.
11690
11691 C<protosv> supplies the subroutine prototype to be applied to the call,
11692 or indicates that there is no prototype.  It may be a normal scalar,
11693 in which case if it is defined then the string value will be used
11694 as a prototype, and if it is undefined then there is no prototype.
11695 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11696 that has been cast to C<SV*>), of which the prototype will be used if it
11697 has one.  The prototype (or lack thereof) supplied, in whichever form,
11698 does not need to match the actual callee referenced by the op tree.
11699
11700 If the argument ops disagree with the prototype, for example by having
11701 an unacceptable number of arguments, a valid op tree is returned anyway.
11702 The error is reflected in the parser state, normally resulting in a single
11703 exception at the top level of parsing which covers all the compilation
11704 errors that occurred.  In the error message, the callee is referred to
11705 by the name defined by the C<namegv> parameter.
11706
11707 =cut
11708 */
11709
11710 OP *
11711 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11712         GV *namegv, SV *protosv)
11713 {
11714     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11715     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11716         return ck_entersub_args_proto(entersubop, namegv, protosv);
11717     else
11718         return ck_entersub_args_list(entersubop);
11719 }
11720
11721 OP *
11722 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11723 {
11724     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11725     OP *aop = cUNOPx(entersubop)->op_first;
11726
11727     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11728
11729     if (!opnum) {
11730         OP *cvop;
11731         if (!OpHAS_SIBLING(aop))
11732             aop = cUNOPx(aop)->op_first;
11733         aop = OpSIBLING(aop);
11734         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11735         if (aop != cvop)
11736             (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11737
11738         op_free(entersubop);
11739         switch(GvNAME(namegv)[2]) {
11740         case 'F': return newSVOP(OP_CONST, 0,
11741                                         newSVpv(CopFILE(PL_curcop),0));
11742         case 'L': return newSVOP(
11743                            OP_CONST, 0,
11744                            Perl_newSVpvf(aTHX_
11745                              "%" IVdf, (IV)CopLINE(PL_curcop)
11746                            )
11747                          );
11748         case 'P': return newSVOP(OP_CONST, 0,
11749                                    (PL_curstash
11750                                      ? newSVhek(HvNAME_HEK(PL_curstash))
11751                                      : &PL_sv_undef
11752                                    )
11753                                 );
11754         }
11755         NOT_REACHED; /* NOTREACHED */
11756     }
11757     else {
11758         OP *prev, *cvop, *first, *parent;
11759         U32 flags = 0;
11760
11761         parent = entersubop;
11762         if (!OpHAS_SIBLING(aop)) {
11763             parent = aop;
11764             aop = cUNOPx(aop)->op_first;
11765         }
11766
11767         first = prev = aop;
11768         aop = OpSIBLING(aop);
11769         /* find last sibling */
11770         for (cvop = aop;
11771              OpHAS_SIBLING(cvop);
11772              prev = cvop, cvop = OpSIBLING(cvop))
11773             ;
11774         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11775             /* Usually, OPf_SPECIAL on an op with no args means that it had
11776              * parens, but these have their own meaning for that flag: */
11777             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11778             && opnum != OP_DELETE && opnum != OP_EXISTS)
11779                 flags |= OPf_SPECIAL;
11780         /* excise cvop from end of sibling chain */
11781         op_sibling_splice(parent, prev, 1, NULL);
11782         op_free(cvop);
11783         if (aop == cvop) aop = NULL;
11784
11785         /* detach remaining siblings from the first sibling, then
11786          * dispose of original optree */
11787
11788         if (aop)
11789             op_sibling_splice(parent, first, -1, NULL);
11790         op_free(entersubop);
11791
11792         if (opnum == OP_ENTEREVAL
11793          && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11794             flags |= OPpEVAL_BYTES <<8;
11795
11796         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11797         case OA_UNOP:
11798         case OA_BASEOP_OR_UNOP:
11799         case OA_FILESTATOP:
11800             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11801         case OA_BASEOP:
11802             if (aop) {
11803                     (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11804                 op_free(aop);
11805             }
11806             return opnum == OP_RUNCV
11807                 ? newPVOP(OP_RUNCV,0,NULL)
11808                 : newOP(opnum,0);
11809         default:
11810             return op_convert_list(opnum,0,aop);
11811         }
11812     }
11813     NOT_REACHED; /* NOTREACHED */
11814     return entersubop;
11815 }
11816
11817 /*
11818 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11819
11820 Retrieves the function that will be used to fix up a call to C<cv>.
11821 Specifically, the function is applied to an C<entersub> op tree for a
11822 subroutine call, not marked with C<&>, where the callee can be identified
11823 at compile time as C<cv>.
11824
11825 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11826 argument for it is returned in C<*ckobj_p>.  The function is intended
11827 to be called in this manner:
11828
11829  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11830
11831 In this call, C<entersubop> is a pointer to the C<entersub> op,
11832 which may be replaced by the check function, and C<namegv> is a GV
11833 supplying the name that should be used by the check function to refer
11834 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11835 It is permitted to apply the check function in non-standard situations,
11836 such as to a call to a different subroutine or to a method call.
11837
11838 By default, the function is
11839 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11840 and the SV parameter is C<cv> itself.  This implements standard
11841 prototype processing.  It can be changed, for a particular subroutine,
11842 by L</cv_set_call_checker>.
11843
11844 =cut
11845 */
11846
11847 static void
11848 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11849                       U8 *flagsp)
11850 {
11851     MAGIC *callmg;
11852     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11853     if (callmg) {
11854         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11855         *ckobj_p = callmg->mg_obj;
11856         if (flagsp) *flagsp = callmg->mg_flags;
11857     } else {
11858         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11859         *ckobj_p = (SV*)cv;
11860         if (flagsp) *flagsp = 0;
11861     }
11862 }
11863
11864 void
11865 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11866 {
11867     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11868     PERL_UNUSED_CONTEXT;
11869     S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11870 }
11871
11872 /*
11873 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11874
11875 Sets the function that will be used to fix up a call to C<cv>.
11876 Specifically, the function is applied to an C<entersub> op tree for a
11877 subroutine call, not marked with C<&>, where the callee can be identified
11878 at compile time as C<cv>.
11879
11880 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11881 for it is supplied in C<ckobj>.  The function should be defined like this:
11882
11883     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11884
11885 It is intended to be called in this manner:
11886
11887     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11888
11889 In this call, C<entersubop> is a pointer to the C<entersub> op,
11890 which may be replaced by the check function, and C<namegv> supplies
11891 the name that should be used by the check function to refer
11892 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11893 It is permitted to apply the check function in non-standard situations,
11894 such as to a call to a different subroutine or to a method call.
11895
11896 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
11897 CV or other SV instead.  Whatever is passed can be used as the first
11898 argument to L</cv_name>.  You can force perl to pass a GV by including
11899 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11900
11901 The current setting for a particular CV can be retrieved by
11902 L</cv_get_call_checker>.
11903
11904 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11905
11906 The original form of L</cv_set_call_checker_flags>, which passes it the
11907 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11908
11909 =cut
11910 */
11911
11912 void
11913 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11914 {
11915     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11916     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11917 }
11918
11919 void
11920 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11921                                      SV *ckobj, U32 flags)
11922 {
11923     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11924     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11925         if (SvMAGICAL((SV*)cv))
11926             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11927     } else {
11928         MAGIC *callmg;
11929         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11930         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11931         assert(callmg);
11932         if (callmg->mg_flags & MGf_REFCOUNTED) {
11933             SvREFCNT_dec(callmg->mg_obj);
11934             callmg->mg_flags &= ~MGf_REFCOUNTED;
11935         }
11936         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11937         callmg->mg_obj = ckobj;
11938         if (ckobj != (SV*)cv) {
11939             SvREFCNT_inc_simple_void_NN(ckobj);
11940             callmg->mg_flags |= MGf_REFCOUNTED;
11941         }
11942         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11943                          | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11944     }
11945 }
11946
11947 static void
11948 S_entersub_alloc_targ(pTHX_ OP * const o)
11949 {
11950     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11951     o->op_private |= OPpENTERSUB_HASTARG;
11952 }
11953
11954 OP *
11955 Perl_ck_subr(pTHX_ OP *o)
11956 {
11957     OP *aop, *cvop;
11958     CV *cv;
11959     GV *namegv;
11960     SV **const_class = NULL;
11961
11962     PERL_ARGS_ASSERT_CK_SUBR;
11963
11964     aop = cUNOPx(o)->op_first;
11965     if (!OpHAS_SIBLING(aop))
11966         aop = cUNOPx(aop)->op_first;
11967     aop = OpSIBLING(aop);
11968     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11969     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11970     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11971
11972     o->op_private &= ~1;
11973     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11974     if (PERLDB_SUB && PL_curstash != PL_debstash)
11975         o->op_private |= OPpENTERSUB_DB;
11976     switch (cvop->op_type) {
11977         case OP_RV2CV:
11978             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11979             op_null(cvop);
11980             break;
11981         case OP_METHOD:
11982         case OP_METHOD_NAMED:
11983         case OP_METHOD_SUPER:
11984         case OP_METHOD_REDIR:
11985         case OP_METHOD_REDIR_SUPER:
11986             o->op_flags |= OPf_REF;
11987             if (aop->op_type == OP_CONST) {
11988                 aop->op_private &= ~OPpCONST_STRICT;
11989                 const_class = &cSVOPx(aop)->op_sv;
11990             }
11991             else if (aop->op_type == OP_LIST) {
11992                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11993                 if (sib && sib->op_type == OP_CONST) {
11994                     sib->op_private &= ~OPpCONST_STRICT;
11995                     const_class = &cSVOPx(sib)->op_sv;
11996                 }
11997             }
11998             /* make class name a shared cow string to speedup method calls */
11999             /* constant string might be replaced with object, f.e. bigint */
12000             if (const_class && SvPOK(*const_class)) {
12001                 STRLEN len;
12002                 const char* str = SvPV(*const_class, len);
12003                 if (len) {
12004                     SV* const shared = newSVpvn_share(
12005                         str, SvUTF8(*const_class)
12006                                     ? -(SSize_t)len : (SSize_t)len,
12007                         0
12008                     );
12009                     if (SvREADONLY(*const_class))
12010                         SvREADONLY_on(shared);
12011                     SvREFCNT_dec(*const_class);
12012                     *const_class = shared;
12013                 }
12014             }
12015             break;
12016     }
12017
12018     if (!cv) {
12019         S_entersub_alloc_targ(aTHX_ o);
12020         return ck_entersub_args_list(o);
12021     } else {
12022         Perl_call_checker ckfun;
12023         SV *ckobj;
12024         U8 flags;
12025         S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
12026         if (CvISXSUB(cv) || !CvROOT(cv))
12027             S_entersub_alloc_targ(aTHX_ o);
12028         if (!namegv) {
12029             /* The original call checker API guarantees that a GV will be
12030                be provided with the right name.  So, if the old API was
12031                used (or the REQUIRE_GV flag was passed), we have to reify
12032                the CV’s GV, unless this is an anonymous sub.  This is not
12033                ideal for lexical subs, as its stringification will include
12034                the package.  But it is the best we can do.  */
12035             if (flags & MGf_REQUIRE_GV) {
12036                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12037                     namegv = CvGV(cv);
12038             }
12039             else namegv = MUTABLE_GV(cv);
12040             /* After a syntax error in a lexical sub, the cv that
12041                rv2cv_op_cv returns may be a nameless stub. */
12042             if (!namegv) return ck_entersub_args_list(o);
12043
12044         }
12045         return ckfun(aTHX_ o, namegv, ckobj);
12046     }
12047 }
12048
12049 OP *
12050 Perl_ck_svconst(pTHX_ OP *o)
12051 {
12052     SV * const sv = cSVOPo->op_sv;
12053     PERL_ARGS_ASSERT_CK_SVCONST;
12054     PERL_UNUSED_CONTEXT;
12055 #ifdef PERL_COPY_ON_WRITE
12056     /* Since the read-only flag may be used to protect a string buffer, we
12057        cannot do copy-on-write with existing read-only scalars that are not
12058        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
12059        that constant, mark the constant as COWable here, if it is not
12060        already read-only. */
12061     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12062         SvIsCOW_on(sv);
12063         CowREFCNT(sv) = 0;
12064 # ifdef PERL_DEBUG_READONLY_COW
12065         sv_buf_to_ro(sv);
12066 # endif
12067     }
12068 #endif
12069     SvREADONLY_on(sv);
12070     return o;
12071 }
12072
12073 OP *
12074 Perl_ck_trunc(pTHX_ OP *o)
12075 {
12076     PERL_ARGS_ASSERT_CK_TRUNC;
12077
12078     if (o->op_flags & OPf_KIDS) {
12079         SVOP *kid = (SVOP*)cUNOPo->op_first;
12080
12081         if (kid->op_type == OP_NULL)
12082             kid = (SVOP*)OpSIBLING(kid);
12083         if (kid && kid->op_type == OP_CONST &&
12084             (kid->op_private & OPpCONST_BARE) &&
12085             !kid->op_folded)
12086         {
12087             o->op_flags |= OPf_SPECIAL;
12088             kid->op_private &= ~OPpCONST_STRICT;
12089         }
12090     }
12091     return ck_fun(o);
12092 }
12093
12094 OP *
12095 Perl_ck_substr(pTHX_ OP *o)
12096 {
12097     PERL_ARGS_ASSERT_CK_SUBSTR;
12098
12099     o = ck_fun(o);
12100     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12101         OP *kid = cLISTOPo->op_first;
12102
12103         if (kid->op_type == OP_NULL)
12104             kid = OpSIBLING(kid);
12105         if (kid)
12106             kid->op_flags |= OPf_MOD;
12107
12108     }
12109     return o;
12110 }
12111
12112 OP *
12113 Perl_ck_tell(pTHX_ OP *o)
12114 {
12115     PERL_ARGS_ASSERT_CK_TELL;
12116     o = ck_fun(o);
12117     if (o->op_flags & OPf_KIDS) {
12118      OP *kid = cLISTOPo->op_first;
12119      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12120      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12121     }
12122     return o;
12123 }
12124
12125 OP *
12126 Perl_ck_each(pTHX_ OP *o)
12127 {
12128     dVAR;
12129     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12130     const unsigned orig_type  = o->op_type;
12131
12132     PERL_ARGS_ASSERT_CK_EACH;
12133
12134     if (kid) {
12135         switch (kid->op_type) {
12136             case OP_PADHV:
12137             case OP_RV2HV:
12138                 break;
12139             case OP_PADAV:
12140             case OP_RV2AV:
12141                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12142                             : orig_type == OP_KEYS ? OP_AKEYS
12143                             :                        OP_AVALUES);
12144                 break;
12145             case OP_CONST:
12146                 if (kid->op_private == OPpCONST_BARE
12147                  || !SvROK(cSVOPx_sv(kid))
12148                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12149                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
12150                    )
12151                     goto bad;
12152                 /* FALLTHROUGH */
12153             default:
12154                 qerror(Perl_mess(aTHX_
12155                     "Experimental %s on scalar is now forbidden",
12156                      PL_op_desc[orig_type]));
12157                bad:
12158                 bad_type_pv(1, "hash or array", o, kid);
12159                 return o;
12160         }
12161     }
12162     return ck_fun(o);
12163 }
12164
12165 OP *
12166 Perl_ck_length(pTHX_ OP *o)
12167 {
12168     PERL_ARGS_ASSERT_CK_LENGTH;
12169
12170     o = ck_fun(o);
12171
12172     if (ckWARN(WARN_SYNTAX)) {
12173         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12174
12175         if (kid) {
12176             SV *name = NULL;
12177             const bool hash = kid->op_type == OP_PADHV
12178                            || kid->op_type == OP_RV2HV;
12179             switch (kid->op_type) {
12180                 case OP_PADHV:
12181                 case OP_PADAV:
12182                 case OP_RV2HV:
12183                 case OP_RV2AV:
12184                     name = S_op_varname(aTHX_ kid);
12185                     break;
12186                 default:
12187                     return o;
12188             }
12189             if (name)
12190                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12191                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
12192                     ")\"?)",
12193                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
12194                 );
12195             else if (hash)
12196      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12197                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12198                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12199             else
12200      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12201                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12202                     "length() used on @array (did you mean \"scalar(@array)\"?)");
12203         }
12204     }
12205
12206     return o;
12207 }
12208
12209
12210
12211 /*
12212    ---------------------------------------------------------
12213
12214    Common vars in list assignment
12215
12216    There now follows some enums and static functions for detecting
12217    common variables in list assignments. Here is a little essay I wrote
12218    for myself when trying to get my head around this. DAPM.
12219
12220    ----
12221
12222    First some random observations:
12223
12224    * If a lexical var is an alias of something else, e.g.
12225        for my $x ($lex, $pkg, $a[0]) {...}
12226      then the act of aliasing will increase the reference count of the SV
12227
12228    * If a package var is an alias of something else, it may still have a
12229      reference count of 1, depending on how the alias was created, e.g.
12230      in *a = *b, $a may have a refcount of 1 since the GP is shared
12231      with a single GvSV pointer to the SV. So If it's an alias of another
12232      package var, then RC may be 1; if it's an alias of another scalar, e.g.
12233      a lexical var or an array element, then it will have RC > 1.
12234
12235    * There are many ways to create a package alias; ultimately, XS code
12236      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12237      run-time tracing mechanisms are unlikely to be able to catch all cases.
12238
12239    * When the LHS is all my declarations, the same vars can't appear directly
12240      on the RHS, but they can indirectly via closures, aliasing and lvalue
12241      subs. But those techniques all involve an increase in the lexical
12242      scalar's ref count.
12243
12244    * When the LHS is all lexical vars (but not necessarily my declarations),
12245      it is possible for the same lexicals to appear directly on the RHS, and
12246      without an increased ref count, since the stack isn't refcounted.
12247      This case can be detected at compile time by scanning for common lex
12248      vars with PL_generation.
12249
12250    * lvalue subs defeat common var detection, but they do at least
12251      return vars with a temporary ref count increment. Also, you can't
12252      tell at compile time whether a sub call is lvalue.
12253
12254
12255    So...
12256
12257    A: There are a few circumstances where there definitely can't be any
12258      commonality:
12259
12260        LHS empty:  () = (...);
12261        RHS empty:  (....) = ();
12262        RHS contains only constants or other 'can't possibly be shared'
12263            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
12264            i.e. they only contain ops not marked as dangerous, whose children
12265            are also not dangerous;
12266        LHS ditto;
12267        LHS contains a single scalar element: e.g. ($x) = (....); because
12268            after $x has been modified, it won't be used again on the RHS;
12269        RHS contains a single element with no aggregate on LHS: e.g.
12270            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
12271            won't be used again.
12272
12273    B: If LHS are all 'my' lexical var declarations (or safe ops, which
12274      we can ignore):
12275
12276        my ($a, $b, @c) = ...;
12277
12278        Due to closure and goto tricks, these vars may already have content.
12279        For the same reason, an element on the RHS may be a lexical or package
12280        alias of one of the vars on the left, or share common elements, for
12281        example:
12282
12283            my ($x,$y) = f(); # $x and $y on both sides
12284            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12285
12286        and
12287
12288            my $ra = f();
12289            my @a = @$ra;  # elements of @a on both sides
12290            sub f { @a = 1..4; \@a }
12291
12292
12293        First, just consider scalar vars on LHS:
12294
12295            RHS is safe only if (A), or in addition,
12296                * contains only lexical *scalar* vars, where neither side's
12297                  lexicals have been flagged as aliases
12298
12299            If RHS is not safe, then it's always legal to check LHS vars for
12300            RC==1, since the only RHS aliases will always be associated
12301            with an RC bump.
12302
12303            Note that in particular, RHS is not safe if:
12304
12305                * it contains package scalar vars; e.g.:
12306
12307                    f();
12308                    my ($x, $y) = (2, $x_alias);
12309                    sub f { $x = 1; *x_alias = \$x; }
12310
12311                * It contains other general elements, such as flattened or
12312                * spliced or single array or hash elements, e.g.
12313
12314                    f();
12315                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12316
12317                    sub f {
12318                        ($x, $y) = (1,2);
12319                        use feature 'refaliasing';
12320                        \($a[0], $a[1]) = \($y,$x);
12321                    }
12322
12323                  It doesn't matter if the array/hash is lexical or package.
12324
12325                * it contains a function call that happens to be an lvalue
12326                  sub which returns one or more of the above, e.g.
12327
12328                    f();
12329                    my ($x,$y) = f();
12330
12331                    sub f : lvalue {
12332                        ($x, $y) = (1,2);
12333                        *x1 = \$x;
12334                        $y, $x1;
12335                    }
12336
12337                    (so a sub call on the RHS should be treated the same
12338                    as having a package var on the RHS).
12339
12340                * any other "dangerous" thing, such an op or built-in that
12341                  returns one of the above, e.g. pp_preinc
12342
12343
12344            If RHS is not safe, what we can do however is at compile time flag
12345            that the LHS are all my declarations, and at run time check whether
12346            all the LHS have RC == 1, and if so skip the full scan.
12347
12348        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12349
12350            Here the issue is whether there can be elements of @a on the RHS
12351            which will get prematurely freed when @a is cleared prior to
12352            assignment. This is only a problem if the aliasing mechanism
12353            is one which doesn't increase the refcount - only if RC == 1
12354            will the RHS element be prematurely freed.
12355
12356            Because the array/hash is being INTROed, it or its elements
12357            can't directly appear on the RHS:
12358
12359                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12360
12361            but can indirectly, e.g.:
12362
12363                my $r = f();
12364                my (@a) = @$r;
12365                sub f { @a = 1..3; \@a }
12366
12367            So if the RHS isn't safe as defined by (A), we must always
12368            mortalise and bump the ref count of any remaining RHS elements
12369            when assigning to a non-empty LHS aggregate.
12370
12371            Lexical scalars on the RHS aren't safe if they've been involved in
12372            aliasing, e.g.
12373
12374                use feature 'refaliasing';
12375
12376                f();
12377                \(my $lex) = \$pkg;
12378                my @a = ($lex,3); # equivalent to ($a[0],3)
12379
12380                sub f {
12381                    @a = (1,2);
12382                    \$pkg = \$a[0];
12383                }
12384
12385            Similarly with lexical arrays and hashes on the RHS:
12386
12387                f();
12388                my @b;
12389                my @a = (@b);
12390
12391                sub f {
12392                    @a = (1,2);
12393                    \$b[0] = \$a[1];
12394                    \$b[1] = \$a[0];
12395                }
12396
12397
12398
12399    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12400        my $a; ($a, my $b) = (....);
12401
12402        The difference between (B) and (C) is that it is now physically
12403        possible for the LHS vars to appear on the RHS too, where they
12404        are not reference counted; but in this case, the compile-time
12405        PL_generation sweep will detect such common vars.
12406
12407        So the rules for (C) differ from (B) in that if common vars are
12408        detected, the runtime "test RC==1" optimisation can no longer be used,
12409        and a full mark and sweep is required
12410
12411    D: As (C), but in addition the LHS may contain package vars.
12412
12413        Since package vars can be aliased without a corresponding refcount
12414        increase, all bets are off. It's only safe if (A). E.g.
12415
12416            my ($x, $y) = (1,2);
12417
12418            for $x_alias ($x) {
12419                ($x_alias, $y) = (3, $x); # whoops
12420            }
12421
12422        Ditto for LHS aggregate package vars.
12423
12424    E: Any other dangerous ops on LHS, e.g.
12425            (f(), $a[0], @$r) = (...);
12426
12427        this is similar to (E) in that all bets are off. In addition, it's
12428        impossible to determine at compile time whether the LHS
12429        contains a scalar or an aggregate, e.g.
12430
12431            sub f : lvalue { @a }
12432            (f()) = 1..3;
12433
12434 * ---------------------------------------------------------
12435 */
12436
12437
12438 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12439  * that at least one of the things flagged was seen.
12440  */
12441
12442 enum {
12443     AAS_MY_SCALAR       = 0x001, /* my $scalar */
12444     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
12445     AAS_LEX_SCALAR      = 0x004, /* $lexical */
12446     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
12447     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12448     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
12449     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
12450     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
12451                                          that's flagged OA_DANGEROUS */
12452     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
12453                                         not in any of the categories above */
12454     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
12455 };
12456
12457
12458
12459 /* helper function for S_aassign_scan().
12460  * check a PAD-related op for commonality and/or set its generation number.
12461  * Returns a boolean indicating whether its shared */
12462
12463 static bool
12464 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12465 {
12466     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12467         /* lexical used in aliasing */
12468         return TRUE;
12469
12470     if (rhs)
12471         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12472     else
12473         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12474
12475     return FALSE;
12476 }
12477
12478
12479 /*
12480   Helper function for OPpASSIGN_COMMON* detection in rpeep().
12481   It scans the left or right hand subtree of the aassign op, and returns a
12482   set of flags indicating what sorts of things it found there.
12483   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12484   set PL_generation on lexical vars; if the latter, we see if
12485   PL_generation matches.
12486   'top' indicates whether we're recursing or at the top level.
12487   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12488   This fn will increment it by the number seen. It's not intended to
12489   be an accurate count (especially as many ops can push a variable
12490   number of SVs onto the stack); rather it's used as to test whether there
12491   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12492 */
12493
12494 static int
12495 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12496 {
12497     int flags = 0;
12498     bool kid_top = FALSE;
12499
12500     /* first, look for a solitary @_ on the RHS */
12501     if (   rhs
12502         && top
12503         && (o->op_flags & OPf_KIDS)
12504         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12505     ) {
12506         OP *kid = cUNOPo->op_first;
12507         if (   (   kid->op_type == OP_PUSHMARK
12508                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12509             && ((kid = OpSIBLING(kid)))
12510             && !OpHAS_SIBLING(kid)
12511             && kid->op_type == OP_RV2AV
12512             && !(kid->op_flags & OPf_REF)
12513             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12514             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12515             && ((kid = cUNOPx(kid)->op_first))
12516             && kid->op_type == OP_GV
12517             && cGVOPx_gv(kid) == PL_defgv
12518         )
12519             flags |= AAS_DEFAV;
12520     }
12521
12522     switch (o->op_type) {
12523     case OP_GVSV:
12524         (*scalars_p)++;
12525         return AAS_PKG_SCALAR;
12526
12527     case OP_PADAV:
12528     case OP_PADHV:
12529         (*scalars_p) += 2;
12530         /* if !top, could be e.g. @a[0,1] */
12531         if (top && (o->op_flags & OPf_REF))
12532             return (o->op_private & OPpLVAL_INTRO)
12533                 ? AAS_MY_AGG : AAS_LEX_AGG;
12534         return AAS_DANGEROUS;
12535
12536     case OP_PADSV:
12537         {
12538             int comm = S_aassign_padcheck(aTHX_ o, rhs)
12539                         ?  AAS_LEX_SCALAR_COMM : 0;
12540             (*scalars_p)++;
12541             return (o->op_private & OPpLVAL_INTRO)
12542                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12543         }
12544
12545     case OP_RV2AV:
12546     case OP_RV2HV:
12547         (*scalars_p) += 2;
12548         if (cUNOPx(o)->op_first->op_type != OP_GV)
12549             return AAS_DANGEROUS; /* @{expr}, %{expr} */
12550         /* @pkg, %pkg */
12551         /* if !top, could be e.g. @a[0,1] */
12552         if (top && (o->op_flags & OPf_REF))
12553             return AAS_PKG_AGG;
12554         return AAS_DANGEROUS;
12555
12556     case OP_RV2SV:
12557         (*scalars_p)++;
12558         if (cUNOPx(o)->op_first->op_type != OP_GV) {
12559             (*scalars_p) += 2;
12560             return AAS_DANGEROUS; /* ${expr} */
12561         }
12562         return AAS_PKG_SCALAR; /* $pkg */
12563
12564     case OP_SPLIT:
12565         if (o->op_private & OPpSPLIT_ASSIGN) {
12566             /* the assign in @a = split() has been optimised away
12567              * and the @a attached directly to the split op
12568              * Treat the array as appearing on the RHS, i.e.
12569              *    ... = (@a = split)
12570              * is treated like
12571              *    ... = @a;
12572              */
12573
12574             if (o->op_flags & OPf_STACKED)
12575                 /* @{expr} = split() - the array expression is tacked
12576                  * on as an extra child to split - process kid */
12577                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12578                                         top, scalars_p);
12579
12580             /* ... else array is directly attached to split op */
12581             (*scalars_p) += 2;
12582             if (PL_op->op_private & OPpSPLIT_LEX)
12583                 return (o->op_private & OPpLVAL_INTRO)
12584                     ? AAS_MY_AGG : AAS_LEX_AGG;
12585             else
12586                 return AAS_PKG_AGG;
12587         }
12588         (*scalars_p)++;
12589         /* other args of split can't be returned */
12590         return AAS_SAFE_SCALAR;
12591
12592     case OP_UNDEF:
12593         /* undef counts as a scalar on the RHS:
12594          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
12595          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
12596          */
12597         if (rhs)
12598             (*scalars_p)++;
12599         flags = AAS_SAFE_SCALAR;
12600         break;
12601
12602     case OP_PUSHMARK:
12603     case OP_STUB:
12604         /* these are all no-ops; they don't push a potentially common SV
12605          * onto the stack, so they are neither AAS_DANGEROUS nor
12606          * AAS_SAFE_SCALAR */
12607         return 0;
12608
12609     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12610         break;
12611
12612     case OP_NULL:
12613     case OP_LIST:
12614         /* these do nothing but may have children; but their children
12615          * should also be treated as top-level */
12616         kid_top = top;
12617         break;
12618
12619     default:
12620         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12621             (*scalars_p) += 2;
12622             flags = AAS_DANGEROUS;
12623             break;
12624         }
12625
12626         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
12627             && (o->op_private & OPpTARGET_MY))
12628         {
12629             (*scalars_p)++;
12630             return S_aassign_padcheck(aTHX_ o, rhs)
12631                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12632         }
12633
12634         /* if its an unrecognised, non-dangerous op, assume that it
12635          * it the cause of at least one safe scalar */
12636         (*scalars_p)++;
12637         flags = AAS_SAFE_SCALAR;
12638         break;
12639     }
12640
12641     /* XXX this assumes that all other ops are "transparent" - i.e. that
12642      * they can return some of their children. While this true for e.g.
12643      * sort and grep, it's not true for e.g. map. We really need a
12644      * 'transparent' flag added to regen/opcodes
12645      */
12646     if (o->op_flags & OPf_KIDS) {
12647         OP *kid;
12648         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12649             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12650     }
12651     return flags;
12652 }
12653
12654
12655 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12656    and modify the optree to make them work inplace */
12657
12658 STATIC void
12659 S_inplace_aassign(pTHX_ OP *o) {
12660
12661     OP *modop, *modop_pushmark;
12662     OP *oright;
12663     OP *oleft, *oleft_pushmark;
12664
12665     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12666
12667     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12668
12669     assert(cUNOPo->op_first->op_type == OP_NULL);
12670     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12671     assert(modop_pushmark->op_type == OP_PUSHMARK);
12672     modop = OpSIBLING(modop_pushmark);
12673
12674     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12675         return;
12676
12677     /* no other operation except sort/reverse */
12678     if (OpHAS_SIBLING(modop))
12679         return;
12680
12681     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12682     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12683
12684     if (modop->op_flags & OPf_STACKED) {
12685         /* skip sort subroutine/block */
12686         assert(oright->op_type == OP_NULL);
12687         oright = OpSIBLING(oright);
12688     }
12689
12690     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12691     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12692     assert(oleft_pushmark->op_type == OP_PUSHMARK);
12693     oleft = OpSIBLING(oleft_pushmark);
12694
12695     /* Check the lhs is an array */
12696     if (!oleft ||
12697         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12698         || OpHAS_SIBLING(oleft)
12699         || (oleft->op_private & OPpLVAL_INTRO)
12700     )
12701         return;
12702
12703     /* Only one thing on the rhs */
12704     if (OpHAS_SIBLING(oright))
12705         return;
12706
12707     /* check the array is the same on both sides */
12708     if (oleft->op_type == OP_RV2AV) {
12709         if (oright->op_type != OP_RV2AV
12710             || !cUNOPx(oright)->op_first
12711             || cUNOPx(oright)->op_first->op_type != OP_GV
12712             || cUNOPx(oleft )->op_first->op_type != OP_GV
12713             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12714                cGVOPx_gv(cUNOPx(oright)->op_first)
12715         )
12716             return;
12717     }
12718     else if (oright->op_type != OP_PADAV
12719         || oright->op_targ != oleft->op_targ
12720     )
12721         return;
12722
12723     /* This actually is an inplace assignment */
12724
12725     modop->op_private |= OPpSORT_INPLACE;
12726
12727     /* transfer MODishness etc from LHS arg to RHS arg */
12728     oright->op_flags = oleft->op_flags;
12729
12730     /* remove the aassign op and the lhs */
12731     op_null(o);
12732     op_null(oleft_pushmark);
12733     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12734         op_null(cUNOPx(oleft)->op_first);
12735     op_null(oleft);
12736 }
12737
12738
12739
12740 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12741  * that potentially represent a series of one or more aggregate derefs
12742  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12743  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12744  * additional ops left in too).
12745  *
12746  * The caller will have already verified that the first few ops in the
12747  * chain following 'start' indicate a multideref candidate, and will have
12748  * set 'orig_o' to the point further on in the chain where the first index
12749  * expression (if any) begins.  'orig_action' specifies what type of
12750  * beginning has already been determined by the ops between start..orig_o
12751  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
12752  *
12753  * 'hints' contains any hints flags that need adding (currently just
12754  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12755  */
12756
12757 STATIC void
12758 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12759 {
12760     dVAR;
12761     int pass;
12762     UNOP_AUX_item *arg_buf = NULL;
12763     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
12764     int index_skip         = -1;    /* don't output index arg on this action */
12765
12766     /* similar to regex compiling, do two passes; the first pass
12767      * determines whether the op chain is convertible and calculates the
12768      * buffer size; the second pass populates the buffer and makes any
12769      * changes necessary to ops (such as moving consts to the pad on
12770      * threaded builds).
12771      *
12772      * NB: for things like Coverity, note that both passes take the same
12773      * path through the logic tree (except for 'if (pass)' bits), since
12774      * both passes are following the same op_next chain; and in
12775      * particular, if it would return early on the second pass, it would
12776      * already have returned early on the first pass.
12777      */
12778     for (pass = 0; pass < 2; pass++) {
12779         OP *o                = orig_o;
12780         UV action            = orig_action;
12781         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
12782         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
12783         int action_count     = 0;     /* number of actions seen so far */
12784         int action_ix        = 0;     /* action_count % (actions per IV) */
12785         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
12786         bool is_last         = FALSE; /* no more derefs to follow */
12787         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12788         UNOP_AUX_item *arg     = arg_buf;
12789         UNOP_AUX_item *action_ptr = arg_buf;
12790
12791         if (pass)
12792             action_ptr->uv = 0;
12793         arg++;
12794
12795         switch (action) {
12796         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12797         case MDEREF_HV_gvhv_helem:
12798             next_is_hash = TRUE;
12799             /* FALLTHROUGH */
12800         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12801         case MDEREF_AV_gvav_aelem:
12802             if (pass) {
12803 #ifdef USE_ITHREADS
12804                 arg->pad_offset = cPADOPx(start)->op_padix;
12805                 /* stop it being swiped when nulled */
12806                 cPADOPx(start)->op_padix = 0;
12807 #else
12808                 arg->sv = cSVOPx(start)->op_sv;
12809                 cSVOPx(start)->op_sv = NULL;
12810 #endif
12811             }
12812             arg++;
12813             break;
12814
12815         case MDEREF_HV_padhv_helem:
12816         case MDEREF_HV_padsv_vivify_rv2hv_helem:
12817             next_is_hash = TRUE;
12818             /* FALLTHROUGH */
12819         case MDEREF_AV_padav_aelem:
12820         case MDEREF_AV_padsv_vivify_rv2av_aelem:
12821             if (pass) {
12822                 arg->pad_offset = start->op_targ;
12823                 /* we skip setting op_targ = 0 for now, since the intact
12824                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12825                 reset_start_targ = TRUE;
12826             }
12827             arg++;
12828             break;
12829
12830         case MDEREF_HV_pop_rv2hv_helem:
12831             next_is_hash = TRUE;
12832             /* FALLTHROUGH */
12833         case MDEREF_AV_pop_rv2av_aelem:
12834             break;
12835
12836         default:
12837             NOT_REACHED; /* NOTREACHED */
12838             return;
12839         }
12840
12841         while (!is_last) {
12842             /* look for another (rv2av/hv; get index;
12843              * aelem/helem/exists/delele) sequence */
12844
12845             OP *kid;
12846             bool is_deref;
12847             bool ok;
12848             UV index_type = MDEREF_INDEX_none;
12849
12850             if (action_count) {
12851                 /* if this is not the first lookup, consume the rv2av/hv  */
12852
12853                 /* for N levels of aggregate lookup, we normally expect
12854                  * that the first N-1 [ah]elem ops will be flagged as
12855                  * /DEREF (so they autovivifiy if necessary), and the last
12856                  * lookup op not to be.
12857                  * For other things (like @{$h{k1}{k2}}) extra scope or
12858                  * leave ops can appear, so abandon the effort in that
12859                  * case */
12860                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12861                     return;
12862
12863                 /* rv2av or rv2hv sKR/1 */
12864
12865                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12866                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12867                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12868                     return;
12869
12870                 /* at this point, we wouldn't expect any of these
12871                  * possible private flags:
12872                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12873                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12874                  */
12875                 ASSUME(!(o->op_private &
12876                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12877
12878                 hints = (o->op_private & OPpHINT_STRICT_REFS);
12879
12880                 /* make sure the type of the previous /DEREF matches the
12881                  * type of the next lookup */
12882                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12883                 top_op = o;
12884
12885                 action = next_is_hash
12886                             ? MDEREF_HV_vivify_rv2hv_helem
12887                             : MDEREF_AV_vivify_rv2av_aelem;
12888                 o = o->op_next;
12889             }
12890
12891             /* if this is the second pass, and we're at the depth where
12892              * previously we encountered a non-simple index expression,
12893              * stop processing the index at this point */
12894             if (action_count != index_skip) {
12895
12896                 /* look for one or more simple ops that return an array
12897                  * index or hash key */
12898
12899                 switch (o->op_type) {
12900                 case OP_PADSV:
12901                     /* it may be a lexical var index */
12902                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12903                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12904                     ASSUME(!(o->op_private &
12905                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12906
12907                     if (   OP_GIMME(o,0) == G_SCALAR
12908                         && !(o->op_flags & (OPf_REF|OPf_MOD))
12909                         && o->op_private == 0)
12910                     {
12911                         if (pass)
12912                             arg->pad_offset = o->op_targ;
12913                         arg++;
12914                         index_type = MDEREF_INDEX_padsv;
12915                         o = o->op_next;
12916                     }
12917                     break;
12918
12919                 case OP_CONST:
12920                     if (next_is_hash) {
12921                         /* it's a constant hash index */
12922                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12923                             /* "use constant foo => FOO; $h{+foo}" for
12924                              * some weird FOO, can leave you with constants
12925                              * that aren't simple strings. It's not worth
12926                              * the extra hassle for those edge cases */
12927                             break;
12928
12929                         if (pass) {
12930                             UNOP *rop = NULL;
12931                             OP * helem_op = o->op_next;
12932
12933                             ASSUME(   helem_op->op_type == OP_HELEM
12934                                    || helem_op->op_type == OP_NULL);
12935                             if (helem_op->op_type == OP_HELEM) {
12936                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12937                                 if (   helem_op->op_private & OPpLVAL_INTRO
12938                                     || rop->op_type != OP_RV2HV
12939                                 )
12940                                     rop = NULL;
12941                             }
12942                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12943
12944 #ifdef USE_ITHREADS
12945                             /* Relocate sv to the pad for thread safety */
12946                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12947                             arg->pad_offset = o->op_targ;
12948                             o->op_targ = 0;
12949 #else
12950                             arg->sv = cSVOPx_sv(o);
12951 #endif
12952                         }
12953                     }
12954                     else {
12955                         /* it's a constant array index */
12956                         IV iv;
12957                         SV *ix_sv = cSVOPo->op_sv;
12958                         if (!SvIOK(ix_sv))
12959                             break;
12960                         iv = SvIV(ix_sv);
12961
12962                         if (   action_count == 0
12963                             && iv >= -128
12964                             && iv <= 127
12965                             && (   action == MDEREF_AV_padav_aelem
12966                                 || action == MDEREF_AV_gvav_aelem)
12967                         )
12968                             maybe_aelemfast = TRUE;
12969
12970                         if (pass) {
12971                             arg->iv = iv;
12972                             SvREFCNT_dec_NN(cSVOPo->op_sv);
12973                         }
12974                     }
12975                     if (pass)
12976                         /* we've taken ownership of the SV */
12977                         cSVOPo->op_sv = NULL;
12978                     arg++;
12979                     index_type = MDEREF_INDEX_const;
12980                     o = o->op_next;
12981                     break;
12982
12983                 case OP_GV:
12984                     /* it may be a package var index */
12985
12986                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12987                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12988                     if (  (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12989                         || o->op_private != 0
12990                     )
12991                         break;
12992
12993                     kid = o->op_next;
12994                     if (kid->op_type != OP_RV2SV)
12995                         break;
12996
12997                     ASSUME(!(kid->op_flags &
12998                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12999                              |OPf_SPECIAL|OPf_PARENS)));
13000                     ASSUME(!(kid->op_private &
13001                                     ~(OPpARG1_MASK
13002                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
13003                                      |OPpDEREF|OPpLVAL_INTRO)));
13004                     if(   (kid->op_flags &~ OPf_PARENS)
13005                             != (OPf_WANT_SCALAR|OPf_KIDS)
13006                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
13007                     )
13008                         break;
13009
13010                     if (pass) {
13011 #ifdef USE_ITHREADS
13012                         arg->pad_offset = cPADOPx(o)->op_padix;
13013                         /* stop it being swiped when nulled */
13014                         cPADOPx(o)->op_padix = 0;
13015 #else
13016                         arg->sv = cSVOPx(o)->op_sv;
13017                         cSVOPo->op_sv = NULL;
13018 #endif
13019                     }
13020                     arg++;
13021                     index_type = MDEREF_INDEX_gvsv;
13022                     o = kid->op_next;
13023                     break;
13024
13025                 } /* switch */
13026             } /* action_count != index_skip */
13027
13028             action |= index_type;
13029
13030
13031             /* at this point we have either:
13032              *   * detected what looks like a simple index expression,
13033              *     and expect the next op to be an [ah]elem, or
13034              *     an nulled  [ah]elem followed by a delete or exists;
13035              *  * found a more complex expression, so something other
13036              *    than the above follows.
13037              */
13038
13039             /* possibly an optimised away [ah]elem (where op_next is
13040              * exists or delete) */
13041             if (o->op_type == OP_NULL)
13042                 o = o->op_next;
13043
13044             /* at this point we're looking for an OP_AELEM, OP_HELEM,
13045              * OP_EXISTS or OP_DELETE */
13046
13047             /* if something like arybase (a.k.a $[ ) is in scope,
13048              * abandon optimisation attempt */
13049             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13050                && PL_check[o->op_type] != Perl_ck_null)
13051                 return;
13052             /* similarly for customised exists and delete */
13053             if (  (o->op_type == OP_EXISTS)
13054                && PL_check[o->op_type] != Perl_ck_exists)
13055                 return;
13056             if (  (o->op_type == OP_DELETE)
13057                && PL_check[o->op_type] != Perl_ck_delete)
13058                 return;
13059
13060             if (   o->op_type != OP_AELEM
13061                 || (o->op_private &
13062                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13063                 )
13064                 maybe_aelemfast = FALSE;
13065
13066             /* look for aelem/helem/exists/delete. If it's not the last elem
13067              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13068              * flags; if it's the last, then it mustn't have
13069              * OPpDEREF_AV/HV, but may have lots of other flags, like
13070              * OPpLVAL_INTRO etc
13071              */
13072
13073             if (   index_type == MDEREF_INDEX_none
13074                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
13075                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13076             )
13077                 ok = FALSE;
13078             else {
13079                 /* we have aelem/helem/exists/delete with valid simple index */
13080
13081                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13082                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
13083                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13084
13085                 if (is_deref) {
13086                     ASSUME(!(o->op_flags &
13087                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13088                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13089
13090                     ok =    (o->op_flags &~ OPf_PARENS)
13091                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13092                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13093                 }
13094                 else if (o->op_type == OP_EXISTS) {
13095                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13096                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13097                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13098                     ok =  !(o->op_private & ~OPpARG1_MASK);
13099                 }
13100                 else if (o->op_type == OP_DELETE) {
13101                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13102                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13103                     ASSUME(!(o->op_private &
13104                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13105                     /* don't handle slices or 'local delete'; the latter
13106                      * is fairly rare, and has a complex runtime */
13107                     ok =  !(o->op_private & ~OPpARG1_MASK);
13108                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13109                         /* skip handling run-tome error */
13110                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13111                 }
13112                 else {
13113                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13114                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13115                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13116                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13117                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13118                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13119                 }
13120             }
13121
13122             if (ok) {
13123                 if (!first_elem_op)
13124                     first_elem_op = o;
13125                 top_op = o;
13126                 if (is_deref) {
13127                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13128                     o = o->op_next;
13129                 }
13130                 else {
13131                     is_last = TRUE;
13132                     action |= MDEREF_FLAG_last;
13133                 }
13134             }
13135             else {
13136                 /* at this point we have something that started
13137                  * promisingly enough (with rv2av or whatever), but failed
13138                  * to find a simple index followed by an
13139                  * aelem/helem/exists/delete. If this is the first action,
13140                  * give up; but if we've already seen at least one
13141                  * aelem/helem, then keep them and add a new action with
13142                  * MDEREF_INDEX_none, which causes it to do the vivify
13143                  * from the end of the previous lookup, and do the deref,
13144                  * but stop at that point. So $a[0][expr] will do one
13145                  * av_fetch, vivify and deref, then continue executing at
13146                  * expr */
13147                 if (!action_count)
13148                     return;
13149                 is_last = TRUE;
13150                 index_skip = action_count;
13151                 action |= MDEREF_FLAG_last;
13152                 if (index_type != MDEREF_INDEX_none)
13153                     arg--;
13154             }
13155
13156             if (pass)
13157                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13158             action_ix++;
13159             action_count++;
13160             /* if there's no space for the next action, create a new slot
13161              * for it *before* we start adding args for that action */
13162             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13163                 action_ptr = arg;
13164                 if (pass)
13165                     arg->uv = 0;
13166                 arg++;
13167                 action_ix = 0;
13168             }
13169         } /* while !is_last */
13170
13171         /* success! */
13172
13173         if (pass) {
13174             OP *mderef;
13175             OP *p, *q;
13176
13177             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13178             if (index_skip == -1) {
13179                 mderef->op_flags = o->op_flags
13180                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13181                 if (o->op_type == OP_EXISTS)
13182                     mderef->op_private = OPpMULTIDEREF_EXISTS;
13183                 else if (o->op_type == OP_DELETE)
13184                     mderef->op_private = OPpMULTIDEREF_DELETE;
13185                 else
13186                     mderef->op_private = o->op_private
13187                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13188             }
13189             /* accumulate strictness from every level (although I don't think
13190              * they can actually vary) */
13191             mderef->op_private |= hints;
13192
13193             /* integrate the new multideref op into the optree and the
13194              * op_next chain.
13195              *
13196              * In general an op like aelem or helem has two child
13197              * sub-trees: the aggregate expression (a_expr) and the
13198              * index expression (i_expr):
13199              *
13200              *     aelem
13201              *       |
13202              *     a_expr - i_expr
13203              *
13204              * The a_expr returns an AV or HV, while the i-expr returns an
13205              * index. In general a multideref replaces most or all of a
13206              * multi-level tree, e.g.
13207              *
13208              *     exists
13209              *       |
13210              *     ex-aelem
13211              *       |
13212              *     rv2av  - i_expr1
13213              *       |
13214              *     helem
13215              *       |
13216              *     rv2hv  - i_expr2
13217              *       |
13218              *     aelem
13219              *       |
13220              *     a_expr - i_expr3
13221              *
13222              * With multideref, all the i_exprs will be simple vars or
13223              * constants, except that i_expr1 may be arbitrary in the case
13224              * of MDEREF_INDEX_none.
13225              *
13226              * The bottom-most a_expr will be either:
13227              *   1) a simple var (so padXv or gv+rv2Xv);
13228              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
13229              *      so a simple var with an extra rv2Xv;
13230              *   3) or an arbitrary expression.
13231              *
13232              * 'start', the first op in the execution chain, will point to
13233              *   1),2): the padXv or gv op;
13234              *   3):    the rv2Xv which forms the last op in the a_expr
13235              *          execution chain, and the top-most op in the a_expr
13236              *          subtree.
13237              *
13238              * For all cases, the 'start' node is no longer required,
13239              * but we can't free it since one or more external nodes
13240              * may point to it. E.g. consider
13241              *     $h{foo} = $a ? $b : $c
13242              * Here, both the op_next and op_other branches of the
13243              * cond_expr point to the gv[*h] of the hash expression, so
13244              * we can't free the 'start' op.
13245              *
13246              * For expr->[...], we need to save the subtree containing the
13247              * expression; for the other cases, we just need to save the
13248              * start node.
13249              * So in all cases, we null the start op and keep it around by
13250              * making it the child of the multideref op; for the expr->
13251              * case, the expr will be a subtree of the start node.
13252              *
13253              * So in the simple 1,2 case the  optree above changes to
13254              *
13255              *     ex-exists
13256              *       |
13257              *     multideref
13258              *       |
13259              *     ex-gv (or ex-padxv)
13260              *
13261              *  with the op_next chain being
13262              *
13263              *  -> ex-gv -> multideref -> op-following-ex-exists ->
13264              *
13265              *  In the 3 case, we have
13266              *
13267              *     ex-exists
13268              *       |
13269              *     multideref
13270              *       |
13271              *     ex-rv2xv
13272              *       |
13273              *    rest-of-a_expr
13274              *      subtree
13275              *
13276              *  and
13277              *
13278              *  -> rest-of-a_expr subtree ->
13279              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
13280              *
13281              *
13282              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13283              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13284              * multideref attached as the child, e.g.
13285              *
13286              *     exists
13287              *       |
13288              *     ex-aelem
13289              *       |
13290              *     ex-rv2av  - i_expr1
13291              *       |
13292              *     multideref
13293              *       |
13294              *     ex-whatever
13295              *
13296              */
13297
13298             /* if we free this op, don't free the pad entry */
13299             if (reset_start_targ)
13300                 start->op_targ = 0;
13301
13302
13303             /* Cut the bit we need to save out of the tree and attach to
13304              * the multideref op, then free the rest of the tree */
13305
13306             /* find parent of node to be detached (for use by splice) */
13307             p = first_elem_op;
13308             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
13309                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13310             {
13311                 /* there is an arbitrary expression preceding us, e.g.
13312                  * expr->[..]? so we need to save the 'expr' subtree */
13313                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13314                     p = cUNOPx(p)->op_first;
13315                 ASSUME(   start->op_type == OP_RV2AV
13316                        || start->op_type == OP_RV2HV);
13317             }
13318             else {
13319                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13320                  * above for exists/delete. */
13321                 while (   (p->op_flags & OPf_KIDS)
13322                        && cUNOPx(p)->op_first != start
13323                 )
13324                     p = cUNOPx(p)->op_first;
13325             }
13326             ASSUME(cUNOPx(p)->op_first == start);
13327
13328             /* detach from main tree, and re-attach under the multideref */
13329             op_sibling_splice(mderef, NULL, 0,
13330                     op_sibling_splice(p, NULL, 1, NULL));
13331             op_null(start);
13332
13333             start->op_next = mderef;
13334
13335             mderef->op_next = index_skip == -1 ? o->op_next : o;
13336
13337             /* excise and free the original tree, and replace with
13338              * the multideref op */
13339             p = op_sibling_splice(top_op, NULL, -1, mderef);
13340             while (p) {
13341                 q = OpSIBLING(p);
13342                 op_free(p);
13343                 p = q;
13344             }
13345             op_null(top_op);
13346         }
13347         else {
13348             Size_t size = arg - arg_buf;
13349
13350             if (maybe_aelemfast && action_count == 1)
13351                 return;
13352
13353             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13354                                 sizeof(UNOP_AUX_item) * (size + 1));
13355             /* for dumping etc: store the length in a hidden first slot;
13356              * we set the op_aux pointer to the second slot */
13357             arg_buf->uv = size;
13358             arg_buf++;
13359         }
13360     } /* for (pass = ...) */
13361 }
13362
13363
13364
13365 /* mechanism for deferring recursion in rpeep() */
13366
13367 #define MAX_DEFERRED 4
13368
13369 #define DEFER(o) \
13370   STMT_START { \
13371     if (defer_ix == (MAX_DEFERRED-1)) { \
13372         OP **defer = defer_queue[defer_base]; \
13373         CALL_RPEEP(*defer); \
13374         S_prune_chain_head(defer); \
13375         defer_base = (defer_base + 1) % MAX_DEFERRED; \
13376         defer_ix--; \
13377     } \
13378     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13379   } STMT_END
13380
13381 #define IS_AND_OP(o)   (o->op_type == OP_AND)
13382 #define IS_OR_OP(o)    (o->op_type == OP_OR)
13383
13384
13385 /* A peephole optimizer.  We visit the ops in the order they're to execute.
13386  * See the comments at the top of this file for more details about when
13387  * peep() is called */
13388
13389 void
13390 Perl_rpeep(pTHX_ OP *o)
13391 {
13392     dVAR;
13393     OP* oldop = NULL;
13394     OP* oldoldop = NULL;
13395     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13396     int defer_base = 0;
13397     int defer_ix = -1;
13398     OP *fop;
13399     OP *sop;
13400
13401     if (!o || o->op_opt)
13402         return;
13403
13404     assert(o->op_type != OP_FREED);
13405
13406     ENTER;
13407     SAVEOP();
13408     SAVEVPTR(PL_curcop);
13409     for (;; o = o->op_next) {
13410         if (o && o->op_opt)
13411             o = NULL;
13412         if (!o) {
13413             while (defer_ix >= 0) {
13414                 OP **defer =
13415                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13416                 CALL_RPEEP(*defer);
13417                 S_prune_chain_head(defer);
13418             }
13419             break;
13420         }
13421
13422       redo:
13423
13424         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13425         assert(!oldoldop || oldoldop->op_next == oldop);
13426         assert(!oldop    || oldop->op_next    == o);
13427
13428         /* By default, this op has now been optimised. A couple of cases below
13429            clear this again.  */
13430         o->op_opt = 1;
13431         PL_op = o;
13432
13433         /* look for a series of 1 or more aggregate derefs, e.g.
13434          *   $a[1]{foo}[$i]{$k}
13435          * and replace with a single OP_MULTIDEREF op.
13436          * Each index must be either a const, or a simple variable,
13437          *
13438          * First, look for likely combinations of starting ops,
13439          * corresponding to (global and lexical variants of)
13440          *     $a[...]   $h{...}
13441          *     $r->[...] $r->{...}
13442          *     (preceding expression)->[...]
13443          *     (preceding expression)->{...}
13444          * and if so, call maybe_multideref() to do a full inspection
13445          * of the op chain and if appropriate, replace with an
13446          * OP_MULTIDEREF
13447          */
13448         {
13449             UV action;
13450             OP *o2 = o;
13451             U8 hints = 0;
13452
13453             switch (o2->op_type) {
13454             case OP_GV:
13455                 /* $pkg[..]   :   gv[*pkg]
13456                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
13457
13458                 /* Fail if there are new op flag combinations that we're
13459                  * not aware of, rather than:
13460                  *  * silently failing to optimise, or
13461                  *  * silently optimising the flag away.
13462                  * If this ASSUME starts failing, examine what new flag
13463                  * has been added to the op, and decide whether the
13464                  * optimisation should still occur with that flag, then
13465                  * update the code accordingly. This applies to all the
13466                  * other ASSUMEs in the block of code too.
13467                  */
13468                 ASSUME(!(o2->op_flags &
13469                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13470                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13471
13472                 o2 = o2->op_next;
13473
13474                 if (o2->op_type == OP_RV2AV) {
13475                     action = MDEREF_AV_gvav_aelem;
13476                     goto do_deref;
13477                 }
13478
13479                 if (o2->op_type == OP_RV2HV) {
13480                     action = MDEREF_HV_gvhv_helem;
13481                     goto do_deref;
13482                 }
13483
13484                 if (o2->op_type != OP_RV2SV)
13485                     break;
13486
13487                 /* at this point we've seen gv,rv2sv, so the only valid
13488                  * construct left is $pkg->[] or $pkg->{} */
13489
13490                 ASSUME(!(o2->op_flags & OPf_STACKED));
13491                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13492                             != (OPf_WANT_SCALAR|OPf_MOD))
13493                     break;
13494
13495                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13496                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13497                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13498                     break;
13499                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
13500                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13501                     break;
13502
13503                 o2 = o2->op_next;
13504                 if (o2->op_type == OP_RV2AV) {
13505                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13506                     goto do_deref;
13507                 }
13508                 if (o2->op_type == OP_RV2HV) {
13509                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13510                     goto do_deref;
13511                 }
13512                 break;
13513
13514             case OP_PADSV:
13515                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13516
13517                 ASSUME(!(o2->op_flags &
13518                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13519                 if ((o2->op_flags &
13520                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13521                      != (OPf_WANT_SCALAR|OPf_MOD))
13522                     break;
13523
13524                 ASSUME(!(o2->op_private &
13525                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13526                 /* skip if state or intro, or not a deref */
13527                 if (      o2->op_private != OPpDEREF_AV
13528                        && o2->op_private != OPpDEREF_HV)
13529                     break;
13530
13531                 o2 = o2->op_next;
13532                 if (o2->op_type == OP_RV2AV) {
13533                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13534                     goto do_deref;
13535                 }
13536                 if (o2->op_type == OP_RV2HV) {
13537                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13538                     goto do_deref;
13539                 }
13540                 break;
13541
13542             case OP_PADAV:
13543             case OP_PADHV:
13544                 /*    $lex[..]:  padav[@lex:1,2] sR *
13545                  * or $lex{..}:  padhv[%lex:1,2] sR */
13546                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13547                                             OPf_REF|OPf_SPECIAL)));
13548                 if ((o2->op_flags &
13549                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13550                      != (OPf_WANT_SCALAR|OPf_REF))
13551                     break;
13552                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13553                     break;
13554                 /* OPf_PARENS isn't currently used in this case;
13555                  * if that changes, let us know! */
13556                 ASSUME(!(o2->op_flags & OPf_PARENS));
13557
13558                 /* at this point, we wouldn't expect any of the remaining
13559                  * possible private flags:
13560                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13561                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13562                  *
13563                  * OPpSLICEWARNING shouldn't affect runtime
13564                  */
13565                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13566
13567                 action = o2->op_type == OP_PADAV
13568                             ? MDEREF_AV_padav_aelem
13569                             : MDEREF_HV_padhv_helem;
13570                 o2 = o2->op_next;
13571                 S_maybe_multideref(aTHX_ o, o2, action, 0);
13572                 break;
13573
13574
13575             case OP_RV2AV:
13576             case OP_RV2HV:
13577                 action = o2->op_type == OP_RV2AV
13578                             ? MDEREF_AV_pop_rv2av_aelem
13579                             : MDEREF_HV_pop_rv2hv_helem;
13580                 /* FALLTHROUGH */
13581             do_deref:
13582                 /* (expr)->[...]:  rv2av sKR/1;
13583                  * (expr)->{...}:  rv2hv sKR/1; */
13584
13585                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13586
13587                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13588                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13589                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13590                     break;
13591
13592                 /* at this point, we wouldn't expect any of these
13593                  * possible private flags:
13594                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13595                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13596                  */
13597                 ASSUME(!(o2->op_private &
13598                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13599                      |OPpOUR_INTRO)));
13600                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13601
13602                 o2 = o2->op_next;
13603
13604                 S_maybe_multideref(aTHX_ o, o2, action, hints);
13605                 break;
13606
13607             default:
13608                 break;
13609             }
13610         }
13611
13612
13613         switch (o->op_type) {
13614         case OP_DBSTATE:
13615             PL_curcop = ((COP*)o);              /* for warnings */
13616             break;
13617         case OP_NEXTSTATE:
13618             PL_curcop = ((COP*)o);              /* for warnings */
13619
13620             /* Optimise a "return ..." at the end of a sub to just be "...".
13621              * This saves 2 ops. Before:
13622              * 1  <;> nextstate(main 1 -e:1) v ->2
13623              * 4  <@> return K ->5
13624              * 2    <0> pushmark s ->3
13625              * -    <1> ex-rv2sv sK/1 ->4
13626              * 3      <#> gvsv[*cat] s ->4
13627              *
13628              * After:
13629              * -  <@> return K ->-
13630              * -    <0> pushmark s ->2
13631              * -    <1> ex-rv2sv sK/1 ->-
13632              * 2      <$> gvsv(*cat) s ->3
13633              */
13634             {
13635                 OP *next = o->op_next;
13636                 OP *sibling = OpSIBLING(o);
13637                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
13638                     && OP_TYPE_IS(sibling, OP_RETURN)
13639                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13640                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13641                        ||OP_TYPE_IS(sibling->op_next->op_next,
13642                                     OP_LEAVESUBLV))
13643                     && cUNOPx(sibling)->op_first == next
13644                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13645                     && next->op_next
13646                 ) {
13647                     /* Look through the PUSHMARK's siblings for one that
13648                      * points to the RETURN */
13649                     OP *top = OpSIBLING(next);
13650                     while (top && top->op_next) {
13651                         if (top->op_next == sibling) {
13652                             top->op_next = sibling->op_next;
13653                             o->op_next = next->op_next;
13654                             break;
13655                         }
13656                         top = OpSIBLING(top);
13657                     }
13658                 }
13659             }
13660
13661             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13662              *
13663              * This latter form is then suitable for conversion into padrange
13664              * later on. Convert:
13665              *
13666              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13667              *
13668              * into:
13669              *
13670              *   nextstate1 ->     listop     -> nextstate3
13671              *                 /            \
13672              *         pushmark -> padop1 -> padop2
13673              */
13674             if (o->op_next && (
13675                     o->op_next->op_type == OP_PADSV
13676                  || o->op_next->op_type == OP_PADAV
13677                  || o->op_next->op_type == OP_PADHV
13678                 )
13679                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13680                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13681                 && o->op_next->op_next->op_next && (
13682                     o->op_next->op_next->op_next->op_type == OP_PADSV
13683                  || o->op_next->op_next->op_next->op_type == OP_PADAV
13684                  || o->op_next->op_next->op_next->op_type == OP_PADHV
13685                 )
13686                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13687                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13688                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13689                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13690             ) {
13691                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13692
13693                 pad1 =    o->op_next;
13694                 ns2  = pad1->op_next;
13695                 pad2 =  ns2->op_next;
13696                 ns3  = pad2->op_next;
13697
13698                 /* we assume here that the op_next chain is the same as
13699                  * the op_sibling chain */
13700                 assert(OpSIBLING(o)    == pad1);
13701                 assert(OpSIBLING(pad1) == ns2);
13702                 assert(OpSIBLING(ns2)  == pad2);
13703                 assert(OpSIBLING(pad2) == ns3);
13704
13705                 /* excise and delete ns2 */
13706                 op_sibling_splice(NULL, pad1, 1, NULL);
13707                 op_free(ns2);
13708
13709                 /* excise pad1 and pad2 */
13710                 op_sibling_splice(NULL, o, 2, NULL);
13711
13712                 /* create new listop, with children consisting of:
13713                  * a new pushmark, pad1, pad2. */
13714                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13715                 newop->op_flags |= OPf_PARENS;
13716                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13717
13718                 /* insert newop between o and ns3 */
13719                 op_sibling_splice(NULL, o, 0, newop);
13720
13721                 /*fixup op_next chain */
13722                 newpm = cUNOPx(newop)->op_first; /* pushmark */
13723                 o    ->op_next = newpm;
13724                 newpm->op_next = pad1;
13725                 pad1 ->op_next = pad2;
13726                 pad2 ->op_next = newop; /* listop */
13727                 newop->op_next = ns3;
13728
13729                 /* Ensure pushmark has this flag if padops do */
13730                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13731                     newpm->op_flags |= OPf_MOD;
13732                 }
13733
13734                 break;
13735             }
13736
13737             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13738                to carry two labels. For now, take the easier option, and skip
13739                this optimisation if the first NEXTSTATE has a label.  */
13740             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13741                 OP *nextop = o->op_next;
13742                 while (nextop && nextop->op_type == OP_NULL)
13743                     nextop = nextop->op_next;
13744
13745                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13746                     op_null(o);
13747                     if (oldop)
13748                         oldop->op_next = nextop;
13749                     o = nextop;
13750                     /* Skip (old)oldop assignment since the current oldop's
13751                        op_next already points to the next op.  */
13752                     goto redo;
13753                 }
13754             }
13755             break;
13756
13757         case OP_CONCAT:
13758             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13759                 if (o->op_next->op_private & OPpTARGET_MY) {
13760                     if (o->op_flags & OPf_STACKED) /* chained concats */
13761                         break; /* ignore_optimization */
13762                     else {
13763                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13764                         o->op_targ = o->op_next->op_targ;
13765                         o->op_next->op_targ = 0;
13766                         o->op_private |= OPpTARGET_MY;
13767                     }
13768                 }
13769                 op_null(o->op_next);
13770             }
13771             break;
13772         case OP_STUB:
13773             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13774                 break; /* Scalar stub must produce undef.  List stub is noop */
13775             }
13776             goto nothin;
13777         case OP_NULL:
13778             if (o->op_targ == OP_NEXTSTATE
13779                 || o->op_targ == OP_DBSTATE)
13780             {
13781                 PL_curcop = ((COP*)o);
13782             }
13783             /* XXX: We avoid setting op_seq here to prevent later calls
13784                to rpeep() from mistakenly concluding that optimisation
13785                has already occurred. This doesn't fix the real problem,
13786                though (See 20010220.007 (#5874)). AMS 20010719 */
13787             /* op_seq functionality is now replaced by op_opt */
13788             o->op_opt = 0;
13789             /* FALLTHROUGH */
13790         case OP_SCALAR:
13791         case OP_LINESEQ:
13792         case OP_SCOPE:
13793         nothin:
13794             if (oldop) {
13795                 oldop->op_next = o->op_next;
13796                 o->op_opt = 0;
13797                 continue;
13798             }
13799             break;
13800
13801         case OP_PUSHMARK:
13802
13803             /* Given
13804                  5 repeat/DOLIST
13805                  3   ex-list
13806                  1     pushmark
13807                  2     scalar or const
13808                  4   const[0]
13809                convert repeat into a stub with no kids.
13810              */
13811             if (o->op_next->op_type == OP_CONST
13812              || (  o->op_next->op_type == OP_PADSV
13813                 && !(o->op_next->op_private & OPpLVAL_INTRO))
13814              || (  o->op_next->op_type == OP_GV
13815                 && o->op_next->op_next->op_type == OP_RV2SV
13816                 && !(o->op_next->op_next->op_private
13817                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13818             {
13819                 const OP *kid = o->op_next->op_next;
13820                 if (o->op_next->op_type == OP_GV)
13821                    kid = kid->op_next;
13822                 /* kid is now the ex-list.  */
13823                 if (kid->op_type == OP_NULL
13824                  && (kid = kid->op_next)->op_type == OP_CONST
13825                     /* kid is now the repeat count.  */
13826                  && kid->op_next->op_type == OP_REPEAT
13827                  && kid->op_next->op_private & OPpREPEAT_DOLIST
13828                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13829                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
13830                  && oldop)
13831                 {
13832                     o = kid->op_next; /* repeat */
13833                     oldop->op_next = o;
13834                     op_free(cBINOPo->op_first);
13835                     op_free(cBINOPo->op_last );
13836                     o->op_flags &=~ OPf_KIDS;
13837                     /* stub is a baseop; repeat is a binop */
13838                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13839                     OpTYPE_set(o, OP_STUB);
13840                     o->op_private = 0;
13841                     break;
13842                 }
13843             }
13844
13845             /* Convert a series of PAD ops for my vars plus support into a
13846              * single padrange op. Basically
13847              *
13848              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13849              *
13850              * becomes, depending on circumstances, one of
13851              *
13852              *    padrange  ----------------------------------> (list) -> rest
13853              *    padrange  --------------------------------------------> rest
13854              *
13855              * where all the pad indexes are sequential and of the same type
13856              * (INTRO or not).
13857              * We convert the pushmark into a padrange op, then skip
13858              * any other pad ops, and possibly some trailing ops.
13859              * Note that we don't null() the skipped ops, to make it
13860              * easier for Deparse to undo this optimisation (and none of
13861              * the skipped ops are holding any resourses). It also makes
13862              * it easier for find_uninit_var(), as it can just ignore
13863              * padrange, and examine the original pad ops.
13864              */
13865         {
13866             OP *p;
13867             OP *followop = NULL; /* the op that will follow the padrange op */
13868             U8 count = 0;
13869             U8 intro = 0;
13870             PADOFFSET base = 0; /* init only to stop compiler whining */
13871             bool gvoid = 0;     /* init only to stop compiler whining */
13872             bool defav = 0;  /* seen (...) = @_ */
13873             bool reuse = 0;  /* reuse an existing padrange op */
13874
13875             /* look for a pushmark -> gv[_] -> rv2av */
13876
13877             {
13878                 OP *rv2av, *q;
13879                 p = o->op_next;
13880                 if (   p->op_type == OP_GV
13881                     && cGVOPx_gv(p) == PL_defgv
13882                     && (rv2av = p->op_next)
13883                     && rv2av->op_type == OP_RV2AV
13884                     && !(rv2av->op_flags & OPf_REF)
13885                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13886                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13887                 ) {
13888                     q = rv2av->op_next;
13889                     if (q->op_type == OP_NULL)
13890                         q = q->op_next;
13891                     if (q->op_type == OP_PUSHMARK) {
13892                         defav = 1;
13893                         p = q;
13894                     }
13895                 }
13896             }
13897             if (!defav) {
13898                 p = o;
13899             }
13900
13901             /* scan for PAD ops */
13902
13903             for (p = p->op_next; p; p = p->op_next) {
13904                 if (p->op_type == OP_NULL)
13905                     continue;
13906
13907                 if ((     p->op_type != OP_PADSV
13908                        && p->op_type != OP_PADAV
13909                        && p->op_type != OP_PADHV
13910                     )
13911                       /* any private flag other than INTRO? e.g. STATE */
13912                    || (p->op_private & ~OPpLVAL_INTRO)
13913                 )
13914                     break;
13915
13916                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13917                  * instead */
13918                 if (   p->op_type == OP_PADAV
13919                     && p->op_next
13920                     && p->op_next->op_type == OP_CONST
13921                     && p->op_next->op_next
13922                     && p->op_next->op_next->op_type == OP_AELEM
13923                 )
13924                     break;
13925
13926                 /* for 1st padop, note what type it is and the range
13927                  * start; for the others, check that it's the same type
13928                  * and that the targs are contiguous */
13929                 if (count == 0) {
13930                     intro = (p->op_private & OPpLVAL_INTRO);
13931                     base = p->op_targ;
13932                     gvoid = OP_GIMME(p,0) == G_VOID;
13933                 }
13934                 else {
13935                     if ((p->op_private & OPpLVAL_INTRO) != intro)
13936                         break;
13937                     /* Note that you'd normally  expect targs to be
13938                      * contiguous in my($a,$b,$c), but that's not the case
13939                      * when external modules start doing things, e.g.
13940                      * Function::Parameters */
13941                     if (p->op_targ != base + count)
13942                         break;
13943                     assert(p->op_targ == base + count);
13944                     /* Either all the padops or none of the padops should
13945                        be in void context.  Since we only do the optimisa-
13946                        tion for av/hv when the aggregate itself is pushed
13947                        on to the stack (one item), there is no need to dis-
13948                        tinguish list from scalar context.  */
13949                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
13950                         break;
13951                 }
13952
13953                 /* for AV, HV, only when we're not flattening */
13954                 if (   p->op_type != OP_PADSV
13955                     && !gvoid
13956                     && !(p->op_flags & OPf_REF)
13957                 )
13958                     break;
13959
13960                 if (count >= OPpPADRANGE_COUNTMASK)
13961                     break;
13962
13963                 /* there's a biggest base we can fit into a
13964                  * SAVEt_CLEARPADRANGE in pp_padrange.
13965                  * (The sizeof() stuff will be constant-folded, and is
13966                  * intended to avoid getting "comparison is always false"
13967                  * compiler warnings. See the comments above
13968                  * MEM_WRAP_CHECK for more explanation on why we do this
13969                  * in a weird way to avoid compiler warnings.)
13970                  */
13971                 if (   intro
13972                     && (8*sizeof(base) >
13973                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13974                         ? (Size_t)base
13975                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13976                         ) >
13977                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13978                 )
13979                     break;
13980
13981                 /* Success! We've got another valid pad op to optimise away */
13982                 count++;
13983                 followop = p->op_next;
13984             }
13985
13986             if (count < 1 || (count == 1 && !defav))
13987                 break;
13988
13989             /* pp_padrange in specifically compile-time void context
13990              * skips pushing a mark and lexicals; in all other contexts
13991              * (including unknown till runtime) it pushes a mark and the
13992              * lexicals. We must be very careful then, that the ops we
13993              * optimise away would have exactly the same effect as the
13994              * padrange.
13995              * In particular in void context, we can only optimise to
13996              * a padrange if we see the complete sequence
13997              *     pushmark, pad*v, ...., list
13998              * which has the net effect of leaving the markstack as it
13999              * was.  Not pushing onto the stack (whereas padsv does touch
14000              * the stack) makes no difference in void context.
14001              */
14002             assert(followop);
14003             if (gvoid) {
14004                 if (followop->op_type == OP_LIST
14005                         && OP_GIMME(followop,0) == G_VOID
14006                    )
14007                 {
14008                     followop = followop->op_next; /* skip OP_LIST */
14009
14010                     /* consolidate two successive my(...);'s */
14011
14012                     if (   oldoldop
14013                         && oldoldop->op_type == OP_PADRANGE
14014                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14015                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14016                         && !(oldoldop->op_flags & OPf_SPECIAL)
14017                     ) {
14018                         U8 old_count;
14019                         assert(oldoldop->op_next == oldop);
14020                         assert(   oldop->op_type == OP_NEXTSTATE
14021                                || oldop->op_type == OP_DBSTATE);
14022                         assert(oldop->op_next == o);
14023
14024                         old_count
14025                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14026
14027                        /* Do not assume pad offsets for $c and $d are con-
14028                           tiguous in
14029                             my ($a,$b,$c);
14030                             my ($d,$e,$f);
14031                         */
14032                         if (  oldoldop->op_targ + old_count == base
14033                            && old_count < OPpPADRANGE_COUNTMASK - count) {
14034                             base = oldoldop->op_targ;
14035                             count += old_count;
14036                             reuse = 1;
14037                         }
14038                     }
14039
14040                     /* if there's any immediately following singleton
14041                      * my var's; then swallow them and the associated
14042                      * nextstates; i.e.
14043                      *    my ($a,$b); my $c; my $d;
14044                      * is treated as
14045                      *    my ($a,$b,$c,$d);
14046                      */
14047
14048                     while (    ((p = followop->op_next))
14049                             && (  p->op_type == OP_PADSV
14050                                || p->op_type == OP_PADAV
14051                                || p->op_type == OP_PADHV)
14052                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14053                             && (p->op_private & OPpLVAL_INTRO) == intro
14054                             && !(p->op_private & ~OPpLVAL_INTRO)
14055                             && p->op_next
14056                             && (   p->op_next->op_type == OP_NEXTSTATE
14057                                 || p->op_next->op_type == OP_DBSTATE)
14058                             && count < OPpPADRANGE_COUNTMASK
14059                             && base + count == p->op_targ
14060                     ) {
14061                         count++;
14062                         followop = p->op_next;
14063                     }
14064                 }
14065                 else
14066                     break;
14067             }
14068
14069             if (reuse) {
14070                 assert(oldoldop->op_type == OP_PADRANGE);
14071                 oldoldop->op_next = followop;
14072                 oldoldop->op_private = (intro | count);
14073                 o = oldoldop;
14074                 oldop = NULL;
14075                 oldoldop = NULL;
14076             }
14077             else {
14078                 /* Convert the pushmark into a padrange.
14079                  * To make Deparse easier, we guarantee that a padrange was
14080                  * *always* formerly a pushmark */
14081                 assert(o->op_type == OP_PUSHMARK);
14082                 o->op_next = followop;
14083                 OpTYPE_set(o, OP_PADRANGE);
14084                 o->op_targ = base;
14085                 /* bit 7: INTRO; bit 6..0: count */
14086                 o->op_private = (intro | count);
14087                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14088                               | gvoid * OPf_WANT_VOID
14089                               | (defav ? OPf_SPECIAL : 0));
14090             }
14091             break;
14092         }
14093
14094         case OP_PADAV:
14095         case OP_PADSV:
14096         case OP_PADHV:
14097         /* Skip over state($x) in void context.  */
14098         if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14099          && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14100         {
14101             oldop->op_next = o->op_next;
14102             goto redo_nextstate;
14103         }
14104         if (o->op_type != OP_PADAV)
14105             break;
14106         /* FALLTHROUGH */
14107         case OP_GV:
14108             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14109                 OP* const pop = (o->op_type == OP_PADAV) ?
14110                             o->op_next : o->op_next->op_next;
14111                 IV i;
14112                 if (pop && pop->op_type == OP_CONST &&
14113                     ((PL_op = pop->op_next)) &&
14114                     pop->op_next->op_type == OP_AELEM &&
14115                     !(pop->op_next->op_private &
14116                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14117                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14118                 {
14119                     GV *gv;
14120                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14121                         no_bareword_allowed(pop);
14122                     if (o->op_type == OP_GV)
14123                         op_null(o->op_next);
14124                     op_null(pop->op_next);
14125                     op_null(pop);
14126                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14127                     o->op_next = pop->op_next->op_next;
14128                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14129                     o->op_private = (U8)i;
14130                     if (o->op_type == OP_GV) {
14131                         gv = cGVOPo_gv;
14132                         GvAVn(gv);
14133                         o->op_type = OP_AELEMFAST;
14134                     }
14135                     else
14136                         o->op_type = OP_AELEMFAST_LEX;
14137                 }
14138                 if (o->op_type != OP_GV)
14139                     break;
14140             }
14141
14142             /* Remove $foo from the op_next chain in void context.  */
14143             if (oldop
14144              && (  o->op_next->op_type == OP_RV2SV
14145                 || o->op_next->op_type == OP_RV2AV
14146                 || o->op_next->op_type == OP_RV2HV  )
14147              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14148              && !(o->op_next->op_private & OPpLVAL_INTRO))
14149             {
14150                 oldop->op_next = o->op_next->op_next;
14151                 /* Reprocess the previous op if it is a nextstate, to
14152                    allow double-nextstate optimisation.  */
14153               redo_nextstate:
14154                 if (oldop->op_type == OP_NEXTSTATE) {
14155                     oldop->op_opt = 0;
14156                     o = oldop;
14157                     oldop = oldoldop;
14158                     oldoldop = NULL;
14159                     goto redo;
14160                 }
14161                 o = oldop->op_next;
14162                 goto redo;
14163             }
14164             else if (o->op_next->op_type == OP_RV2SV) {
14165                 if (!(o->op_next->op_private & OPpDEREF)) {
14166                     op_null(o->op_next);
14167                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14168                                                                | OPpOUR_INTRO);
14169                     o->op_next = o->op_next->op_next;
14170                     OpTYPE_set(o, OP_GVSV);
14171                 }
14172             }
14173             else if (o->op_next->op_type == OP_READLINE
14174                     && o->op_next->op_next->op_type == OP_CONCAT
14175                     && (o->op_next->op_next->op_flags & OPf_STACKED))
14176             {
14177                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14178                 OpTYPE_set(o, OP_RCATLINE);
14179                 o->op_flags |= OPf_STACKED;
14180                 op_null(o->op_next->op_next);
14181                 op_null(o->op_next);
14182             }
14183
14184             break;
14185
14186 #define HV_OR_SCALARHV(op)                                   \
14187     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14188        ? (op)                                                  \
14189        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14190        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
14191           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
14192          ? cUNOPx(op)->op_first                                   \
14193          : NULL)
14194
14195         case OP_NOT:
14196             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14197                 fop->op_private |= OPpTRUEBOOL;
14198             break;
14199
14200         case OP_AND:
14201         case OP_OR:
14202         case OP_DOR:
14203             fop = cLOGOP->op_first;
14204             sop = OpSIBLING(fop);
14205             while (cLOGOP->op_other->op_type == OP_NULL)
14206                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14207             while (o->op_next && (   o->op_type == o->op_next->op_type
14208                                   || o->op_next->op_type == OP_NULL))
14209                 o->op_next = o->op_next->op_next;
14210
14211             /* If we're an OR and our next is an AND in void context, we'll
14212                follow its op_other on short circuit, same for reverse.
14213                We can't do this with OP_DOR since if it's true, its return
14214                value is the underlying value which must be evaluated
14215                by the next op. */
14216             if (o->op_next &&
14217                 (
14218                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14219                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14220                 )
14221                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14222             ) {
14223                 o->op_next = ((LOGOP*)o->op_next)->op_other;
14224             }
14225             DEFER(cLOGOP->op_other);
14226
14227             o->op_opt = 1;
14228             fop = HV_OR_SCALARHV(fop);
14229             if (sop) sop = HV_OR_SCALARHV(sop);
14230             if (fop || sop
14231             ){
14232                 OP * nop = o;
14233                 OP * lop = o;
14234                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14235                     while (nop && nop->op_next) {
14236                         switch (nop->op_next->op_type) {
14237                             case OP_NOT:
14238                             case OP_AND:
14239                             case OP_OR:
14240                             case OP_DOR:
14241                                 lop = nop = nop->op_next;
14242                                 break;
14243                             case OP_NULL:
14244                                 nop = nop->op_next;
14245                                 break;
14246                             default:
14247                                 nop = NULL;
14248                                 break;
14249                         }
14250                     }
14251                 }
14252                 if (fop) {
14253                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14254                       || o->op_type == OP_AND  )
14255                         fop->op_private |= OPpTRUEBOOL;
14256                     else if (!(lop->op_flags & OPf_WANT))
14257                         fop->op_private |= OPpMAYBE_TRUEBOOL;
14258                 }
14259                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14260                    && sop)
14261                     sop->op_private |= OPpTRUEBOOL;
14262             }
14263
14264
14265             break;
14266
14267         case OP_COND_EXPR:
14268             if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14269                 fop->op_private |= OPpTRUEBOOL;
14270 #undef HV_OR_SCALARHV
14271             /* GERONIMO! */ /* FALLTHROUGH */
14272
14273         case OP_MAPWHILE:
14274         case OP_GREPWHILE:
14275         case OP_ANDASSIGN:
14276         case OP_ORASSIGN:
14277         case OP_DORASSIGN:
14278         case OP_RANGE:
14279         case OP_ONCE:
14280         case OP_ARGDEFELEM:
14281             while (cLOGOP->op_other->op_type == OP_NULL)
14282                 cLOGOP->op_other = cLOGOP->op_other->op_next;
14283             DEFER(cLOGOP->op_other);
14284             break;
14285
14286         case OP_ENTERLOOP:
14287         case OP_ENTERITER:
14288             while (cLOOP->op_redoop->op_type == OP_NULL)
14289                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14290             while (cLOOP->op_nextop->op_type == OP_NULL)
14291                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14292             while (cLOOP->op_lastop->op_type == OP_NULL)
14293                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14294             /* a while(1) loop doesn't have an op_next that escapes the
14295              * loop, so we have to explicitly follow the op_lastop to
14296              * process the rest of the code */
14297             DEFER(cLOOP->op_lastop);
14298             break;
14299
14300         case OP_ENTERTRY:
14301             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14302             DEFER(cLOGOPo->op_other);
14303             break;
14304
14305         case OP_SUBST:
14306             assert(!(cPMOP->op_pmflags & PMf_ONCE));
14307             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14308                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14309                 cPMOP->op_pmstashstartu.op_pmreplstart
14310                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14311             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14312             break;
14313
14314         case OP_SORT: {
14315             OP *oright;
14316
14317             if (o->op_flags & OPf_SPECIAL) {
14318                 /* first arg is a code block */
14319                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14320                 OP * kid          = cUNOPx(nullop)->op_first;
14321
14322                 assert(nullop->op_type == OP_NULL);
14323                 assert(kid->op_type == OP_SCOPE
14324                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14325                 /* since OP_SORT doesn't have a handy op_other-style
14326                  * field that can point directly to the start of the code
14327                  * block, store it in the otherwise-unused op_next field
14328                  * of the top-level OP_NULL. This will be quicker at
14329                  * run-time, and it will also allow us to remove leading
14330                  * OP_NULLs by just messing with op_nexts without
14331                  * altering the basic op_first/op_sibling layout. */
14332                 kid = kLISTOP->op_first;
14333                 assert(
14334                       (kid->op_type == OP_NULL
14335                       && (  kid->op_targ == OP_NEXTSTATE
14336                          || kid->op_targ == OP_DBSTATE  ))
14337                     || kid->op_type == OP_STUB
14338                     || kid->op_type == OP_ENTER);
14339                 nullop->op_next = kLISTOP->op_next;
14340                 DEFER(nullop->op_next);
14341             }
14342
14343             /* check that RHS of sort is a single plain array */
14344             oright = cUNOPo->op_first;
14345             if (!oright || oright->op_type != OP_PUSHMARK)
14346                 break;
14347
14348             if (o->op_private & OPpSORT_INPLACE)
14349                 break;
14350
14351             /* reverse sort ... can be optimised.  */
14352             if (!OpHAS_SIBLING(cUNOPo)) {
14353                 /* Nothing follows us on the list. */
14354                 OP * const reverse = o->op_next;
14355
14356                 if (reverse->op_type == OP_REVERSE &&
14357                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14358                     OP * const pushmark = cUNOPx(reverse)->op_first;
14359                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14360                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14361                         /* reverse -> pushmark -> sort */
14362                         o->op_private |= OPpSORT_REVERSE;
14363                         op_null(reverse);
14364                         pushmark->op_next = oright->op_next;
14365                         op_null(oright);
14366                     }
14367                 }
14368             }
14369
14370             break;
14371         }
14372
14373         case OP_REVERSE: {
14374             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14375             OP *gvop = NULL;
14376             LISTOP *enter, *exlist;
14377
14378             if (o->op_private & OPpSORT_INPLACE)
14379                 break;
14380
14381             enter = (LISTOP *) o->op_next;
14382             if (!enter)
14383                 break;
14384             if (enter->op_type == OP_NULL) {
14385                 enter = (LISTOP *) enter->op_next;
14386                 if (!enter)
14387                     break;
14388             }
14389             /* for $a (...) will have OP_GV then OP_RV2GV here.
14390                for (...) just has an OP_GV.  */
14391             if (enter->op_type == OP_GV) {
14392                 gvop = (OP *) enter;
14393                 enter = (LISTOP *) enter->op_next;
14394                 if (!enter)
14395                     break;
14396                 if (enter->op_type == OP_RV2GV) {
14397                   enter = (LISTOP *) enter->op_next;
14398                   if (!enter)
14399                     break;
14400                 }
14401             }
14402
14403             if (enter->op_type != OP_ENTERITER)
14404                 break;
14405
14406             iter = enter->op_next;
14407             if (!iter || iter->op_type != OP_ITER)
14408                 break;
14409
14410             expushmark = enter->op_first;
14411             if (!expushmark || expushmark->op_type != OP_NULL
14412                 || expushmark->op_targ != OP_PUSHMARK)
14413                 break;
14414
14415             exlist = (LISTOP *) OpSIBLING(expushmark);
14416             if (!exlist || exlist->op_type != OP_NULL
14417                 || exlist->op_targ != OP_LIST)
14418                 break;
14419
14420             if (exlist->op_last != o) {
14421                 /* Mmm. Was expecting to point back to this op.  */
14422                 break;
14423             }
14424             theirmark = exlist->op_first;
14425             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14426                 break;
14427
14428             if (OpSIBLING(theirmark) != o) {
14429                 /* There's something between the mark and the reverse, eg
14430                    for (1, reverse (...))
14431                    so no go.  */
14432                 break;
14433             }
14434
14435             ourmark = ((LISTOP *)o)->op_first;
14436             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14437                 break;
14438
14439             ourlast = ((LISTOP *)o)->op_last;
14440             if (!ourlast || ourlast->op_next != o)
14441                 break;
14442
14443             rv2av = OpSIBLING(ourmark);
14444             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14445                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14446                 /* We're just reversing a single array.  */
14447                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14448                 enter->op_flags |= OPf_STACKED;
14449             }
14450
14451             /* We don't have control over who points to theirmark, so sacrifice
14452                ours.  */
14453             theirmark->op_next = ourmark->op_next;
14454             theirmark->op_flags = ourmark->op_flags;
14455             ourlast->op_next = gvop ? gvop : (OP *) enter;
14456             op_null(ourmark);
14457             op_null(o);
14458             enter->op_private |= OPpITER_REVERSED;
14459             iter->op_private |= OPpITER_REVERSED;
14460
14461             oldoldop = NULL;
14462             oldop    = ourlast;
14463             o        = oldop->op_next;
14464             goto redo;
14465             NOT_REACHED; /* NOTREACHED */
14466             break;
14467         }
14468
14469         case OP_QR:
14470         case OP_MATCH:
14471             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14472                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14473             }
14474             break;
14475
14476         case OP_RUNCV:
14477             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14478              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14479             {
14480                 SV *sv;
14481                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14482                 else {
14483                     sv = newRV((SV *)PL_compcv);
14484                     sv_rvweaken(sv);
14485                     SvREADONLY_on(sv);
14486                 }
14487                 OpTYPE_set(o, OP_CONST);
14488                 o->op_flags |= OPf_SPECIAL;
14489                 cSVOPo->op_sv = sv;
14490             }
14491             break;
14492
14493         case OP_SASSIGN:
14494             if (OP_GIMME(o,0) == G_VOID
14495              || (  o->op_next->op_type == OP_LINESEQ
14496                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
14497                    || (  o->op_next->op_next->op_type == OP_RETURN
14498                       && !CvLVALUE(PL_compcv)))))
14499             {
14500                 OP *right = cBINOP->op_first;
14501                 if (right) {
14502                     /*   sassign
14503                     *      RIGHT
14504                     *      substr
14505                     *         pushmark
14506                     *         arg1
14507                     *         arg2
14508                     *         ...
14509                     * becomes
14510                     *
14511                     *  ex-sassign
14512                     *     substr
14513                     *        pushmark
14514                     *        RIGHT
14515                     *        arg1
14516                     *        arg2
14517                     *        ...
14518                     */
14519                     OP *left = OpSIBLING(right);
14520                     if (left->op_type == OP_SUBSTR
14521                          && (left->op_private & 7) < 4) {
14522                         op_null(o);
14523                         /* cut out right */
14524                         op_sibling_splice(o, NULL, 1, NULL);
14525                         /* and insert it as second child of OP_SUBSTR */
14526                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14527                                     right);
14528                         left->op_private |= OPpSUBSTR_REPL_FIRST;
14529                         left->op_flags =
14530                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14531                     }
14532                 }
14533             }
14534             break;
14535
14536         case OP_AASSIGN: {
14537             int l, r, lr, lscalars, rscalars;
14538
14539             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14540                Note that we do this now rather than in newASSIGNOP(),
14541                since only by now are aliased lexicals flagged as such
14542
14543                See the essay "Common vars in list assignment" above for
14544                the full details of the rationale behind all the conditions
14545                below.
14546
14547                PL_generation sorcery:
14548                To detect whether there are common vars, the global var
14549                PL_generation is incremented for each assign op we scan.
14550                Then we run through all the lexical variables on the LHS,
14551                of the assignment, setting a spare slot in each of them to
14552                PL_generation.  Then we scan the RHS, and if any lexicals
14553                already have that value, we know we've got commonality.
14554                Also, if the generation number is already set to
14555                PERL_INT_MAX, then the variable is involved in aliasing, so
14556                we also have potential commonality in that case.
14557              */
14558
14559             PL_generation++;
14560             /* scan LHS */
14561             lscalars = 0;
14562             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
14563             /* scan RHS */
14564             rscalars = 0;
14565             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14566             lr = (l|r);
14567
14568
14569             /* After looking for things which are *always* safe, this main
14570              * if/else chain selects primarily based on the type of the
14571              * LHS, gradually working its way down from the more dangerous
14572              * to the more restrictive and thus safer cases */
14573
14574             if (   !l                      /* () = ....; */
14575                 || !r                      /* .... = (); */
14576                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14577                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14578                 || (lscalars < 2)          /* ($x, undef) = ... */
14579             ) {
14580                 NOOP; /* always safe */
14581             }
14582             else if (l & AAS_DANGEROUS) {
14583                 /* always dangerous */
14584                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14585                 o->op_private |= OPpASSIGN_COMMON_AGG;
14586             }
14587             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14588                 /* package vars are always dangerous - too many
14589                  * aliasing possibilities */
14590                 if (l & AAS_PKG_SCALAR)
14591                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
14592                 if (l & AAS_PKG_AGG)
14593                     o->op_private |= OPpASSIGN_COMMON_AGG;
14594             }
14595             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14596                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
14597             {
14598                 /* LHS contains only lexicals and safe ops */
14599
14600                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14601                     o->op_private |= OPpASSIGN_COMMON_AGG;
14602
14603                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14604                     if (lr & AAS_LEX_SCALAR_COMM)
14605                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
14606                     else if (   !(l & AAS_LEX_SCALAR)
14607                              && (r & AAS_DEFAV))
14608                     {
14609                         /* falsely mark
14610                          *    my (...) = @_
14611                          * as scalar-safe for performance reasons.
14612                          * (it will still have been marked _AGG if necessary */
14613                         NOOP;
14614                     }
14615                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14616                         /* if there are only lexicals on the LHS and no
14617                          * common ones on the RHS, then we assume that the
14618                          * only way those lexicals could also get
14619                          * on the RHS is via some sort of dereffing or
14620                          * closure, e.g.
14621                          *    $r = \$lex;
14622                          *    ($lex, $x) = (1, $$r)
14623                          * and in this case we assume the var must have
14624                          *  a bumped ref count. So if its ref count is 1,
14625                          *  it must only be on the LHS.
14626                          */
14627                         o->op_private |= OPpASSIGN_COMMON_RC1;
14628                 }
14629             }
14630
14631             /* ... = ($x)
14632              * may have to handle aggregate on LHS, but we can't
14633              * have common scalars. */
14634             if (rscalars < 2)
14635                 o->op_private &=
14636                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14637
14638             break;
14639         }
14640
14641         case OP_CUSTOM: {
14642             Perl_cpeep_t cpeep =
14643                 XopENTRYCUSTOM(o, xop_peep);
14644             if (cpeep)
14645                 cpeep(aTHX_ o, oldop);
14646             break;
14647         }
14648
14649         }
14650         /* did we just null the current op? If so, re-process it to handle
14651          * eliding "empty" ops from the chain */
14652         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14653             o->op_opt = 0;
14654             o = oldop;
14655         }
14656         else {
14657             oldoldop = oldop;
14658             oldop = o;
14659         }
14660     }
14661     LEAVE;
14662 }
14663
14664 void
14665 Perl_peep(pTHX_ OP *o)
14666 {
14667     CALL_RPEEP(o);
14668 }
14669
14670 /*
14671 =head1 Custom Operators
14672
14673 =for apidoc Ao||custom_op_xop
14674 Return the XOP structure for a given custom op.  This macro should be
14675 considered internal to C<OP_NAME> and the other access macros: use them instead.
14676 This macro does call a function.  Prior
14677 to 5.19.6, this was implemented as a
14678 function.
14679
14680 =cut
14681 */
14682
14683 XOPRETANY
14684 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14685 {
14686     SV *keysv;
14687     HE *he = NULL;
14688     XOP *xop;
14689
14690     static const XOP xop_null = { 0, 0, 0, 0, 0 };
14691
14692     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14693     assert(o->op_type == OP_CUSTOM);
14694
14695     /* This is wrong. It assumes a function pointer can be cast to IV,
14696      * which isn't guaranteed, but this is what the old custom OP code
14697      * did. In principle it should be safer to Copy the bytes of the
14698      * pointer into a PV: since the new interface is hidden behind
14699      * functions, this can be changed later if necessary.  */
14700     /* Change custom_op_xop if this ever happens */
14701     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14702
14703     if (PL_custom_ops)
14704         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14705
14706     /* assume noone will have just registered a desc */
14707     if (!he && PL_custom_op_names &&
14708         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14709     ) {
14710         const char *pv;
14711         STRLEN l;
14712
14713         /* XXX does all this need to be shared mem? */
14714         Newxz(xop, 1, XOP);
14715         pv = SvPV(HeVAL(he), l);
14716         XopENTRY_set(xop, xop_name, savepvn(pv, l));
14717         if (PL_custom_op_descs &&
14718             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14719         ) {
14720             pv = SvPV(HeVAL(he), l);
14721             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14722         }
14723         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14724     }
14725     else {
14726         if (!he)
14727             xop = (XOP *)&xop_null;
14728         else
14729             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14730     }
14731     {
14732         XOPRETANY any;
14733         if(field == XOPe_xop_ptr) {
14734             any.xop_ptr = xop;
14735         } else {
14736             const U32 flags = XopFLAGS(xop);
14737             if(flags & field) {
14738                 switch(field) {
14739                 case XOPe_xop_name:
14740                     any.xop_name = xop->xop_name;
14741                     break;
14742                 case XOPe_xop_desc:
14743                     any.xop_desc = xop->xop_desc;
14744                     break;
14745                 case XOPe_xop_class:
14746                     any.xop_class = xop->xop_class;
14747                     break;
14748                 case XOPe_xop_peep:
14749                     any.xop_peep = xop->xop_peep;
14750                     break;
14751                 default:
14752                     NOT_REACHED; /* NOTREACHED */
14753                     break;
14754                 }
14755             } else {
14756                 switch(field) {
14757                 case XOPe_xop_name:
14758                     any.xop_name = XOPd_xop_name;
14759                     break;
14760                 case XOPe_xop_desc:
14761                     any.xop_desc = XOPd_xop_desc;
14762                     break;
14763                 case XOPe_xop_class:
14764                     any.xop_class = XOPd_xop_class;
14765                     break;
14766                 case XOPe_xop_peep:
14767                     any.xop_peep = XOPd_xop_peep;
14768                     break;
14769                 default:
14770                     NOT_REACHED; /* NOTREACHED */
14771                     break;
14772                 }
14773             }
14774         }
14775         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14776          * op.c: In function 'Perl_custom_op_get_field':
14777          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14778          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14779          * expands to assert(0), which expands to ((0) ? (void)0 :
14780          * __assert(...)), and gcc doesn't know that __assert can never return. */
14781         return any;
14782     }
14783 }
14784
14785 /*
14786 =for apidoc Ao||custom_op_register
14787 Register a custom op.  See L<perlguts/"Custom Operators">.
14788
14789 =cut
14790 */
14791
14792 void
14793 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14794 {
14795     SV *keysv;
14796
14797     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14798
14799     /* see the comment in custom_op_xop */
14800     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14801
14802     if (!PL_custom_ops)
14803         PL_custom_ops = newHV();
14804
14805     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14806         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14807 }
14808
14809 /*
14810
14811 =for apidoc core_prototype
14812
14813 This function assigns the prototype of the named core function to C<sv>, or
14814 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
14815 C<NULL> if the core function has no prototype.  C<code> is a code as returned
14816 by C<keyword()>.  It must not be equal to 0.
14817
14818 =cut
14819 */
14820
14821 SV *
14822 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14823                           int * const opnum)
14824 {
14825     int i = 0, n = 0, seen_question = 0, defgv = 0;
14826     I32 oa;
14827 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14828     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14829     bool nullret = FALSE;
14830
14831     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14832
14833     assert (code);
14834
14835     if (!sv) sv = sv_newmortal();
14836
14837 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14838
14839     switch (code < 0 ? -code : code) {
14840     case KEY_and   : case KEY_chop: case KEY_chomp:
14841     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
14842     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
14843     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
14844     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
14845     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
14846     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
14847     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
14848     case KEY_x     : case KEY_xor    :
14849         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14850     case KEY_glob:    retsetpvs("_;", OP_GLOB);
14851     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
14852     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
14853     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
14854     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
14855     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14856         retsetpvs("", 0);
14857     case KEY_evalbytes:
14858         name = "entereval"; break;
14859     case KEY_readpipe:
14860         name = "backtick";
14861     }
14862
14863 #undef retsetpvs
14864
14865   findopnum:
14866     while (i < MAXO) {  /* The slow way. */
14867         if (strEQ(name, PL_op_name[i])
14868             || strEQ(name, PL_op_desc[i]))
14869         {
14870             if (nullret) { assert(opnum); *opnum = i; return NULL; }
14871             goto found;
14872         }
14873         i++;
14874     }
14875     return NULL;
14876   found:
14877     defgv = PL_opargs[i] & OA_DEFGV;
14878     oa = PL_opargs[i] >> OASHIFT;
14879     while (oa) {
14880         if (oa & OA_OPTIONAL && !seen_question && (
14881               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14882         )) {
14883             seen_question = 1;
14884             str[n++] = ';';
14885         }
14886         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14887             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14888             /* But globs are already references (kinda) */
14889             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14890         ) {
14891             str[n++] = '\\';
14892         }
14893         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14894          && !scalar_mod_type(NULL, i)) {
14895             str[n++] = '[';
14896             str[n++] = '$';
14897             str[n++] = '@';
14898             str[n++] = '%';
14899             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14900             str[n++] = '*';
14901             str[n++] = ']';
14902         }
14903         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14904         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14905             str[n-1] = '_'; defgv = 0;
14906         }
14907         oa = oa >> 4;
14908     }
14909     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14910     str[n++] = '\0';
14911     sv_setpvn(sv, str, n - 1);
14912     if (opnum) *opnum = i;
14913     return sv;
14914 }
14915
14916 OP *
14917 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14918                       const int opnum)
14919 {
14920     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14921     OP *o;
14922
14923     PERL_ARGS_ASSERT_CORESUB_OP;
14924
14925     switch(opnum) {
14926     case 0:
14927         return op_append_elem(OP_LINESEQ,
14928                        argop,
14929                        newSLICEOP(0,
14930                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14931                                   newOP(OP_CALLER,0)
14932                        )
14933                );
14934     case OP_EACH:
14935     case OP_KEYS:
14936     case OP_VALUES:
14937         o = newUNOP(OP_AVHVSWITCH,0,argop);
14938         o->op_private = opnum-OP_EACH;
14939         return o;
14940     case OP_SELECT: /* which represents OP_SSELECT as well */
14941         if (code)
14942             return newCONDOP(
14943                          0,
14944                          newBINOP(OP_GT, 0,
14945                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14946                                   newSVOP(OP_CONST, 0, newSVuv(1))
14947                                  ),
14948                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
14949                                     OP_SSELECT),
14950                          coresub_op(coreargssv, 0, OP_SELECT)
14951                    );
14952         /* FALLTHROUGH */
14953     default:
14954         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14955         case OA_BASEOP:
14956             return op_append_elem(
14957                         OP_LINESEQ, argop,
14958                         newOP(opnum,
14959                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
14960                                 ? OPpOFFBYONE << 8 : 0)
14961                    );
14962         case OA_BASEOP_OR_UNOP:
14963             if (opnum == OP_ENTEREVAL) {
14964                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14965                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14966             }
14967             else o = newUNOP(opnum,0,argop);
14968             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14969             else {
14970           onearg:
14971               if (is_handle_constructor(o, 1))
14972                 argop->op_private |= OPpCOREARGS_DEREF1;
14973               if (scalar_mod_type(NULL, opnum))
14974                 argop->op_private |= OPpCOREARGS_SCALARMOD;
14975             }
14976             return o;
14977         default:
14978             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14979             if (is_handle_constructor(o, 2))
14980                 argop->op_private |= OPpCOREARGS_DEREF2;
14981             if (opnum == OP_SUBSTR) {
14982                 o->op_private |= OPpMAYBE_LVSUB;
14983                 return o;
14984             }
14985             else goto onearg;
14986         }
14987     }
14988 }
14989
14990 void
14991 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14992                                SV * const *new_const_svp)
14993 {
14994     const char *hvname;
14995     bool is_const = !!CvCONST(old_cv);
14996     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14997
14998     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14999
15000     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15001         return;
15002         /* They are 2 constant subroutines generated from
15003            the same constant. This probably means that
15004            they are really the "same" proxy subroutine
15005            instantiated in 2 places. Most likely this is
15006            when a constant is exported twice.  Don't warn.
15007         */
15008     if (
15009         (ckWARN(WARN_REDEFINE)
15010          && !(
15011                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15012              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15013              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15014                  strEQ(hvname, "autouse"))
15015              )
15016         )
15017      || (is_const
15018          && ckWARN_d(WARN_REDEFINE)
15019          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15020         )
15021     )
15022         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15023                           is_const
15024                             ? "Constant subroutine %" SVf " redefined"
15025                             : "Subroutine %" SVf " redefined",
15026                           SVfARG(name));
15027 }
15028
15029 /*
15030 =head1 Hook manipulation
15031
15032 These functions provide convenient and thread-safe means of manipulating
15033 hook variables.
15034
15035 =cut
15036 */
15037
15038 /*
15039 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15040
15041 Puts a C function into the chain of check functions for a specified op
15042 type.  This is the preferred way to manipulate the L</PL_check> array.
15043 C<opcode> specifies which type of op is to be affected.  C<new_checker>
15044 is a pointer to the C function that is to be added to that opcode's
15045 check chain, and C<old_checker_p> points to the storage location where a
15046 pointer to the next function in the chain will be stored.  The value of
15047 C<new_pointer> is written into the L</PL_check> array, while the value
15048 previously stored there is written to C<*old_checker_p>.
15049
15050 The function should be defined like this:
15051
15052     static OP *new_checker(pTHX_ OP *op) { ... }
15053
15054 It is intended to be called in this manner:
15055
15056     new_checker(aTHX_ op)
15057
15058 C<old_checker_p> should be defined like this:
15059
15060     static Perl_check_t old_checker_p;
15061
15062 L</PL_check> is global to an entire process, and a module wishing to
15063 hook op checking may find itself invoked more than once per process,
15064 typically in different threads.  To handle that situation, this function
15065 is idempotent.  The location C<*old_checker_p> must initially (once
15066 per process) contain a null pointer.  A C variable of static duration
15067 (declared at file scope, typically also marked C<static> to give
15068 it internal linkage) will be implicitly initialised appropriately,
15069 if it does not have an explicit initialiser.  This function will only
15070 actually modify the check chain if it finds C<*old_checker_p> to be null.
15071 This function is also thread safe on the small scale.  It uses appropriate
15072 locking to avoid race conditions in accessing L</PL_check>.
15073
15074 When this function is called, the function referenced by C<new_checker>
15075 must be ready to be called, except for C<*old_checker_p> being unfilled.
15076 In a threading situation, C<new_checker> may be called immediately,
15077 even before this function has returned.  C<*old_checker_p> will always
15078 be appropriately set before C<new_checker> is called.  If C<new_checker>
15079 decides not to do anything special with an op that it is given (which
15080 is the usual case for most uses of op check hooking), it must chain the
15081 check function referenced by C<*old_checker_p>.
15082
15083 If you want to influence compilation of calls to a specific subroutine,
15084 then use L</cv_set_call_checker> rather than hooking checking of all
15085 C<entersub> ops.
15086
15087 =cut
15088 */
15089
15090 void
15091 Perl_wrap_op_checker(pTHX_ Optype opcode,
15092     Perl_check_t new_checker, Perl_check_t *old_checker_p)
15093 {
15094     dVAR;
15095
15096     PERL_UNUSED_CONTEXT;
15097     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15098     if (*old_checker_p) return;
15099     OP_CHECK_MUTEX_LOCK;
15100     if (!*old_checker_p) {
15101         *old_checker_p = PL_check[opcode];
15102         PL_check[opcode] = new_checker;
15103     }
15104     OP_CHECK_MUTEX_UNLOCK;
15105 }
15106
15107 #include "XSUB.h"
15108
15109 /* Efficient sub that returns a constant scalar value. */
15110 static void
15111 const_sv_xsub(pTHX_ CV* cv)
15112 {
15113     dXSARGS;
15114     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15115     PERL_UNUSED_ARG(items);
15116     if (!sv) {
15117         XSRETURN(0);
15118     }
15119     EXTEND(sp, 1);
15120     ST(0) = sv;
15121     XSRETURN(1);
15122 }
15123
15124 static void
15125 const_av_xsub(pTHX_ CV* cv)
15126 {
15127     dXSARGS;
15128     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15129     SP -= items;
15130     assert(av);
15131 #ifndef DEBUGGING
15132     if (!av) {
15133         XSRETURN(0);
15134     }
15135 #endif
15136     if (SvRMAGICAL(av))
15137         Perl_croak(aTHX_ "Magical list constants are not supported");
15138     if (GIMME_V != G_ARRAY) {
15139         EXTEND(SP, 1);
15140         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15141         XSRETURN(1);
15142     }
15143     EXTEND(SP, AvFILLp(av)+1);
15144     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15145     XSRETURN(AvFILLp(av)+1);
15146 }
15147
15148
15149 /*
15150  * ex: set ts=8 sts=4 sw=4 et:
15151  */