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 dDEFER_OP  \
 179     SSize_t defer_stack_alloc = 0; \
 180     SSize_t defer_ix = -1; \
 181     OP **defer_stack = NULL;
 182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
 183 #define DEFERRED_OP_STEP 100
 184 #define DEFER_OP(o) \
 185   STMT_START { \
 186     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 187         defer_stack_alloc += DEFERRED_OP_STEP; \
 188         assert(defer_stack_alloc > 0); \
 189         Renew(defer_stack, defer_stack_alloc, OP *); \
 190     } \
 191     defer_stack[++defer_ix] = o; \
 192   } STMT_END
 193 #define DEFER_REVERSE(count)                            \
 194     STMT_START {                                        \
 195         UV cnt = (count);                               \
 196         if (cnt > 1) {                                  \
 197             OP **top = defer_stack + defer_ix;          \
 198             /* top - (cnt) + 1 isn't safe here */       \
 199             OP **bottom = top - (cnt - 1);              \
 200             OP *tmp;                                    \
 201             assert(bottom >= defer_stack);              \
 202             while (top > bottom) {                      \
 203                 tmp = *top;                             \
 204                 *top-- = *bottom;                       \
 205                 *bottom++ = tmp;                        \
 206             }                                           \
 207         }                                               \
 208     } STMT_END;
 209
 210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 211
 212 /* remove any leading "empty" ops from the op_next chain whose first
 213  * node's address is stored in op_p. Store the updated address of the
 214  * first node in op_p.
 215  */
 216
 217 STATIC void
 218 S_prune_chain_head(OP** op_p)
 219 {
 220     while (*op_p
 221         && (   (*op_p)->op_type == OP_NULL
 222             || (*op_p)->op_type == OP_SCOPE
 223             || (*op_p)->op_type == OP_SCALAR
 224             || (*op_p)->op_type == OP_LINESEQ)
 225     )
 226         *op_p = (*op_p)->op_next;
 227 }
 228
 229
 230 /* See the explanatory comments above struct opslab in op.h. */
 231
 232 #ifdef PERL_DEBUG_READONLY_OPS
 233 #  define PERL_SLAB_SIZE 128
 234 #  define PERL_MAX_SLAB_SIZE 4096
 235 #  include <sys/mman.h>
 236 #endif
 237
 238 #ifndef PERL_SLAB_SIZE
 239 #  define PERL_SLAB_SIZE 64
 240 #endif
 241 #ifndef PERL_MAX_SLAB_SIZE
 242 #  define PERL_MAX_SLAB_SIZE 2048
 243 #endif
 244
 245 /* rounds up to nearest pointer */
 246 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 247 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 248
 249 static OPSLAB *
 250 S_new_slab(pTHX_ size_t sz)
 251 {
 252 #ifdef PERL_DEBUG_READONLY_OPS
 253     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 254                                    PROT_READ|PROT_WRITE,
 255                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 256     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 257                           (unsigned long) sz, slab));
 258     if (slab == MAP_FAILED) {
 259         perror("mmap failed");
 260         abort();
 261     }
 262     slab->opslab_size = (U16)sz;
 263 #else
 264     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 265 #endif
 266 #ifndef WIN32
 267     /* The context is unused in non-Windows */
 268     PERL_UNUSED_CONTEXT;
 269 #endif
 270     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 271     return slab;
 272 }
 273
 274 /* requires double parens and aTHX_ */
 275 #define DEBUG_S_warn(args)                                             \
 276     DEBUG_S(                                                            \
 277         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 278     )
 279
 280 void *
 281 Perl_Slab_Alloc(pTHX_ size_t sz)
 282 {
 283     OPSLAB *slab;
 284     OPSLAB *slab2;
 285     OPSLOT *slot;
 286     OP *o;
 287     size_t opsz, space;
 288
 289     /* We only allocate ops from the slab during subroutine compilation.
 290        We find the slab via PL_compcv, hence that must be non-NULL. It could
 291        also be pointing to a subroutine which is now fully set up (CvROOT()
 292        pointing to the top of the optree for that sub), or a subroutine
 293        which isn't using the slab allocator. If our sanity checks aren't met,
 294        don't use a slab, but allocate the OP directly from the heap.  */
 295     if (!PL_compcv || CvROOT(PL_compcv)
 296      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 297     {
 298         o = (OP*)PerlMemShared_calloc(1, sz);
 299         goto gotit;
 300     }
 301
 302     /* While the subroutine is under construction, the slabs are accessed via
 303        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 304        unneeded at runtime. Once a subroutine is constructed, the slabs are
 305        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 306        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 307        details.  */
 308     if (!CvSTART(PL_compcv)) {
 309         CvSTART(PL_compcv) =
 310             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 311         CvSLABBED_on(PL_compcv);
 312         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 313     }
 314     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 315
 316     opsz = SIZE_TO_PSIZE(sz);
 317     sz = opsz + OPSLOT_HEADER_P;
 318
 319     /* The slabs maintain a free list of OPs. In particular, constant folding
 320        will free up OPs, so it makes sense to re-use them where possible. A
 321        freed up slot is used in preference to a new allocation.  */
 322     if (slab->opslab_freed) {
 323         OP **too = &slab->opslab_freed;
 324         o = *too;
 325         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 326         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 327             DEBUG_S_warn((aTHX_ "Alas! too small"));
 328             o = *(too = &o->op_next);
 329             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 330         }
 331         if (o) {
 332             *too = o->op_next;
 333             Zero(o, opsz, I32 *);
 334             o->op_slabbed = 1;
 335             goto gotit;
 336         }
 337     }
 338
 339 #define INIT_OPSLOT \
 340             slot->opslot_slab = slab;                   \
 341             slot->opslot_next = slab2->opslab_first;    \
 342             slab2->opslab_first = slot;                 \
 343             o = &slot->opslot_op;                       \
 344             o->op_slabbed = 1
 345
 346     /* The partially-filled slab is next in the chain. */
 347     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 348     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 349         /* Remaining space is too small. */
 350
 351         /* If we can fit a BASEOP, add it to the free chain, so as not
 352            to waste it. */
 353         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 354             slot = &slab2->opslab_slots;
 355             INIT_OPSLOT;
 356             o->op_type = OP_FREED;
 357             o->op_next = slab->opslab_freed;
 358             slab->opslab_freed = o;
 359         }
 360
 361         /* Create a new slab.  Make this one twice as big. */
 362         slot = slab2->opslab_first;
 363         while (slot->opslot_next) slot = slot->opslot_next;
 364         slab2 = S_new_slab(aTHX_
 365                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 366                                         ? PERL_MAX_SLAB_SIZE
 367                                         : (DIFF(slab2, slot)+1)*2);
 368         slab2->opslab_next = slab->opslab_next;
 369         slab->opslab_next = slab2;
 370     }
 371     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 372
 373     /* Create a new op slot */
 374     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 375     assert(slot >= &slab2->opslab_slots);
 376     if (DIFF(&slab2->opslab_slots, slot)
 377          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 378         slot = &slab2->opslab_slots;
 379     INIT_OPSLOT;
 380     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 381
 382   gotit:
 383     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 384     assert(!o->op_moresib);
 385     assert(!o->op_sibparent);
 386
 387     return (void *)o;
 388 }
 389
 390 #undef INIT_OPSLOT
 391
 392 #ifdef PERL_DEBUG_READONLY_OPS
 393 void
 394 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 395 {
 396     PERL_ARGS_ASSERT_SLAB_TO_RO;
 397
 398     if (slab->opslab_readonly) return;
 399     slab->opslab_readonly = 1;
 400     for (; slab; slab = slab->opslab_next) {
 401         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 402                               (unsigned long) slab->opslab_size, slab));*/
 403         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 404             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 405                              (unsigned long)slab->opslab_size, errno);
 406     }
 407 }
 408
 409 void
 410 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 411 {
 412     OPSLAB *slab2;
 413
 414     PERL_ARGS_ASSERT_SLAB_TO_RW;
 415
 416     if (!slab->opslab_readonly) return;
 417     slab2 = slab;
 418     for (; slab2; slab2 = slab2->opslab_next) {
 419         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 420                               (unsigned long) size, slab2));*/
 421         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 422                      PROT_READ|PROT_WRITE)) {
 423             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 424                              (unsigned long)slab2->opslab_size, errno);
 425         }
 426     }
 427     slab->opslab_readonly = 0;
 428 }
 429
 430 #else
 431 #  define Slab_to_rw(op)    NOOP
 432 #endif
 433
 434 /* This cannot possibly be right, but it was copied from the old slab
 435    allocator, to which it was originally added, without explanation, in
 436    commit 083fcd5. */
 437 #ifdef NETWARE
 438 #    define PerlMemShared PerlMem
 439 #endif
 440
 441 /* make freed ops die if they're inadvertently executed */
 442 #ifdef DEBUGGING
 443 static OP *
 444 S_pp_freed(pTHX)
 445 {
 446     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 447 }
 448 #endif
 449
 450 void
 451 Perl_Slab_Free(pTHX_ void *op)
 452 {
 453     OP * const o = (OP *)op;
 454     OPSLAB *slab;
 455
 456     PERL_ARGS_ASSERT_SLAB_FREE;
 457
 458 #ifdef DEBUGGING
 459     o->op_ppaddr = S_pp_freed;
 460 #endif
 461
 462     if (!o->op_slabbed) {
 463         if (!o->op_static)
 464             PerlMemShared_free(op);
 465         return;
 466     }
 467
 468     slab = OpSLAB(o);
 469     /* If this op is already freed, our refcount will get screwy. */
 470     assert(o->op_type != OP_FREED);
 471     o->op_type = OP_FREED;
 472     o->op_next = slab->opslab_freed;
 473     slab->opslab_freed = o;
 474     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 475     OpslabREFCNT_dec_padok(slab);
 476 }
 477
 478 void
 479 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 480 {
 481     const bool havepad = !!PL_comppad;
 482     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 483     if (havepad) {
 484         ENTER;
 485         PAD_SAVE_SETNULLPAD();
 486     }
 487     opslab_free(slab);
 488     if (havepad) LEAVE;
 489 }
 490
 491 void
 492 Perl_opslab_free(pTHX_ OPSLAB *slab)
 493 {
 494     OPSLAB *slab2;
 495     PERL_ARGS_ASSERT_OPSLAB_FREE;
 496     PERL_UNUSED_CONTEXT;
 497     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 498     assert(slab->opslab_refcnt == 1);
 499     do {
 500         slab2 = slab->opslab_next;
 501 #ifdef DEBUGGING
 502         slab->opslab_refcnt = ~(size_t)0;
 503 #endif
 504 #ifdef PERL_DEBUG_READONLY_OPS
 505         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 506                                                (void*)slab));
 507         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 508             perror("munmap failed");
 509             abort();
 510         }
 511 #else
 512         PerlMemShared_free(slab);
 513 #endif
 514         slab = slab2;
 515     } while (slab);
 516 }
 517
 518 void
 519 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 520 {
 521     OPSLAB *slab2;
 522 #ifdef DEBUGGING
 523     size_t savestack_count = 0;
 524 #endif
 525     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 526     slab2 = slab;
 527     do {
 528         OPSLOT *slot;
 529         for (slot = slab2->opslab_first;
 530              slot->opslot_next;
 531              slot = slot->opslot_next) {
 532             if (slot->opslot_op.op_type != OP_FREED
 533              && !(slot->opslot_op.op_savefree
 534 #ifdef DEBUGGING
 535                   && ++savestack_count
 536 #endif
 537                  )
 538             ) {
 539                 assert(slot->opslot_op.op_slabbed);
 540                 op_free(&slot->opslot_op);
 541                 if (slab->opslab_refcnt == 1) goto free;
 542             }
 543         }
 544     } while ((slab2 = slab2->opslab_next));
 545     /* > 1 because the CV still holds a reference count. */
 546     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 547 #ifdef DEBUGGING
 548         assert(savestack_count == slab->opslab_refcnt-1);
 549 #endif
 550         /* Remove the CV’s reference count. */
 551         slab->opslab_refcnt--;
 552         return;
 553     }
 554    free:
 555     opslab_free(slab);
 556 }
 557
 558 #ifdef PERL_DEBUG_READONLY_OPS
 559 OP *
 560 Perl_op_refcnt_inc(pTHX_ OP *o)
 561 {
 562     if(o) {
 563         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 564         if (slab && slab->opslab_readonly) {
 565             Slab_to_rw(slab);
 566             ++o->op_targ;
 567             Slab_to_ro(slab);
 568         } else {
 569             ++o->op_targ;
 570         }
 571     }
 572     return o;
 573
 574 }
 575
 576 PADOFFSET
 577 Perl_op_refcnt_dec(pTHX_ OP *o)
 578 {
 579     PADOFFSET result;
 580     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 581
 582     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 583
 584     if (slab && slab->opslab_readonly) {
 585         Slab_to_rw(slab);
 586         result = --o->op_targ;
 587         Slab_to_ro(slab);
 588     } else {
 589         result = --o->op_targ;
 590     }
 591     return result;
 592 }
 593 #endif
 594 /*
 595  * In the following definition, the ", (OP*)0" is just to make the compiler
 596  * think the expression is of the right type: croak actually does a Siglongjmp.
 597  */
 598 #define CHECKOP(type,o) \
 599     ((PL_op_mask && PL_op_mask[type])                           \
 600      ? ( op_free((OP*)o),                                       \
 601          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 602          (OP*)0 )                                               \
 603      : PL_check[type](aTHX_ (OP*)o))
 604
 605 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 606
 607 #define OpTYPE_set(o,type) \
 608     STMT_START {                                \
 609         o->op_type = (OPCODE)type;              \
 610         o->op_ppaddr = PL_ppaddr[type];         \
 611     } STMT_END
 612
 613 STATIC OP *
 614 S_no_fh_allowed(pTHX_ OP *o)
 615 {
 616     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 617
 618     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 619                  OP_DESC(o)));
 620     return o;
 621 }
 622
 623 STATIC OP *
 624 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 625 {
 626     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 627     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 628     return o;
 629 }
 630
 631 STATIC OP *
 632 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 633 {
 634     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 635
 636     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 637     return o;
 638 }
 639
 640 STATIC void
 641 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 642 {
 643     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 644
 645     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 646                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 647 }
 648
 649 /* remove flags var, its unused in all callers, move to to right end since gv
 650   and kid are always the same */
 651 STATIC void
 652 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 653 {
 654     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 655     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 656
 657     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 658                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 659 }
 660
 661 STATIC void
 662 S_no_bareword_allowed(pTHX_ OP *o)
 663 {
 664     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 665
 666     qerror(Perl_mess(aTHX_
 667                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 668                      SVfARG(cSVOPo_sv)));
 669     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 670 }
 671
 672 /* "register" allocation */
 673
 674 PADOFFSET
 675 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 676 {
 677     PADOFFSET off;
 678     const bool is_our = (PL_parser->in_my == KEY_our);
 679
 680     PERL_ARGS_ASSERT_ALLOCMY;
 681
 682     if (flags & ~SVf_UTF8)
 683         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 684                    (UV)flags);
 685
 686     /* complain about "my $<special_var>" etc etc */
 687     if (   len
 688         && !(  is_our
 689             || isALPHA(name[1])
 690             || (   (flags & SVf_UTF8)
 691                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 692             || (name[1] == '_' && len > 2)))
 693     {
 694         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 695          && isASCII(name[1])
 696          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 697             /* diag_listed_as: Can't use global %s in "%s" */
 698             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 699                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 700                               PL_parser->in_my == KEY_state ? "state" : "my"));
 701         } else {
 702             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 703                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 704         }
 705     }
 706
 707     /* allocate a spare slot and store the name in that slot */
 708
 709     off = pad_add_name_pvn(name, len,
 710                        (is_our ? padadd_OUR :
 711                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 712                     PL_parser->in_my_stash,
 713                     (is_our
 714                         /* $_ is always in main::, even with our */
 715                         ? (PL_curstash && !memEQs(name,len,"$_")
 716                             ? PL_curstash
 717                             : PL_defstash)
 718                         : NULL
 719                     )
 720     );
 721     /* anon sub prototypes contains state vars should always be cloned,
 722      * otherwise the state var would be shared between anon subs */
 723
 724     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 725         CvCLONE_on(PL_compcv);
 726
 727     return off;
 728 }
 729
 730 /*
 731 =head1 Optree Manipulation Functions
 732
 733 =for apidoc alloccopstash
 734
 735 Available only under threaded builds, this function allocates an entry in
 736 C<PL_stashpad> for the stash passed to it.
 737
 738 =cut
 739 */
 740
 741 #ifdef USE_ITHREADS
 742 PADOFFSET
 743 Perl_alloccopstash(pTHX_ HV *hv)
 744 {
 745     PADOFFSET off = 0, o = 1;
 746     bool found_slot = FALSE;
 747
 748     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 749
 750     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 751
 752     for (; o < PL_stashpadmax; ++o) {
 753         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 754         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 755             found_slot = TRUE, off = o;
 756     }
 757     if (!found_slot) {
 758         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 759         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 760         off = PL_stashpadmax;
 761         PL_stashpadmax += 10;
 762     }
 763
 764     PL_stashpad[PL_stashpadix = off] = hv;
 765     return off;
 766 }
 767 #endif
 768
 769 /* free the body of an op without examining its contents.
 770  * Always use this rather than FreeOp directly */
 771
 772 static void
 773 S_op_destroy(pTHX_ OP *o)
 774 {
 775     FreeOp(o);
 776 }
 777
 778 /* Destructor */
 779
 780 /*
 781 =for apidoc Am|void|op_free|OP *o
 782
 783 Free an op.  Only use this when an op is no longer linked to from any
 784 optree.
 785
 786 =cut
 787 */
 788
 789 void
 790 Perl_op_free(pTHX_ OP *o)
 791 {
 792     dVAR;
 793     OPCODE type;
 794     dDEFER_OP;
 795
 796     do {
 797
 798         /* Though ops may be freed twice, freeing the op after its slab is a
 799            big no-no. */
 800         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 801         /* During the forced freeing of ops after compilation failure, kidops
 802            may be freed before their parents. */
 803         if (!o || o->op_type == OP_FREED)
 804             continue;
 805
 806         type = o->op_type;
 807
 808         /* an op should only ever acquire op_private flags that we know about.
 809          * If this fails, you may need to fix something in regen/op_private.
 810          * Don't bother testing if:
 811          *   * the op_ppaddr doesn't match the op; someone may have
 812          *     overridden the op and be doing strange things with it;
 813          *   * we've errored, as op flags are often left in an
 814          *     inconsistent state then. Note that an error when
 815          *     compiling the main program leaves PL_parser NULL, so
 816          *     we can't spot faults in the main code, only
 817          *     evaled/required code */
 818 #ifdef DEBUGGING
 819         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 820             && PL_parser
 821             && !PL_parser->error_count)
 822         {
 823             assert(!(o->op_private & ~PL_op_private_valid[type]));
 824         }
 825 #endif
 826
 827         if (o->op_private & OPpREFCOUNTED) {
 828             switch (type) {
 829             case OP_LEAVESUB:
 830             case OP_LEAVESUBLV:
 831             case OP_LEAVEEVAL:
 832             case OP_LEAVE:
 833             case OP_SCOPE:
 834             case OP_LEAVEWRITE:
 835                 {
 836                 PADOFFSET refcnt;
 837                 OP_REFCNT_LOCK;
 838                 refcnt = OpREFCNT_dec(o);
 839                 OP_REFCNT_UNLOCK;
 840                 if (refcnt) {
 841                     /* Need to find and remove any pattern match ops from the list
 842                        we maintain for reset().  */
 843                     find_and_forget_pmops(o);
 844                     continue;
 845                 }
 846                 }
 847                 break;
 848             default:
 849                 break;
 850             }
 851         }
 852
 853         /* Call the op_free hook if it has been set. Do it now so that it's called
 854          * at the right time for refcounted ops, but still before all of the kids
 855          * are freed. */
 856         CALL_OPFREEHOOK(o);
 857
 858         if (o->op_flags & OPf_KIDS) {
 859             OP *kid, *nextkid;
 860             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 861                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 862                 if (!kid || kid->op_type == OP_FREED)
 863                     /* During the forced freeing of ops after
 864                        compilation failure, kidops may be freed before
 865                        their parents. */
 866                     continue;
 867                 if (!(kid->op_flags & OPf_KIDS))
 868                     /* If it has no kids, just free it now */
 869                     op_free(kid);
 870                 else
 871                     DEFER_OP(kid);
 872             }
 873         }
 874         if (type == OP_NULL)
 875             type = (OPCODE)o->op_targ;
 876
 877         if (o->op_slabbed)
 878             Slab_to_rw(OpSLAB(o));
 879
 880         /* COP* is not cleared by op_clear() so that we may track line
 881          * numbers etc even after null() */
 882         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 883             cop_free((COP*)o);
 884         }
 885
 886         op_clear(o);
 887         FreeOp(o);
 888         if (PL_op == o)
 889             PL_op = NULL;
 890     } while ( (o = POP_DEFERRED_OP()) );
 891
 892     DEFER_OP_CLEANUP;
 893 }
 894
 895 /* S_op_clear_gv(): free a GV attached to an OP */
 896
 897 STATIC
 898 #ifdef USE_ITHREADS
 899 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 900 #else
 901 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 902 #endif
 903 {
 904
 905     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 906             || o->op_type == OP_MULTIDEREF)
 907 #ifdef USE_ITHREADS
 908                 && PL_curpad
 909                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 910 #else
 911                 ? (GV*)(*svp) : NULL;
 912 #endif
 913     /* It's possible during global destruction that the GV is freed
 914        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 915        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 916        will trigger an assertion failure, because the entry to sv_clear
 917        checks that the scalar is not already freed.  A check of for
 918        !SvIS_FREED(gv) turns out to be invalid, because during global
 919        destruction the reference count can be forced down to zero
 920        (with SVf_BREAK set).  In which case raising to 1 and then
 921        dropping to 0 triggers cleanup before it should happen.  I
 922        *think* that this might actually be a general, systematic,
 923        weakness of the whole idea of SVf_BREAK, in that code *is*
 924        allowed to raise and lower references during global destruction,
 925        so any *valid* code that happens to do this during global
 926        destruction might well trigger premature cleanup.  */
 927     bool still_valid = gv && SvREFCNT(gv);
 928
 929     if (still_valid)
 930         SvREFCNT_inc_simple_void(gv);
 931 #ifdef USE_ITHREADS
 932     if (*ixp > 0) {
 933         pad_swipe(*ixp, TRUE);
 934         *ixp = 0;
 935     }
 936 #else
 937     SvREFCNT_dec(*svp);
 938     *svp = NULL;
 939 #endif
 940     if (still_valid) {
 941         int try_downgrade = SvREFCNT(gv) == 2;
 942         SvREFCNT_dec_NN(gv);
 943         if (try_downgrade)
 944             gv_try_downgrade(gv);
 945     }
 946 }
 947
 948
 949 void
 950 Perl_op_clear(pTHX_ OP *o)
 951 {
 952
 953     dVAR;
 954
 955     PERL_ARGS_ASSERT_OP_CLEAR;
 956
 957     switch (o->op_type) {
 958     case OP_NULL:       /* Was holding old type, if any. */
 959         /* FALLTHROUGH */
 960     case OP_ENTERTRY:
 961     case OP_ENTEREVAL:  /* Was holding hints. */
 962     case OP_ARGDEFELEM: /* Was holding signature index. */
 963         o->op_targ = 0;
 964         break;
 965     default:
 966         if (!(o->op_flags & OPf_REF)
 967             || (PL_check[o->op_type] != Perl_ck_ftst))
 968             break;
 969         /* FALLTHROUGH */
 970     case OP_GVSV:
 971     case OP_GV:
 972     case OP_AELEMFAST:
 973 #ifdef USE_ITHREADS
 974             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 975 #else
 976             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 977 #endif
 978         break;
 979     case OP_METHOD_REDIR:
 980     case OP_METHOD_REDIR_SUPER:
 981 #ifdef USE_ITHREADS
 982         if (cMETHOPx(o)->op_rclass_targ) {
 983             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 984             cMETHOPx(o)->op_rclass_targ = 0;
 985         }
 986 #else
 987         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 988         cMETHOPx(o)->op_rclass_sv = NULL;
 989 #endif
 990         /* FALLTHROUGH */
 991     case OP_METHOD_NAMED:
 992     case OP_METHOD_SUPER:
 993         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 994         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 995 #ifdef USE_ITHREADS
 996         if (o->op_targ) {
 997             pad_swipe(o->op_targ, 1);
 998             o->op_targ = 0;
 999         }
1000 #endif
1001         break;
1002     case OP_CONST:
1003     case OP_HINTSEVAL:
1004         SvREFCNT_dec(cSVOPo->op_sv);
1005         cSVOPo->op_sv = NULL;
1006 #ifdef USE_ITHREADS
1007         /** Bug #15654
1008           Even if op_clear does a pad_free for the target of the op,
1009           pad_free doesn't actually remove the sv that exists in the pad;
1010           instead it lives on. This results in that it could be reused as
1011           a target later on when the pad was reallocated.
1012         **/
1013         if(o->op_targ) {
1014           pad_swipe(o->op_targ,1);
1015           o->op_targ = 0;
1016         }
1017 #endif
1018         break;
1019     case OP_DUMP:
1020     case OP_GOTO:
1021     case OP_NEXT:
1022     case OP_LAST:
1023     case OP_REDO:
1024         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1025             break;
1026         /* FALLTHROUGH */
1027     case OP_TRANS:
1028     case OP_TRANSR:
1029         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1030             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1031         {
1032 #ifdef USE_ITHREADS
1033             if (cPADOPo->op_padix > 0) {
1034                 pad_swipe(cPADOPo->op_padix, TRUE);
1035                 cPADOPo->op_padix = 0;
1036             }
1037 #else
1038             SvREFCNT_dec(cSVOPo->op_sv);
1039             cSVOPo->op_sv = NULL;
1040 #endif
1041         }
1042         else {
1043             PerlMemShared_free(cPVOPo->op_pv);
1044             cPVOPo->op_pv = NULL;
1045         }
1046         break;
1047     case OP_SUBST:
1048         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1049         goto clear_pmop;
1050
1051     case OP_SPLIT:
1052         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1053             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1054         {
1055             if (o->op_private & OPpSPLIT_LEX)
1056                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1057             else
1058 #ifdef USE_ITHREADS
1059                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1060 #else
1061                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1062 #endif
1063         }
1064         /* FALLTHROUGH */
1065     case OP_MATCH:
1066     case OP_QR:
1067     clear_pmop:
1068         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1069             op_free(cPMOPo->op_code_list);
1070         cPMOPo->op_code_list = NULL;
1071         forget_pmop(cPMOPo);
1072         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1073         /* we use the same protection as the "SAFE" version of the PM_ macros
1074          * here since sv_clean_all might release some PMOPs
1075          * after PL_regex_padav has been cleared
1076          * and the clearing of PL_regex_padav needs to
1077          * happen before sv_clean_all
1078          */
1079 #ifdef USE_ITHREADS
1080         if(PL_regex_pad) {        /* We could be in destruction */
1081             const IV offset = (cPMOPo)->op_pmoffset;
1082             ReREFCNT_dec(PM_GETRE(cPMOPo));
1083             PL_regex_pad[offset] = &PL_sv_undef;
1084             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1085                            sizeof(offset));
1086         }
1087 #else
1088         ReREFCNT_dec(PM_GETRE(cPMOPo));
1089         PM_SETRE(cPMOPo, NULL);
1090 #endif
1091
1092         break;
1093
1094     case OP_ARGCHECK:
1095         PerlMemShared_free(cUNOP_AUXo->op_aux);
1096         break;
1097
1098     case OP_MULTICONCAT:
1099         {
1100             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1101             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1102              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1103              * utf8 shared strings */
1104             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1105             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1106             if (p1)
1107                 PerlMemShared_free(p1);
1108             if (p2 && p1 != p2)
1109                 PerlMemShared_free(p2);
1110             PerlMemShared_free(aux);
1111         }
1112         break;
1113
1114     case OP_MULTIDEREF:
1115         {
1116             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1117             UV actions = items->uv;
1118             bool last = 0;
1119             bool is_hash = FALSE;
1120
1121             while (!last) {
1122                 switch (actions & MDEREF_ACTION_MASK) {
1123
1124                 case MDEREF_reload:
1125                     actions = (++items)->uv;
1126                     continue;
1127
1128                 case MDEREF_HV_padhv_helem:
1129                     is_hash = TRUE;
1130                     /* FALLTHROUGH */
1131                 case MDEREF_AV_padav_aelem:
1132                     pad_free((++items)->pad_offset);
1133                     goto do_elem;
1134
1135                 case MDEREF_HV_gvhv_helem:
1136                     is_hash = TRUE;
1137                     /* FALLTHROUGH */
1138                 case MDEREF_AV_gvav_aelem:
1139 #ifdef USE_ITHREADS
1140                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1141 #else
1142                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1143 #endif
1144                     goto do_elem;
1145
1146                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1147                     is_hash = TRUE;
1148                     /* FALLTHROUGH */
1149                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1150 #ifdef USE_ITHREADS
1151                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1152 #else
1153                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1154 #endif
1155                     goto do_vivify_rv2xv_elem;
1156
1157                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1158                     is_hash = TRUE;
1159                     /* FALLTHROUGH */
1160                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1161                     pad_free((++items)->pad_offset);
1162                     goto do_vivify_rv2xv_elem;
1163
1164                 case MDEREF_HV_pop_rv2hv_helem:
1165                 case MDEREF_HV_vivify_rv2hv_helem:
1166                     is_hash = TRUE;
1167                     /* FALLTHROUGH */
1168                 do_vivify_rv2xv_elem:
1169                 case MDEREF_AV_pop_rv2av_aelem:
1170                 case MDEREF_AV_vivify_rv2av_aelem:
1171                 do_elem:
1172                     switch (actions & MDEREF_INDEX_MASK) {
1173                     case MDEREF_INDEX_none:
1174                         last = 1;
1175                         break;
1176                     case MDEREF_INDEX_const:
1177                         if (is_hash) {
1178 #ifdef USE_ITHREADS
1179                             /* see RT #15654 */
1180                             pad_swipe((++items)->pad_offset, 1);
1181 #else
1182                             SvREFCNT_dec((++items)->sv);
1183 #endif
1184                         }
1185                         else
1186                             items++;
1187                         break;
1188                     case MDEREF_INDEX_padsv:
1189                         pad_free((++items)->pad_offset);
1190                         break;
1191                     case MDEREF_INDEX_gvsv:
1192 #ifdef USE_ITHREADS
1193                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1194 #else
1195                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1196 #endif
1197                         break;
1198                     }
1199
1200                     if (actions & MDEREF_FLAG_last)
1201                         last = 1;
1202                     is_hash = FALSE;
1203
1204                     break;
1205
1206                 default:
1207                     assert(0);
1208                     last = 1;
1209                     break;
1210
1211                 } /* switch */
1212
1213                 actions >>= MDEREF_SHIFT;
1214             } /* while */
1215
1216             /* start of malloc is at op_aux[-1], where the length is
1217              * stored */
1218             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1219         }
1220         break;
1221     }
1222
1223     if (o->op_targ > 0) {
1224         pad_free(o->op_targ);
1225         o->op_targ = 0;
1226     }
1227 }
1228
1229 STATIC void
1230 S_cop_free(pTHX_ COP* cop)
1231 {
1232     PERL_ARGS_ASSERT_COP_FREE;
1233
1234     CopFILE_free(cop);
1235     if (! specialWARN(cop->cop_warnings))
1236         PerlMemShared_free(cop->cop_warnings);
1237     cophh_free(CopHINTHASH_get(cop));
1238     if (PL_curcop == cop)
1239        PL_curcop = NULL;
1240 }
1241
1242 STATIC void
1243 S_forget_pmop(pTHX_ PMOP *const o)
1244 {
1245     HV * const pmstash = PmopSTASH(o);
1246
1247     PERL_ARGS_ASSERT_FORGET_PMOP;
1248
1249     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1250         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1251         if (mg) {
1252             PMOP **const array = (PMOP**) mg->mg_ptr;
1253             U32 count = mg->mg_len / sizeof(PMOP**);
1254             U32 i = count;
1255
1256             while (i--) {
1257                 if (array[i] == o) {
1258                     /* Found it. Move the entry at the end to overwrite it.  */
1259                     array[i] = array[--count];
1260                     mg->mg_len = count * sizeof(PMOP**);
1261                     /* Could realloc smaller at this point always, but probably
1262                        not worth it. Probably worth free()ing if we're the
1263                        last.  */
1264                     if(!count) {
1265                         Safefree(mg->mg_ptr);
1266                         mg->mg_ptr = NULL;
1267                     }
1268                     break;
1269                 }
1270             }
1271         }
1272     }
1273     if (PL_curpm == o)
1274         PL_curpm = NULL;
1275 }
1276
1277 STATIC void
1278 S_find_and_forget_pmops(pTHX_ OP *o)
1279 {
1280     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1281
1282     if (o->op_flags & OPf_KIDS) {
1283         OP *kid = cUNOPo->op_first;
1284         while (kid) {
1285             switch (kid->op_type) {
1286             case OP_SUBST:
1287             case OP_SPLIT:
1288             case OP_MATCH:
1289             case OP_QR:
1290                 forget_pmop((PMOP*)kid);
1291             }
1292             find_and_forget_pmops(kid);
1293             kid = OpSIBLING(kid);
1294         }
1295     }
1296 }
1297
1298 /*
1299 =for apidoc Am|void|op_null|OP *o
1300
1301 Neutralizes an op when it is no longer needed, but is still linked to from
1302 other ops.
1303
1304 =cut
1305 */
1306
1307 void
1308 Perl_op_null(pTHX_ OP *o)
1309 {
1310     dVAR;
1311
1312     PERL_ARGS_ASSERT_OP_NULL;
1313
1314     if (o->op_type == OP_NULL)
1315         return;
1316     op_clear(o);
1317     o->op_targ = o->op_type;
1318     OpTYPE_set(o, OP_NULL);
1319 }
1320
1321 void
1322 Perl_op_refcnt_lock(pTHX)
1323   PERL_TSA_ACQUIRE(PL_op_mutex)
1324 {
1325 #ifdef USE_ITHREADS
1326     dVAR;
1327 #endif
1328     PERL_UNUSED_CONTEXT;
1329     OP_REFCNT_LOCK;
1330 }
1331
1332 void
1333 Perl_op_refcnt_unlock(pTHX)
1334   PERL_TSA_RELEASE(PL_op_mutex)
1335 {
1336 #ifdef USE_ITHREADS
1337     dVAR;
1338 #endif
1339     PERL_UNUSED_CONTEXT;
1340     OP_REFCNT_UNLOCK;
1341 }
1342
1343
1344 /*
1345 =for apidoc op_sibling_splice
1346
1347 A general function for editing the structure of an existing chain of
1348 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1349 you to delete zero or more sequential nodes, replacing them with zero or
1350 more different nodes.  Performs the necessary op_first/op_last
1351 housekeeping on the parent node and op_sibling manipulation on the
1352 children.  The last deleted node will be marked as as the last node by
1353 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1354
1355 Note that op_next is not manipulated, and nodes are not freed; that is the
1356 responsibility of the caller.  It also won't create a new list op for an
1357 empty list etc; use higher-level functions like op_append_elem() for that.
1358
1359 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1360 the splicing doesn't affect the first or last op in the chain.
1361
1362 C<start> is the node preceding the first node to be spliced.  Node(s)
1363 following it will be deleted, and ops will be inserted after it.  If it is
1364 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1365 beginning.
1366
1367 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1368 If -1 or greater than or equal to the number of remaining kids, all
1369 remaining kids are deleted.
1370
1371 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1372 If C<NULL>, no nodes are inserted.
1373
1374 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1375 deleted.
1376
1377 For example:
1378
1379     action                    before      after         returns
1380     ------                    -----       -----         -------
1381
1382                               P           P
1383     splice(P, A, 2, X-Y-Z)    |           |             B-C
1384                               A-B-C-D     A-X-Y-Z-D
1385
1386                               P           P
1387     splice(P, NULL, 1, X-Y)   |           |             A
1388                               A-B-C-D     X-Y-B-C-D
1389
1390                               P           P
1391     splice(P, NULL, 3, NULL)  |           |             A-B-C
1392                               A-B-C-D     D
1393
1394                               P           P
1395     splice(P, B, 0, X-Y)      |           |             NULL
1396                               A-B-C-D     A-B-X-Y-C-D
1397
1398
1399 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1400 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1401
1402 =cut
1403 */
1404
1405 OP *
1406 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1407 {
1408     OP *first;
1409     OP *rest;
1410     OP *last_del = NULL;
1411     OP *last_ins = NULL;
1412
1413     if (start)
1414         first = OpSIBLING(start);
1415     else if (!parent)
1416         goto no_parent;
1417     else
1418         first = cLISTOPx(parent)->op_first;
1419
1420     assert(del_count >= -1);
1421
1422     if (del_count && first) {
1423         last_del = first;
1424         while (--del_count && OpHAS_SIBLING(last_del))
1425             last_del = OpSIBLING(last_del);
1426         rest = OpSIBLING(last_del);
1427         OpLASTSIB_set(last_del, NULL);
1428     }
1429     else
1430         rest = first;
1431
1432     if (insert) {
1433         last_ins = insert;
1434         while (OpHAS_SIBLING(last_ins))
1435             last_ins = OpSIBLING(last_ins);
1436         OpMAYBESIB_set(last_ins, rest, NULL);
1437     }
1438     else
1439         insert = rest;
1440
1441     if (start) {
1442         OpMAYBESIB_set(start, insert, NULL);
1443     }
1444     else {
1445         if (!parent)
1446             goto no_parent;
1447         cLISTOPx(parent)->op_first = insert;
1448         if (insert)
1449             parent->op_flags |= OPf_KIDS;
1450         else
1451             parent->op_flags &= ~OPf_KIDS;
1452     }
1453
1454     if (!rest) {
1455         /* update op_last etc */
1456         U32 type;
1457         OP *lastop;
1458
1459         if (!parent)
1460             goto no_parent;
1461
1462         /* ought to use OP_CLASS(parent) here, but that can't handle
1463          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1464          * either */
1465         type = parent->op_type;
1466         if (type == OP_CUSTOM) {
1467             dTHX;
1468             type = XopENTRYCUSTOM(parent, xop_class);
1469         }
1470         else {
1471             if (type == OP_NULL)
1472                 type = parent->op_targ;
1473             type = PL_opargs[type] & OA_CLASS_MASK;
1474         }
1475
1476         lastop = last_ins ? last_ins : start ? start : NULL;
1477         if (   type == OA_BINOP
1478             || type == OA_LISTOP
1479             || type == OA_PMOP
1480             || type == OA_LOOP
1481         )
1482             cLISTOPx(parent)->op_last = lastop;
1483
1484         if (lastop)
1485             OpLASTSIB_set(lastop, parent);
1486     }
1487     return last_del ? first : NULL;
1488
1489   no_parent:
1490     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1491 }
1492
1493 /*
1494 =for apidoc op_parent
1495
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1497
1498 =cut
1499 */
1500
1501 OP *
1502 Perl_op_parent(OP *o)
1503 {
1504     PERL_ARGS_ASSERT_OP_PARENT;
1505     while (OpHAS_SIBLING(o))
1506         o = OpSIBLING(o);
1507     return o->op_sibparent;
1508 }
1509
1510 /* replace the sibling following start with a new UNOP, which becomes
1511  * the parent of the original sibling; e.g.
1512  *
1513  *  op_sibling_newUNOP(P, A, unop-args...)
1514  *
1515  *  P              P
1516  *  |      becomes |
1517  *  A-B-C          A-U-C
1518  *                   |
1519  *                   B
1520  *
1521  * where U is the new UNOP.
1522  *
1523  * parent and start args are the same as for op_sibling_splice();
1524  * type and flags args are as newUNOP().
1525  *
1526  * Returns the new UNOP.
1527  */
1528
1529 STATIC OP *
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1531 {
1532     OP *kid, *newop;
1533
1534     kid = op_sibling_splice(parent, start, 1, NULL);
1535     newop = newUNOP(type, flags, kid);
1536     op_sibling_splice(parent, start, 0, newop);
1537     return newop;
1538 }
1539
1540
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542  * the struct. Higher-level stuff should be done by S_new_logop() /
1543  * newLOGOP(). This function exists mainly to avoid op_first assignment
1544  * being spread throughout this file.
1545  */
1546
1547 LOGOP *
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1549 {
1550     dVAR;
1551     LOGOP *logop;
1552     OP *kid = first;
1553     NewOp(1101, logop, 1, LOGOP);
1554     OpTYPE_set(logop, type);
1555     logop->op_first = first;
1556     logop->op_other = other;
1557     if (first)
1558         logop->op_flags = OPf_KIDS;
1559     while (kid && OpHAS_SIBLING(kid))
1560         kid = OpSIBLING(kid);
1561     if (kid)
1562         OpLASTSIB_set(kid, (OP*)logop);
1563     return logop;
1564 }
1565
1566
1567 /* Contextualizers */
1568
1569 /*
1570 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1571
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply.  The modified op tree
1575 is returned.
1576
1577 =cut
1578 */
1579
1580 OP *
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582 {
1583     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584     switch (context) {
1585         case G_SCALAR: return scalar(o);
1586         case G_ARRAY:  return list(o);
1587         case G_VOID:   return scalarvoid(o);
1588         default:
1589             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1590                        (long) context);
1591     }
1592 }
1593
1594 /*
1595
1596 =for apidoc Am|OP*|op_linklist|OP *o
1597 This function is the implementation of the L</LINKLIST> macro.  It should
1598 not be called directly.
1599
1600 =cut
1601 */
1602
1603 OP *
1604 Perl_op_linklist(pTHX_ OP *o)
1605 {
1606     OP *first;
1607
1608     PERL_ARGS_ASSERT_OP_LINKLIST;
1609
1610     if (o->op_next)
1611         return o->op_next;
1612
1613     /* establish postfix order */
1614     first = cUNOPo->op_first;
1615     if (first) {
1616         OP *kid;
1617         o->op_next = LINKLIST(first);
1618         kid = first;
1619         for (;;) {
1620             OP *sibl = OpSIBLING(kid);
1621             if (sibl) {
1622                 kid->op_next = LINKLIST(sibl);
1623                 kid = sibl;
1624             } else {
1625                 kid->op_next = o;
1626                 break;
1627             }
1628         }
1629     }
1630     else
1631         o->op_next = o;
1632
1633     return o->op_next;
1634 }
1635
1636 static OP *
1637 S_scalarkids(pTHX_ OP *o)
1638 {
1639     if (o && o->op_flags & OPf_KIDS) {
1640         OP *kid;
1641         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1642             scalar(kid);
1643     }
1644     return o;
1645 }
1646
1647 STATIC OP *
1648 S_scalarboolean(pTHX_ OP *o)
1649 {
1650     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1651
1652     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657         if (ckWARN(WARN_SYNTAX)) {
1658             const line_t oldline = CopLINE(PL_curcop);
1659
1660             if (PL_parser && PL_parser->copline != NOLINE) {
1661                 /* This ensures that warnings are reported at the first line
1662                    of the conditional, not the last.  */
1663                 CopLINE_set(PL_curcop, PL_parser->copline);
1664             }
1665             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666             CopLINE_set(PL_curcop, oldline);
1667         }
1668     }
1669     return scalar(o);
1670 }
1671
1672 static SV *
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1674 {
1675     assert(o);
1676     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1678     {
1679         const char funny  = o->op_type == OP_PADAV
1680                          || o->op_type == OP_RV2AV ? '@' : '%';
1681         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1682             GV *gv;
1683             if (cUNOPo->op_first->op_type != OP_GV
1684              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1685                 return NULL;
1686             return varname(gv, funny, 0, NULL, 0, subscript_type);
1687         }
1688         return
1689             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1690     }
1691 }
1692
1693 static SV *
1694 S_op_varname(pTHX_ const OP *o)
1695 {
1696     return S_op_varname_subscript(aTHX_ o, 1);
1697 }
1698
1699 static void
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702     if (o->op_type == OP_CONST) {
1703         *retsv = cSVOPo_sv;
1704         if (SvPOK(*retsv)) {
1705             SV *sv = *retsv;
1706             *retsv = sv_newmortal();
1707             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1709         }
1710         else if (!SvOK(*retsv))
1711             *retpv = "undef";
1712     }
1713     else *retpv = "...";
1714 }
1715
1716 static void
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1718 {
1719     OP *kid;
1720     const bool h = o->op_type == OP_HSLICE
1721                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1722     const char lbrack =
1723         h ? '{' : '[';
1724     const char rbrack =
1725         h ? '}' : ']';
1726     SV *name;
1727     SV *keysv = NULL; /* just to silence compiler warnings */
1728     const char *key = NULL;
1729
1730     if (!(o->op_private & OPpSLICEWARNING))
1731         return;
1732     if (PL_parser && PL_parser->error_count)
1733         /* This warning can be nonsensical when there is a syntax error. */
1734         return;
1735
1736     kid = cLISTOPo->op_first;
1737     kid = OpSIBLING(kid); /* get past pushmark */
1738     /* weed out false positives: any ops that can return lists */
1739     switch (kid->op_type) {
1740     case OP_BACKTICK:
1741     case OP_GLOB:
1742     case OP_READLINE:
1743     case OP_MATCH:
1744     case OP_RV2AV:
1745     case OP_EACH:
1746     case OP_VALUES:
1747     case OP_KEYS:
1748     case OP_SPLIT:
1749     case OP_LIST:
1750     case OP_SORT:
1751     case OP_REVERSE:
1752     case OP_ENTERSUB:
1753     case OP_CALLER:
1754     case OP_LSTAT:
1755     case OP_STAT:
1756     case OP_READDIR:
1757     case OP_SYSTEM:
1758     case OP_TMS:
1759     case OP_LOCALTIME:
1760     case OP_GMTIME:
1761     case OP_ENTEREVAL:
1762         return;
1763     }
1764
1765     /* Don't warn if we have a nulled list either. */
1766     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1767         return;
1768
1769     assert(OpSIBLING(kid));
1770     name = S_op_varname(aTHX_ OpSIBLING(kid));
1771     if (!name) /* XS module fiddling with the op tree */
1772         return;
1773     S_op_pretty(aTHX_ kid, &keysv, &key);
1774     assert(SvPOK(name));
1775     sv_chop(name,SvPVX(name)+1);
1776     if (key)
1777        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1780                    "%c%s%c",
1781                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782                     lbrack, key, rbrack);
1783     else
1784        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1787                     SVf "%c%" SVf "%c",
1788                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1790 }
1791
1792 OP *
1793 Perl_scalar(pTHX_ OP *o)
1794 {
1795     OP *kid;
1796
1797     /* assumes no premature commitment */
1798     if (!o || (PL_parser && PL_parser->error_count)
1799          || (o->op_flags & OPf_WANT)
1800          || o->op_type == OP_RETURN)
1801     {
1802         return o;
1803     }
1804
1805     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1806
1807     switch (o->op_type) {
1808     case OP_REPEAT:
1809         scalar(cBINOPo->op_first);
1810         if (o->op_private & OPpREPEAT_DOLIST) {
1811             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1812             assert(kid->op_type == OP_PUSHMARK);
1813             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1814                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1815                 o->op_private &=~ OPpREPEAT_DOLIST;
1816             }
1817         }
1818         break;
1819     case OP_OR:
1820     case OP_AND:
1821     case OP_COND_EXPR:
1822         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1823             scalar(kid);
1824         break;
1825         /* FALLTHROUGH */
1826     case OP_SPLIT:
1827     case OP_MATCH:
1828     case OP_QR:
1829     case OP_SUBST:
1830     case OP_NULL:
1831     default:
1832         if (o->op_flags & OPf_KIDS) {
1833             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1834                 scalar(kid);
1835         }
1836         break;
1837     case OP_LEAVE:
1838     case OP_LEAVETRY:
1839         kid = cLISTOPo->op_first;
1840         scalar(kid);
1841         kid = OpSIBLING(kid);
1842     do_kids:
1843         while (kid) {
1844             OP *sib = OpSIBLING(kid);
1845             if (sib && kid->op_type != OP_LEAVEWHEN
1846              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1847                 || (  sib->op_targ != OP_NEXTSTATE
1848                    && sib->op_targ != OP_DBSTATE  )))
1849                 scalarvoid(kid);
1850             else
1851                 scalar(kid);
1852             kid = sib;
1853         }
1854         PL_curcop = &PL_compiling;
1855         break;
1856     case OP_SCOPE:
1857     case OP_LINESEQ:
1858     case OP_LIST:
1859         kid = cLISTOPo->op_first;
1860         goto do_kids;
1861     case OP_SORT:
1862         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1863         break;
1864     case OP_KVHSLICE:
1865     case OP_KVASLICE:
1866     {
1867         /* Warn about scalar context */
1868         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1869         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1870         SV *name;
1871         SV *keysv;
1872         const char *key = NULL;
1873
1874         /* This warning can be nonsensical when there is a syntax error. */
1875         if (PL_parser && PL_parser->error_count)
1876             break;
1877
1878         if (!ckWARN(WARN_SYNTAX)) break;
1879
1880         kid = cLISTOPo->op_first;
1881         kid = OpSIBLING(kid); /* get past pushmark */
1882         assert(OpSIBLING(kid));
1883         name = S_op_varname(aTHX_ OpSIBLING(kid));
1884         if (!name) /* XS module fiddling with the op tree */
1885             break;
1886         S_op_pretty(aTHX_ kid, &keysv, &key);
1887         assert(SvPOK(name));
1888         sv_chop(name,SvPVX(name)+1);
1889         if (key)
1890   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1891             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1892                        "%%%" SVf "%c%s%c in scalar context better written "
1893                        "as $%" SVf "%c%s%c",
1894                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1895                         lbrack, key, rbrack);
1896         else
1897   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1898             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1899                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1900                        "written as $%" SVf "%c%" SVf "%c",
1901                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1902                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1903     }
1904     }
1905     return o;
1906 }
1907
1908 OP *
1909 Perl_scalarvoid(pTHX_ OP *arg)
1910 {
1911     dVAR;
1912     OP *kid;
1913     SV* sv;
1914     OP *o = arg;
1915     dDEFER_OP;
1916
1917     PERL_ARGS_ASSERT_SCALARVOID;
1918
1919     do {
1920         U8 want;
1921         SV *useless_sv = NULL;
1922         const char* useless = NULL;
1923
1924         if (o->op_type == OP_NEXTSTATE
1925             || o->op_type == OP_DBSTATE
1926             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1927                                           || o->op_targ == OP_DBSTATE)))
1928             PL_curcop = (COP*)o;                /* for warning below */
1929
1930         /* assumes no premature commitment */
1931         want = o->op_flags & OPf_WANT;
1932         if ((want && want != OPf_WANT_SCALAR)
1933             || (PL_parser && PL_parser->error_count)
1934             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1935         {
1936             continue;
1937         }
1938
1939         if ((o->op_private & OPpTARGET_MY)
1940             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1941         {
1942             /* newASSIGNOP has already applied scalar context, which we
1943                leave, as if this op is inside SASSIGN.  */
1944             continue;
1945         }
1946
1947         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1948
1949         switch (o->op_type) {
1950         default:
1951             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1952                 break;
1953             /* FALLTHROUGH */
1954         case OP_REPEAT:
1955             if (o->op_flags & OPf_STACKED)
1956                 break;
1957             if (o->op_type == OP_REPEAT)
1958                 scalar(cBINOPo->op_first);
1959             goto func_ops;
1960         case OP_CONCAT:
1961             if ((o->op_flags & OPf_STACKED) &&
1962                     !(o->op_private & OPpCONCAT_NESTED))
1963                 break;
1964             goto func_ops;
1965         case OP_SUBSTR:
1966             if (o->op_private == 4)
1967                 break;
1968             /* FALLTHROUGH */
1969         case OP_WANTARRAY:
1970         case OP_GV:
1971         case OP_SMARTMATCH:
1972         case OP_AV2ARYLEN:
1973         case OP_REF:
1974         case OP_REFGEN:
1975         case OP_SREFGEN:
1976         case OP_DEFINED:
1977         case OP_HEX:
1978         case OP_OCT:
1979         case OP_LENGTH:
1980         case OP_VEC:
1981         case OP_INDEX:
1982         case OP_RINDEX:
1983         case OP_SPRINTF:
1984         case OP_KVASLICE:
1985         case OP_KVHSLICE:
1986         case OP_UNPACK:
1987         case OP_PACK:
1988         case OP_JOIN:
1989         case OP_LSLICE:
1990         case OP_ANONLIST:
1991         case OP_ANONHASH:
1992         case OP_SORT:
1993         case OP_REVERSE:
1994         case OP_RANGE:
1995         case OP_FLIP:
1996         case OP_FLOP:
1997         case OP_CALLER:
1998         case OP_FILENO:
1999         case OP_EOF:
2000         case OP_TELL:
2001         case OP_GETSOCKNAME:
2002         case OP_GETPEERNAME:
2003         case OP_READLINK:
2004         case OP_TELLDIR:
2005         case OP_GETPPID:
2006         case OP_GETPGRP:
2007         case OP_GETPRIORITY:
2008         case OP_TIME:
2009         case OP_TMS:
2010         case OP_LOCALTIME:
2011         case OP_GMTIME:
2012         case OP_GHBYNAME:
2013         case OP_GHBYADDR:
2014         case OP_GHOSTENT:
2015         case OP_GNBYNAME:
2016         case OP_GNBYADDR:
2017         case OP_GNETENT:
2018         case OP_GPBYNAME:
2019         case OP_GPBYNUMBER:
2020         case OP_GPROTOENT:
2021         case OP_GSBYNAME:
2022         case OP_GSBYPORT:
2023         case OP_GSERVENT:
2024         case OP_GPWNAM:
2025         case OP_GPWUID:
2026         case OP_GGRNAM:
2027         case OP_GGRGID:
2028         case OP_GETLOGIN:
2029         case OP_PROTOTYPE:
2030         case OP_RUNCV:
2031         func_ops:
2032             useless = OP_DESC(o);
2033             break;
2034
2035         case OP_GVSV:
2036         case OP_PADSV:
2037         case OP_PADAV:
2038         case OP_PADHV:
2039         case OP_PADANY:
2040         case OP_AELEM:
2041         case OP_AELEMFAST:
2042         case OP_AELEMFAST_LEX:
2043         case OP_ASLICE:
2044         case OP_HELEM:
2045         case OP_HSLICE:
2046             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2047                 /* Otherwise it's "Useless use of grep iterator" */
2048                 useless = OP_DESC(o);
2049             break;
2050
2051         case OP_SPLIT:
2052             if (!(o->op_private & OPpSPLIT_ASSIGN))
2053                 useless = OP_DESC(o);
2054             break;
2055
2056         case OP_NOT:
2057             kid = cUNOPo->op_first;
2058             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2059                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2060                 goto func_ops;
2061             }
2062             useless = "negative pattern binding (!~)";
2063             break;
2064
2065         case OP_SUBST:
2066             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2067                 useless = "non-destructive substitution (s///r)";
2068             break;
2069
2070         case OP_TRANSR:
2071             useless = "non-destructive transliteration (tr///r)";
2072             break;
2073
2074         case OP_RV2GV:
2075         case OP_RV2SV:
2076         case OP_RV2AV:
2077         case OP_RV2HV:
2078             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2079                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2080                 useless = "a variable";
2081             break;
2082
2083         case OP_CONST:
2084             sv = cSVOPo_sv;
2085             if (cSVOPo->op_private & OPpCONST_STRICT)
2086                 no_bareword_allowed(o);
2087             else {
2088                 if (ckWARN(WARN_VOID)) {
2089                     NV nv;
2090                     /* don't warn on optimised away booleans, eg
2091                      * use constant Foo, 5; Foo || print; */
2092                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2093                         useless = NULL;
2094                     /* the constants 0 and 1 are permitted as they are
2095                        conventionally used as dummies in constructs like
2096                        1 while some_condition_with_side_effects;  */
2097                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2098                         useless = NULL;
2099                     else if (SvPOK(sv)) {
2100                         SV * const dsv = newSVpvs("");
2101                         useless_sv
2102                             = Perl_newSVpvf(aTHX_
2103                                             "a constant (%s)",
2104                                             pv_pretty(dsv, SvPVX_const(sv),
2105                                                       SvCUR(sv), 32, NULL, NULL,
2106                                                       PERL_PV_PRETTY_DUMP
2107                                                       | PERL_PV_ESCAPE_NOCLEAR
2108                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2109                         SvREFCNT_dec_NN(dsv);
2110                     }
2111                     else if (SvOK(sv)) {
2112                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2113                     }
2114                     else
2115                         useless = "a constant (undef)";
2116                 }
2117             }
2118             op_null(o);         /* don't execute or even remember it */
2119             break;
2120
2121         case OP_POSTINC:
2122             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2123             break;
2124
2125         case OP_POSTDEC:
2126             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2127             break;
2128
2129         case OP_I_POSTINC:
2130             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2131             break;
2132
2133         case OP_I_POSTDEC:
2134             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2135             break;
2136
2137         case OP_SASSIGN: {
2138             OP *rv2gv;
2139             UNOP *refgen, *rv2cv;
2140             LISTOP *exlist;
2141
2142             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2143                 break;
2144
2145             rv2gv = ((BINOP *)o)->op_last;
2146             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2147                 break;
2148
2149             refgen = (UNOP *)((BINOP *)o)->op_first;
2150
2151             if (!refgen || (refgen->op_type != OP_REFGEN
2152                             && refgen->op_type != OP_SREFGEN))
2153                 break;
2154
2155             exlist = (LISTOP *)refgen->op_first;
2156             if (!exlist || exlist->op_type != OP_NULL
2157                 || exlist->op_targ != OP_LIST)
2158                 break;
2159
2160             if (exlist->op_first->op_type != OP_PUSHMARK
2161                 && exlist->op_first != exlist->op_last)
2162                 break;
2163
2164             rv2cv = (UNOP*)exlist->op_last;
2165
2166             if (rv2cv->op_type != OP_RV2CV)
2167                 break;
2168
2169             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2170             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2171             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2172
2173             o->op_private |= OPpASSIGN_CV_TO_GV;
2174             rv2gv->op_private |= OPpDONT_INIT_GV;
2175             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2176
2177             break;
2178         }
2179
2180         case OP_AASSIGN: {
2181             inplace_aassign(o);
2182             break;
2183         }
2184
2185         case OP_OR:
2186         case OP_AND:
2187             kid = cLOGOPo->op_first;
2188             if (kid->op_type == OP_NOT
2189                 && (kid->op_flags & OPf_KIDS)) {
2190                 if (o->op_type == OP_AND) {
2191                     OpTYPE_set(o, OP_OR);
2192                 } else {
2193                     OpTYPE_set(o, OP_AND);
2194                 }
2195                 op_null(kid);
2196             }
2197             /* FALLTHROUGH */
2198
2199         case OP_DOR:
2200         case OP_COND_EXPR:
2201         case OP_ENTERGIVEN:
2202         case OP_ENTERWHEN:
2203             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204                 if (!(kid->op_flags & OPf_KIDS))
2205                     scalarvoid(kid);
2206                 else
2207                     DEFER_OP(kid);
2208         break;
2209
2210         case OP_NULL:
2211             if (o->op_flags & OPf_STACKED)
2212                 break;
2213             /* FALLTHROUGH */
2214         case OP_NEXTSTATE:
2215         case OP_DBSTATE:
2216         case OP_ENTERTRY:
2217         case OP_ENTER:
2218             if (!(o->op_flags & OPf_KIDS))
2219                 break;
2220             /* FALLTHROUGH */
2221         case OP_SCOPE:
2222         case OP_LEAVE:
2223         case OP_LEAVETRY:
2224         case OP_LEAVELOOP:
2225         case OP_LINESEQ:
2226         case OP_LEAVEGIVEN:
2227         case OP_LEAVEWHEN:
2228         kids:
2229             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2230                 if (!(kid->op_flags & OPf_KIDS))
2231                     scalarvoid(kid);
2232                 else
2233                     DEFER_OP(kid);
2234             break;
2235         case OP_LIST:
2236             /* If the first kid after pushmark is something that the padrange
2237                optimisation would reject, then null the list and the pushmark.
2238             */
2239             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2240                 && (  !(kid = OpSIBLING(kid))
2241                       || (  kid->op_type != OP_PADSV
2242                             && kid->op_type != OP_PADAV
2243                             && kid->op_type != OP_PADHV)
2244                       || kid->op_private & ~OPpLVAL_INTRO
2245                       || !(kid = OpSIBLING(kid))
2246                       || (  kid->op_type != OP_PADSV
2247                             && kid->op_type != OP_PADAV
2248                             && kid->op_type != OP_PADHV)
2249                       || kid->op_private & ~OPpLVAL_INTRO)
2250             ) {
2251                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2252                 op_null(o); /* NULL the list */
2253             }
2254             goto kids;
2255         case OP_ENTEREVAL:
2256             scalarkids(o);
2257             break;
2258         case OP_SCALAR:
2259             scalar(o);
2260             break;
2261         }
2262
2263         if (useless_sv) {
2264             /* mortalise it, in case warnings are fatal.  */
2265             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2266                            "Useless use of %" SVf " in void context",
2267                            SVfARG(sv_2mortal(useless_sv)));
2268         }
2269         else if (useless) {
2270             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2271                            "Useless use of %s in void context",
2272                            useless);
2273         }
2274     } while ( (o = POP_DEFERRED_OP()) );
2275
2276     DEFER_OP_CLEANUP;
2277
2278     return arg;
2279 }
2280
2281 static OP *
2282 S_listkids(pTHX_ OP *o)
2283 {
2284     if (o && o->op_flags & OPf_KIDS) {
2285         OP *kid;
2286         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2287             list(kid);
2288     }
2289     return o;
2290 }
2291
2292 OP *
2293 Perl_list(pTHX_ OP *o)
2294 {
2295     OP *kid;
2296
2297     /* assumes no premature commitment */
2298     if (!o || (o->op_flags & OPf_WANT)
2299          || (PL_parser && PL_parser->error_count)
2300          || o->op_type == OP_RETURN)
2301     {
2302         return o;
2303     }
2304
2305     if ((o->op_private & OPpTARGET_MY)
2306         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2307     {
2308         return o;                               /* As if inside SASSIGN */
2309     }
2310
2311     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2312
2313     switch (o->op_type) {
2314     case OP_FLOP:
2315         list(cBINOPo->op_first);
2316         break;
2317     case OP_REPEAT:
2318         if (o->op_private & OPpREPEAT_DOLIST
2319          && !(o->op_flags & OPf_STACKED))
2320         {
2321             list(cBINOPo->op_first);
2322             kid = cBINOPo->op_last;
2323             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2324              && SvIVX(kSVOP_sv) == 1)
2325             {
2326                 op_null(o); /* repeat */
2327                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2328                 /* const (rhs): */
2329                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2330             }
2331         }
2332         break;
2333     case OP_OR:
2334     case OP_AND:
2335     case OP_COND_EXPR:
2336         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2337             list(kid);
2338         break;
2339     default:
2340     case OP_MATCH:
2341     case OP_QR:
2342     case OP_SUBST:
2343     case OP_NULL:
2344         if (!(o->op_flags & OPf_KIDS))
2345             break;
2346         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2347             list(cBINOPo->op_first);
2348             return gen_constant_list(o);
2349         }
2350         listkids(o);
2351         break;
2352     case OP_LIST:
2353         listkids(o);
2354         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2355             op_null(cUNOPo->op_first); /* NULL the pushmark */
2356             op_null(o); /* NULL the list */
2357         }
2358         break;
2359     case OP_LEAVE:
2360     case OP_LEAVETRY:
2361         kid = cLISTOPo->op_first;
2362         list(kid);
2363         kid = OpSIBLING(kid);
2364     do_kids:
2365         while (kid) {
2366             OP *sib = OpSIBLING(kid);
2367             if (sib && kid->op_type != OP_LEAVEWHEN)
2368                 scalarvoid(kid);
2369             else
2370                 list(kid);
2371             kid = sib;
2372         }
2373         PL_curcop = &PL_compiling;
2374         break;
2375     case OP_SCOPE:
2376     case OP_LINESEQ:
2377         kid = cLISTOPo->op_first;
2378         goto do_kids;
2379     }
2380     return o;
2381 }
2382
2383 static OP *
2384 S_scalarseq(pTHX_ OP *o)
2385 {
2386     if (o) {
2387         const OPCODE type = o->op_type;
2388
2389         if (type == OP_LINESEQ || type == OP_SCOPE ||
2390             type == OP_LEAVE || type == OP_LEAVETRY)
2391         {
2392             OP *kid, *sib;
2393             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2394                 if ((sib = OpSIBLING(kid))
2395                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2396                     || (  sib->op_targ != OP_NEXTSTATE
2397                        && sib->op_targ != OP_DBSTATE  )))
2398                 {
2399                     scalarvoid(kid);
2400                 }
2401             }
2402             PL_curcop = &PL_compiling;
2403         }
2404         o->op_flags &= ~OPf_PARENS;
2405         if (PL_hints & HINT_BLOCK_SCOPE)
2406             o->op_flags |= OPf_PARENS;
2407     }
2408     else
2409         o = newOP(OP_STUB, 0);
2410     return o;
2411 }
2412
2413 STATIC OP *
2414 S_modkids(pTHX_ OP *o, I32 type)
2415 {
2416     if (o && o->op_flags & OPf_KIDS) {
2417         OP *kid;
2418         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2419             op_lvalue(kid, type);
2420     }
2421     return o;
2422 }
2423
2424
2425 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2426  * const fields. Also, convert CONST keys to HEK-in-SVs.
2427  * rop is the op that retrieves the hash;
2428  * key_op is the first key
2429  */
2430
2431 STATIC void
2432 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2433 {
2434     PADNAME *lexname;
2435     GV **fields;
2436     bool check_fields;
2437
2438     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2439     if (rop) {
2440         if (rop->op_first->op_type == OP_PADSV)
2441             /* @$hash{qw(keys here)} */
2442             rop = (UNOP*)rop->op_first;
2443         else {
2444             /* @{$hash}{qw(keys here)} */
2445             if (rop->op_first->op_type == OP_SCOPE
2446                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2447                 {
2448                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2449                 }
2450             else
2451                 rop = NULL;
2452         }
2453     }
2454
2455     lexname = NULL; /* just to silence compiler warnings */
2456     fields  = NULL; /* just to silence compiler warnings */
2457
2458     check_fields =
2459             rop
2460          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2461              SvPAD_TYPED(lexname))
2462          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2463          && isGV(*fields) && GvHV(*fields);
2464
2465     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2466         SV **svp, *sv;
2467         if (key_op->op_type != OP_CONST)
2468             continue;
2469         svp = cSVOPx_svp(key_op);
2470
2471         /* make sure it's not a bareword under strict subs */
2472         if (key_op->op_private & OPpCONST_BARE &&
2473             key_op->op_private & OPpCONST_STRICT)
2474         {
2475             no_bareword_allowed((OP*)key_op);
2476         }
2477
2478         /* Make the CONST have a shared SV */
2479         if (   !SvIsCOW_shared_hash(sv = *svp)
2480             && SvTYPE(sv) < SVt_PVMG
2481             && SvOK(sv)
2482             && !SvROK(sv))
2483         {
2484             SSize_t keylen;
2485             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2486             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2487             SvREFCNT_dec_NN(sv);
2488             *svp = nsv;
2489         }
2490
2491         if (   check_fields
2492             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2493         {
2494             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2495                         "in variable %" PNf " of type %" HEKf,
2496                         SVfARG(*svp), PNfARG(lexname),
2497                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2498         }
2499     }
2500 }
2501
2502 /* info returned by S_sprintf_is_multiconcatable() */
2503
2504 struct sprintf_ismc_info {
2505     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2506     char  *start;     /* start of raw format string */
2507     char  *end;       /* bytes after end of raw format string */
2508     STRLEN total_len; /* total length (in bytes) of format string, not
2509                          including '%s' and  half of '%%' */
2510     STRLEN variant;   /* number of bytes by which total_len_p would grow
2511                          if upgraded to utf8 */
2512     bool   utf8;      /* whether the format is utf8 */
2513 };
2514
2515
2516 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2517  * i.e. its format argument is a const string with only '%s' and '%%'
2518  * formats, and the number of args is known, e.g.
2519  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2520  * but not
2521  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2522  *
2523  * If successful, the sprintf_ismc_info struct pointed to by info will be
2524  * populated.
2525  */
2526
2527 STATIC bool
2528 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2529 {
2530     OP    *pm, *constop, *kid;
2531     SV    *sv;
2532     char  *s, *e, *p;
2533     SSize_t nargs, nformats;
2534     STRLEN cur, total_len, variant;
2535     bool   utf8;
2536
2537     /* if sprintf's behaviour changes, die here so that someone
2538      * can decide whether to enhance this function or skip optimising
2539      * under those new circumstances */
2540     assert(!(o->op_flags & OPf_STACKED));
2541     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2542     assert(!(o->op_private & ~OPpARG4_MASK));
2543
2544     pm = cUNOPo->op_first;
2545     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2546         return FALSE;
2547     constop = OpSIBLING(pm);
2548     if (!constop || constop->op_type != OP_CONST)
2549         return FALSE;
2550     sv = cSVOPx_sv(constop);
2551     if (SvMAGICAL(sv) || !SvPOK(sv))
2552         return FALSE;
2553
2554     s = SvPV(sv, cur);
2555     e = s + cur;
2556
2557     /* Scan format for %% and %s and work out how many %s there are.
2558      * Abandon if other format types are found.
2559      */
2560
2561     nformats  = 0;
2562     total_len = 0;
2563     variant   = 0;
2564
2565     for (p = s; p < e; p++) {
2566         if (*p != '%') {
2567             total_len++;
2568             if (!UTF8_IS_INVARIANT(*p))
2569                 variant++;
2570             continue;
2571         }
2572         p++;
2573         if (p >= e)
2574             return FALSE; /* lone % at end gives "Invalid conversion" */
2575         if (*p == '%')
2576             total_len++;
2577         else if (*p == 's')
2578             nformats++;
2579         else
2580             return FALSE;
2581     }
2582
2583     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2584         return FALSE;
2585
2586     utf8 = cBOOL(SvUTF8(sv));
2587     if (utf8)
2588         variant = 0;
2589
2590     /* scan args; they must all be in scalar cxt */
2591
2592     nargs = 0;
2593     kid = OpSIBLING(constop);
2594
2595     while (kid) {
2596         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2597             return FALSE;
2598         nargs++;
2599         kid = OpSIBLING(kid);
2600     }
2601
2602     if (nargs != nformats)
2603         return FALSE; /* e.g. sprintf("%s%s", $a); */
2604
2605
2606     info->nargs      = nargs;
2607     info->start      = s;
2608     info->end        = e;
2609     info->total_len  = total_len;
2610     info->variant    = variant;
2611     info->utf8       = utf8;
2612
2613     return TRUE;
2614 }
2615
2616
2617
2618 /* S_maybe_multiconcat():
2619  *
2620  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2621  * convert it (and its children) into an OP_MULTICONCAT. See the code
2622  * comments just before pp_multiconcat() for the full details of what
2623  * OP_MULTICONCAT supports.
2624  *
2625  * Basically we're looking for an optree with a chain of OP_CONCATS down
2626  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2627  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2628  *
2629  *      $x = "$a$b-$c"
2630  *
2631  *  looks like
2632  *
2633  *      SASSIGN
2634  *         |
2635  *      STRINGIFY   -- PADSV[$x]
2636  *         |
2637  *         |
2638  *      ex-PUSHMARK -- CONCAT/S
2639  *                        |
2640  *                     CONCAT/S  -- PADSV[$d]
2641  *                        |
2642  *                     CONCAT    -- CONST["-"]
2643  *                        |
2644  *                     PADSV[$a] -- PADSV[$b]
2645  *
2646  * Note that at this stage the OP_SASSIGN may have already been optimised
2647  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2648  */
2649
2650 STATIC void
2651 S_maybe_multiconcat(pTHX_ OP *o)
2652 {
2653     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2654     OP *topop;       /* the top-most op in the concat tree (often equals o,
2655                         unless there are assign/stringify ops above it */
2656     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2657     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2658     OP *targetop;    /* the op corresponding to target=... or target.=... */
2659     OP *stringop;    /* the OP_STRINGIFY op, if any */
2660     OP *nextop;      /* used for recreating the op_next chain without consts */
2661     OP *kid;         /* general-purpose op pointer */
2662     UNOP_AUX_item *aux;
2663     UNOP_AUX_item *lenp;
2664     char *const_str, *p;
2665     struct sprintf_ismc_info sprintf_info;
2666
2667                      /* store info about each arg in args[];
2668                       * toparg is the highest used slot; argp is a general
2669                       * pointer to args[] slots */
2670     struct {
2671         void *p;      /* initially points to const sv (or null for op);
2672                          later, set to SvPV(constsv), with ... */
2673         STRLEN len;   /* ... len set to SvPV(..., len) */
2674     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2675
2676     SSize_t nargs  = 0;
2677     SSize_t nconst = 0;
2678     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2679     STRLEN variant;
2680     bool utf8 = FALSE;
2681     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2682                                  the last-processed arg will the LHS of one,
2683                                  as args are processed in reverse order */
2684     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2685     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2686     U8 flags          = 0;   /* what will become the op_flags and ... */
2687     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2688     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2689     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2690     bool prev_was_const = FALSE; /* previous arg was a const */
2691
2692     /* -----------------------------------------------------------------
2693      * Phase 1:
2694      *
2695      * Examine the optree non-destructively to determine whether it's
2696      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2697      * information about the optree in args[].
2698      */
2699
2700     argp     = args;
2701     targmyop = NULL;
2702     targetop = NULL;
2703     stringop = NULL;
2704     topop    = o;
2705     parentop = o;
2706
2707     assert(   o->op_type == OP_SASSIGN
2708            || o->op_type == OP_CONCAT
2709            || o->op_type == OP_SPRINTF
2710            || o->op_type == OP_STRINGIFY);
2711
2712     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2713
2714     /* first see if, at the top of the tree, there is an assign,
2715      * append and/or stringify */
2716
2717     if (topop->op_type == OP_SASSIGN) {
2718         /* expr = ..... */
2719         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2720             return;
2721         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2722             return;
2723         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2724
2725         parentop = topop;
2726         topop = cBINOPo->op_first;
2727         targetop = OpSIBLING(topop);
2728         if (!targetop) /* probably some sort of syntax error */
2729             return;
2730     }
2731     else if (   topop->op_type == OP_CONCAT
2732              && (topop->op_flags & OPf_STACKED)
2733              && (!(topop->op_private & OPpCONCAT_NESTED))
2734             )
2735     {
2736         /* expr .= ..... */
2737
2738         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2739          * decide what to do about it */
2740         assert(!(o->op_private & OPpTARGET_MY));
2741
2742         /* barf on unknown flags */
2743         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2744         private_flags |= OPpMULTICONCAT_APPEND;
2745         targetop = cBINOPo->op_first;
2746         parentop = topop;
2747         topop    = OpSIBLING(targetop);
2748
2749         /* $x .= <FOO> gets optimised to rcatline instead */
2750         if (topop->op_type == OP_READLINE)
2751             return;
2752     }
2753
2754     if (targetop) {
2755         /* Can targetop (the LHS) if it's a padsv, be be optimised
2756          * away and use OPpTARGET_MY instead?
2757          */
2758         if (    (targetop->op_type == OP_PADSV)
2759             && !(targetop->op_private & OPpDEREF)
2760             && !(targetop->op_private & OPpPAD_STATE)
2761                /* we don't support 'my $x .= ...' */
2762             && (   o->op_type == OP_SASSIGN
2763                 || !(targetop->op_private & OPpLVAL_INTRO))
2764         )
2765             is_targable = TRUE;
2766     }
2767
2768     if (topop->op_type == OP_STRINGIFY) {
2769         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2770             return;
2771         stringop = topop;
2772
2773         /* barf on unknown flags */
2774         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2775
2776         if ((topop->op_private & OPpTARGET_MY)) {
2777             if (o->op_type == OP_SASSIGN)
2778                 return; /* can't have two assigns */
2779             targmyop = topop;
2780         }
2781
2782         private_flags |= OPpMULTICONCAT_STRINGIFY;
2783         parentop = topop;
2784         topop = cBINOPx(topop)->op_first;
2785         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2786         topop = OpSIBLING(topop);
2787     }
2788
2789     if (topop->op_type == OP_SPRINTF) {
2790         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2791             return;
2792         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2793             nargs     = sprintf_info.nargs;
2794             total_len = sprintf_info.total_len;
2795             variant   = sprintf_info.variant;
2796             utf8      = sprintf_info.utf8;
2797             is_sprintf = TRUE;
2798             private_flags |= OPpMULTICONCAT_FAKE;
2799             toparg = argp;
2800             /* we have an sprintf op rather than a concat optree.
2801              * Skip most of the code below which is associated with
2802              * processing that optree. We also skip phase 2, determining
2803              * whether its cost effective to optimise, since for sprintf,
2804              * multiconcat is *always* faster */
2805             goto create_aux;
2806         }
2807         /* note that even if the sprintf itself isn't multiconcatable,
2808          * the expression as a whole may be, e.g. in
2809          *    $x .= sprintf("%d",...)
2810          * the sprintf op will be left as-is, but the concat/S op may
2811          * be upgraded to multiconcat
2812          */
2813     }
2814     else if (topop->op_type == OP_CONCAT) {
2815         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2816             return;
2817
2818         if ((topop->op_private & OPpTARGET_MY)) {
2819             if (o->op_type == OP_SASSIGN || targmyop)
2820                 return; /* can't have two assigns */
2821             targmyop = topop;
2822         }
2823     }
2824
2825     /* Is it safe to convert a sassign/stringify/concat op into
2826      * a multiconcat? */
2827     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2828     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2829     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2830     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2831     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2832                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2833     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2834                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2835
2836     /* Now scan the down the tree looking for a series of
2837      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2838      * stacked). For example this tree:
2839      *
2840      *     |
2841      *   CONCAT/STACKED
2842      *     |
2843      *   CONCAT/STACKED -- EXPR5
2844      *     |
2845      *   CONCAT/STACKED -- EXPR4
2846      *     |
2847      *   CONCAT -- EXPR3
2848      *     |
2849      *   EXPR1  -- EXPR2
2850      *
2851      * corresponds to an expression like
2852      *
2853      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2854      *
2855      * Record info about each EXPR in args[]: in particular, whether it is
2856      * a stringifiable OP_CONST and if so what the const sv is.
2857      *
2858      * The reason why the last concat can't be STACKED is the difference
2859      * between
2860      *
2861      *    ((($a .= $a) .= $a) .= $a) .= $a
2862      *
2863      * and
2864      *    $a . $a . $a . $a . $a
2865      *
2866      * The main difference between the optrees for those two constructs
2867      * is the presence of the last STACKED. As well as modifying $a,
2868      * the former sees the changed $a between each concat, so if $s is
2869      * initially 'a', the first returns 'a' x 16, while the latter returns
2870      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2871      */
2872
2873     kid = topop;
2874
2875     for (;;) {
2876         OP *argop;
2877         SV *sv;
2878         bool last = FALSE;
2879
2880         if (    kid->op_type == OP_CONCAT
2881             && !kid_is_last
2882         ) {
2883             OP *k1, *k2;
2884             k1 = cUNOPx(kid)->op_first;
2885             k2 = OpSIBLING(k1);
2886             /* shouldn't happen except maybe after compile err? */
2887             if (!k2)
2888                 return;
2889
2890             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2891             if (kid->op_private & OPpTARGET_MY)
2892                 kid_is_last = TRUE;
2893
2894             stacked_last = (kid->op_flags & OPf_STACKED);
2895             if (!stacked_last)
2896                 kid_is_last = TRUE;
2897
2898             kid   = k1;
2899             argop = k2;
2900         }
2901         else {
2902             argop = kid;
2903             last = TRUE;
2904         }
2905
2906         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2907             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2908         {
2909             /* At least two spare slots are needed to decompose both
2910              * concat args. If there are no slots left, continue to
2911              * examine the rest of the optree, but don't push new values
2912              * on args[]. If the optree as a whole is legal for conversion
2913              * (in particular that the last concat isn't STACKED), then
2914              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2915              * can be converted into an OP_MULTICONCAT now, with the first
2916              * child of that op being the remainder of the optree -
2917              * which may itself later be converted to a multiconcat op
2918              * too.
2919              */
2920             if (last) {
2921                 /* the last arg is the rest of the optree */
2922                 argp++->p = NULL;
2923                 nargs++;
2924             }
2925         }
2926         else if (   argop->op_type == OP_CONST
2927             && ((sv = cSVOPx_sv(argop)))
2928             /* defer stringification until runtime of 'constant'
2929              * things that might stringify variantly, e.g. the radix
2930              * point of NVs, or overloaded RVs */
2931             && (SvPOK(sv) || SvIOK(sv))
2932             && (!SvGMAGICAL(sv))
2933         ) {
2934             argp++->p = sv;
2935             utf8   |= cBOOL(SvUTF8(sv));
2936             nconst++;
2937             if (prev_was_const)
2938                 /* this const may be demoted back to a plain arg later;
2939                  * make sure we have enough arg slots left */
2940                 nadjconst++;
2941             prev_was_const = !prev_was_const;
2942         }
2943         else {
2944             argp++->p = NULL;
2945             nargs++;
2946             prev_was_const = FALSE;
2947         }
2948
2949         if (last)
2950             break;
2951     }
2952
2953     toparg = argp - 1;
2954
2955     if (stacked_last)
2956         return; /* we don't support ((A.=B).=C)...) */
2957
2958     /* look for two adjacent consts and don't fold them together:
2959      *     $o . "a" . "b"
2960      * should do
2961      *     $o->concat("a")->concat("b")
2962      * rather than
2963      *     $o->concat("ab")
2964      * (but $o .=  "a" . "b" should still fold)
2965      */
2966     {
2967         bool seen_nonconst = FALSE;
2968         for (argp = toparg; argp >= args; argp--) {
2969             if (argp->p == NULL) {
2970                 seen_nonconst = TRUE;
2971                 continue;
2972             }
2973             if (!seen_nonconst)
2974                 continue;
2975             if (argp[1].p) {
2976                 /* both previous and current arg were constants;
2977                  * leave the current OP_CONST as-is */
2978                 argp->p = NULL;
2979                 nconst--;
2980                 nargs++;
2981             }
2982         }
2983     }
2984
2985     /* -----------------------------------------------------------------
2986      * Phase 2:
2987      *
2988      * At this point we have determined that the optree *can* be converted
2989      * into a multiconcat. Having gathered all the evidence, we now decide
2990      * whether it *should*.
2991      */
2992
2993
2994     /* we need at least one concat action, e.g.:
2995      *
2996      *  Y . Z
2997      *  X = Y . Z
2998      *  X .= Y
2999      *
3000      * otherwise we could be doing something like $x = "foo", which
3001      * if treated as as a concat, would fail to COW.
3002      */
3003     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3004         return;
3005
3006     /* Benchmarking seems to indicate that we gain if:
3007      * * we optimise at least two actions into a single multiconcat
3008      *    (e.g concat+concat, sassign+concat);
3009      * * or if we can eliminate at least 1 OP_CONST;
3010      * * or if we can eliminate a padsv via OPpTARGET_MY
3011      */
3012
3013     if (
3014            /* eliminated at least one OP_CONST */
3015            nconst >= 1
3016            /* eliminated an OP_SASSIGN */
3017         || o->op_type == OP_SASSIGN
3018            /* eliminated an OP_PADSV */
3019         || (!targmyop && is_targable)
3020     )
3021         /* definitely a net gain to optimise */
3022         goto optimise;
3023
3024     /* ... if not, what else? */
3025
3026     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3027      * multiconcat is faster (due to not creating a temporary copy of
3028      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3029      * faster.
3030      */
3031     if (   nconst == 0
3032          && nargs == 2
3033          && targmyop
3034          && topop->op_type == OP_CONCAT
3035     ) {
3036         PADOFFSET t = targmyop->op_targ;
3037         OP *k1 = cBINOPx(topop)->op_first;
3038         OP *k2 = cBINOPx(topop)->op_last;
3039         if (   k2->op_type == OP_PADSV
3040             && k2->op_targ == t
3041             && (   k1->op_type != OP_PADSV
3042                 || k1->op_targ != t)
3043         )
3044             goto optimise;
3045     }
3046
3047     /* need at least two concats */
3048     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3049         return;
3050
3051
3052
3053     /* -----------------------------------------------------------------
3054      * Phase 3:
3055      *
3056      * At this point the optree has been verified as ok to be optimised
3057      * into an OP_MULTICONCAT. Now start changing things.
3058      */
3059
3060    optimise:
3061
3062     /* stringify all const args and determine utf8ness */
3063
3064     variant = 0;
3065     for (argp = args; argp <= toparg; argp++) {
3066         SV *sv = (SV*)argp->p;
3067         if (!sv)
3068             continue; /* not a const op */
3069         if (utf8 && !SvUTF8(sv))
3070             sv_utf8_upgrade_nomg(sv);
3071         argp->p = SvPV_nomg(sv, argp->len);
3072         total_len += argp->len;
3073
3074         /* see if any strings would grow if converted to utf8 */
3075         if (!utf8) {
3076             char *p    = (char*)argp->p;
3077             STRLEN len = argp->len;
3078             while (len--) {
3079                 U8 c = *p++;
3080                 if (!UTF8_IS_INVARIANT(c))
3081                     variant++;
3082             }
3083         }
3084     }
3085
3086     /* create and populate aux struct */
3087
3088   create_aux:
3089
3090     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3091                     sizeof(UNOP_AUX_item)
3092                     *  (
3093                            PERL_MULTICONCAT_HEADER_SIZE
3094                          + ((nargs + 1) * (variant ? 2 : 1))
3095                         )
3096                     );
3097     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3098
3099     /* Extract all the non-const expressions from the concat tree then
3100      * dispose of the old tree, e.g. convert the tree from this:
3101      *
3102      *  o => SASSIGN
3103      *         |
3104      *       STRINGIFY   -- TARGET
3105      *         |
3106      *       ex-PUSHMARK -- CONCAT
3107      *                        |
3108      *                      CONCAT -- EXPR5
3109      *                        |
3110      *                      CONCAT -- EXPR4
3111      *                        |
3112      *                      CONCAT -- EXPR3
3113      *                        |
3114      *                      EXPR1  -- EXPR2
3115      *
3116      *
3117      * to:
3118      *
3119      *  o => MULTICONCAT
3120      *         |
3121      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3122      *
3123      * except that if EXPRi is an OP_CONST, it's discarded.
3124      *
3125      * During the conversion process, EXPR ops are stripped from the tree
3126      * and unshifted onto o. Finally, any of o's remaining original
3127      * childen are discarded and o is converted into an OP_MULTICONCAT.
3128      *
3129      * In this middle of this, o may contain both: unshifted args on the
3130      * left, and some remaining original args on the right. lastkidop
3131      * is set to point to the right-most unshifted arg to delineate
3132      * between the two sets.
3133      */
3134
3135
3136     if (is_sprintf) {
3137         /* create a copy of the format with the %'s removed, and record
3138          * the sizes of the const string segments in the aux struct */
3139         char *q, *oldq;
3140         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3141
3142         p    = sprintf_info.start;
3143         q    = const_str;
3144         oldq = q;
3145         for (; p < sprintf_info.end; p++) {
3146             if (*p == '%') {
3147                 p++;
3148                 if (*p != '%') {
3149                     (lenp++)->ssize = q - oldq;
3150                     oldq = q;
3151                     continue;
3152                 }
3153             }
3154             *q++ = *p;
3155         }
3156         lenp->ssize = q - oldq;
3157         assert((STRLEN)(q - const_str) == total_len);
3158
3159         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3160          * may or may not be topop) The pushmark and const ops need to be
3161          * kept in case they're an op_next entry point.
3162          */
3163         lastkidop = cLISTOPx(topop)->op_last;
3164         kid = cUNOPx(topop)->op_first; /* pushmark */
3165         op_null(kid);
3166         op_null(OpSIBLING(kid));       /* const */
3167         if (o != topop) {
3168             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3169             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3170             lastkidop->op_next = o;
3171         }
3172     }
3173     else {
3174         p = const_str;
3175         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3176
3177         lenp->ssize = -1;
3178
3179         /* Concatenate all const strings into const_str.
3180          * Note that args[] contains the RHS args in reverse order, so
3181          * we scan args[] from top to bottom to get constant strings
3182          * in L-R order
3183          */
3184         for (argp = toparg; argp >= args; argp--) {
3185             if (!argp->p)
3186                 /* not a const op */
3187                 (++lenp)->ssize = -1;
3188             else {
3189                 STRLEN l = argp->len;
3190                 Copy(argp->p, p, l, char);
3191                 p += l;
3192                 if (lenp->ssize == -1)
3193                     lenp->ssize = l;
3194                 else
3195                     lenp->ssize += l;
3196             }
3197         }
3198
3199         kid = topop;
3200         nextop = o;
3201         lastkidop = NULL;
3202
3203         for (argp = args; argp <= toparg; argp++) {
3204             /* only keep non-const args, except keep the first-in-next-chain
3205              * arg no matter what it is (but nulled if OP_CONST), because it
3206              * may be the entry point to this subtree from the previous
3207              * op_next.
3208              */
3209             bool last = (argp == toparg);
3210             OP *prev;
3211
3212             /* set prev to the sibling *before* the arg to be cut out,
3213              * e.g. when cutting EXPR:
3214              *
3215              *         |
3216              * kid=  CONCAT
3217              *         |
3218              * prev= CONCAT -- EXPR
3219              *         |
3220              */
3221             if (argp == args && kid->op_type != OP_CONCAT) {
3222                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3223                  * so the expression to be cut isn't kid->op_last but
3224                  * kid itself */
3225                 OP *o1, *o2;
3226                 /* find the op before kid */
3227                 o1 = NULL;
3228                 o2 = cUNOPx(parentop)->op_first;
3229                 while (o2 && o2 != kid) {
3230                     o1 = o2;
3231                     o2 = OpSIBLING(o2);
3232                 }
3233                 assert(o2 == kid);
3234                 prev = o1;
3235                 kid  = parentop;
3236             }
3237             else if (kid == o && lastkidop)
3238                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3239             else
3240                 prev = last ? NULL : cUNOPx(kid)->op_first;
3241
3242             if (!argp->p || last) {
3243                 /* cut RH op */
3244                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3245                 /* and unshift to front of o */
3246                 op_sibling_splice(o, NULL, 0, aop);
3247                 /* record the right-most op added to o: later we will
3248                  * free anything to the right of it */
3249                 if (!lastkidop)
3250                     lastkidop = aop;
3251                 aop->op_next = nextop;
3252                 if (last) {
3253                     if (argp->p)
3254                         /* null the const at start of op_next chain */
3255                         op_null(aop);
3256                 }
3257                 else if (prev)
3258                     nextop = prev->op_next;
3259             }
3260
3261             /* the last two arguments are both attached to the same concat op */
3262             if (argp < toparg - 1)
3263                 kid = prev;
3264         }
3265     }
3266
3267     /* Populate the aux struct */
3268
3269     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3270     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3271     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3272     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3273     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3274
3275     /* if variant > 0, calculate a variant const string and lengths where
3276      * the utf8 version of the string will take 'variant' more bytes than
3277      * the plain one. */
3278
3279     if (variant) {
3280         char              *p = const_str;
3281         STRLEN          ulen = total_len + variant;
3282         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3283         UNOP_AUX_item *ulens = lens + (nargs + 1);
3284         char             *up = (char*)PerlMemShared_malloc(ulen);
3285         SSize_t            n;
3286
3287         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3288         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3289
3290         for (n = 0; n < (nargs + 1); n++) {
3291             SSize_t i;
3292             char * orig_up = up;
3293             for (i = (lens++)->ssize; i > 0; i--) {
3294                 U8 c = *p++;
3295                 append_utf8_from_native_byte(c, (U8**)&up);
3296             }
3297             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3298         }
3299     }
3300
3301     if (stringop) {
3302         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3303          * that op's first child - an ex-PUSHMARK - because the op_next of
3304          * the previous op may point to it (i.e. it's the entry point for
3305          * the o optree)
3306          */
3307         OP *pmop =
3308             (stringop == o)
3309                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3310                 : op_sibling_splice(stringop, NULL, 1, NULL);
3311         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3312         op_sibling_splice(o, NULL, 0, pmop);
3313         if (!lastkidop)
3314             lastkidop = pmop;
3315     }
3316
3317     /* Optimise
3318      *    target  = A.B.C...
3319      *    target .= A.B.C...
3320      */
3321
3322     if (targetop) {
3323         assert(!targmyop);
3324
3325         if (o->op_type == OP_SASSIGN) {
3326             /* Move the target subtree from being the last of o's children
3327              * to being the last of o's preserved children.
3328              * Note the difference between 'target = ...' and 'target .= ...':
3329              * for the former, target is executed last; for the latter,
3330              * first.
3331              */
3332             kid = OpSIBLING(lastkidop);
3333             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3334             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3335             lastkidop->op_next = kid->op_next;
3336             lastkidop = targetop;
3337         }
3338         else {
3339             /* Move the target subtree from being the first of o's
3340              * original children to being the first of *all* o's children.
3341              */
3342             if (lastkidop) {
3343                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3344                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3345             }
3346             else {
3347                 /* if the RHS of .= doesn't contain a concat (e.g.
3348                  * $x .= "foo"), it gets missed by the "strip ops from the
3349                  * tree and add to o" loop earlier */
3350                 assert(topop->op_type != OP_CONCAT);
3351                 if (stringop) {
3352                     /* in e.g. $x .= "$y", move the $y expression
3353                      * from being a child of OP_STRINGIFY to being the
3354                      * second child of the OP_CONCAT
3355                      */
3356                     assert(cUNOPx(stringop)->op_first == topop);
3357                     op_sibling_splice(stringop, NULL, 1, NULL);
3358                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3359                 }
3360                 assert(topop == OpSIBLING(cBINOPo->op_first));
3361                 if (toparg->p)
3362                     op_null(topop);
3363                 lastkidop = topop;
3364             }
3365         }
3366
3367         if (is_targable) {
3368             /* optimise
3369              *  my $lex  = A.B.C...
3370              *     $lex  = A.B.C...
3371              *     $lex .= A.B.C...
3372              * The original padsv op is kept but nulled in case it's the
3373              * entry point for the optree (which it will be for
3374              * '$lex .=  ... '
3375              */
3376             private_flags |= OPpTARGET_MY;
3377             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3378             o->op_targ = targetop->op_targ;
3379             targetop->op_targ = 0;
3380             op_null(targetop);
3381         }
3382         else
3383             flags |= OPf_STACKED;
3384     }
3385     else if (targmyop) {
3386         private_flags |= OPpTARGET_MY;
3387         if (o != targmyop) {
3388             o->op_targ = targmyop->op_targ;
3389             targmyop->op_targ = 0;
3390         }
3391     }
3392
3393     /* detach the emaciated husk of the sprintf/concat optree and free it */
3394     for (;;) {
3395         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3396         if (!kid)
3397             break;
3398         op_free(kid);
3399     }
3400
3401     /* and convert o into a multiconcat */
3402
3403     o->op_flags        = (flags|OPf_KIDS|stacked_last
3404                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3405     o->op_private      = private_flags;
3406     o->op_type         = OP_MULTICONCAT;
3407     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3408     cUNOP_AUXo->op_aux = aux;
3409 }
3410
3411
3412 /* do all the final processing on an optree (e.g. running the peephole
3413  * optimiser on it), then attach it to cv (if cv is non-null)
3414  */
3415
3416 static void
3417 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3418 {
3419     OP **startp;
3420
3421     /* XXX for some reason, evals, require and main optrees are
3422      * never attached to their CV; instead they just hang off
3423      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3424      * and get manually freed when appropriate */
3425     if (cv)
3426         startp = &CvSTART(cv);
3427     else
3428         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3429
3430     *startp = start;
3431     optree->op_private |= OPpREFCOUNTED;
3432     OpREFCNT_set(optree, 1);
3433     optimize_optree(optree);
3434     CALL_PEEP(*startp);
3435     finalize_optree(optree);
3436     S_prune_chain_head(startp);
3437
3438     if (cv) {
3439         /* now that optimizer has done its work, adjust pad values */
3440         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3441                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3442     }
3443 }
3444
3445
3446 /*
3447 =for apidoc optimize_optree
3448
3449 This function applies some optimisations to the optree in top-down order.
3450 It is called before the peephole optimizer, which processes ops in
3451 execution order. Note that finalize_optree() also does a top-down scan,
3452 but is called *after* the peephole optimizer.
3453
3454 =cut
3455 */
3456
3457 void
3458 Perl_optimize_optree(pTHX_ OP* o)
3459 {
3460     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3461
3462     ENTER;
3463     SAVEVPTR(PL_curcop);
3464
3465     optimize_op(o);
3466
3467     LEAVE;
3468 }
3469
3470
3471 /* helper for optimize_optree() which optimises on op then recurses
3472  * to optimise any children.
3473  */
3474
3475 STATIC void
3476 S_optimize_op(pTHX_ OP* o)
3477 {
3478     dDEFER_OP;
3479
3480     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3481     do {
3482         assert(o->op_type != OP_FREED);
3483
3484         switch (o->op_type) {
3485         case OP_NEXTSTATE:
3486         case OP_DBSTATE:
3487             PL_curcop = ((COP*)o);              /* for warnings */
3488             break;
3489
3490
3491         case OP_CONCAT:
3492         case OP_SASSIGN:
3493         case OP_STRINGIFY:
3494         case OP_SPRINTF:
3495             S_maybe_multiconcat(aTHX_ o);
3496             break;
3497
3498         case OP_SUBST:
3499             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3500                 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3501             break;
3502
3503         default:
3504             break;
3505         }
3506
3507         if (o->op_flags & OPf_KIDS) {
3508             OP *kid;
3509             IV child_count = 0;
3510             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3511                 DEFER_OP(kid);
3512                 ++child_count;
3513             }
3514             DEFER_REVERSE(child_count);
3515         }
3516     } while ( ( o = POP_DEFERRED_OP() ) );
3517
3518     DEFER_OP_CLEANUP;
3519 }
3520
3521
3522 /*
3523 =for apidoc finalize_optree
3524
3525 This function finalizes the optree.  Should be called directly after
3526 the complete optree is built.  It does some additional
3527 checking which can't be done in the normal C<ck_>xxx functions and makes
3528 the tree thread-safe.
3529
3530 =cut
3531 */
3532 void
3533 Perl_finalize_optree(pTHX_ OP* o)
3534 {
3535     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3536
3537     ENTER;
3538     SAVEVPTR(PL_curcop);
3539
3540     finalize_op(o);
3541
3542     LEAVE;
3543 }
3544
3545 #ifdef USE_ITHREADS
3546 /* Relocate sv to the pad for thread safety.
3547  * Despite being a "constant", the SV is written to,
3548  * for reference counts, sv_upgrade() etc. */
3549 PERL_STATIC_INLINE void
3550 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3551 {
3552     PADOFFSET ix;
3553     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3554     if (!*svp) return;
3555     ix = pad_alloc(OP_CONST, SVf_READONLY);
3556     SvREFCNT_dec(PAD_SVl(ix));
3557     PAD_SETSV(ix, *svp);
3558     /* XXX I don't know how this isn't readonly already. */
3559     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3560     *svp = NULL;
3561     *targp = ix;
3562 }
3563 #endif
3564
3565 /*
3566 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3567
3568 Return the next op in a depth-first traversal of the op tree,
3569 returning NULL when the traversal is complete.
3570
3571 The initial call must supply the root of the tree as both top and o.
3572
3573 For now it's static, but it may be exposed to the API in the future.
3574
3575 =cut
3576 */
3577
3578 STATIC OP*
3579 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3580     OP *sib;
3581
3582     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3583
3584     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3585         return cUNOPo->op_first;
3586     }
3587     else if ((sib = OpSIBLING(o))) {
3588         return sib;
3589     }
3590     else {
3591         OP *parent = o->op_sibparent;
3592         assert(!(o->op_moresib));
3593         while (parent && parent != top) {
3594             OP *sib = OpSIBLING(parent);
3595             if (sib)
3596                 return sib;
3597             parent = parent->op_sibparent;
3598         }
3599
3600         return NULL;
3601     }
3602 }
3603
3604 STATIC void
3605 S_finalize_op(pTHX_ OP* o)
3606 {
3607     OP * const top = o;
3608     PERL_ARGS_ASSERT_FINALIZE_OP;
3609
3610     do {
3611         assert(o->op_type != OP_FREED);
3612
3613         switch (o->op_type) {
3614         case OP_NEXTSTATE:
3615         case OP_DBSTATE:
3616             PL_curcop = ((COP*)o);              /* for warnings */
3617             break;
3618         case OP_EXEC:
3619             if (OpHAS_SIBLING(o)) {
3620                 OP *sib = OpSIBLING(o);
3621                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3622                     && ckWARN(WARN_EXEC)
3623                     && OpHAS_SIBLING(sib))
3624                 {
3625                     const OPCODE type = OpSIBLING(sib)->op_type;
3626                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3627                         const line_t oldline = CopLINE(PL_curcop);
3628                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3629                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3630                             "Statement unlikely to be reached");
3631                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3632                             "\t(Maybe you meant system() when you said exec()?)\n");
3633                         CopLINE_set(PL_curcop, oldline);
3634                     }
3635                 }
3636             }
3637             break;
3638
3639         case OP_GV:
3640             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3641                 GV * const gv = cGVOPo_gv;
3642                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3643                     /* XXX could check prototype here instead of just carping */
3644                     SV * const sv = sv_newmortal();
3645                     gv_efullname3(sv, gv, NULL);
3646                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3647                                 "%" SVf "() called too early to check prototype",
3648                                 SVfARG(sv));
3649                 }
3650             }
3651             break;
3652
3653         case OP_CONST:
3654             if (cSVOPo->op_private & OPpCONST_STRICT)
3655                 no_bareword_allowed(o);
3656 #ifdef USE_ITHREADS
3657             /* FALLTHROUGH */
3658         case OP_HINTSEVAL:
3659             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3660 #endif
3661             break;
3662
3663 #ifdef USE_ITHREADS
3664             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3665         case OP_METHOD_NAMED:
3666         case OP_METHOD_SUPER:
3667         case OP_METHOD_REDIR:
3668         case OP_METHOD_REDIR_SUPER:
3669             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3670             break;
3671 #endif
3672
3673         case OP_HELEM: {
3674             UNOP *rop;
3675             SVOP *key_op;
3676             OP *kid;
3677
3678             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3679                 break;
3680
3681             rop = (UNOP*)((BINOP*)o)->op_first;
3682
3683             goto check_keys;
3684
3685             case OP_HSLICE:
3686                 S_scalar_slice_warning(aTHX_ o);
3687                 /* FALLTHROUGH */
3688
3689             case OP_KVHSLICE:
3690                 kid = OpSIBLING(cLISTOPo->op_first);
3691             if (/* I bet there's always a pushmark... */
3692                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3693                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3694             {
3695                 break;
3696             }
3697
3698             key_op = (SVOP*)(kid->op_type == OP_CONST
3699                              ? kid
3700                              : OpSIBLING(kLISTOP->op_first));
3701
3702             rop = (UNOP*)((LISTOP*)o)->op_last;
3703
3704         check_keys:
3705             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3706                 rop = NULL;
3707             S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3708             break;
3709         }
3710         case OP_NULL:
3711             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3712                 break;
3713             /* FALLTHROUGH */
3714         case OP_ASLICE:
3715             S_scalar_slice_warning(aTHX_ o);
3716             break;
3717
3718         case OP_SUBST: {
3719             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3720                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3721             break;
3722         }
3723         default:
3724             break;
3725         }
3726
3727 #ifdef DEBUGGING
3728         if (o->op_flags & OPf_KIDS) {
3729             OP *kid;
3730
3731             /* check that op_last points to the last sibling, and that
3732              * the last op_sibling/op_sibparent field points back to the
3733              * parent, and that the only ops with KIDS are those which are
3734              * entitled to them */
3735             U32 type = o->op_type;
3736             U32 family;
3737             bool has_last;
3738
3739             if (type == OP_NULL) {
3740                 type = o->op_targ;
3741                 /* ck_glob creates a null UNOP with ex-type GLOB
3742                  * (which is a list op. So pretend it wasn't a listop */
3743                 if (type == OP_GLOB)
3744                     type = OP_NULL;
3745             }
3746             family = PL_opargs[type] & OA_CLASS_MASK;
3747
3748             has_last = (   family == OA_BINOP
3749                         || family == OA_LISTOP
3750                         || family == OA_PMOP
3751                         || family == OA_LOOP
3752                        );
3753             assert(  has_last /* has op_first and op_last, or ...
3754                   ... has (or may have) op_first: */
3755                   || family == OA_UNOP
3756                   || family == OA_UNOP_AUX
3757                   || family == OA_LOGOP
3758                   || family == OA_BASEOP_OR_UNOP
3759                   || family == OA_FILESTATOP
3760                   || family == OA_LOOPEXOP
3761                   || family == OA_METHOP
3762                   || type == OP_CUSTOM
3763                   || type == OP_NULL /* new_logop does this */
3764                   );
3765
3766             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3767                 if (!OpHAS_SIBLING(kid)) {
3768                     if (has_last)
3769                         assert(kid == cLISTOPo->op_last);
3770                     assert(kid->op_sibparent == o);
3771                 }
3772             }
3773         }
3774 #endif
3775     } while (( o = traverse_op_tree(top, o)) != NULL);
3776 }
3777
3778 /*
3779 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3780
3781 Propagate lvalue ("modifiable") context to an op and its children.
3782 C<type> represents the context type, roughly based on the type of op that
3783 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3784 because it has no op type of its own (it is signalled by a flag on
3785 the lvalue op).
3786
3787 This function detects things that can't be modified, such as C<$x+1>, and
3788 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3789 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3790
3791 It also flags things that need to behave specially in an lvalue context,
3792 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3793
3794 =cut
3795 */
3796
3797 static void
3798 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3799 {
3800     CV *cv = PL_compcv;
3801     PadnameLVALUE_on(pn);
3802     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3803         cv = CvOUTSIDE(cv);
3804         /* RT #127786: cv can be NULL due to an eval within the DB package
3805          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3806          * unless they contain an eval, but calling eval within DB
3807          * pretends the eval was done in the caller's scope.
3808          */
3809         if (!cv)
3810             break;
3811         assert(CvPADLIST(cv));
3812         pn =
3813            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3814         assert(PadnameLEN(pn));
3815         PadnameLVALUE_on(pn);
3816     }
3817 }
3818
3819 static bool
3820 S_vivifies(const OPCODE type)
3821 {
3822     switch(type) {
3823     case OP_RV2AV:     case   OP_ASLICE:
3824     case OP_RV2HV:     case OP_KVASLICE:
3825     case OP_RV2SV:     case   OP_HSLICE:
3826     case OP_AELEMFAST: case OP_KVHSLICE:
3827     case OP_HELEM:
3828     case OP_AELEM:
3829         return 1;
3830     }
3831     return 0;
3832 }
3833
3834 static void
3835 S_lvref(pTHX_ OP *o, I32 type)
3836 {
3837     dVAR;
3838     OP *kid;
3839     switch (o->op_type) {
3840     case OP_COND_EXPR:
3841         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3842              kid = OpSIBLING(kid))
3843             S_lvref(aTHX_ kid, type);
3844         /* FALLTHROUGH */
3845     case OP_PUSHMARK:
3846         return;
3847     case OP_RV2AV:
3848         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3849         o->op_flags |= OPf_STACKED;
3850         if (o->op_flags & OPf_PARENS) {
3851             if (o->op_private & OPpLVAL_INTRO) {
3852                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3853                       "localized parenthesized array in list assignment"));
3854                 return;
3855             }
3856           slurpy:
3857             OpTYPE_set(o, OP_LVAVREF);
3858             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3859             o->op_flags |= OPf_MOD|OPf_REF;
3860             return;
3861         }
3862         o->op_private |= OPpLVREF_AV;
3863         goto checkgv;
3864     case OP_RV2CV:
3865         kid = cUNOPo->op_first;
3866         if (kid->op_type == OP_NULL)
3867             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3868                 ->op_first;
3869         o->op_private = OPpLVREF_CV;
3870         if (kid->op_type == OP_GV)
3871             o->op_flags |= OPf_STACKED;
3872         else if (kid->op_type == OP_PADCV) {
3873             o->op_targ = kid->op_targ;
3874             kid->op_targ = 0;
3875             op_free(cUNOPo->op_first);
3876             cUNOPo->op_first = NULL;
3877             o->op_flags &=~ OPf_KIDS;
3878         }
3879         else goto badref;
3880         break;
3881     case OP_RV2HV:
3882         if (o->op_flags & OPf_PARENS) {
3883           parenhash:
3884             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3885                                  "parenthesized hash in list assignment"));
3886                 return;
3887         }
3888         o->op_private |= OPpLVREF_HV;
3889         /* FALLTHROUGH */
3890     case OP_RV2SV:
3891       checkgv:
3892         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3893         o->op_flags |= OPf_STACKED;
3894         break;
3895     case OP_PADHV:
3896         if (o->op_flags & OPf_PARENS) goto parenhash;
3897         o->op_private |= OPpLVREF_HV;
3898         /* FALLTHROUGH */
3899     case OP_PADSV:
3900         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3901         break;
3902     case OP_PADAV:
3903         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3904         if (o->op_flags & OPf_PARENS) goto slurpy;
3905         o->op_private |= OPpLVREF_AV;
3906         break;
3907     case OP_AELEM:
3908     case OP_HELEM:
3909         o->op_private |= OPpLVREF_ELEM;
3910         o->op_flags   |= OPf_STACKED;
3911         break;
3912     case OP_ASLICE:
3913     case OP_HSLICE:
3914         OpTYPE_set(o, OP_LVREFSLICE);
3915         o->op_private &= OPpLVAL_INTRO;
3916         return;
3917     case OP_NULL:
3918         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3919             goto badref;
3920         else if (!(o->op_flags & OPf_KIDS))
3921             return;
3922         if (o->op_targ != OP_LIST) {
3923             S_lvref(aTHX_ cBINOPo->op_first, type);
3924             return;
3925         }
3926         /* FALLTHROUGH */
3927     case OP_LIST:
3928         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3929             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3930             S_lvref(aTHX_ kid, type);
3931         }
3932         return;
3933     case OP_STUB:
3934         if (o->op_flags & OPf_PARENS)
3935             return;
3936         /* FALLTHROUGH */
3937     default:
3938       badref:
3939         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3940         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3941                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3942                       ? "do block"
3943                       : OP_DESC(o),
3944                      PL_op_desc[type]));
3945         return;
3946     }
3947     OpTYPE_set(o, OP_LVREF);
3948     o->op_private &=
3949         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3950     if (type == OP_ENTERLOOP)
3951         o->op_private |= OPpLVREF_ITER;
3952 }
3953
3954 PERL_STATIC_INLINE bool
3955 S_potential_mod_type(I32 type)
3956 {
3957     /* Types that only potentially result in modification.  */
3958     return type == OP_GREPSTART || type == OP_ENTERSUB
3959         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3960 }
3961
3962 OP *
3963 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3964 {
3965     dVAR;
3966     OP *kid;
3967     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3968     int localize = -1;
3969
3970     if (!o || (PL_parser && PL_parser->error_count))
3971         return o;
3972
3973     if ((o->op_private & OPpTARGET_MY)
3974         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3975     {
3976         return o;
3977     }
3978
3979     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3980
3981     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3982
3983     switch (o->op_type) {
3984     case OP_UNDEF:
3985         PL_modcount++;
3986         return o;
3987     case OP_STUB:
3988         if ((o->op_flags & OPf_PARENS))
3989             break;
3990         goto nomod;
3991     case OP_ENTERSUB:
3992         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3993             !(o->op_flags & OPf_STACKED)) {
3994             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3995             assert(cUNOPo->op_first->op_type == OP_NULL);
3996             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3997             break;
3998         }
3999         else {                          /* lvalue subroutine call */
4000             o->op_private |= OPpLVAL_INTRO;
4001             PL_modcount = RETURN_UNLIMITED_NUMBER;
4002             if (S_potential_mod_type(type)) {
4003                 o->op_private |= OPpENTERSUB_INARGS;
4004                 break;
4005             }
4006             else {                      /* Compile-time error message: */
4007                 OP *kid = cUNOPo->op_first;
4008                 CV *cv;
4009                 GV *gv;
4010                 SV *namesv;
4011
4012                 if (kid->op_type != OP_PUSHMARK) {
4013                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4014                         Perl_croak(aTHX_
4015                                 "panic: unexpected lvalue entersub "
4016                                 "args: type/targ %ld:%" UVuf,
4017                                 (long)kid->op_type, (UV)kid->op_targ);
4018                     kid = kLISTOP->op_first;
4019                 }
4020                 while (OpHAS_SIBLING(kid))
4021                     kid = OpSIBLING(kid);
4022                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4023                     break;      /* Postpone until runtime */
4024                 }
4025
4026                 kid = kUNOP->op_first;
4027                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4028                     kid = kUNOP->op_first;
4029                 if (kid->op_type == OP_NULL)
4030                     Perl_croak(aTHX_
4031                                "Unexpected constant lvalue entersub "
4032                                "entry via type/targ %ld:%" UVuf,
4033                                (long)kid->op_type, (UV)kid->op_targ);
4034                 if (kid->op_type != OP_GV) {
4035                     break;
4036                 }
4037
4038                 gv = kGVOP_gv;
4039                 cv = isGV(gv)
4040                     ? GvCV(gv)
4041                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4042                         ? MUTABLE_CV(SvRV(gv))
4043                         : NULL;
4044                 if (!cv)
4045                     break;
4046                 if (CvLVALUE(cv))
4047                     break;
4048                 if (flags & OP_LVALUE_NO_CROAK)
4049                     return NULL;
4050
4051                 namesv = cv_name(cv, NULL, 0);
4052                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4053                                      "subroutine call of &%" SVf " in %s",
4054                                      SVfARG(namesv), PL_op_desc[type]),
4055                            SvUTF8(namesv));
4056                 return o;
4057             }
4058         }
4059         /* FALLTHROUGH */
4060     default:
4061       nomod:
4062         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4063         /* grep, foreach, subcalls, refgen */
4064         if (S_potential_mod_type(type))
4065             break;
4066         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4067                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4068                       ? "do block"
4069                       : OP_DESC(o)),
4070                      type ? PL_op_desc[type] : "local"));
4071         return o;
4072
4073     case OP_PREINC:
4074     case OP_PREDEC:
4075     case OP_POW:
4076     case OP_MULTIPLY:
4077     case OP_DIVIDE:
4078     case OP_MODULO:
4079     case OP_ADD:
4080     case OP_SUBTRACT:
4081     case OP_CONCAT:
4082     case OP_LEFT_SHIFT:
4083     case OP_RIGHT_SHIFT:
4084     case OP_BIT_AND:
4085     case OP_BIT_XOR:
4086     case OP_BIT_OR:
4087     case OP_I_MULTIPLY:
4088     case OP_I_DIVIDE:
4089     case OP_I_MODULO:
4090     case OP_I_ADD:
4091     case OP_I_SUBTRACT:
4092         if (!(o->op_flags & OPf_STACKED))
4093             goto nomod;
4094         PL_modcount++;
4095         break;
4096
4097     case OP_REPEAT:
4098         if (o->op_flags & OPf_STACKED) {
4099             PL_modcount++;
4100             break;
4101         }
4102         if (!(o->op_private & OPpREPEAT_DOLIST))
4103             goto nomod;
4104         else {
4105             const I32 mods = PL_modcount;
4106             modkids(cBINOPo->op_first, type);
4107             if (type != OP_AASSIGN)
4108                 goto nomod;
4109             kid = cBINOPo->op_last;
4110             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4111                 const IV iv = SvIV(kSVOP_sv);
4112                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4113                     PL_modcount =
4114                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4115             }
4116             else
4117                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4118         }
4119         break;
4120
4121     case OP_COND_EXPR:
4122         localize = 1;
4123         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4124             op_lvalue(kid, type);
4125         break;
4126
4127     case OP_RV2AV:
4128     case OP_RV2HV:
4129         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4130            PL_modcount = RETURN_UNLIMITED_NUMBER;
4131            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4132               fiable since some contexts need to know.  */
4133            o->op_flags |= OPf_MOD;
4134            return o;
4135         }
4136         /* FALLTHROUGH */
4137     case OP_RV2GV:
4138         if (scalar_mod_type(o, type))
4139             goto nomod;
4140         ref(cUNOPo->op_first, o->op_type);
4141         /* FALLTHROUGH */
4142     case OP_ASLICE:
4143     case OP_HSLICE:
4144         localize = 1;
4145         /* FALLTHROUGH */
4146     case OP_AASSIGN:
4147         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4148         if (type == OP_LEAVESUBLV && (
4149                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4150              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4151            ))
4152             o->op_private |= OPpMAYBE_LVSUB;
4153         /* FALLTHROUGH */
4154     case OP_NEXTSTATE:
4155     case OP_DBSTATE:
4156        PL_modcount = RETURN_UNLIMITED_NUMBER;
4157         break;
4158     case OP_KVHSLICE:
4159     case OP_KVASLICE:
4160     case OP_AKEYS:
4161         if (type == OP_LEAVESUBLV)
4162             o->op_private |= OPpMAYBE_LVSUB;
4163         goto nomod;
4164     case OP_AVHVSWITCH:
4165         if (type == OP_LEAVESUBLV
4166          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4167             o->op_private |= OPpMAYBE_LVSUB;
4168         goto nomod;
4169     case OP_AV2ARYLEN:
4170         PL_hints |= HINT_BLOCK_SCOPE;
4171         if (type == OP_LEAVESUBLV)
4172             o->op_private |= OPpMAYBE_LVSUB;
4173         PL_modcount++;
4174         break;
4175     case OP_RV2SV:
4176         ref(cUNOPo->op_first, o->op_type);
4177         localize = 1;
4178         /* FALLTHROUGH */
4179     case OP_GV:
4180         PL_hints |= HINT_BLOCK_SCOPE;
4181         /* FALLTHROUGH */
4182     case OP_SASSIGN:
4183     case OP_ANDASSIGN:
4184     case OP_ORASSIGN:
4185     case OP_DORASSIGN:
4186         PL_modcount++;
4187         break;
4188
4189     case OP_AELEMFAST:
4190     case OP_AELEMFAST_LEX:
4191         localize = -1;
4192         PL_modcount++;
4193         break;
4194
4195     case OP_PADAV:
4196     case OP_PADHV:
4197        PL_modcount = RETURN_UNLIMITED_NUMBER;
4198         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4199         {
4200            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4201               fiable since some contexts need to know.  */
4202             o->op_flags |= OPf_MOD;
4203             return o;
4204         }
4205         if (scalar_mod_type(o, type))
4206             goto nomod;
4207         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4208           && type == OP_LEAVESUBLV)
4209             o->op_private |= OPpMAYBE_LVSUB;
4210         /* FALLTHROUGH */
4211     case OP_PADSV:
4212         PL_modcount++;
4213         if (!type) /* local() */
4214             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4215                               PNfARG(PAD_COMPNAME(o->op_targ)));
4216         if (!(o->op_private & OPpLVAL_INTRO)
4217          || (  type != OP_SASSIGN && type != OP_AASSIGN
4218             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4219             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4220         break;
4221
4222     case OP_PUSHMARK:
4223         localize = 0;
4224         break;
4225
4226     case OP_KEYS:
4227         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4228             goto nomod;
4229         goto lvalue_func;
4230     case OP_SUBSTR:
4231         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4232             goto nomod;
4233         /* FALLTHROUGH */
4234     case OP_POS:
4235     case OP_VEC:
4236       lvalue_func:
4237         if (type == OP_LEAVESUBLV)
4238             o->op_private |= OPpMAYBE_LVSUB;
4239         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4240             /* substr and vec */
4241             /* If this op is in merely potential (non-fatal) modifiable
4242                context, then apply OP_ENTERSUB context to
4243                the kid op (to avoid croaking).  Other-
4244                wise pass this op’s own type so the correct op is mentioned
4245                in error messages.  */
4246             op_lvalue(OpSIBLING(cBINOPo->op_first),
4247                       S_potential_mod_type(type)
4248                         ? (I32)OP_ENTERSUB
4249                         : o->op_type);
4250         }
4251         break;
4252
4253     case OP_AELEM:
4254     case OP_HELEM:
4255         ref(cBINOPo->op_first, o->op_type);
4256         if (type == OP_ENTERSUB &&
4257              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4258             o->op_private |= OPpLVAL_DEFER;
4259         if (type == OP_LEAVESUBLV)
4260             o->op_private |= OPpMAYBE_LVSUB;
4261         localize = 1;
4262         PL_modcount++;
4263         break;
4264
4265     case OP_LEAVE:
4266     case OP_LEAVELOOP:
4267         o->op_private |= OPpLVALUE;
4268         /* FALLTHROUGH */
4269     case OP_SCOPE:
4270     case OP_ENTER:
4271     case OP_LINESEQ:
4272         localize = 0;
4273         if (o->op_flags & OPf_KIDS)
4274             op_lvalue(cLISTOPo->op_last, type);
4275         break;
4276
4277     case OP_NULL:
4278         localize = 0;
4279         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4280             goto nomod;
4281         else if (!(o->op_flags & OPf_KIDS))
4282             break;
4283
4284         if (o->op_targ != OP_LIST) {
4285             OP *sib = OpSIBLING(cLISTOPo->op_first);
4286             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4287              * that looks like
4288              *
4289              *   null
4290              *      arg
4291              *      trans
4292              *
4293              * compared with things like OP_MATCH which have the argument
4294              * as a child:
4295              *
4296              *   match
4297              *      arg
4298              *
4299              * so handle specially to correctly get "Can't modify" croaks etc
4300              */
4301
4302             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4303             {
4304                 /* this should trigger a "Can't modify transliteration" err */
4305                 op_lvalue(sib, type);
4306             }
4307             op_lvalue(cBINOPo->op_first, type);
4308             break;
4309         }
4310         /* FALLTHROUGH */
4311     case OP_LIST:
4312         localize = 0;
4313         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4314             /* elements might be in void context because the list is
4315                in scalar context or because they are attribute sub calls */
4316             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4317                 op_lvalue(kid, type);
4318         break;
4319
4320     case OP_COREARGS:
4321         return o;
4322
4323     case OP_AND:
4324     case OP_OR:
4325         if (type == OP_LEAVESUBLV
4326          || !S_vivifies(cLOGOPo->op_first->op_type))
4327             op_lvalue(cLOGOPo->op_first, type);
4328         if (type == OP_LEAVESUBLV
4329          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4330             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4331         goto nomod;
4332
4333     case OP_SREFGEN:
4334         if (type == OP_NULL) { /* local */
4335           local_refgen:
4336             if (!FEATURE_MYREF_IS_ENABLED)
4337                 Perl_croak(aTHX_ "The experimental declared_refs "
4338                                  "feature is not enabled");
4339             Perl_ck_warner_d(aTHX_
4340                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4341                     "Declaring references is experimental");
4342             op_lvalue(cUNOPo->op_first, OP_NULL);
4343             return o;
4344         }
4345         if (type != OP_AASSIGN && type != OP_SASSIGN
4346          && type != OP_ENTERLOOP)
4347             goto nomod;
4348         /* Don’t bother applying lvalue context to the ex-list.  */
4349         kid = cUNOPx(cUNOPo->op_first)->op_first;
4350         assert (!OpHAS_SIBLING(kid));
4351         goto kid_2lvref;
4352     case OP_REFGEN:
4353         if (type == OP_NULL) /* local */
4354             goto local_refgen;
4355         if (type != OP_AASSIGN) goto nomod;
4356         kid = cUNOPo->op_first;
4357       kid_2lvref:
4358         {
4359             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4360             S_lvref(aTHX_ kid, type);
4361             if (!PL_parser || PL_parser->error_count == ec) {
4362                 if (!FEATURE_REFALIASING_IS_ENABLED)
4363                     Perl_croak(aTHX_
4364                        "Experimental aliasing via reference not enabled");
4365                 Perl_ck_warner_d(aTHX_
4366                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4367                                 "Aliasing via reference is experimental");
4368             }
4369         }
4370         if (o->op_type == OP_REFGEN)
4371             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4372         op_null(o);
4373         return o;
4374
4375     case OP_SPLIT:
4376         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4377             /* This is actually @array = split.  */
4378             PL_modcount = RETURN_UNLIMITED_NUMBER;
4379             break;
4380         }
4381         goto nomod;
4382
4383     case OP_SCALAR:
4384         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4385         goto nomod;
4386     }
4387
4388     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4389        their argument is a filehandle; thus \stat(".") should not set
4390        it. AMS 20011102 */
4391     if (type == OP_REFGEN &&
4392         PL_check[o->op_type] == Perl_ck_ftst)
4393         return o;
4394
4395     if (type != OP_LEAVESUBLV)
4396         o->op_flags |= OPf_MOD;
4397
4398     if (type == OP_AASSIGN || type == OP_SASSIGN)
4399         o->op_flags |= OPf_SPECIAL
4400                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4401     else if (!type) { /* local() */
4402         switch (localize) {
4403         case 1:
4404             o->op_private |= OPpLVAL_INTRO;
4405             o->op_flags &= ~OPf_SPECIAL;
4406             PL_hints |= HINT_BLOCK_SCOPE;
4407             break;
4408         case 0:
4409             break;
4410         case -1:
4411             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4412                            "Useless localization of %s", OP_DESC(o));
4413         }
4414     }
4415     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4416              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4417         o->op_flags |= OPf_REF;
4418     return o;
4419 }
4420
4421 STATIC bool
4422 S_scalar_mod_type(const OP *o, I32 type)
4423 {
4424     switch (type) {
4425     case OP_POS:
4426     case OP_SASSIGN:
4427         if (o && o->op_type == OP_RV2GV)
4428             return FALSE;
4429         /* FALLTHROUGH */
4430     case OP_PREINC:
4431     case OP_PREDEC:
4432     case OP_POSTINC:
4433     case OP_POSTDEC:
4434     case OP_I_PREINC:
4435     case OP_I_PREDEC:
4436     case OP_I_POSTINC:
4437     case OP_I_POSTDEC:
4438     case OP_POW:
4439     case OP_MULTIPLY:
4440     case OP_DIVIDE:
4441     case OP_MODULO:
4442     case OP_REPEAT:
4443     case OP_ADD:
4444     case OP_SUBTRACT:
4445     case OP_I_MULTIPLY:
4446     case OP_I_DIVIDE:
4447     case OP_I_MODULO:
4448     case OP_I_ADD:
4449     case OP_I_SUBTRACT:
4450     case OP_LEFT_SHIFT:
4451     case OP_RIGHT_SHIFT:
4452     case OP_BIT_AND:
4453     case OP_BIT_XOR:
4454     case OP_BIT_OR:
4455     case OP_NBIT_AND:
4456     case OP_NBIT_XOR:
4457     case OP_NBIT_OR:
4458     case OP_SBIT_AND:
4459     case OP_SBIT_XOR:
4460     case OP_SBIT_OR:
4461     case OP_CONCAT:
4462     case OP_SUBST:
4463     case OP_TRANS:
4464     case OP_TRANSR:
4465     case OP_READ:
4466     case OP_SYSREAD:
4467     case OP_RECV:
4468     case OP_ANDASSIGN:
4469     case OP_ORASSIGN:
4470     case OP_DORASSIGN:
4471     case OP_VEC:
4472     case OP_SUBSTR:
4473         return TRUE;
4474     default:
4475         return FALSE;
4476     }
4477 }
4478
4479 STATIC bool
4480 S_is_handle_constructor(const OP *o, I32 numargs)
4481 {
4482     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4483
4484     switch (o->op_type) {
4485     case OP_PIPE_OP:
4486     case OP_SOCKPAIR:
4487         if (numargs == 2)
4488             return TRUE;
4489         /* FALLTHROUGH */
4490     case OP_SYSOPEN:
4491     case OP_OPEN:
4492     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4493     case OP_SOCKET:
4494     case OP_OPEN_DIR:
4495     case OP_ACCEPT:
4496         if (numargs == 1)
4497             return TRUE;
4498         /* FALLTHROUGH */
4499     default:
4500         return FALSE;
4501     }
4502 }
4503
4504 static OP *
4505 S_refkids(pTHX_ OP *o, I32 type)
4506 {
4507     if (o && o->op_flags & OPf_KIDS) {
4508         OP *kid;
4509         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4510             ref(kid, type);
4511     }
4512     return o;
4513 }
4514
4515 OP *
4516 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4517 {
4518     dVAR;
4519     OP *kid;
4520
4521     PERL_ARGS_ASSERT_DOREF;
4522
4523     if (PL_parser && PL_parser->error_count)
4524         return o;
4525
4526     switch (o->op_type) {
4527     case OP_ENTERSUB:
4528         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4529             !(o->op_flags & OPf_STACKED)) {
4530             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4531             assert(cUNOPo->op_first->op_type == OP_NULL);
4532             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4533             o->op_flags |= OPf_SPECIAL;
4534         }
4535         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4536             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4537                               : type == OP_RV2HV ? OPpDEREF_HV
4538                               : OPpDEREF_SV);
4539             o->op_flags |= OPf_MOD;
4540         }
4541
4542         break;
4543
4544     case OP_COND_EXPR:
4545         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4546             doref(kid, type, set_op_ref);
4547         break;
4548     case OP_RV2SV:
4549         if (type == OP_DEFINED)
4550             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4551         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4552         /* FALLTHROUGH */
4553     case OP_PADSV:
4554         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4555             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4556                               : type == OP_RV2HV ? OPpDEREF_HV
4557                               : OPpDEREF_SV);
4558             o->op_flags |= OPf_MOD;
4559         }
4560         break;
4561
4562     case OP_RV2AV:
4563     case OP_RV2HV:
4564         if (set_op_ref)
4565             o->op_flags |= OPf_REF;
4566         /* FALLTHROUGH */
4567     case OP_RV2GV:
4568         if (type == OP_DEFINED)
4569             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4570         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4571         break;
4572
4573     case OP_PADAV:
4574     case OP_PADHV:
4575         if (set_op_ref)
4576             o->op_flags |= OPf_REF;
4577         break;
4578
4579     case OP_SCALAR:
4580     case OP_NULL:
4581         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4582             break;
4583         doref(cBINOPo->op_first, type, set_op_ref);
4584         break;
4585     case OP_AELEM:
4586     case OP_HELEM:
4587         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4588         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4589             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4590                               : type == OP_RV2HV ? OPpDEREF_HV
4591                               : OPpDEREF_SV);
4592             o->op_flags |= OPf_MOD;
4593         }
4594         break;
4595
4596     case OP_SCOPE:
4597     case OP_LEAVE:
4598         set_op_ref = FALSE;
4599         /* FALLTHROUGH */
4600     case OP_ENTER:
4601     case OP_LIST:
4602         if (!(o->op_flags & OPf_KIDS))
4603             break;
4604         doref(cLISTOPo->op_last, type, set_op_ref);
4605         break;
4606     default:
4607         break;
4608     }
4609     return scalar(o);
4610
4611 }
4612
4613 STATIC OP *
4614 S_dup_attrlist(pTHX_ OP *o)
4615 {
4616     OP *rop;
4617
4618     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4619
4620     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4621      * where the first kid is OP_PUSHMARK and the remaining ones
4622      * are OP_CONST.  We need to push the OP_CONST values.
4623      */
4624     if (o->op_type == OP_CONST)
4625         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4626     else {
4627         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4628         rop = NULL;
4629         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4630             if (o->op_type == OP_CONST)
4631                 rop = op_append_elem(OP_LIST, rop,
4632                                   newSVOP(OP_CONST, o->op_flags,
4633                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4634         }
4635     }
4636     return rop;
4637 }
4638
4639 STATIC void
4640 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4641 {
4642     PERL_ARGS_ASSERT_APPLY_ATTRS;
4643     {
4644         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4645
4646         /* fake up C<use attributes $pkg,$rv,@attrs> */
4647
4648 #define ATTRSMODULE "attributes"
4649 #define ATTRSMODULE_PM "attributes.pm"
4650
4651         Perl_load_module(
4652           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4653           newSVpvs(ATTRSMODULE),
4654           NULL,
4655           op_prepend_elem(OP_LIST,
4656                           newSVOP(OP_CONST, 0, stashsv),
4657                           op_prepend_elem(OP_LIST,
4658                                           newSVOP(OP_CONST, 0,
4659                                                   newRV(target)),
4660                                           dup_attrlist(attrs))));
4661     }
4662 }
4663
4664 STATIC void
4665 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4666 {
4667     OP *pack, *imop, *arg;
4668     SV *meth, *stashsv, **svp;
4669
4670     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4671
4672     if (!attrs)
4673         return;
4674
4675     assert(target->op_type == OP_PADSV ||
4676            target->op_type == OP_PADHV ||
4677            target->op_type == OP_PADAV);
4678
4679     /* Ensure that attributes.pm is loaded. */
4680     /* Don't force the C<use> if we don't need it. */
4681     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4682     if (svp && *svp != &PL_sv_undef)
4683         NOOP;   /* already in %INC */
4684     else
4685         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4686                                newSVpvs(ATTRSMODULE), NULL);
4687
4688     /* Need package name for method call. */
4689     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4690
4691     /* Build up the real arg-list. */
4692     stashsv = newSVhek(HvNAME_HEK(stash));
4693
4694     arg = newOP(OP_PADSV, 0);
4695     arg->op_targ = target->op_targ;
4696     arg = op_prepend_elem(OP_LIST,
4697                        newSVOP(OP_CONST, 0, stashsv),
4698                        op_prepend_elem(OP_LIST,
4699                                     newUNOP(OP_REFGEN, 0,
4700                                             arg),
4701                                     dup_attrlist(attrs)));
4702
4703     /* Fake up a method call to import */
4704     meth = newSVpvs_share("import");
4705     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4706                    op_append_elem(OP_LIST,
4707                                op_prepend_elem(OP_LIST, pack, arg),
4708                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4709
4710     /* Combine the ops. */
4711     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4712 }
4713
4714 /*
4715 =notfor apidoc apply_attrs_string
4716
4717 Attempts to apply a list of attributes specified by the C<attrstr> and
4718 C<len> arguments to the subroutine identified by the C<cv> argument which
4719 is expected to be associated with the package identified by the C<stashpv>
4720 argument (see L<attributes>).  It gets this wrong, though, in that it
4721 does not correctly identify the boundaries of the individual attribute
4722 specifications within C<attrstr>.  This is not really intended for the
4723 public API, but has to be listed here for systems such as AIX which
4724 need an explicit export list for symbols.  (It's called from XS code
4725 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4726 to respect attribute syntax properly would be welcome.
4727
4728 =cut
4729 */
4730
4731 void
4732 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4733                         const char *attrstr, STRLEN len)
4734 {
4735     OP *attrs = NULL;
4736
4737     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4738
4739     if (!len) {
4740         len = strlen(attrstr);
4741     }
4742
4743     while (len) {
4744         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4745         if (len) {
4746             const char * const sstr = attrstr;
4747             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4748             attrs = op_append_elem(OP_LIST, attrs,
4749                                 newSVOP(OP_CONST, 0,
4750                                         newSVpvn(sstr, attrstr-sstr)));
4751         }
4752     }
4753
4754     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4755                      newSVpvs(ATTRSMODULE),
4756                      NULL, op_prepend_elem(OP_LIST,
4757                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4758                                   op_prepend_elem(OP_LIST,
4759                                                newSVOP(OP_CONST, 0,
4760                                                        newRV(MUTABLE_SV(cv))),
4761                                                attrs)));
4762 }
4763
4764 STATIC void
4765 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4766                         bool curstash)
4767 {
4768     OP *new_proto = NULL;
4769     STRLEN pvlen;
4770     char *pv;
4771     OP *o;
4772
4773     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4774
4775     if (!*attrs)
4776         return;
4777
4778     o = *attrs;
4779     if (o->op_type == OP_CONST) {
4780         pv = SvPV(cSVOPo_sv, pvlen);
4781         if (memBEGINs(pv, pvlen, "prototype(")) {
4782             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4783             SV ** const tmpo = cSVOPx_svp(o);
4784             SvREFCNT_dec(cSVOPo_sv);
4785             *tmpo = tmpsv;
4786             new_proto = o;
4787             *attrs = NULL;
4788         }
4789     } else if (o->op_type == OP_LIST) {
4790         OP * lasto;
4791         assert(o->op_flags & OPf_KIDS);
4792         lasto = cLISTOPo->op_first;
4793         assert(lasto->op_type == OP_PUSHMARK);
4794         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4795             if (o->op_type == OP_CONST) {
4796                 pv = SvPV(cSVOPo_sv, pvlen);
4797                 if (memBEGINs(pv, pvlen, "prototype(")) {
4798                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4799                     SV ** const tmpo = cSVOPx_svp(o);
4800                     SvREFCNT_dec(cSVOPo_sv);
4801                     *tmpo = tmpsv;
4802                     if (new_proto && ckWARN(WARN_MISC)) {
4803                         STRLEN new_len;
4804                         const char * newp = SvPV(cSVOPo_sv, new_len);
4805                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4806                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4807                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4808                         op_free(new_proto);
4809                     }
4810                     else if (new_proto)
4811                         op_free(new_proto);
4812                     new_proto = o;
4813                     /* excise new_proto from the list */
4814                     op_sibling_splice(*attrs, lasto, 1, NULL);
4815                     o = lasto;
4816                     continue;
4817                 }
4818             }
4819             lasto = o;
4820         }
4821         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4822            would get pulled in with no real need */
4823         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4824             op_free(*attrs);
4825             *attrs = NULL;
4826         }
4827     }
4828
4829     if (new_proto) {
4830         SV *svname;
4831         if (isGV(name)) {
4832             svname = sv_newmortal();
4833             gv_efullname3(svname, name, NULL);
4834         }
4835         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4836             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4837         else
4838             svname = (SV *)name;
4839         if (ckWARN(WARN_ILLEGALPROTO))
4840             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4841                                  curstash);
4842         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4843             STRLEN old_len, new_len;
4844             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4845             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4846
4847             if (curstash && svname == (SV *)name
4848              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4849                 svname = sv_2mortal(newSVsv(PL_curstname));
4850                 sv_catpvs(svname, "::");
4851                 sv_catsv(svname, (SV *)name);
4852             }
4853
4854             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4855                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4856                 " in %" SVf,
4857                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4858                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4859                 SVfARG(svname));
4860         }
4861         if (*proto)
4862             op_free(*proto);
4863         *proto = new_proto;
4864     }
4865 }
4866
4867 static void
4868 S_cant_declare(pTHX_ OP *o)
4869 {
4870     if (o->op_type == OP_NULL
4871      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4872         o = cUNOPo->op_first;
4873     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4874                              o->op_type == OP_NULL
4875                                && o->op_flags & OPf_SPECIAL
4876                                  ? "do block"
4877                                  : OP_DESC(o),
4878                              PL_parser->in_my == KEY_our   ? "our"   :
4879                              PL_parser->in_my == KEY_state ? "state" :
4880                                                              "my"));
4881 }
4882
4883 STATIC OP *
4884 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4885 {
4886     I32 type;
4887     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4888
4889     PERL_ARGS_ASSERT_MY_KID;
4890
4891     if (!o || (PL_parser && PL_parser->error_count))
4892         return o;
4893
4894     type = o->op_type;
4895
4896     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4897         OP *kid;
4898         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4899             my_kid(kid, attrs, imopsp);
4900         return o;
4901     } else if (type == OP_UNDEF || type == OP_STUB) {
4902         return o;
4903     } else if (type == OP_RV2SV ||      /* "our" declaration */
4904                type == OP_RV2AV ||
4905                type == OP_RV2HV) {
4906         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4907             S_cant_declare(aTHX_ o);
4908         } else if (attrs) {
4909             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4910             assert(PL_parser);
4911             PL_parser->in_my = FALSE;
4912             PL_parser->in_my_stash = NULL;
4913             apply_attrs(GvSTASH(gv),
4914                         (type == OP_RV2SV ? GvSVn(gv) :
4915                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4916                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4917                         attrs);
4918         }
4919         o->op_private |= OPpOUR_INTRO;
4920         return o;
4921     }
4922     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4923         if (!FEATURE_MYREF_IS_ENABLED)
4924             Perl_croak(aTHX_ "The experimental declared_refs "
4925                              "feature is not enabled");
4926         Perl_ck_warner_d(aTHX_
4927              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4928             "Declaring references is experimental");
4929         /* Kid is a nulled OP_LIST, handled above.  */
4930         my_kid(cUNOPo->op_first, attrs, imopsp);
4931         return o;
4932     }
4933     else if (type != OP_PADSV &&
4934              type != OP_PADAV &&
4935              type != OP_PADHV &&
4936              type != OP_PUSHMARK)
4937     {
4938         S_cant_declare(aTHX_ o);
4939         return o;
4940     }
4941     else if (attrs && type != OP_PUSHMARK) {
4942         HV *stash;
4943
4944         assert(PL_parser);
4945         PL_parser->in_my = FALSE;
4946         PL_parser->in_my_stash = NULL;
4947
4948         /* check for C<my Dog $spot> when deciding package */
4949         stash = PAD_COMPNAME_TYPE(o->op_targ);
4950         if (!stash)
4951             stash = PL_curstash;
4952         apply_attrs_my(stash, o, attrs, imopsp);
4953     }
4954     o->op_flags |= OPf_MOD;
4955     o->op_private |= OPpLVAL_INTRO;
4956     if (stately)
4957         o->op_private |= OPpPAD_STATE;
4958     return o;
4959 }
4960
4961 OP *
4962 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4963 {
4964     OP *rops;
4965     int maybe_scalar = 0;
4966
4967     PERL_ARGS_ASSERT_MY_ATTRS;
4968
4969 /* [perl #17376]: this appears to be premature, and results in code such as
4970    C< our(%x); > executing in list mode rather than void mode */
4971 #if 0
4972     if (o->op_flags & OPf_PARENS)
4973         list(o);
4974     else
4975         maybe_scalar = 1;
4976 #else
4977     maybe_scalar = 1;
4978 #endif
4979     if (attrs)
4980         SAVEFREEOP(attrs);
4981     rops = NULL;
4982     o = my_kid(o, attrs, &rops);
4983     if (rops) {
4984         if (maybe_scalar && o->op_type == OP_PADSV) {
4985             o = scalar(op_append_list(OP_LIST, rops, o));
4986             o->op_private |= OPpLVAL_INTRO;
4987         }
4988         else {
4989             /* The listop in rops might have a pushmark at the beginning,
4990                which will mess up list assignment. */
4991             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4992             if (rops->op_type == OP_LIST &&
4993                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4994             {
4995                 OP * const pushmark = lrops->op_first;
4996                 /* excise pushmark */
4997                 op_sibling_splice(rops, NULL, 1, NULL);
4998                 op_free(pushmark);
4999             }
5000             o = op_append_list(OP_LIST, o, rops);
5001         }
5002     }
5003     PL_parser->in_my = FALSE;
5004     PL_parser->in_my_stash = NULL;
5005     return o;
5006 }
5007
5008 OP *
5009 Perl_sawparens(pTHX_ OP *o)
5010 {
5011     PERL_UNUSED_CONTEXT;
5012     if (o)
5013         o->op_flags |= OPf_PARENS;
5014     return o;
5015 }
5016
5017 OP *
5018 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5019 {
5020     OP *o;
5021     bool ismatchop = 0;
5022     const OPCODE ltype = left->op_type;
5023     const OPCODE rtype = right->op_type;
5024
5025     PERL_ARGS_ASSERT_BIND_MATCH;
5026
5027     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5028           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5029     {
5030       const char * const desc
5031           = PL_op_desc[(
5032                           rtype == OP_SUBST || rtype == OP_TRANS
5033                        || rtype == OP_TRANSR
5034                        )
5035                        ? (int)rtype : OP_MATCH];
5036       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5037       SV * const name =
5038         S_op_varname(aTHX_ left);
5039       if (name)
5040         Perl_warner(aTHX_ packWARN(WARN_MISC),
5041              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5042              desc, SVfARG(name), SVfARG(name));
5043       else {
5044         const char * const sample = (isary
5045              ? "@array" : "%hash");
5046         Perl_warner(aTHX_ packWARN(WARN_MISC),
5047              "Applying %s to %s will act on scalar(%s)",
5048              desc, sample, sample);
5049       }
5050     }
5051
5052     if (rtype == OP_CONST &&
5053         cSVOPx(right)->op_private & OPpCONST_BARE &&
5054         cSVOPx(right)->op_private & OPpCONST_STRICT)
5055     {
5056         no_bareword_allowed(right);
5057     }
5058
5059     /* !~ doesn't make sense with /r, so error on it for now */
5060     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5061         type == OP_NOT)
5062         /* diag_listed_as: Using !~ with %s doesn't make sense */
5063         yyerror("Using !~ with s///r doesn't make sense");
5064     if (rtype == OP_TRANSR && type == OP_NOT)
5065         /* diag_listed_as: Using !~ with %s doesn't make sense */
5066         yyerror("Using !~ with tr///r doesn't make sense");
5067
5068     ismatchop = (rtype == OP_MATCH ||
5069                  rtype == OP_SUBST ||
5070                  rtype == OP_TRANS || rtype == OP_TRANSR)
5071              && !(right->op_flags & OPf_SPECIAL);
5072     if (ismatchop && right->op_private & OPpTARGET_MY) {
5073         right->op_targ = 0;
5074         right->op_private &= ~OPpTARGET_MY;
5075     }
5076     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5077         if (left->op_type == OP_PADSV
5078          && !(left->op_private & OPpLVAL_INTRO))
5079         {
5080             right->op_targ = left->op_targ;
5081             op_free(left);
5082             o = right;
5083         }
5084         else {
5085             right->op_flags |= OPf_STACKED;
5086             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5087             ! (rtype == OP_TRANS &&
5088                right->op_private & OPpTRANS_IDENTICAL) &&
5089             ! (rtype == OP_SUBST &&
5090                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5091                 left = op_lvalue(left, rtype);
5092             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5093                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5094             else
5095                 o = op_prepend_elem(rtype, scalar(left), right);
5096         }
5097         if (type == OP_NOT)
5098             return newUNOP(OP_NOT, 0, scalar(o));
5099         return o;
5100     }
5101     else
5102         return bind_match(type, left,
5103                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5104 }
5105
5106 OP *
5107 Perl_invert(pTHX_ OP *o)
5108 {
5109     if (!o)
5110         return NULL;
5111     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5112 }
5113
5114 /*
5115 =for apidoc Amx|OP *|op_scope|OP *o
5116
5117 Wraps up an op tree with some additional ops so that at runtime a dynamic
5118 scope will be created.  The original ops run in the new dynamic scope,
5119 and then, provided that they exit normally, the scope will be unwound.
5120 The additional ops used to create and unwind the dynamic scope will
5121 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5122 instead if the ops are simple enough to not need the full dynamic scope
5123 structure.
5124
5125 =cut
5126 */
5127
5128 OP *
5129 Perl_op_scope(pTHX_ OP *o)
5130 {
5131     dVAR;
5132     if (o) {
5133         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5134             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5135             OpTYPE_set(o, OP_LEAVE);
5136         }
5137         else if (o->op_type == OP_LINESEQ) {
5138             OP *kid;
5139             OpTYPE_set(o, OP_SCOPE);
5140             kid = ((LISTOP*)o)->op_first;
5141             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5142                 op_null(kid);
5143
5144                 /* The following deals with things like 'do {1 for 1}' */
5145                 kid = OpSIBLING(kid);
5146                 if (kid &&
5147                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5148                     op_null(kid);
5149             }
5150         }
5151         else
5152             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5153     }
5154     return o;
5155 }
5156
5157 OP *
5158 Perl_op_unscope(pTHX_ OP *o)
5159 {
5160     if (o && o->op_type == OP_LINESEQ) {
5161         OP *kid = cLISTOPo->op_first;
5162         for(; kid; kid = OpSIBLING(kid))
5163             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5164                 op_null(kid);
5165     }
5166     return o;
5167 }
5168
5169 /*
5170 =for apidoc Am|int|block_start|int full
5171
5172 Handles compile-time scope entry.
5173 Arranges for hints to be restored on block
5174 exit and also handles pad sequence numbers to make lexical variables scope
5175 right.  Returns a savestack index for use with C<block_end>.
5176
5177 =cut
5178 */
5179
5180 int
5181 Perl_block_start(pTHX_ int full)
5182 {
5183     const int retval = PL_savestack_ix;
5184
5185     PL_compiling.cop_seq = PL_cop_seqmax;
5186     COP_SEQMAX_INC;
5187     pad_block_start(full);
5188     SAVEHINTS();
5189     PL_hints &= ~HINT_BLOCK_SCOPE;
5190     SAVECOMPILEWARNINGS();
5191     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5192     SAVEI32(PL_compiling.cop_seq);
5193     PL_compiling.cop_seq = 0;
5194
5195     CALL_BLOCK_HOOKS(bhk_start, full);
5196
5197     return retval;
5198 }
5199
5200 /*
5201 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5202
5203 Handles compile-time scope exit.  C<floor>
5204 is the savestack index returned by
5205 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5206 possibly modified.
5207
5208 =cut
5209 */
5210
5211 OP*
5212 Perl_block_end(pTHX_ I32 floor, OP *seq)
5213 {
5214     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5215     OP* retval = scalarseq(seq);
5216     OP *o;
5217
5218     /* XXX Is the null PL_parser check necessary here? */
5219     assert(PL_parser); /* Let’s find out under debugging builds.  */
5220     if (PL_parser && PL_parser->parsed_sub) {
5221         o = newSTATEOP(0, NULL, NULL);
5222         op_null(o);
5223         retval = op_append_elem(OP_LINESEQ, retval, o);
5224     }
5225
5226     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5227
5228     LEAVE_SCOPE(floor);
5229     if (needblockscope)
5230         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5231     o = pad_leavemy();
5232
5233     if (o) {
5234         /* pad_leavemy has created a sequence of introcv ops for all my
5235            subs declared in the block.  We have to replicate that list with
5236            clonecv ops, to deal with this situation:
5237
5238                sub {
5239                    my sub s1;
5240                    my sub s2;
5241                    sub s1 { state sub foo { \&s2 } }
5242                }->()
5243
5244            Originally, I was going to have introcv clone the CV and turn
5245            off the stale flag.  Since &s1 is declared before &s2, the
5246            introcv op for &s1 is executed (on sub entry) before the one for
5247            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5248            cloned, since it is a state sub) closes over &s2 and expects
5249            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5250            then &s2 is still marked stale.  Since &s1 is not active, and
5251            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5252            ble will not stay shared’ warning.  Because it is the same stub
5253            that will be used when the introcv op for &s2 is executed, clos-
5254            ing over it is safe.  Hence, we have to turn off the stale flag
5255            on all lexical subs in the block before we clone any of them.
5256            Hence, having introcv clone the sub cannot work.  So we create a
5257            list of ops like this:
5258
5259                lineseq
5260                   |
5261                   +-- introcv
5262                   |
5263                   +-- introcv
5264                   |
5265                   +-- introcv
5266                   |
5267                   .
5268                   .
5269                   .
5270                   |
5271                   +-- clonecv
5272                   |
5273                   +-- clonecv
5274                   |
5275                   +-- clonecv
5276                   |
5277                   .
5278                   .
5279                   .
5280          */
5281         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5282         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5283         for (;; kid = OpSIBLING(kid)) {
5284             OP *newkid = newOP(OP_CLONECV, 0);
5285             newkid->op_targ = kid->op_targ;
5286             o = op_append_elem(OP_LINESEQ, o, newkid);
5287             if (kid == last) break;
5288         }
5289         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5290     }
5291
5292     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5293
5294     return retval;
5295 }
5296
5297 /*
5298 =head1 Compile-time scope hooks
5299
5300 =for apidoc Aox||blockhook_register
5301
5302 Register a set of hooks to be called when the Perl lexical scope changes
5303 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5304
5305 =cut
5306 */
5307
5308 void
5309 Perl_blockhook_register(pTHX_ BHK *hk)
5310 {
5311     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5312
5313     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5314 }
5315
5316 void
5317 Perl_newPROG(pTHX_ OP *o)
5318 {
5319     OP *start;
5320
5321     PERL_ARGS_ASSERT_NEWPROG;
5322
5323     if (PL_in_eval) {
5324         PERL_CONTEXT *cx;
5325         I32 i;
5326         if (PL_eval_root)
5327                 return;
5328         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5329                                ((PL_in_eval & EVAL_KEEPERR)
5330                                 ? OPf_SPECIAL : 0), o);
5331
5332         cx = CX_CUR();
5333         assert(CxTYPE(cx) == CXt_EVAL);
5334
5335         if ((cx->blk_gimme & G_WANT) == G_VOID)
5336             scalarvoid(PL_eval_root);
5337         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5338             list(PL_eval_root);
5339         else
5340             scalar(PL_eval_root);
5341
5342         start = op_linklist(PL_eval_root);
5343         PL_eval_root->op_next = 0;
5344         i = PL_savestack_ix;
5345         SAVEFREEOP(o);
5346         ENTER;
5347         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5348         LEAVE;
5349         PL_savestack_ix = i;
5350     }
5351     else {
5352         if (o->op_type == OP_STUB) {
5353             /* This block is entered if nothing is compiled for the main
5354                program. This will be the case for an genuinely empty main
5355                program, or one which only has BEGIN blocks etc, so already
5356                run and freed.
5357
5358                Historically (5.000) the guard above was !o. However, commit
5359                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5360                c71fccf11fde0068, changed perly.y so that newPROG() is now
5361                called with the output of block_end(), which returns a new
5362                OP_STUB for the case of an empty optree. ByteLoader (and
5363                maybe other things) also take this path, because they set up
5364                PL_main_start and PL_main_root directly, without generating an
5365                optree.
5366
5367                If the parsing the main program aborts (due to parse errors,
5368                or due to BEGIN or similar calling exit), then newPROG()
5369                isn't even called, and hence this code path and its cleanups
5370                are skipped. This shouldn't make a make a difference:
5371                * a non-zero return from perl_parse is a failure, and
5372                  perl_destruct() should be called immediately.
5373                * however, if exit(0) is called during the parse, then
5374                  perl_parse() returns 0, and perl_run() is called. As
5375                  PL_main_start will be NULL, perl_run() will return
5376                  promptly, and the exit code will remain 0.
5377             */
5378
5379             PL_comppad_name = 0;
5380             PL_compcv = 0;
5381             S_op_destroy(aTHX_ o);
5382             return;
5383         }
5384         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5385         PL_curcop = &PL_compiling;
5386         start = LINKLIST(PL_main_root);
5387         PL_main_root->op_next = 0;
5388         S_process_optree(aTHX_ NULL, PL_main_root, start);
5389         cv_forget_slab(PL_compcv);
5390         PL_compcv = 0;
5391
5392         /* Register with debugger */
5393         if (PERLDB_INTER) {
5394             CV * const cv = get_cvs("DB::postponed", 0);
5395             if (cv) {
5396                 dSP;
5397                 PUSHMARK(SP);
5398                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5399                 PUTBACK;
5400                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5401             }
5402         }
5403     }
5404 }
5405
5406 OP *
5407 Perl_localize(pTHX_ OP *o, I32 lex)
5408 {
5409     PERL_ARGS_ASSERT_LOCALIZE;
5410
5411     if (o->op_flags & OPf_PARENS)
5412 /* [perl #17376]: this appears to be premature, and results in code such as
5413    C< our(%x); > executing in list mode rather than void mode */
5414 #if 0
5415         list(o);
5416 #else
5417         NOOP;
5418 #endif
5419     else {
5420         if ( PL_parser->bufptr > PL_parser->oldbufptr
5421             && PL_parser->bufptr[-1] == ','
5422             && ckWARN(WARN_PARENTHESIS))
5423         {
5424             char *s = PL_parser->bufptr;
5425             bool sigil = FALSE;
5426
5427             /* some heuristics to detect a potential error */
5428             while (*s && (strchr(", \t\n", *s)))
5429                 s++;
5430
5431             while (1) {
5432                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5433                        && *++s
5434                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5435                     s++;
5436                     sigil = TRUE;
5437                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5438                         s++;
5439                     while (*s && (strchr(", \t\n", *s)))
5440                         s++;
5441                 }
5442                 else
5443                     break;
5444             }
5445             if (sigil && (*s == ';' || *s == '=')) {
5446                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5447                                 "Parentheses missing around \"%s\" list",
5448                                 lex
5449                                     ? (PL_parser->in_my == KEY_our
5450                                         ? "our"
5451                                         : PL_parser->in_my == KEY_state
5452                                             ? "state"
5453                                             : "my")
5454                                     : "local");
5455             }
5456         }
5457     }
5458     if (lex)
5459         o = my(o);
5460     else
5461         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5462     PL_parser->in_my = FALSE;
5463     PL_parser->in_my_stash = NULL;
5464     return o;
5465 }
5466
5467 OP *
5468 Perl_jmaybe(pTHX_ OP *o)
5469 {
5470     PERL_ARGS_ASSERT_JMAYBE;
5471
5472     if (o->op_type == OP_LIST) {
5473         OP * const o2
5474             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5475         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5476     }
5477     return o;
5478 }
5479
5480 PERL_STATIC_INLINE OP *
5481 S_op_std_init(pTHX_ OP *o)
5482 {
5483     I32 type = o->op_type;
5484
5485     PERL_ARGS_ASSERT_OP_STD_INIT;
5486
5487     if (PL_opargs[type] & OA_RETSCALAR)
5488         scalar(o);
5489     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5490         o->op_targ = pad_alloc(type, SVs_PADTMP);
5491
5492     return o;
5493 }
5494
5495 PERL_STATIC_INLINE OP *
5496 S_op_integerize(pTHX_ OP *o)
5497 {
5498     I32 type = o->op_type;
5499
5500     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5501
5502     /* integerize op. */
5503     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5504     {
5505         dVAR;
5506         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5507     }
5508
5509     if (type == OP_NEGATE)
5510         /* XXX might want a ck_negate() for this */
5511         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5512
5513     return o;
5514 }
5515
5516 /* This function exists solely to provide a scope to limit
5517    setjmp/longjmp() messing with auto variables.
5518  */
5519 PERL_STATIC_INLINE int
5520 S_fold_constants_eval(pTHX) {
5521     int ret = 0;
5522     dJMPENV;
5523
5524     JMPENV_PUSH(ret);
5525
5526     if (ret == 0) {
5527         CALLRUNOPS(aTHX);
5528     }
5529
5530     JMPENV_POP;
5531
5532     return ret;
5533 }
5534
5535 static OP *
5536 S_fold_constants(pTHX_ OP *const o)
5537 {
5538     dVAR;
5539     OP *curop;
5540     OP *newop;
5541     I32 type = o->op_type;
5542     bool is_stringify;
5543     SV *sv = NULL;
5544     int ret = 0;
5545     OP *old_next;
5546     SV * const oldwarnhook = PL_warnhook;
5547     SV * const olddiehook  = PL_diehook;
5548     COP not_compiling;
5549     U8 oldwarn = PL_dowarn;
5550     I32 old_cxix;
5551
5552     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5553
5554     if (!(PL_opargs[type] & OA_FOLDCONST))
5555         goto nope;
5556
5557     switch (type) {
5558     case OP_UCFIRST:
5559     case OP_LCFIRST:
5560     case OP_UC:
5561     case OP_LC:
5562     case OP_FC:
5563 #ifdef USE_LOCALE_CTYPE
5564         if (IN_LC_COMPILETIME(LC_CTYPE))
5565             goto nope;
5566 #endif
5567         break;
5568     case OP_SLT:
5569     case OP_SGT:
5570     case OP_SLE:
5571     case OP_SGE:
5572     case OP_SCMP:
5573 #ifdef USE_LOCALE_COLLATE
5574         if (IN_LC_COMPILETIME(LC_COLLATE))
5575             goto nope;
5576 #endif
5577         break;
5578     case OP_SPRINTF:
5579         /* XXX what about the numeric ops? */
5580 #ifdef USE_LOCALE_NUMERIC
5581         if (IN_LC_COMPILETIME(LC_NUMERIC))
5582             goto nope;
5583 #endif
5584         break;
5585     case OP_PACK:
5586         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5587           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5588             goto nope;
5589         {
5590             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5591             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5592             {
5593                 const char *s = SvPVX_const(sv);
5594                 while (s < SvEND(sv)) {
5595                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5596                     s++;
5597                 }
5598             }
5599         }
5600         break;
5601     case OP_REPEAT:
5602         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5603         break;
5604     case OP_SREFGEN:
5605         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5606          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5607             goto nope;
5608     }
5609
5610     if (PL_parser && PL_parser->error_count)
5611         goto nope;              /* Don't try to run w/ errors */
5612
5613     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5614         switch (curop->op_type) {
5615         case OP_CONST:
5616             if (   (curop->op_private & OPpCONST_BARE)
5617                 && (curop->op_private & OPpCONST_STRICT)) {
5618                 no_bareword_allowed(curop);
5619                 goto nope;
5620             }
5621             /* FALLTHROUGH */
5622         case OP_LIST:
5623         case OP_SCALAR:
5624         case OP_NULL:
5625         case OP_PUSHMARK:
5626             /* Foldable; move to next op in list */
5627             break;
5628
5629         default:
5630             /* No other op types are considered foldable */
5631             goto nope;
5632         }
5633     }
5634
5635     curop = LINKLIST(o);
5636     old_next = o->op_next;
5637     o->op_next = 0;
5638     PL_op = curop;
5639
5640     old_cxix = cxstack_ix;
5641     create_eval_scope(NULL, G_FAKINGEVAL);
5642
5643     /* Verify that we don't need to save it:  */
5644     assert(PL_curcop == &PL_compiling);
5645     StructCopy(&PL_compiling, &not_compiling, COP);
5646     PL_curcop = &not_compiling;
5647     /* The above ensures that we run with all the correct hints of the
5648        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5649     assert(IN_PERL_RUNTIME);
5650     PL_warnhook = PERL_WARNHOOK_FATAL;
5651     PL_diehook  = NULL;
5652
5653     /* Effective $^W=1.  */
5654     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5655         PL_dowarn |= G_WARN_ON;
5656
5657     ret = S_fold_constants_eval(aTHX);
5658
5659     switch (ret) {
5660     case 0:
5661         sv = *(PL_stack_sp--);
5662         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5663             pad_swipe(o->op_targ,  FALSE);
5664         }
5665         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5666             SvREFCNT_inc_simple_void(sv);
5667             SvTEMP_off(sv);
5668         }
5669         else { assert(SvIMMORTAL(sv)); }
5670         break;
5671     case 3:
5672         /* Something tried to die.  Abandon constant folding.  */
5673         /* Pretend the error never happened.  */
5674         CLEAR_ERRSV();
5675         o->op_next = old_next;
5676         break;
5677     default:
5678         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5679         PL_warnhook = oldwarnhook;
5680         PL_diehook  = olddiehook;
5681         /* XXX note that this croak may fail as we've already blown away
5682          * the stack - eg any nested evals */
5683         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5684     }
5685     PL_dowarn   = oldwarn;
5686     PL_warnhook = oldwarnhook;
5687     PL_diehook  = olddiehook;
5688     PL_curcop = &PL_compiling;
5689
5690     /* if we croaked, depending on how we croaked the eval scope
5691      * may or may not have already been popped */
5692     if (cxstack_ix > old_cxix) {
5693         assert(cxstack_ix == old_cxix + 1);
5694         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5695         delete_eval_scope();
5696     }
5697     if (ret)
5698         goto nope;
5699
5700     /* OP_STRINGIFY and constant folding are used to implement qq.
5701        Here the constant folding is an implementation detail that we
5702        want to hide.  If the stringify op is itself already marked
5703        folded, however, then it is actually a folded join.  */
5704     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5705     op_free(o);
5706     assert(sv);
5707     if (is_stringify)
5708         SvPADTMP_off(sv);
5709     else if (!SvIMMORTAL(sv)) {
5710         SvPADTMP_on(sv);
5711         SvREADONLY_on(sv);
5712     }
5713     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5714     if (!is_stringify) newop->op_folded = 1;
5715     return newop;
5716
5717  nope:
5718     return o;
5719 }
5720
5721 static OP *
5722 S_gen_constant_list(pTHX_ OP *o)
5723 {
5724     dVAR;
5725     OP *curop, *old_next;
5726     SV * const oldwarnhook = PL_warnhook;
5727     SV * const olddiehook  = PL_diehook;
5728     COP *old_curcop;
5729     U8 oldwarn = PL_dowarn;
5730     SV **svp;
5731     AV *av;
5732     I32 old_cxix;
5733     COP not_compiling;
5734     int ret = 0;
5735     dJMPENV;
5736     bool op_was_null;
5737
5738     list(o);
5739     if (PL_parser && PL_parser->error_count)
5740         return o;               /* Don't attempt to run with errors */
5741
5742     curop = LINKLIST(o);
5743     old_next = o->op_next;
5744     o->op_next = 0;
5745     op_was_null = o->op_type == OP_NULL;
5746     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5747         o->op_type = OP_CUSTOM;
5748     CALL_PEEP(curop);
5749     if (op_was_null)
5750         o->op_type = OP_NULL;
5751     S_prune_chain_head(&curop);
5752     PL_op = curop;
5753
5754     old_cxix = cxstack_ix;
5755     create_eval_scope(NULL, G_FAKINGEVAL);
5756
5757     old_curcop = PL_curcop;
5758     StructCopy(old_curcop, &not_compiling, COP);
5759     PL_curcop = &not_compiling;
5760     /* The above ensures that we run with all the correct hints of the
5761        current COP, but that IN_PERL_RUNTIME is true. */
5762     assert(IN_PERL_RUNTIME);
5763     PL_warnhook = PERL_WARNHOOK_FATAL;
5764     PL_diehook  = NULL;
5765     JMPENV_PUSH(ret);
5766
5767     /* Effective $^W=1.  */
5768     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5769         PL_dowarn |= G_WARN_ON;
5770
5771     switch (ret) {
5772     case 0:
5773 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5774         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5775 #endif
5776         Perl_pp_pushmark(aTHX);
5777         CALLRUNOPS(aTHX);
5778         PL_op = curop;
5779         assert (!(curop->op_flags & OPf_SPECIAL));
5780         assert(curop->op_type == OP_RANGE);
5781         Perl_pp_anonlist(aTHX);
5782         break;
5783     case 3:
5784         CLEAR_ERRSV();
5785         o->op_next = old_next;
5786         break;
5787     default:
5788         JMPENV_POP;
5789         PL_warnhook = oldwarnhook;
5790         PL_diehook = olddiehook;
5791         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5792             ret);
5793     }
5794
5795     JMPENV_POP;
5796     PL_dowarn = oldwarn;
5797     PL_warnhook = oldwarnhook;
5798     PL_diehook = olddiehook;
5799     PL_curcop = old_curcop;
5800
5801     if (cxstack_ix > old_cxix) {
5802         assert(cxstack_ix == old_cxix + 1);
5803         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5804         delete_eval_scope();
5805     }
5806     if (ret)
5807         return o;
5808
5809     OpTYPE_set(o, OP_RV2AV);
5810     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5811     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5812     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5813     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5814
5815     /* replace subtree with an OP_CONST */
5816     curop = ((UNOP*)o)->op_first;
5817     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5818     op_free(curop);
5819
5820     if (AvFILLp(av) != -1)
5821         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5822         {
5823             SvPADTMP_on(*svp);
5824             SvREADONLY_on(*svp);
5825         }
5826     LINKLIST(o);
5827     return list(o);
5828 }
5829
5830 /*
5831 =head1 Optree Manipulation Functions
5832 */
5833
5834 /* List constructors */
5835
5836 /*
5837 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5838
5839 Append an item to the list of ops contained directly within a list-type
5840 op, returning the lengthened list.  C<first> is the list-type op,
5841 and C<last> is the op to append to the list.  C<optype> specifies the
5842 intended opcode for the list.  If C<first> is not already a list of the
5843 right type, it will be upgraded into one.  If either C<first> or C<last>
5844 is null, the other is returned unchanged.
5845
5846 =cut
5847 */
5848
5849 OP *
5850 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5851 {
5852     if (!first)
5853         return last;
5854
5855     if (!last)
5856         return first;
5857
5858     if (first->op_type != (unsigned)type
5859         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5860     {
5861         return newLISTOP(type, 0, first, last);
5862     }
5863
5864     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5865     first->op_flags |= OPf_KIDS;
5866     return first;
5867 }
5868
5869 /*
5870 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5871
5872 Concatenate the lists of ops contained directly within two list-type ops,
5873 returning the combined list.  C<first> and C<last> are the list-type ops
5874 to concatenate.  C<optype> specifies the intended opcode for the list.
5875 If either C<first> or C<last> is not already a list of the right type,
5876 it will be upgraded into one.  If either C<first> or C<last> is null,
5877 the other is returned unchanged.
5878
5879 =cut
5880 */
5881
5882 OP *
5883 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5884 {
5885     if (!first)
5886         return last;
5887
5888     if (!last)
5889         return first;
5890
5891     if (first->op_type != (unsigned)type)
5892         return op_prepend_elem(type, first, last);
5893
5894     if (last->op_type != (unsigned)type)
5895         return op_append_elem(type, first, last);
5896
5897     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5898     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5899     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5900     first->op_flags |= (last->op_flags & OPf_KIDS);
5901
5902     S_op_destroy(aTHX_ last);
5903
5904     return first;
5905 }
5906
5907 /*
5908 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5909
5910 Prepend an item to the list of ops contained directly within a list-type
5911 op, returning the lengthened list.  C<first> is the op to prepend to the
5912 list, and C<last> is the list-type op.  C<optype> specifies the intended
5913 opcode for the list.  If C<last> is not already a list of the right type,
5914 it will be upgraded into one.  If either C<first> or C<last> is null,
5915 the other is returned unchanged.
5916
5917 =cut
5918 */
5919
5920 OP *
5921 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5922 {
5923     if (!first)
5924         return last;
5925
5926     if (!last)
5927         return first;
5928
5929     if (last->op_type == (unsigned)type) {
5930         if (type == OP_LIST) {  /* already a PUSHMARK there */
5931             /* insert 'first' after pushmark */
5932             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5933             if (!(first->op_flags & OPf_PARENS))
5934                 last->op_flags &= ~OPf_PARENS;
5935         }
5936         else
5937             op_sibling_splice(last, NULL, 0, first);
5938         last->op_flags |= OPf_KIDS;
5939         return last;
5940     }
5941
5942     return newLISTOP(type, 0, first, last);
5943 }
5944
5945 /*
5946 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5947
5948 Converts C<o> into a list op if it is not one already, and then converts it
5949 into the specified C<type>, calling its check function, allocating a target if
5950 it needs one, and folding constants.
5951
5952 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5953 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5954 C<op_convert_list> to make it the right type.
5955
5956 =cut
5957 */
5958
5959 OP *
5960 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5961 {
5962     dVAR;
5963     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5964     if (!o || o->op_type != OP_LIST)
5965         o = force_list(o, 0);
5966     else
5967     {
5968         o->op_flags &= ~OPf_WANT;
5969         o->op_private &= ~OPpLVAL_INTRO;
5970     }
5971
5972     if (!(PL_opargs[type] & OA_MARK))
5973         op_null(cLISTOPo->op_first);
5974     else {
5975         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5976         if (kid2 && kid2->op_type == OP_COREARGS) {
5977             op_null(cLISTOPo->op_first);
5978             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5979         }
5980     }
5981
5982     if (type != OP_SPLIT)
5983         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5984          * ck_split() create a real PMOP and leave the op's type as listop
5985          * for now. Otherwise op_free() etc will crash.
5986          */
5987         OpTYPE_set(o, type);
5988
5989     o->op_flags |= flags;
5990     if (flags & OPf_FOLDED)
5991         o->op_folded = 1;
5992
5993     o = CHECKOP(type, o);
5994     if (o->op_type != (unsigned)type)
5995         return o;
5996
5997     return fold_constants(op_integerize(op_std_init(o)));
5998 }
5999
6000 /* Constructors */
6001
6002
6003 /*
6004 =head1 Optree construction
6005
6006 =for apidoc Am|OP *|newNULLLIST
6007
6008 Constructs, checks, and returns a new C<stub> op, which represents an
6009 empty list expression.
6010
6011 =cut
6012 */
6013
6014 OP *
6015 Perl_newNULLLIST(pTHX)
6016 {
6017     return newOP(OP_STUB, 0);
6018 }
6019
6020 /* promote o and any siblings to be a list if its not already; i.e.
6021  *
6022  *  o - A - B
6023  *
6024  * becomes
6025  *
6026  *  list
6027  *    |
6028  *  pushmark - o - A - B
6029  *
6030  * If nullit it true, the list op is nulled.
6031  */
6032
6033 static OP *
6034 S_force_list(pTHX_ OP *o, bool nullit)
6035 {
6036     if (!o || o->op_type != OP_LIST) {
6037         OP *rest = NULL;
6038         if (o) {
6039             /* manually detach any siblings then add them back later */
6040             rest = OpSIBLING(o);
6041             OpLASTSIB_set(o, NULL);
6042         }
6043         o = newLISTOP(OP_LIST, 0, o, NULL);
6044         if (rest)
6045             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6046     }
6047     if (nullit)
6048         op_null(o);
6049     return o;
6050 }
6051
6052 /*
6053 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6054
6055 Constructs, checks, and returns an op of any list type.  C<type> is
6056 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6057 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
6058 supply up to two ops to be direct children of the list op; they are
6059 consumed by this function and become part of the constructed op tree.
6060
6061 For most list operators, the check function expects all the kid ops to be
6062 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6063 appropriate.  What you want to do in that case is create an op of type
6064 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6065 See L</op_convert_list> for more information.
6066
6067
6068 =cut
6069 */
6070
6071 OP *
6072 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6073 {
6074     dVAR;
6075     LISTOP *listop;
6076
6077     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6078         || type == OP_CUSTOM);
6079
6080     NewOp(1101, listop, 1, LISTOP);
6081
6082     OpTYPE_set(listop, type);
6083     if (first || last)
6084         flags |= OPf_KIDS;
6085     listop->op_flags = (U8)flags;
6086
6087     if (!last && first)
6088         last = first;
6089     else if (!first && last)
6090         first = last;
6091     else if (first)
6092         OpMORESIB_set(first, last);
6093     listop->op_first = first;
6094     listop->op_last = last;
6095     if (type == OP_LIST) {
6096         OP* const pushop = newOP(OP_PUSHMARK, 0);
6097         OpMORESIB_set(pushop, first);
6098         listop->op_first = pushop;
6099         listop->op_flags |= OPf_KIDS;
6100         if (!last)
6101             listop->op_last = pushop;
6102     }
6103     if (listop->op_last)
6104         OpLASTSIB_set(listop->op_last, (OP*)listop);
6105
6106     return CHECKOP(type, listop);
6107 }
6108
6109 /*
6110 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6111
6112 Constructs, checks, and returns an op of any base type (any type that
6113 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6114 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6115 of C<op_private>.
6116
6117 =cut
6118 */
6119
6120 OP *
6121 Perl_newOP(pTHX_ I32 type, I32 flags)
6122 {
6123     dVAR;
6124     OP *o;
6125
6126     if (type == -OP_ENTEREVAL) {
6127         type = OP_ENTEREVAL;
6128         flags |= OPpEVAL_BYTES<<8;
6129     }
6130
6131     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6132         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6133         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6134         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6135
6136     NewOp(1101, o, 1, OP);
6137     OpTYPE_set(o, type);
6138     o->op_flags = (U8)flags;
6139
6140     o->op_next = o;
6141     o->op_private = (U8)(0 | (flags >> 8));
6142     if (PL_opargs[type] & OA_RETSCALAR)
6143         scalar(o);
6144     if (PL_opargs[type] & OA_TARGET)
6145         o->op_targ = pad_alloc(type, SVs_PADTMP);
6146     return CHECKOP(type, o);
6147 }
6148
6149 /*
6150 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6151
6152 Constructs, checks, and returns an op of any unary type.  C<type> is
6153 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6154 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6155 bits, the eight bits of C<op_private>, except that the bit with value 1
6156 is automatically set.  C<first> supplies an optional op to be the direct
6157 child of the unary op; it is consumed by this function and become part
6158 of the constructed op tree.
6159
6160 =cut
6161 */
6162
6163 OP *
6164 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6165 {
6166     dVAR;
6167     UNOP *unop;
6168
6169     if (type == -OP_ENTEREVAL) {
6170         type = OP_ENTEREVAL;
6171         flags |= OPpEVAL_BYTES<<8;
6172     }
6173
6174     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6175         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6176         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6177         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6178         || type == OP_SASSIGN
6179         || type == OP_ENTERTRY
6180         || type == OP_CUSTOM
6181         || type == OP_NULL );
6182
6183     if (!first)
6184         first = newOP(OP_STUB, 0);
6185     if (PL_opargs[type] & OA_MARK)
6186         first = force_list(first, 1);
6187
6188     NewOp(1101, unop, 1, UNOP);
6189     OpTYPE_set(unop, type);
6190     unop->op_first = first;
6191     unop->op_flags = (U8)(flags | OPf_KIDS);
6192     unop->op_private = (U8)(1 | (flags >> 8));
6193
6194     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6195         OpLASTSIB_set(first, (OP*)unop);
6196
6197     unop = (UNOP*) CHECKOP(type, unop);
6198     if (unop->op_next)
6199         return (OP*)unop;
6200
6201     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6202 }
6203
6204 /*
6205 =for apidoc newUNOP_AUX
6206
6207 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6208 initialised to C<aux>
6209
6210 =cut
6211 */
6212
6213 OP *
6214 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6215 {
6216     dVAR;
6217     UNOP_AUX *unop;
6218
6219     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6220         || type == OP_CUSTOM);
6221
6222     NewOp(1101, unop, 1, UNOP_AUX);
6223     unop->op_type = (OPCODE)type;
6224     unop->op_ppaddr = PL_ppaddr[type];
6225     unop->op_first = first;
6226     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6227     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6228     unop->op_aux = aux;
6229
6230     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6231         OpLASTSIB_set(first, (OP*)unop);
6232
6233     unop = (UNOP_AUX*) CHECKOP(type, unop);
6234
6235     return op_std_init((OP *) unop);
6236 }
6237
6238 /*
6239 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6240
6241 Constructs, checks, and returns an op of method type with a method name
6242 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6243 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6244 and, shifted up eight bits, the eight bits of C<op_private>, except that
6245 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6246 op which evaluates method name; it is consumed by this function and
6247 become part of the constructed op tree.
6248 Supported optypes: C<OP_METHOD>.
6249
6250 =cut
6251 */
6252
6253 static OP*
6254 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6255     dVAR;
6256     METHOP *methop;
6257
6258     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6259         || type == OP_CUSTOM);
6260
6261     NewOp(1101, methop, 1, METHOP);
6262     if (dynamic_meth) {
6263         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6264         methop->op_flags = (U8)(flags | OPf_KIDS);
6265         methop->op_u.op_first = dynamic_meth;
6266         methop->op_private = (U8)(1 | (flags >> 8));
6267
6268         if (!OpHAS_SIBLING(dynamic_meth))
6269             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6270     }
6271     else {
6272         assert(const_meth);
6273         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6274         methop->op_u.op_meth_sv = const_meth;
6275         methop->op_private = (U8)(0 | (flags >> 8));
6276         methop->op_next = (OP*)methop;
6277     }
6278
6279 #ifdef USE_ITHREADS
6280     methop->op_rclass_targ = 0;
6281 #else
6282     methop->op_rclass_sv = NULL;
6283 #endif
6284
6285     OpTYPE_set(methop, type);
6286     return CHECKOP(type, methop);
6287 }
6288
6289 OP *
6290 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6291     PERL_ARGS_ASSERT_NEWMETHOP;
6292     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6293 }
6294
6295 /*
6296 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6297
6298 Constructs, checks, and returns an op of method type with a constant
6299 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6300 C<op_flags>, and, shifted up eight bits, the eight bits of
6301 C<op_private>.  C<const_meth> supplies a constant method name;
6302 it must be a shared COW string.
6303 Supported optypes: C<OP_METHOD_NAMED>.
6304
6305 =cut
6306 */
6307
6308 OP *
6309 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6310     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6311     return newMETHOP_internal(type, flags, NULL, const_meth);
6312 }
6313
6314 /*
6315 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6316
6317 Constructs, checks, and returns an op of any binary type.  C<type>
6318 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6319 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6320 the eight bits of C<op_private>, except that the bit with value 1 or
6321 2 is automatically set as required.  C<first> and C<last> supply up to
6322 two ops to be the direct children of the binary op; they are consumed
6323 by this function and become part of the constructed op tree.
6324
6325 =cut
6326 */
6327
6328 OP *
6329 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6330 {
6331     dVAR;
6332     BINOP *binop;
6333
6334     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6335         || type == OP_NULL || type == OP_CUSTOM);
6336
6337     NewOp(1101, binop, 1, BINOP);
6338
6339     if (!first)
6340         first = newOP(OP_NULL, 0);
6341
6342     OpTYPE_set(binop, type);
6343     binop->op_first = first;
6344     binop->op_flags = (U8)(flags | OPf_KIDS);
6345     if (!last) {
6346         last = first;
6347         binop->op_private = (U8)(1 | (flags >> 8));
6348     }
6349     else {
6350         binop->op_private = (U8)(2 | (flags >> 8));
6351         OpMORESIB_set(first, last);
6352     }
6353
6354     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6355         OpLASTSIB_set(last, (OP*)binop);
6356
6357     binop->op_last = OpSIBLING(binop->op_first);
6358     if (binop->op_last)
6359         OpLASTSIB_set(binop->op_last, (OP*)binop);
6360
6361     binop = (BINOP*)CHECKOP(type, binop);
6362     if (binop->op_next || binop->op_type != (OPCODE)type)
6363         return (OP*)binop;
6364
6365     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6366 }
6367
6368 /* Helper function for S_pmtrans(): comparison function to sort an array
6369  * of codepoint range pairs. Sorts by start point, or if equal, by end
6370  * point */
6371
6372 static int uvcompare(const void *a, const void *b)
6373     __attribute__nonnull__(1)
6374     __attribute__nonnull__(2)
6375     __attribute__pure__;
6376 static int uvcompare(const void *a, const void *b)
6377 {
6378     if (*((const UV *)a) < (*(const UV *)b))
6379         return -1;
6380     if (*((const UV *)a) > (*(const UV *)b))
6381         return 1;
6382     if (*((const UV *)a+1) < (*(const UV *)b+1))
6383         return -1;
6384     if (*((const UV *)a+1) > (*(const UV *)b+1))
6385         return 1;
6386     return 0;
6387 }
6388
6389 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6390  * containing the search and replacement strings, assemble into
6391  * a translation table attached as o->op_pv.
6392  * Free expr and repl.
6393  * It expects the toker to have already set the
6394  *   OPpTRANS_COMPLEMENT
6395  *   OPpTRANS_SQUASH
6396  *   OPpTRANS_DELETE
6397  * flags as appropriate; this function may add
6398  *   OPpTRANS_FROM_UTF
6399  *   OPpTRANS_TO_UTF
6400  *   OPpTRANS_IDENTICAL
6401  *   OPpTRANS_GROWS
6402  * flags
6403  */
6404
6405 static OP *
6406 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6407 {
6408     SV * const tstr = ((SVOP*)expr)->op_sv;
6409     SV * const rstr = ((SVOP*)repl)->op_sv;
6410     STRLEN tlen;
6411     STRLEN rlen;
6412     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6413     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6414     Size_t i, j;
6415     bool grows = FALSE;
6416     OPtrans_map *tbl;
6417     SSize_t struct_size; /* malloced size of table struct */
6418
6419     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6420     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6421     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6422     SV* swash;
6423
6424     PERL_ARGS_ASSERT_PMTRANS;
6425
6426     PL_hints |= HINT_BLOCK_SCOPE;
6427
6428     if (SvUTF8(tstr))
6429         o->op_private |= OPpTRANS_FROM_UTF;
6430
6431     if (SvUTF8(rstr))
6432         o->op_private |= OPpTRANS_TO_UTF;
6433
6434     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6435
6436         /* for utf8 translations, op_sv will be set to point to a swash
6437          * containing codepoint ranges. This is done by first assembling
6438          * a textual representation of the ranges in listsv then compiling
6439          * it using swash_init(). For more details of the textual format,
6440          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6441          */
6442
6443         SV* const listsv = newSVpvs("# comment\n");
6444         SV* transv = NULL;
6445         const U8* tend = t + tlen;
6446         const U8* rend = r + rlen;
6447         STRLEN ulen;
6448         UV tfirst = 1;
6449         UV tlast = 0;
6450         IV tdiff;
6451         STRLEN tcount = 0;
6452         UV rfirst = 1;
6453         UV rlast = 0;
6454         IV rdiff;
6455         STRLEN rcount = 0;
6456         IV diff;
6457         I32 none = 0;
6458         U32 max = 0;
6459         I32 bits;
6460         I32 havefinal = 0;
6461         U32 final = 0;
6462         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6463         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6464         U8* tsave = NULL;
6465         U8* rsave = NULL;
6466         const U32 flags = UTF8_ALLOW_DEFAULT;
6467
6468         if (!from_utf) {
6469             STRLEN len = tlen;
6470             t = tsave = bytes_to_utf8(t, &len);
6471             tend = t + len;
6472         }
6473         if (!to_utf && rlen) {
6474             STRLEN len = rlen;
6475             r = rsave = bytes_to_utf8(r, &len);
6476             rend = r + len;
6477         }
6478
6479 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6480  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6481  * odd.  */
6482
6483         if (complement) {
6484             /* utf8 and /c:
6485              * replace t/tlen/tend with a version that has the ranges
6486              * complemented
6487              */
6488             U8 tmpbuf[UTF8_MAXBYTES+1];
6489             UV *cp;
6490             UV nextmin = 0;
6491             Newx(cp, 2*tlen, UV);
6492             i = 0;
6493             transv = newSVpvs("");
6494
6495             /* convert search string into array of (start,end) range
6496              * codepoint pairs stored in cp[]. Most "ranges" will start
6497              * and end at the same char */
6498             while (t < tend) {
6499                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6500                 t += ulen;
6501                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6502                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6503                     t++;
6504                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6505                     t += ulen;
6506                 }
6507                 else {
6508                  cp[2*i+1] = cp[2*i];
6509                 }
6510                 i++;
6511             }
6512
6513             /* sort the ranges */
6514             qsort(cp, i, 2*sizeof(UV), uvcompare);
6515
6516             /* Create a utf8 string containing the complement of the
6517              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6518              * then transv will contain the equivalent of:
6519              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6520              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6521              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6522              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6523              * end cp.
6524              */
6525             for (j = 0; j < i; j++) {
6526                 UV  val = cp[2*j];
6527                 diff = val - nextmin;
6528                 if (diff > 0) {
6529                     t = uvchr_to_utf8(tmpbuf,nextmin);
6530                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6531                     if (diff > 1) {
6532                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6533                         t = uvchr_to_utf8(tmpbuf, val - 1);
6534                         sv_catpvn(transv, (char *)&range_mark, 1);
6535                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6536                     }
6537                 }
6538                 val = cp[2*j+1];
6539                 if (val >= nextmin)
6540                     nextmin = val + 1;
6541             }
6542
6543             t = uvchr_to_utf8(tmpbuf,nextmin);
6544             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6545             {
6546                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6547                 sv_catpvn(transv, (char *)&range_mark, 1);
6548             }
6549             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6550             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6551             t = (const U8*)SvPVX_const(transv);
6552             tlen = SvCUR(transv);
6553             tend = t + tlen;
6554             Safefree(cp);
6555         }
6556         else if (!rlen && !del) {
6557             r = t; rlen = tlen; rend = tend;
6558         }
6559
6560         if (!squash) {
6561                 if ((!rlen && !del) || t == r ||
6562                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6563                 {
6564                     o->op_private |= OPpTRANS_IDENTICAL;
6565                 }
6566         }
6567
6568         /* extract char ranges from t and r and append them to listsv */
6569
6570         while (t < tend || tfirst <= tlast) {
6571             /* see if we need more "t" chars */
6572             if (tfirst > tlast) {
6573                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6574                 t += ulen;
6575                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6576                     t++;
6577                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6578                     t += ulen;
6579                 }
6580                 else
6581                     tlast = tfirst;
6582             }
6583
6584             /* now see if we need more "r" chars */
6585             if (rfirst > rlast) {
6586                 if (r < rend) {
6587                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6588                     r += ulen;
6589                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6590                         r++;
6591                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6592                         r += ulen;
6593                     }
6594                     else
6595                         rlast = rfirst;
6596                 }
6597                 else {
6598                     if (!havefinal++)
6599                         final = rlast;
6600                     rfirst = rlast = 0xffffffff;
6601                 }
6602             }
6603
6604             /* now see which range will peter out first, if either. */
6605             tdiff = tlast - tfirst;
6606             rdiff = rlast - rfirst;
6607             tcount += tdiff + 1;
6608             rcount += rdiff + 1;
6609
6610             if (tdiff <= rdiff)
6611                 diff = tdiff;
6612             else
6613                 diff = rdiff;
6614
6615             if (rfirst == 0xffffffff) {
6616                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6617                 if (diff > 0)
6618                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6619                                    (long)tfirst, (long)tlast);
6620                 else
6621                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6622             }
6623             else {
6624                 if (diff > 0)
6625                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6626                                    (long)tfirst, (long)(tfirst + diff),
6627                                    (long)rfirst);
6628                 else
6629                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6630                                    (long)tfirst, (long)rfirst);
6631
6632                 if (rfirst + diff > max)
6633                     max = rfirst + diff;
6634                 if (!grows)
6635                     grows = (tfirst < rfirst &&
6636                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6637                 rfirst += diff + 1;
6638             }
6639             tfirst += diff + 1;
6640         }
6641
6642         /* compile listsv into a swash and attach to o */
6643
6644         none = ++max;
6645         if (del)
6646             ++max;
6647
6648         if (max > 0xffff)
6649             bits = 32;
6650         else if (max > 0xff)
6651             bits = 16;
6652         else
6653             bits = 8;
6654
6655         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6656 #ifdef USE_ITHREADS
6657         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6658         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6659         PAD_SETSV(cPADOPo->op_padix, swash);
6660         SvPADTMP_on(swash);
6661         SvREADONLY_on(swash);
6662 #else
6663         cSVOPo->op_sv = swash;
6664 #endif
6665         SvREFCNT_dec(listsv);
6666         SvREFCNT_dec(transv);
6667
6668         if (!del && havefinal && rlen)
6669             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6670                            newSVuv((UV)final), 0);
6671
6672         Safefree(tsave);
6673         Safefree(rsave);
6674
6675         tlen = tcount;
6676         rlen = rcount;
6677         if (r < rend)
6678             rlen++;
6679         else if (rlast == 0xffffffff)
6680             rlen = 0;
6681
6682         goto warnins;
6683     }
6684
6685     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6686      * table. Entries with the value -1 indicate chars not to be
6687      * translated, while -2 indicates a search char without a
6688      * corresponding replacement char under /d.
6689      *
6690      * Normally, the table has 256 slots. However, in the presence of
6691      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6692      * added, and if there are enough replacement chars to start pairing
6693      * with the \x{100},... search chars, then a larger (> 256) table
6694      * is allocated.
6695      *
6696      * In addition, regardless of whether under /c, an extra slot at the
6697      * end is used to store the final repeating char, or -3 under an empty
6698      * replacement list, or -2 under /d; which makes the runtime code
6699      * easier.
6700      *
6701      * The toker will have already expanded char ranges in t and r.
6702      */
6703
6704     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6705      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6706      * The OPtrans_map struct already contains one slot; hence the -1.
6707      */
6708     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6709     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6710     tbl->size = 256;
6711     cPVOPo->op_pv = (char*)tbl;
6712
6713     if (complement) {
6714         Size_t excess;
6715
6716         /* in this branch, j is a count of 'consumed' (i.e. paired off
6717          * with a search char) replacement chars (so j <= rlen always)
6718          */
6719         for (i = 0; i < tlen; i++)
6720             tbl->map[t[i]] = -1;
6721
6722         for (i = 0, j = 0; i < 256; i++) {
6723             if (!tbl->map[i]) {
6724                 if (j == rlen) {
6725                     if (del)
6726                         tbl->map[i] = -2;
6727                     else if (rlen)
6728                         tbl->map[i] = r[j-1];
6729                     else
6730                         tbl->map[i] = (short)i;
6731                 }
6732                 else {
6733                     tbl->map[i] = r[j++];
6734                 }
6735                 if (   tbl->map[i] >= 0
6736                     &&  UVCHR_IS_INVARIANT((UV)i)
6737                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6738                 )
6739                     grows = TRUE;
6740             }
6741         }
6742
6743         ASSUME(j <= rlen);
6744         excess = rlen - j;
6745
6746         if (excess) {
6747             /* More replacement chars than search chars:
6748              * store excess replacement chars at end of main table.
6749              */
6750
6751             struct_size += excess;
6752             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6753                         struct_size + excess * sizeof(short));
6754             tbl->size += excess;
6755             cPVOPo->op_pv = (char*)tbl;
6756
6757             for (i = 0; i < excess; i++)
6758                 tbl->map[i + 256] = r[j+i];
6759         }
6760         else {
6761             /* no more replacement chars than search chars */
6762             if (!rlen && !del && !squash)
6763                 o->op_private |= OPpTRANS_IDENTICAL;
6764         }
6765
6766         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6767     }
6768     else {
6769         if (!rlen && !del) {
6770             r = t; rlen = tlen;
6771             if (!squash)
6772                 o->op_private |= OPpTRANS_IDENTICAL;
6773         }
6774         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6775             o->op_private |= OPpTRANS_IDENTICAL;
6776         }
6777
6778         for (i = 0; i < 256; i++)
6779             tbl->map[i] = -1;
6780         for (i = 0, j = 0; i < tlen; i++,j++) {
6781             if (j >= rlen) {
6782                 if (del) {
6783                     if (tbl->map[t[i]] == -1)
6784                         tbl->map[t[i]] = -2;
6785                     continue;
6786                 }
6787                 --j;
6788             }
6789             if (tbl->map[t[i]] == -1) {
6790                 if (     UVCHR_IS_INVARIANT(t[i])
6791                     && ! UVCHR_IS_INVARIANT(r[j]))
6792                     grows = TRUE;
6793                 tbl->map[t[i]] = r[j];
6794             }
6795         }
6796         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6797     }
6798
6799     /* both non-utf8 and utf8 code paths end up here */
6800
6801   warnins:
6802     if(del && rlen == tlen) {
6803         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6804     } else if(rlen > tlen && !complement) {
6805         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6806     }
6807
6808     if (grows)
6809         o->op_private |= OPpTRANS_GROWS;
6810     op_free(expr);
6811     op_free(repl);
6812
6813     return o;
6814 }
6815
6816
6817 /*
6818 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6819
6820 Constructs, checks, and returns an op of any pattern matching type.
6821 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6822 and, shifted up eight bits, the eight bits of C<op_private>.
6823
6824 =cut
6825 */
6826
6827 OP *
6828 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6829 {
6830     dVAR;
6831     PMOP *pmop;
6832
6833     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6834         || type == OP_CUSTOM);
6835
6836     NewOp(1101, pmop, 1, PMOP);
6837     OpTYPE_set(pmop, type);
6838     pmop->op_flags = (U8)flags;
6839     pmop->op_private = (U8)(0 | (flags >> 8));
6840     if (PL_opargs[type] & OA_RETSCALAR)
6841         scalar((OP *)pmop);
6842
6843     if (PL_hints & HINT_RE_TAINT)
6844         pmop->op_pmflags |= PMf_RETAINT;
6845 #ifdef USE_LOCALE_CTYPE
6846     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6847         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6848     }
6849     else
6850 #endif
6851          if (IN_UNI_8_BIT) {
6852         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6853     }
6854     if (PL_hints & HINT_RE_FLAGS) {
6855         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6856          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6857         );
6858         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6859         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6860          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6861         );
6862         if (reflags && SvOK(reflags)) {
6863             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6864         }
6865     }
6866
6867
6868 #ifdef USE_ITHREADS
6869     assert(SvPOK(PL_regex_pad[0]));
6870     if (SvCUR(PL_regex_pad[0])) {
6871         /* Pop off the "packed" IV from the end.  */
6872         SV *const repointer_list = PL_regex_pad[0];
6873         const char *p = SvEND(repointer_list) - sizeof(IV);
6874         const IV offset = *((IV*)p);
6875
6876         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6877
6878         SvEND_set(repointer_list, p);
6879
6880         pmop->op_pmoffset = offset;
6881         /* This slot should be free, so assert this:  */
6882         assert(PL_regex_pad[offset] == &PL_sv_undef);
6883     } else {
6884         SV * const repointer = &PL_sv_undef;
6885         av_push(PL_regex_padav, repointer);
6886         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6887         PL_regex_pad = AvARRAY(PL_regex_padav);
6888     }
6889 #endif
6890
6891     return CHECKOP(type, pmop);
6892 }
6893
6894 static void
6895 S_set_haseval(pTHX)
6896 {
6897     PADOFFSET i = 1;
6898     PL_cv_has_eval = 1;
6899     /* Any pad names in scope are potentially lvalues.  */
6900     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6901         PADNAME *pn = PAD_COMPNAME_SV(i);
6902         if (!pn || !PadnameLEN(pn))
6903             continue;
6904         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6905             S_mark_padname_lvalue(aTHX_ pn);
6906     }
6907 }
6908
6909 /* Given some sort of match op o, and an expression expr containing a
6910  * pattern, either compile expr into a regex and attach it to o (if it's
6911  * constant), or convert expr into a runtime regcomp op sequence (if it's
6912  * not)
6913  *
6914  * Flags currently has 2 bits of meaning:
6915  * 1: isreg indicates that the pattern is part of a regex construct, eg
6916  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6917  * split "pattern", which aren't. In the former case, expr will be a list
6918  * if the pattern contains more than one term (eg /a$b/).
6919  * 2: The pattern is for a split.
6920  *
6921  * When the pattern has been compiled within a new anon CV (for
6922  * qr/(?{...})/ ), then floor indicates the savestack level just before
6923  * the new sub was created
6924  */
6925
6926 OP *
6927 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6928 {
6929     PMOP *pm;
6930     LOGOP *rcop;
6931     I32 repl_has_vars = 0;
6932     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6933     bool is_compiletime;
6934     bool has_code;
6935     bool isreg    = cBOOL(flags & 1);
6936     bool is_split = cBOOL(flags & 2);
6937
6938     PERL_ARGS_ASSERT_PMRUNTIME;
6939
6940     if (is_trans) {
6941         return pmtrans(o, expr, repl);
6942     }
6943
6944     /* find whether we have any runtime or code elements;
6945      * at the same time, temporarily set the op_next of each DO block;
6946      * then when we LINKLIST, this will cause the DO blocks to be excluded
6947      * from the op_next chain (and from having LINKLIST recursively
6948      * applied to them). We fix up the DOs specially later */
6949
6950     is_compiletime = 1;
6951     has_code = 0;
6952     if (expr->op_type == OP_LIST) {
6953         OP *o;
6954         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6955             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6956                 has_code = 1;
6957                 assert(!o->op_next);
6958                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6959                     assert(PL_parser && PL_parser->error_count);
6960                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6961                        the op we were expecting to see, to avoid crashing
6962                        elsewhere.  */
6963                     op_sibling_splice(expr, o, 0,
6964                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6965                 }
6966                 o->op_next = OpSIBLING(o);
6967             }
6968             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6969                 is_compiletime = 0;
6970         }
6971     }
6972     else if (expr->op_type != OP_CONST)
6973         is_compiletime = 0;
6974
6975     LINKLIST(expr);
6976
6977     /* fix up DO blocks; treat each one as a separate little sub;
6978      * also, mark any arrays as LIST/REF */
6979
6980     if (expr->op_type == OP_LIST) {
6981         OP *o;
6982         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6983
6984             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6985                 assert( !(o->op_flags  & OPf_WANT));
6986                 /* push the array rather than its contents. The regex
6987                  * engine will retrieve and join the elements later */
6988                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6989                 continue;
6990             }
6991
6992             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6993                 continue;
6994             o->op_next = NULL; /* undo temporary hack from above */
6995             scalar(o);
6996             LINKLIST(o);
6997             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6998                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6999                 /* skip ENTER */
7000                 assert(leaveop->op_first->op_type == OP_ENTER);
7001                 assert(OpHAS_SIBLING(leaveop->op_first));
7002                 o->op_next = OpSIBLING(leaveop->op_first);
7003                 /* skip leave */
7004                 assert(leaveop->op_flags & OPf_KIDS);
7005                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7006                 leaveop->op_next = NULL; /* stop on last op */
7007                 op_null((OP*)leaveop);
7008             }
7009             else {
7010                 /* skip SCOPE */
7011                 OP *scope = cLISTOPo->op_first;
7012                 assert(scope->op_type == OP_SCOPE);
7013                 assert(scope->op_flags & OPf_KIDS);
7014                 scope->op_next = NULL; /* stop on last op */
7015                 op_null(scope);
7016             }
7017
7018             /* XXX optimize_optree() must be called on o before
7019              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7020              * currently cope with a peephole-optimised optree.
7021              * Calling optimize_optree() here ensures that condition
7022              * is met, but may mean optimize_optree() is applied
7023              * to the same optree later (where hopefully it won't do any
7024              * harm as it can't convert an op to multiconcat if it's
7025              * already been converted */
7026             optimize_optree(o);
7027
7028             /* have to peep the DOs individually as we've removed it from
7029              * the op_next chain */
7030             CALL_PEEP(o);
7031             S_prune_chain_head(&(o->op_next));
7032             if (is_compiletime)
7033                 /* runtime finalizes as part of finalizing whole tree */
7034                 finalize_optree(o);
7035         }
7036     }
7037     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7038         assert( !(expr->op_flags  & OPf_WANT));
7039         /* push the array rather than its contents. The regex
7040          * engine will retrieve and join the elements later */
7041         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7042     }
7043
7044     PL_hints |= HINT_BLOCK_SCOPE;
7045     pm = (PMOP*)o;
7046     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7047
7048     if (is_compiletime) {
7049         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7050         regexp_engine const *eng = current_re_engine();
7051
7052         if (is_split) {
7053             /* make engine handle split ' ' specially */
7054             pm->op_pmflags |= PMf_SPLIT;
7055             rx_flags |= RXf_SPLIT;
7056         }
7057
7058         /* Skip compiling if parser found an error for this pattern */
7059         if (pm->op_pmflags & PMf_HAS_ERROR) {
7060             return o;
7061         }
7062
7063         if (!has_code || !eng->op_comp) {
7064             /* compile-time simple constant pattern */
7065
7066             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7067                 /* whoops! we guessed that a qr// had a code block, but we
7068                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7069                  * that isn't required now. Note that we have to be pretty
7070                  * confident that nothing used that CV's pad while the
7071                  * regex was parsed, except maybe op targets for \Q etc.
7072                  * If there were any op targets, though, they should have
7073                  * been stolen by constant folding.
7074                  */
7075 #ifdef DEBUGGING
7076                 SSize_t i = 0;
7077                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7078                 while (++i <= AvFILLp(PL_comppad)) {
7079 #  ifdef USE_PAD_RESET
7080                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7081                      * folded constant with a fresh padtmp */
7082                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7083 #  else
7084                     assert(!PL_curpad[i]);
7085 #  endif
7086                 }
7087 #endif
7088                 /* But we know that one op is using this CV's slab. */
7089                 cv_forget_slab(PL_compcv);
7090                 LEAVE_SCOPE(floor);
7091                 pm->op_pmflags &= ~PMf_HAS_CV;
7092             }
7093
7094             PM_SETRE(pm,
7095                 eng->op_comp
7096                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7097                                         rx_flags, pm->op_pmflags)
7098                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7099                                         rx_flags, pm->op_pmflags)
7100             );
7101             op_free(expr);
7102         }
7103         else {
7104             /* compile-time pattern that includes literal code blocks */
7105             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7106                         rx_flags,
7107                         (pm->op_pmflags |
7108                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7109                     );
7110             PM_SETRE(pm, re);
7111             if (pm->op_pmflags & PMf_HAS_CV) {
7112                 CV *cv;
7113                 /* this QR op (and the anon sub we embed it in) is never
7114                  * actually executed. It's just a placeholder where we can
7115                  * squirrel away expr in op_code_list without the peephole
7116                  * optimiser etc processing it for a second time */
7117                 OP *qr = newPMOP(OP_QR, 0);
7118                 ((PMOP*)qr)->op_code_list = expr;
7119
7120                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7121                 SvREFCNT_inc_simple_void(PL_compcv);
7122                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7123                 ReANY(re)->qr_anoncv = cv;
7124
7125                 /* attach the anon CV to the pad so that
7126                  * pad_fixup_inner_anons() can find it */
7127                 (void)pad_add_anon(cv, o->op_type);
7128                 SvREFCNT_inc_simple_void(cv);
7129             }
7130             else {
7131                 pm->op_code_list = expr;
7132             }
7133         }
7134     }
7135     else {
7136         /* runtime pattern: build chain of regcomp etc ops */
7137         bool reglist;
7138         PADOFFSET cv_targ = 0;
7139
7140         reglist = isreg && expr->op_type == OP_LIST;
7141         if (reglist)
7142             op_null(expr);
7143
7144         if (has_code) {
7145             pm->op_code_list = expr;
7146             /* don't free op_code_list; its ops are embedded elsewhere too */
7147             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7148         }
7149
7150         if (is_split)
7151             /* make engine handle split ' ' specially */
7152             pm->op_pmflags |= PMf_SPLIT;
7153
7154         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7155          * to allow its op_next to be pointed past the regcomp and
7156          * preceding stacking ops;
7157          * OP_REGCRESET is there to reset taint before executing the
7158          * stacking ops */
7159         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7160             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7161
7162         if (pm->op_pmflags & PMf_HAS_CV) {
7163             /* we have a runtime qr with literal code. This means
7164              * that the qr// has been wrapped in a new CV, which
7165              * means that runtime consts, vars etc will have been compiled
7166              * against a new pad. So... we need to execute those ops
7167              * within the environment of the new CV. So wrap them in a call
7168              * to a new anon sub. i.e. for
7169              *
7170              *     qr/a$b(?{...})/,
7171              *
7172              * we build an anon sub that looks like
7173              *
7174              *     sub { "a", $b, '(?{...})' }
7175              *
7176              * and call it, passing the returned list to regcomp.
7177              * Or to put it another way, the list of ops that get executed
7178              * are:
7179              *
7180              *     normal              PMf_HAS_CV
7181              *     ------              -------------------
7182              *                         pushmark (for regcomp)
7183              *                         pushmark (for entersub)
7184              *                         anoncode
7185              *                         srefgen
7186              *                         entersub
7187              *     regcreset                  regcreset
7188              *     pushmark                   pushmark
7189              *     const("a")                 const("a")
7190              *     gvsv(b)                    gvsv(b)
7191              *     const("(?{...})")          const("(?{...})")
7192              *                                leavesub
7193              *     regcomp             regcomp
7194              */
7195
7196             SvREFCNT_inc_simple_void(PL_compcv);
7197             CvLVALUE_on(PL_compcv);
7198             /* these lines are just an unrolled newANONATTRSUB */
7199             expr = newSVOP(OP_ANONCODE, 0,
7200                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7201             cv_targ = expr->op_targ;
7202             expr = newUNOP(OP_REFGEN, 0, expr);
7203
7204             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7205         }
7206
7207         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7208         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7209                            | (reglist ? OPf_STACKED : 0);
7210         rcop->op_targ = cv_targ;
7211
7212         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7213         if (PL_hints & HINT_RE_EVAL)
7214             S_set_haseval(aTHX);
7215
7216         /* establish postfix order */
7217         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7218             LINKLIST(expr);
7219             rcop->op_next = expr;
7220             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7221         }
7222         else {
7223             rcop->op_next = LINKLIST(expr);
7224             expr->op_next = (OP*)rcop;
7225         }
7226
7227         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7228     }
7229
7230     if (repl) {
7231         OP *curop = repl;
7232         bool konst;
7233         /* If we are looking at s//.../e with a single statement, get past
7234            the implicit do{}. */
7235         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7236              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7237              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7238          {
7239             OP *sib;
7240             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7241             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7242              && !OpHAS_SIBLING(sib))
7243                 curop = sib;
7244         }
7245         if (curop->op_type == OP_CONST)
7246             konst = TRUE;
7247         else if (( (curop->op_type == OP_RV2SV ||
7248                     curop->op_type == OP_RV2AV ||
7249                     curop->op_type == OP_RV2HV ||
7250                     curop->op_type == OP_RV2GV)
7251                    && cUNOPx(curop)->op_first
7252                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7253                 || curop->op_type == OP_PADSV
7254                 || curop->op_type == OP_PADAV
7255                 || curop->op_type == OP_PADHV
7256                 || curop->op_type == OP_PADANY) {
7257             repl_has_vars = 1;
7258             konst = TRUE;
7259         }
7260         else konst = FALSE;
7261         if (konst
7262             && !(repl_has_vars
7263                  && (!PM_GETRE(pm)
7264                      || !RX_PRELEN(PM_GETRE(pm))
7265                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7266         {
7267             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7268             op_prepend_elem(o->op_type, scalar(repl), o);
7269         }
7270         else {
7271             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7272             rcop->op_private = 1;
7273
7274             /* establish postfix order */
7275             rcop->op_next = LINKLIST(repl);
7276             repl->op_next = (OP*)rcop;
7277
7278             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7279             assert(!(pm->op_pmflags & PMf_ONCE));
7280             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7281             rcop->op_next = 0;
7282         }
7283     }
7284
7285     return (OP*)pm;
7286 }
7287
7288 /*
7289 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7290
7291 Constructs, checks, and returns an op of any type that involves an
7292 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7293 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7294 takes ownership of one reference to it.
7295
7296 =cut
7297 */
7298
7299 OP *
7300 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7301 {
7302     dVAR;
7303     SVOP *svop;
7304
7305     PERL_ARGS_ASSERT_NEWSVOP;
7306
7307     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7308         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7309         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7310         || type == OP_CUSTOM);
7311
7312     NewOp(1101, svop, 1, SVOP);
7313     OpTYPE_set(svop, type);
7314     svop->op_sv = sv;
7315     svop->op_next = (OP*)svop;
7316     svop->op_flags = (U8)flags;
7317     svop->op_private = (U8)(0 | (flags >> 8));
7318     if (PL_opargs[type] & OA_RETSCALAR)
7319         scalar((OP*)svop);
7320     if (PL_opargs[type] & OA_TARGET)
7321         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7322     return CHECKOP(type, svop);
7323 }
7324
7325 /*
7326 =for apidoc Am|OP *|newDEFSVOP|
7327
7328 Constructs and returns an op to access C<$_>.
7329
7330 =cut
7331 */
7332
7333 OP *
7334 Perl_newDEFSVOP(pTHX)
7335 {
7336         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7337 }
7338
7339 #ifdef USE_ITHREADS
7340
7341 /*
7342 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7343
7344 Constructs, checks, and returns an op of any type that involves a
7345 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7346 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7347 is populated with C<sv>; this function takes ownership of one reference
7348 to it.
7349
7350 This function only exists if Perl has been compiled to use ithreads.
7351
7352 =cut
7353 */
7354
7355 OP *
7356 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7357 {
7358     dVAR;
7359     PADOP *padop;
7360
7361     PERL_ARGS_ASSERT_NEWPADOP;
7362
7363     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7364         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7365         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7366         || type == OP_CUSTOM);
7367
7368     NewOp(1101, padop, 1, PADOP);
7369     OpTYPE_set(padop, type);
7370     padop->op_padix =
7371         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7372     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7373     PAD_SETSV(padop->op_padix, sv);
7374     assert(sv);
7375     padop->op_next = (OP*)padop;
7376     padop->op_flags = (U8)flags;
7377     if (PL_opargs[type] & OA_RETSCALAR)
7378         scalar((OP*)padop);
7379     if (PL_opargs[type] & OA_TARGET)
7380         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7381     return CHECKOP(type, padop);
7382 }
7383
7384 #endif /* USE_ITHREADS */
7385
7386 /*
7387 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7388
7389 Constructs, checks, and returns an op of any type that involves an
7390 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7391 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7392 reference; calling this function does not transfer ownership of any
7393 reference to it.
7394
7395 =cut
7396 */
7397
7398 OP *
7399 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7400 {
7401     PERL_ARGS_ASSERT_NEWGVOP;
7402
7403 #ifdef USE_ITHREADS
7404     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7405 #else
7406     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7407 #endif
7408 }
7409
7410 /*
7411 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7412
7413 Constructs, checks, and returns an op of any type that involves an
7414 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7415 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7416 Depending on the op type, the memory referenced by C<pv> may be freed
7417 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7418 have been allocated using C<PerlMemShared_malloc>.
7419
7420 =cut
7421 */
7422
7423 OP *
7424 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7425 {
7426     dVAR;
7427     const bool utf8 = cBOOL(flags & SVf_UTF8);
7428     PVOP *pvop;
7429
7430     flags &= ~SVf_UTF8;
7431
7432     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7433         || type == OP_RUNCV || type == OP_CUSTOM
7434         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7435
7436     NewOp(1101, pvop, 1, PVOP);
7437     OpTYPE_set(pvop, type);
7438     pvop->op_pv = pv;
7439     pvop->op_next = (OP*)pvop;
7440     pvop->op_flags = (U8)flags;
7441     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7442     if (PL_opargs[type] & OA_RETSCALAR)
7443         scalar((OP*)pvop);
7444     if (PL_opargs[type] & OA_TARGET)
7445         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7446     return CHECKOP(type, pvop);
7447 }
7448
7449 void
7450 Perl_package(pTHX_ OP *o)
7451 {
7452     SV *const sv = cSVOPo->op_sv;
7453
7454     PERL_ARGS_ASSERT_PACKAGE;
7455
7456     SAVEGENERICSV(PL_curstash);
7457     save_item(PL_curstname);
7458
7459     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7460
7461     sv_setsv(PL_curstname, sv);
7462
7463     PL_hints |= HINT_BLOCK_SCOPE;
7464     PL_parser->copline = NOLINE;
7465
7466     op_free(o);
7467 }
7468
7469 void
7470 Perl_package_version( pTHX_ OP *v )
7471 {
7472     U32 savehints = PL_hints;
7473     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7474     PL_hints &= ~HINT_STRICT_VARS;
7475     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7476     PL_hints = savehints;
7477     op_free(v);
7478 }
7479
7480 void
7481 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7482 {
7483     OP *pack;
7484     OP *imop;
7485     OP *veop;
7486     SV *use_version = NULL;
7487
7488     PERL_ARGS_ASSERT_UTILIZE;
7489
7490     if (idop->op_type != OP_CONST)
7491         Perl_croak(aTHX_ "Module name must be constant");
7492
7493     veop = NULL;
7494
7495     if (version) {
7496         SV * const vesv = ((SVOP*)version)->op_sv;
7497
7498         if (!arg && !SvNIOKp(vesv)) {
7499             arg = version;
7500         }
7501         else {
7502             OP *pack;
7503             SV *meth;
7504
7505             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7506                 Perl_croak(aTHX_ "Version number must be a constant number");
7507
7508             /* Make copy of idop so we don't free it twice */
7509             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7510
7511             /* Fake up a method call to VERSION */
7512             meth = newSVpvs_share("VERSION");
7513             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7514                             op_append_elem(OP_LIST,
7515                                         op_prepend_elem(OP_LIST, pack, version),
7516                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7517         }
7518     }
7519
7520     /* Fake up an import/unimport */
7521     if (arg && arg->op_type == OP_STUB) {
7522         imop = arg;             /* no import on explicit () */
7523     }
7524     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7525         imop = NULL;            /* use 5.0; */
7526         if (aver)
7527             use_version = ((SVOP*)idop)->op_sv;
7528         else
7529             idop->op_private |= OPpCONST_NOVER;
7530     }
7531     else {
7532         SV *meth;
7533
7534         /* Make copy of idop so we don't free it twice */
7535         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7536
7537         /* Fake up a method call to import/unimport */
7538         meth = aver
7539             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7540         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7541                        op_append_elem(OP_LIST,
7542                                    op_prepend_elem(OP_LIST, pack, arg),
7543                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7544                        ));
7545     }
7546
7547     /* Fake up the BEGIN {}, which does its thing immediately. */
7548     newATTRSUB(floor,
7549         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7550         NULL,
7551         NULL,
7552         op_append_elem(OP_LINESEQ,
7553             op_append_elem(OP_LINESEQ,
7554                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7555                 newSTATEOP(0, NULL, veop)),
7556             newSTATEOP(0, NULL, imop) ));
7557
7558     if (use_version) {
7559         /* Enable the
7560          * feature bundle that corresponds to the required version. */
7561         use_version = sv_2mortal(new_version(use_version));
7562         S_enable_feature_bundle(aTHX_ use_version);
7563
7564         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7565         if (vcmp(use_version,
7566                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7567             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7568                 PL_hints |= HINT_STRICT_REFS;
7569             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7570                 PL_hints |= HINT_STRICT_SUBS;
7571             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7572                 PL_hints |= HINT_STRICT_VARS;
7573         }
7574         /* otherwise they are off */
7575         else {
7576             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7577                 PL_hints &= ~HINT_STRICT_REFS;
7578             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7579                 PL_hints &= ~HINT_STRICT_SUBS;
7580             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7581                 PL_hints &= ~HINT_STRICT_VARS;
7582         }
7583     }
7584
7585     /* The "did you use incorrect case?" warning used to be here.
7586      * The problem is that on case-insensitive filesystems one
7587      * might get false positives for "use" (and "require"):
7588      * "use Strict" or "require CARP" will work.  This causes
7589      * portability problems for the script: in case-strict
7590      * filesystems the script will stop working.
7591      *
7592      * The "incorrect case" warning checked whether "use Foo"
7593      * imported "Foo" to your namespace, but that is wrong, too:
7594      * there is no requirement nor promise in the language that
7595      * a Foo.pm should or would contain anything in package "Foo".
7596      *
7597      * There is very little Configure-wise that can be done, either:
7598      * the case-sensitivity of the build filesystem of Perl does not
7599      * help in guessing the case-sensitivity of the runtime environment.
7600      */
7601
7602     PL_hints |= HINT_BLOCK_SCOPE;
7603     PL_parser->copline = NOLINE;
7604     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7605 }
7606
7607 /*
7608 =head1 Embedding Functions
7609
7610 =for apidoc load_module
7611
7612 Loads the module whose name is pointed to by the string part of C<name>.
7613 Note that the actual module name, not its filename, should be given.
7614 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7615 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7616 trailing arguments can be used to specify arguments to the module's C<import()>
7617 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7618 on the flags. The flags argument is a bitwise-ORed collection of any of
7619 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7620 (or 0 for no flags).
7621
7622 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7623 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7624 the trailing optional arguments may be omitted entirely. Otherwise, if
7625 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7626 exactly one C<OP*>, containing the op tree that produces the relevant import
7627 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7628 will be used as import arguments; and the list must be terminated with C<(SV*)
7629 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7630 set, the trailing C<NULL> pointer is needed even if no import arguments are
7631 desired. The reference count for each specified C<SV*> argument is
7632 decremented. In addition, the C<name> argument is modified.
7633
7634 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7635 than C<use>.
7636
7637 =cut */
7638
7639 void
7640 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7641 {
7642     va_list args;
7643
7644     PERL_ARGS_ASSERT_LOAD_MODULE;
7645
7646     va_start(args, ver);
7647     vload_module(flags, name, ver, &args);
7648     va_end(args);
7649 }
7650
7651 #ifdef PERL_IMPLICIT_CONTEXT
7652 void
7653 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7654 {
7655     dTHX;
7656     va_list args;
7657     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7658     va_start(args, ver);
7659     vload_module(flags, name, ver, &args);
7660     va_end(args);
7661 }
7662 #endif
7663
7664 void
7665 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7666 {
7667     OP *veop, *imop;
7668     OP * const modname = newSVOP(OP_CONST, 0, name);
7669
7670     PERL_ARGS_ASSERT_VLOAD_MODULE;
7671
7672     modname->op_private |= OPpCONST_BARE;
7673     if (ver) {
7674         veop = newSVOP(OP_CONST, 0, ver);
7675     }
7676     else
7677         veop = NULL;
7678     if (flags & PERL_LOADMOD_NOIMPORT) {
7679         imop = sawparens(newNULLLIST());
7680     }
7681     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7682         imop = va_arg(*args, OP*);
7683     }
7684     else {
7685         SV *sv;
7686         imop = NULL;
7687         sv = va_arg(*args, SV*);
7688         while (sv) {
7689             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7690             sv = va_arg(*args, SV*);
7691         }
7692     }
7693
7694     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7695      * that it has a PL_parser to play with while doing that, and also
7696      * that it doesn't mess with any existing parser, by creating a tmp
7697      * new parser with lex_start(). This won't actually be used for much,
7698      * since pp_require() will create another parser for the real work.
7699      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7700
7701     ENTER;
7702     SAVEVPTR(PL_curcop);
7703     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7704     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7705             veop, modname, imop);
7706     LEAVE;
7707 }
7708
7709 PERL_STATIC_INLINE OP *
7710 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7711 {
7712     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7713                    newLISTOP(OP_LIST, 0, arg,
7714                              newUNOP(OP_RV2CV, 0,
7715                                      newGVOP(OP_GV, 0, gv))));
7716 }
7717
7718 OP *
7719 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7720 {
7721     OP *doop;
7722     GV *gv;
7723
7724     PERL_ARGS_ASSERT_DOFILE;
7725
7726     if (!force_builtin && (gv = gv_override("do", 2))) {
7727         doop = S_new_entersubop(aTHX_ gv, term);
7728     }
7729     else {
7730         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7731     }
7732     return doop;
7733 }
7734
7735 /*
7736 =head1 Optree construction
7737
7738 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7739
7740 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7741 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7742 be set automatically, and, shifted up eight bits, the eight bits of
7743 C<op_private>, except that the bit with value 1 or 2 is automatically
7744 set as required.  C<listval> and C<subscript> supply the parameters of
7745 the slice; they are consumed by this function and become part of the
7746 constructed op tree.
7747
7748 =cut
7749 */
7750
7751 OP *
7752 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7753 {
7754     return newBINOP(OP_LSLICE, flags,
7755             list(force_list(subscript, 1)),
7756             list(force_list(listval,   1)) );
7757 }
7758
7759 #define ASSIGN_LIST   1
7760 #define ASSIGN_REF    2
7761
7762 STATIC I32
7763 S_assignment_type(pTHX_ const OP *o)
7764 {
7765     unsigned type;
7766     U8 flags;
7767     U8 ret;
7768
7769     if (!o)
7770         return TRUE;
7771
7772     if (o->op_type == OP_SREFGEN)
7773     {
7774         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7775         type = kid->op_type;
7776         flags = o->op_flags | kid->op_flags;
7777         if (!(flags & OPf_PARENS)
7778           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7779               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7780             return ASSIGN_REF;
7781         ret = ASSIGN_REF;
7782     } else {
7783         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7784             o = cUNOPo->op_first;
7785         flags = o->op_flags;
7786         type = o->op_type;
7787         ret = 0;
7788     }
7789
7790     if (type == OP_COND_EXPR) {
7791         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7792         const I32 t = assignment_type(sib);
7793         const I32 f = assignment_type(OpSIBLING(sib));
7794
7795         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7796             return ASSIGN_LIST;
7797         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7798             yyerror("Assignment to both a list and a scalar");
7799         return FALSE;
7800     }
7801
7802     if (type == OP_LIST &&
7803         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7804         o->op_private & OPpLVAL_INTRO)
7805         return ret;
7806
7807     if (type == OP_LIST || flags & OPf_PARENS ||
7808         type == OP_RV2AV || type == OP_RV2HV ||
7809         type == OP_ASLICE || type == OP_HSLICE ||
7810         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7811         return TRUE;
7812
7813     if (type == OP_PADAV || type == OP_PADHV)
7814         return TRUE;
7815
7816     if (type == OP_RV2SV)
7817         return ret;
7818
7819     return ret;
7820 }
7821
7822 static OP *
7823 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7824 {
7825     const PADOFFSET target = padop->op_targ;
7826     OP *const other = newOP(OP_PADSV,
7827                             padop->op_flags
7828                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7829     OP *const first = newOP(OP_NULL, 0);
7830     OP *const nullop = newCONDOP(0, first, initop, other);
7831     /* XXX targlex disabled for now; see ticket #124160
7832         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7833      */
7834     OP *const condop = first->op_next;
7835
7836     OpTYPE_set(condop, OP_ONCE);
7837     other->op_targ = target;
7838     nullop->op_flags |= OPf_WANT_SCALAR;
7839
7840     /* Store the initializedness of state vars in a separate
7841        pad entry.  */
7842     condop->op_targ =
7843       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7844     /* hijacking PADSTALE for uninitialized state variables */
7845     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7846
7847     return nullop;
7848 }
7849
7850 /*
7851 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7852
7853 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7854 supply the parameters of the assignment; they are consumed by this
7855 function and become part of the constructed op tree.
7856
7857 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7858 a suitable conditional optree is constructed.  If C<optype> is the opcode
7859 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7860 performs the binary operation and assigns the result to the left argument.
7861 Either way, if C<optype> is non-zero then C<flags> has no effect.
7862
7863 If C<optype> is zero, then a plain scalar or list assignment is
7864 constructed.  Which type of assignment it is is automatically determined.
7865 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7866 will be set automatically, and, shifted up eight bits, the eight bits
7867 of C<op_private>, except that the bit with value 1 or 2 is automatically
7868 set as required.
7869
7870 =cut
7871 */
7872
7873 OP *
7874 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7875 {
7876     OP *o;
7877     I32 assign_type;
7878
7879     if (optype) {
7880         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7881             right = scalar(right);
7882             return newLOGOP(optype, 0,
7883                 op_lvalue(scalar(left), optype),
7884                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7885         }
7886         else {
7887             return newBINOP(optype, OPf_STACKED,
7888                 op_lvalue(scalar(left), optype), scalar(right));
7889         }
7890     }
7891
7892     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7893         OP *state_var_op = NULL;
7894         static const char no_list_state[] = "Initialization of state variables"
7895             " in list currently forbidden";
7896         OP *curop;
7897
7898         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7899             left->op_private &= ~ OPpSLICEWARNING;
7900
7901         PL_modcount = 0;
7902         left = op_lvalue(left, OP_AASSIGN);
7903         curop = list(force_list(left, 1));
7904         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7905         o->op_private = (U8)(0 | (flags >> 8));
7906
7907         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7908         {
7909             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7910             if (!(left->op_flags & OPf_PARENS) &&
7911                     lop->op_type == OP_PUSHMARK &&
7912                     (vop = OpSIBLING(lop)) &&
7913                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7914                     !(vop->op_flags & OPf_PARENS) &&
7915                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7916                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7917                     (eop = OpSIBLING(vop)) &&
7918                     eop->op_type == OP_ENTERSUB &&
7919                     !OpHAS_SIBLING(eop)) {
7920                 state_var_op = vop;
7921             } else {
7922                 while (lop) {
7923                     if ((lop->op_type == OP_PADSV ||
7924                          lop->op_type == OP_PADAV ||
7925                          lop->op_type == OP_PADHV ||
7926                          lop->op_type == OP_PADANY)
7927                       && (lop->op_private & OPpPAD_STATE)
7928                     )
7929                         yyerror(no_list_state);
7930                     lop = OpSIBLING(lop);
7931                 }
7932             }
7933         }
7934         else if (  (left->op_private & OPpLVAL_INTRO)
7935                 && (left->op_private & OPpPAD_STATE)
7936                 && (   left->op_type == OP_PADSV
7937                     || left->op_type == OP_PADAV
7938                     || left->op_type == OP_PADHV
7939                     || left->op_type == OP_PADANY)
7940         ) {
7941                 /* All single variable list context state assignments, hence
7942                    state ($a) = ...
7943                    (state $a) = ...
7944                    state @a = ...
7945                    state (@a) = ...
7946                    (state @a) = ...
7947                    state %a = ...
7948                    state (%a) = ...
7949                    (state %a) = ...
7950                 */
7951                 if (left->op_flags & OPf_PARENS)
7952                     yyerror(no_list_state);
7953                 else
7954                     state_var_op = left;
7955         }
7956
7957         /* optimise @a = split(...) into:
7958         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7959         * @a, my @a, local @a:  split(...)          (where @a is attached to
7960         *                                            the split op itself)
7961         */
7962
7963         if (   right
7964             && right->op_type == OP_SPLIT
7965             /* don't do twice, e.g. @b = (@a = split) */
7966             && !(right->op_private & OPpSPLIT_ASSIGN))
7967         {
7968             OP *gvop = NULL;
7969
7970             if (   (  left->op_type == OP_RV2AV
7971                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7972                 || left->op_type == OP_PADAV)
7973             {
7974                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7975                 OP *tmpop;
7976                 if (gvop) {
7977 #ifdef USE_ITHREADS
7978                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7979                         = cPADOPx(gvop)->op_padix;
7980                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7981 #else
7982                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7983                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7984                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7985 #endif
7986                     right->op_private |=
7987                         left->op_private & OPpOUR_INTRO;
7988                 }
7989                 else {
7990                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7991                     left->op_targ = 0;  /* steal it */
7992                     right->op_private |= OPpSPLIT_LEX;
7993                 }
7994                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7995
7996               detach_split:
7997                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7998                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7999                 assert(OpSIBLING(tmpop) == right);
8000                 assert(!OpHAS_SIBLING(right));
8001                 /* detach the split subtreee from the o tree,
8002                  * then free the residual o tree */
8003                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8004                 op_free(o);                     /* blow off assign */
8005                 right->op_private |= OPpSPLIT_ASSIGN;
8006                 right->op_flags &= ~OPf_WANT;
8007                         /* "I don't know and I don't care." */
8008                 return right;
8009             }
8010             else if (left->op_type == OP_RV2AV) {
8011                 /* @{expr} */
8012
8013                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8014                 assert(OpSIBLING(pushop) == left);
8015                 /* Detach the array ...  */
8016                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8017                 /* ... and attach it to the split.  */
8018                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8019                                   0, left);
8020                 right->op_flags |= OPf_STACKED;
8021                 /* Detach split and expunge aassign as above.  */
8022                 goto detach_split;
8023             }
8024             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8025                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
8026             {
8027                 /* convert split(...,0) to split(..., PL_modcount+1) */
8028                 SV ** const svp =
8029                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8030                 SV * const sv = *svp;
8031                 if (SvIOK(sv) && SvIVX(sv) == 0)
8032                 {
8033                   if (right->op_private & OPpSPLIT_IMPLIM) {
8034                     /* our own SV, created in ck_split */
8035                     SvREADONLY_off(sv);
8036                     sv_setiv(sv, PL_modcount+1);
8037                   }
8038                   else {
8039                     /* SV may belong to someone else */
8040                     SvREFCNT_dec(sv);
8041                     *svp = newSViv(PL_modcount+1);
8042                   }
8043                 }
8044             }
8045         }
8046
8047         if (state_var_op)
8048             o = S_newONCEOP(aTHX_ o, state_var_op);
8049         return o;
8050     }
8051     if (assign_type == ASSIGN_REF)
8052         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8053     if (!right)
8054         right = newOP(OP_UNDEF, 0);
8055     if (right->op_type == OP_READLINE) {
8056         right->op_flags |= OPf_STACKED;
8057         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8058                 scalar(right));
8059     }
8060     else {
8061         o = newBINOP(OP_SASSIGN, flags,
8062             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8063     }
8064     return o;
8065 }
8066
8067 /*
8068 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8069
8070 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8071 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8072 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8073 If C<label> is non-null, it supplies the name of a label to attach to
8074 the state op; this function takes ownership of the memory pointed at by
8075 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8076 for the state op.
8077
8078 If C<o> is null, the state op is returned.  Otherwise the state op is
8079 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8080 is consumed by this function and becomes part of the returned op tree.
8081
8082 =cut
8083 */
8084
8085 OP *
8086 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8087 {
8088     dVAR;
8089     const U32 seq = intro_my();
8090     const U32 utf8 = flags & SVf_UTF8;
8091     COP *cop;
8092
8093     PL_parser->parsed_sub = 0;
8094
8095     flags &= ~SVf_UTF8;
8096
8097     NewOp(1101, cop, 1, COP);
8098     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8099         OpTYPE_set(cop, OP_DBSTATE);
8100     }
8101     else {
8102         OpTYPE_set(cop, OP_NEXTSTATE);
8103     }
8104     cop->op_flags = (U8)flags;
8105     CopHINTS_set(cop, PL_hints);
8106 #ifdef VMS
8107     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8108 #endif
8109     cop->op_next = (OP*)cop;
8110
8111     cop->cop_seq = seq;
8112     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8113     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8114     if (label) {
8115         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8116
8117         PL_hints |= HINT_BLOCK_SCOPE;
8118         /* It seems that we need to defer freeing this pointer, as other parts
8119            of the grammar end up wanting to copy it after this op has been
8120            created. */
8121         SAVEFREEPV(label);
8122     }
8123
8124     if (PL_parser->preambling != NOLINE) {
8125         CopLINE_set(cop, PL_parser->preambling);
8126         PL_parser->copline = NOLINE;
8127     }
8128     else if (PL_parser->copline == NOLINE)
8129         CopLINE_set(cop, CopLINE(PL_curcop));
8130     else {
8131         CopLINE_set(cop, PL_parser->copline);
8132         PL_parser->copline = NOLINE;
8133     }
8134 #ifdef USE_ITHREADS
8135     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8136 #else
8137     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8138 #endif
8139     CopSTASH_set(cop, PL_curstash);
8140
8141     if (cop->op_type == OP_DBSTATE) {
8142         /* this line can have a breakpoint - store the cop in IV */
8143         AV *av = CopFILEAVx(PL_curcop);
8144         if (av) {
8145             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8146             if (svp && *svp != &PL_sv_undef ) {
8147                 (void)SvIOK_on(*svp);
8148                 SvIV_set(*svp, PTR2IV(cop));
8149             }
8150         }
8151     }
8152
8153     if (flags & OPf_SPECIAL)
8154         op_null((OP*)cop);
8155     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8156 }
8157
8158 /*
8159 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8160
8161 Constructs, checks, and returns a logical (flow control) op.  C<type>
8162 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8163 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8164 the eight bits of C<op_private>, except that the bit with value 1 is
8165 automatically set.  C<first> supplies the expression controlling the
8166 flow, and C<other> supplies the side (alternate) chain of ops; they are
8167 consumed by this function and become part of the constructed op tree.
8168
8169 =cut
8170 */
8171
8172 OP *
8173 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8174 {
8175     PERL_ARGS_ASSERT_NEWLOGOP;
8176
8177     return new_logop(type, flags, &first, &other);
8178 }
8179
8180 STATIC OP *
8181 S_search_const(pTHX_ OP *o)
8182 {
8183     PERL_ARGS_ASSERT_SEARCH_CONST;
8184
8185     switch (o->op_type) {
8186         case OP_CONST:
8187             return o;
8188         case OP_NULL:
8189             if (o->op_flags & OPf_KIDS)
8190                 return search_const(cUNOPo->op_first);
8191             break;
8192         case OP_LEAVE:
8193         case OP_SCOPE:
8194         case OP_LINESEQ:
8195         {
8196             OP *kid;
8197             if (!(o->op_flags & OPf_KIDS))
8198                 return NULL;
8199             kid = cLISTOPo->op_first;
8200             do {
8201                 switch (kid->op_type) {
8202                     case OP_ENTER:
8203                     case OP_NULL:
8204                     case OP_NEXTSTATE:
8205                         kid = OpSIBLING(kid);
8206                         break;
8207                     default:
8208                         if (kid != cLISTOPo->op_last)
8209                             return NULL;
8210                         goto last;
8211                 }
8212             } while (kid);
8213             if (!kid)
8214                 kid = cLISTOPo->op_last;
8215           last:
8216             return search_const(kid);
8217         }
8218     }
8219
8220     return NULL;
8221 }
8222
8223 STATIC OP *
8224 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8225 {
8226     dVAR;
8227     LOGOP *logop;
8228     OP *o;
8229     OP *first;
8230     OP *other;
8231     OP *cstop = NULL;
8232     int prepend_not = 0;
8233
8234     PERL_ARGS_ASSERT_NEW_LOGOP;
8235
8236     first = *firstp;
8237     other = *otherp;
8238
8239     /* [perl #59802]: Warn about things like "return $a or $b", which
8240        is parsed as "(return $a) or $b" rather than "return ($a or
8241        $b)".  NB: This also applies to xor, which is why we do it
8242        here.
8243      */
8244     switch (first->op_type) {
8245     case OP_NEXT:
8246     case OP_LAST:
8247     case OP_REDO:
8248         /* XXX: Perhaps we should emit a stronger warning for these.
8249            Even with the high-precedence operator they don't seem to do
8250            anything sensible.
8251
8252            But until we do, fall through here.
8253          */
8254     case OP_RETURN:
8255     case OP_EXIT:
8256     case OP_DIE:
8257     case OP_GOTO:
8258         /* XXX: Currently we allow people to "shoot themselves in the
8259            foot" by explicitly writing "(return $a) or $b".
8260
8261            Warn unless we are looking at the result from folding or if
8262            the programmer explicitly grouped the operators like this.
8263            The former can occur with e.g.
8264
8265                 use constant FEATURE => ( $] >= ... );
8266                 sub { not FEATURE and return or do_stuff(); }
8267          */
8268         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8269             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8270                            "Possible precedence issue with control flow operator");
8271         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8272            the "or $b" part)?
8273         */
8274         break;
8275     }
8276
8277     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8278         return newBINOP(type, flags, scalar(first), scalar(other));
8279
8280     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8281         || type == OP_CUSTOM);
8282
8283     scalarboolean(first);
8284
8285     /* search for a constant op that could let us fold the test */
8286     if ((cstop = search_const(first))) {
8287         if (cstop->op_private & OPpCONST_STRICT)
8288             no_bareword_allowed(cstop);
8289         else if ((cstop->op_private & OPpCONST_BARE))
8290                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8291         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8292             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8293             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8294             /* Elide the (constant) lhs, since it can't affect the outcome */
8295             *firstp = NULL;
8296             if (other->op_type == OP_CONST)
8297                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8298             op_free(first);
8299             if (other->op_type == OP_LEAVE)
8300                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8301             else if (other->op_type == OP_MATCH
8302                   || other->op_type == OP_SUBST
8303                   || other->op_type == OP_TRANSR
8304                   || other->op_type == OP_TRANS)
8305                 /* Mark the op as being unbindable with =~ */
8306                 other->op_flags |= OPf_SPECIAL;
8307
8308             other->op_folded = 1;
8309             return other;
8310         }
8311         else {
8312             /* Elide the rhs, since the outcome is entirely determined by
8313              * the (constant) lhs */
8314
8315             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8316             const OP *o2 = other;
8317             if ( ! (o2->op_type == OP_LIST
8318                     && (( o2 = cUNOPx(o2)->op_first))
8319                     && o2->op_type == OP_PUSHMARK
8320                     && (( o2 = OpSIBLING(o2))) )
8321             )
8322                 o2 = other;
8323             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8324                         || o2->op_type == OP_PADHV)
8325                 && o2->op_private & OPpLVAL_INTRO
8326                 && !(o2->op_private & OPpPAD_STATE))
8327             {
8328         Perl_croak(aTHX_ "This use of my() in false conditional is "
8329                           "no longer allowed");
8330             }
8331
8332             *otherp = NULL;
8333             if (cstop->op_type == OP_CONST)
8334                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8335             op_free(other);
8336             return first;
8337         }
8338     }
8339     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8340         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8341     {
8342         const OP * const k1 = ((UNOP*)first)->op_first;
8343         const OP * const k2 = OpSIBLING(k1);
8344         OPCODE warnop = 0;
8345         switch (first->op_type)
8346         {
8347         case OP_NULL:
8348             if (k2 && k2->op_type == OP_READLINE
8349                   && (k2->op_flags & OPf_STACKED)
8350                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8351             {
8352                 warnop = k2->op_type;
8353             }
8354             break;
8355
8356         case OP_SASSIGN:
8357             if (k1->op_type == OP_READDIR
8358                   || k1->op_type == OP_GLOB
8359                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8360                  || k1->op_type == OP_EACH
8361                  || k1->op_type == OP_AEACH)
8362             {
8363                 warnop = ((k1->op_type == OP_NULL)
8364                           ? (OPCODE)k1->op_targ : k1->op_type);
8365             }
8366             break;
8367         }
8368         if (warnop) {
8369             const line_t oldline = CopLINE(PL_curcop);
8370             /* This ensures that warnings are reported at the first line
8371                of the construction, not the last.  */
8372             CopLINE_set(PL_curcop, PL_parser->copline);
8373             Perl_warner(aTHX_ packWARN(WARN_MISC),
8374                  "Value of %s%s can be \"0\"; test with defined()",
8375                  PL_op_desc[warnop],
8376                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8377                   ? " construct" : "() operator"));
8378             CopLINE_set(PL_curcop, oldline);
8379         }
8380     }
8381
8382     /* optimize AND and OR ops that have NOTs as children */
8383     if (first->op_type == OP_NOT
8384         && (first->op_flags & OPf_KIDS)
8385         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8386             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8387         ) {
8388         if (type == OP_AND || type == OP_OR) {
8389             if (type == OP_AND)
8390                 type = OP_OR;
8391             else
8392                 type = OP_AND;
8393             op_null(first);
8394             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8395                 op_null(other);
8396                 prepend_not = 1; /* prepend a NOT op later */
8397             }
8398         }
8399     }
8400
8401     logop = alloc_LOGOP(type, first, LINKLIST(other));
8402     logop->op_flags |= (U8)flags;
8403     logop->op_private = (U8)(1 | (flags >> 8));
8404
8405     /* establish postfix order */
8406     logop->op_next = LINKLIST(first);
8407     first->op_next = (OP*)logop;
8408     assert(!OpHAS_SIBLING(first));
8409     op_sibling_splice((OP*)logop, first, 0, other);
8410
8411     CHECKOP(type,logop);
8412
8413     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8414                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8415                 (OP*)logop);
8416     other->op_next = o;
8417
8418     return o;
8419 }
8420
8421 /*
8422 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8423
8424 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8425 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8426 will be set automatically, and, shifted up eight bits, the eight bits of
8427 C<op_private>, except that the bit with value 1 is automatically set.
8428 C<first> supplies the expression selecting between the two branches,
8429 and C<trueop> and C<falseop> supply the branches; they are consumed by
8430 this function and become part of the constructed op tree.
8431
8432 =cut
8433 */
8434
8435 OP *
8436 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8437 {
8438     dVAR;
8439     LOGOP *logop;
8440     OP *start;
8441     OP *o;
8442     OP *cstop;
8443
8444     PERL_ARGS_ASSERT_NEWCONDOP;
8445
8446     if (!falseop)
8447         return newLOGOP(OP_AND, 0, first, trueop);
8448     if (!trueop)
8449         return newLOGOP(OP_OR, 0, first, falseop);
8450
8451     scalarboolean(first);
8452     if ((cstop = search_const(first))) {
8453         /* Left or right arm of the conditional?  */
8454         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8455         OP *live = left ? trueop : falseop;
8456         OP *const dead = left ? falseop : trueop;
8457         if (cstop->op_private & OPpCONST_BARE &&
8458             cstop->op_private & OPpCONST_STRICT) {
8459             no_bareword_allowed(cstop);
8460         }
8461         op_free(first);
8462         op_free(dead);
8463         if (live->op_type == OP_LEAVE)
8464             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8465         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8466               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8467             /* Mark the op as being unbindable with =~ */
8468             live->op_flags |= OPf_SPECIAL;
8469         live->op_folded = 1;
8470         return live;
8471     }
8472     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8473     logop->op_flags |= (U8)flags;
8474     logop->op_private = (U8)(1 | (flags >> 8));
8475     logop->op_next = LINKLIST(falseop);
8476
8477     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8478             logop);
8479
8480     /* establish postfix order */
8481     start = LINKLIST(first);
8482     first->op_next = (OP*)logop;
8483
8484     /* make first, trueop, falseop siblings */
8485     op_sibling_splice((OP*)logop, first,  0, trueop);
8486     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8487
8488     o = newUNOP(OP_NULL, 0, (OP*)logop);
8489
8490     trueop->op_next = falseop->op_next = o;
8491
8492     o->op_next = start;
8493     return o;
8494 }
8495
8496 /*
8497 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8498
8499 Constructs and returns a C<range> op, with subordinate C<flip> and
8500 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8501 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8502 for both the C<flip> and C<range> ops, except that the bit with value
8503 1 is automatically set.  C<left> and C<right> supply the expressions
8504 controlling the endpoints of the range; they are consumed by this function
8505 and become part of the constructed op tree.
8506
8507 =cut
8508 */
8509
8510 OP *
8511 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8512 {
8513     LOGOP *range;
8514     OP *flip;
8515     OP *flop;
8516     OP *leftstart;
8517     OP *o;
8518
8519     PERL_ARGS_ASSERT_NEWRANGE;
8520
8521     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8522     range->op_flags = OPf_KIDS;
8523     leftstart = LINKLIST(left);
8524     range->op_private = (U8)(1 | (flags >> 8));
8525
8526     /* make left and right siblings */
8527     op_sibling_splice((OP*)range, left, 0, right);
8528
8529     range->op_next = (OP*)range;
8530     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8531     flop = newUNOP(OP_FLOP, 0, flip);
8532     o = newUNOP(OP_NULL, 0, flop);
8533     LINKLIST(flop);
8534     range->op_next = leftstart;
8535
8536     left->op_next = flip;
8537     right->op_next = flop;
8538
8539     range->op_targ =
8540         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8541     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8542     flip->op_targ =
8543         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8544     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8545     SvPADTMP_on(PAD_SV(flip->op_targ));
8546
8547     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8548     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8549
8550     /* check barewords before they might be optimized aways */
8551     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8552         no_bareword_allowed(left);
8553     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8554         no_bareword_allowed(right);
8555
8556     flip->op_next = o;
8557     if (!flip->op_private || !flop->op_private)
8558         LINKLIST(o);            /* blow off optimizer unless constant */
8559
8560     return o;
8561 }
8562
8563 /*
8564 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8565
8566 Constructs, checks, and returns an op tree expressing a loop.  This is
8567 only a loop in the control flow through the op tree; it does not have
8568 the heavyweight loop structure that allows exiting the loop by C<last>
8569 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8570 top-level op, except that some bits will be set automatically as required.
8571 C<expr> supplies the expression controlling loop iteration, and C<block>
8572 supplies the body of the loop; they are consumed by this function and
8573 become part of the constructed op tree.  C<debuggable> is currently
8574 unused and should always be 1.
8575
8576 =cut
8577 */
8578
8579 OP *
8580 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8581 {
8582     OP* listop;
8583     OP* o;
8584     const bool once = block && block->op_flags & OPf_SPECIAL &&
8585                       block->op_type == OP_NULL;
8586
8587     PERL_UNUSED_ARG(debuggable);
8588
8589     if (expr) {
8590         if (once && (
8591               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8592            || (  expr->op_type == OP_NOT
8593               && cUNOPx(expr)->op_first->op_type == OP_CONST
8594               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8595               )
8596            ))
8597             /* Return the block now, so that S_new_logop does not try to
8598                fold it away. */
8599             return block;       /* do {} while 0 does once */
8600         if (expr->op_type == OP_READLINE
8601             || expr->op_type == OP_READDIR
8602             || expr->op_type == OP_GLOB
8603             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8604             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8605             expr = newUNOP(OP_DEFINED, 0,
8606                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8607         } else if (expr->op_flags & OPf_KIDS) {
8608             const OP * const k1 = ((UNOP*)expr)->op_first;
8609             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8610             switch (expr->op_type) {
8611               case OP_NULL:
8612                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8613                       && (k2->op_flags & OPf_STACKED)
8614                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8615                     expr = newUNOP(OP_DEFINED, 0, expr);
8616                 break;
8617
8618               case OP_SASSIGN:
8619                 if (k1 && (k1->op_type == OP_READDIR
8620                       || k1->op_type == OP_GLOB
8621                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8622                      || k1->op_type == OP_EACH
8623                      || k1->op_type == OP_AEACH))
8624                     expr = newUNOP(OP_DEFINED, 0, expr);
8625                 break;
8626             }
8627         }
8628     }
8629
8630     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8631      * op, in listop. This is wrong. [perl #27024] */
8632     if (!block)
8633         block = newOP(OP_NULL, 0);
8634     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8635     o = new_logop(OP_AND, 0, &expr, &listop);
8636
8637     if (once) {
8638         ASSUME(listop);
8639     }
8640
8641     if (listop)
8642         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8643
8644     if (once && o != listop)
8645     {
8646         assert(cUNOPo->op_first->op_type == OP_AND
8647             || cUNOPo->op_first->op_type == OP_OR);
8648         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8649     }
8650
8651     if (o == listop)
8652         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8653
8654     o->op_flags |= flags;
8655     o = op_scope(o);
8656     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8657     return o;
8658 }
8659
8660 /*
8661 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8662
8663 Constructs, checks, and returns an op tree expressing a C<while> loop.
8664 This is a heavyweight loop, with structure that allows exiting the loop
8665 by C<last> and suchlike.
8666
8667 C<loop> is an optional preconstructed C<enterloop> op to use in the
8668 loop; if it is null then a suitable op will be constructed automatically.
8669 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8670 main body of the loop, and C<cont> optionally supplies a C<continue> block
8671 that operates as a second half of the body.  All of these optree inputs
8672 are consumed by this function and become part of the constructed op tree.
8673
8674 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8675 op and, shifted up eight bits, the eight bits of C<op_private> for
8676 the C<leaveloop> op, except that (in both cases) some bits will be set
8677 automatically.  C<debuggable> is currently unused and should always be 1.
8678 C<has_my> can be supplied as true to force the
8679 loop body to be enclosed in its own scope.
8680
8681 =cut
8682 */
8683
8684 OP *
8685 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8686         OP *expr, OP *block, OP *cont, I32 has_my)
8687 {
8688     dVAR;
8689     OP *redo;
8690     OP *next = NULL;
8691     OP *listop;
8692     OP *o;
8693     U8 loopflags = 0;
8694
8695     PERL_UNUSED_ARG(debuggable);
8696
8697     if (expr) {
8698         if (expr->op_type == OP_READLINE
8699          || expr->op_type == OP_READDIR
8700          || expr->op_type == OP_GLOB
8701          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8702                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8703             expr = newUNOP(OP_DEFINED, 0,
8704                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8705         } else if (expr->op_flags & OPf_KIDS) {
8706             const OP * const k1 = ((UNOP*)expr)->op_first;
8707             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8708             switch (expr->op_type) {
8709               case OP_NULL:
8710                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8711                       && (k2->op_flags & OPf_STACKED)
8712                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8713                     expr = newUNOP(OP_DEFINED, 0, expr);
8714                 break;
8715
8716               case OP_SASSIGN:
8717                 if (k1 && (k1->op_type == OP_READDIR
8718                       || k1->op_type == OP_GLOB
8719                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8720                      || k1->op_type == OP_EACH
8721                      || k1->op_type == OP_AEACH))
8722                     expr = newUNOP(OP_DEFINED, 0, expr);
8723                 break;
8724             }
8725         }
8726     }
8727
8728     if (!block)
8729         block = newOP(OP_NULL, 0);
8730     else if (cont || has_my) {
8731         block = op_scope(block);
8732     }
8733
8734     if (cont) {
8735         next = LINKLIST(cont);
8736     }
8737     if (expr) {
8738         OP * const unstack = newOP(OP_UNSTACK, 0);
8739         if (!next)
8740             next = unstack;
8741         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8742     }
8743
8744     assert(block);
8745     listop = op_append_list(OP_LINESEQ, block, cont);
8746     assert(listop);
8747     redo = LINKLIST(listop);
8748
8749     if (expr) {
8750         scalar(listop);
8751         o = new_logop(OP_AND, 0, &expr, &listop);
8752         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8753             op_free((OP*)loop);
8754             return expr;                /* listop already freed by new_logop */
8755         }
8756         if (listop)
8757             ((LISTOP*)listop)->op_last->op_next =
8758                 (o == listop ? redo : LINKLIST(o));
8759     }
8760     else
8761         o = listop;
8762
8763     if (!loop) {
8764         NewOp(1101,loop,1,LOOP);
8765         OpTYPE_set(loop, OP_ENTERLOOP);
8766         loop->op_private = 0;
8767         loop->op_next = (OP*)loop;
8768     }
8769
8770     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8771
8772     loop->op_redoop = redo;
8773     loop->op_lastop = o;
8774     o->op_private |= loopflags;
8775
8776     if (next)
8777         loop->op_nextop = next;
8778     else
8779         loop->op_nextop = o;
8780
8781     o->op_flags |= flags;
8782     o->op_private |= (flags >> 8);
8783     return o;
8784 }
8785
8786 /*
8787 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8788
8789 Constructs, checks, and returns an op tree expressing a C<foreach>
8790 loop (iteration through a list of values).  This is a heavyweight loop,
8791 with structure that allows exiting the loop by C<last> and suchlike.
8792
8793 C<sv> optionally supplies the variable that will be aliased to each
8794 item in turn; if null, it defaults to C<$_>.
8795 C<expr> supplies the list of values to iterate over.  C<block> supplies
8796 the main body of the loop, and C<cont> optionally supplies a C<continue>
8797 block that operates as a second half of the body.  All of these optree
8798 inputs are consumed by this function and become part of the constructed
8799 op tree.
8800
8801 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8802 op and, shifted up eight bits, the eight bits of C<op_private> for
8803 the C<leaveloop> op, except that (in both cases) some bits will be set
8804 automatically.
8805
8806 =cut
8807 */
8808
8809 OP *
8810 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8811 {
8812     dVAR;
8813     LOOP *loop;
8814     OP *wop;
8815     PADOFFSET padoff = 0;
8816     I32 iterflags = 0;
8817     I32 iterpflags = 0;
8818
8819     PERL_ARGS_ASSERT_NEWFOROP;
8820
8821     if (sv) {
8822         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8823             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8824             OpTYPE_set(sv, OP_RV2GV);
8825
8826             /* The op_type check is needed to prevent a possible segfault
8827              * if the loop variable is undeclared and 'strict vars' is in
8828              * effect. This is illegal but is nonetheless parsed, so we
8829              * may reach this point with an OP_CONST where we're expecting
8830              * an OP_GV.
8831              */
8832             if (cUNOPx(sv)->op_first->op_type == OP_GV
8833              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8834                 iterpflags |= OPpITER_DEF;
8835         }
8836         else if (sv->op_type == OP_PADSV) { /* private variable */
8837             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8838             padoff = sv->op_targ;
8839             sv->op_targ = 0;
8840             op_free(sv);
8841             sv = NULL;
8842             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8843         }
8844         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8845             NOOP;
8846         else
8847             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8848         if (padoff) {
8849             PADNAME * const pn = PAD_COMPNAME(padoff);
8850             const char * const name = PadnamePV(pn);
8851
8852             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8853                 iterpflags |= OPpITER_DEF;
8854         }
8855     }
8856     else {
8857         sv = newGVOP(OP_GV, 0, PL_defgv);
8858         iterpflags |= OPpITER_DEF;
8859     }
8860
8861     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8862         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8863         iterflags |= OPf_STACKED;
8864     }
8865     else if (expr->op_type == OP_NULL &&
8866              (expr->op_flags & OPf_KIDS) &&
8867              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8868     {
8869         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8870          * set the STACKED flag to indicate that these values are to be
8871          * treated as min/max values by 'pp_enteriter'.
8872          */
8873         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8874         LOGOP* const range = (LOGOP*) flip->op_first;
8875         OP* const left  = range->op_first;
8876         OP* const right = OpSIBLING(left);
8877         LISTOP* listop;
8878
8879         range->op_flags &= ~OPf_KIDS;
8880         /* detach range's children */
8881         op_sibling_splice((OP*)range, NULL, -1, NULL);
8882
8883         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8884         listop->op_first->op_next = range->op_next;
8885         left->op_next = range->op_other;
8886         right->op_next = (OP*)listop;
8887         listop->op_next = listop->op_first;
8888
8889         op_free(expr);
8890         expr = (OP*)(listop);
8891         op_null(expr);
8892         iterflags |= OPf_STACKED;
8893     }
8894     else {
8895         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8896     }
8897
8898     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8899                                   op_append_elem(OP_LIST, list(expr),
8900                                                  scalar(sv)));
8901     assert(!loop->op_next);
8902     /* for my  $x () sets OPpLVAL_INTRO;
8903      * for our $x () sets OPpOUR_INTRO */
8904     loop->op_private = (U8)iterpflags;
8905     if (loop->op_slabbed
8906      && DIFF(loop, OpSLOT(loop)->opslot_next)
8907          < SIZE_TO_PSIZE(sizeof(LOOP)))
8908     {
8909         LOOP *tmp;
8910         NewOp(1234,tmp,1,LOOP);
8911         Copy(loop,tmp,1,LISTOP);
8912         assert(loop->op_last->op_sibparent == (OP*)loop);
8913         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8914         S_op_destroy(aTHX_ (OP*)loop);
8915         loop = tmp;
8916     }
8917     else if (!loop->op_slabbed)
8918     {
8919         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8920         OpLASTSIB_set(loop->op_last, (OP*)loop);
8921     }
8922     loop->op_targ = padoff;
8923     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8924     return wop;
8925 }
8926
8927 /*
8928 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8929
8930 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8931 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8932 determining the target of the op; it is consumed by this function and
8933 becomes part of the constructed op tree.
8934
8935 =cut
8936 */
8937
8938 OP*
8939 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8940 {
8941     OP *o = NULL;
8942
8943     PERL_ARGS_ASSERT_NEWLOOPEX;
8944
8945     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8946         || type == OP_CUSTOM);
8947
8948     if (type != OP_GOTO) {
8949         /* "last()" means "last" */
8950         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8951             o = newOP(type, OPf_SPECIAL);
8952         }
8953     }
8954     else {
8955         /* Check whether it's going to be a goto &function */
8956         if (label->op_type == OP_ENTERSUB
8957                 && !(label->op_flags & OPf_STACKED))
8958             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8959     }
8960
8961     /* Check for a constant argument */
8962     if (label->op_type == OP_CONST) {
8963             SV * const sv = ((SVOP *)label)->op_sv;
8964             STRLEN l;
8965             const char *s = SvPV_const(sv,l);
8966             if (l == strlen(s)) {
8967                 o = newPVOP(type,
8968                             SvUTF8(((SVOP*)label)->op_sv),
8969                             savesharedpv(
8970                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8971             }
8972     }
8973
8974     /* If we have already created an op, we do not need the label. */
8975     if (o)
8976                 op_free(label);
8977     else o = newUNOP(type, OPf_STACKED, label);
8978
8979     PL_hints |= HINT_BLOCK_SCOPE;
8980     return o;
8981 }
8982
8983 /* if the condition is a literal array or hash
8984    (or @{ ... } etc), make a reference to it.
8985  */
8986 STATIC OP *
8987 S_ref_array_or_hash(pTHX_ OP *cond)
8988 {
8989     if (cond
8990     && (cond->op_type == OP_RV2AV
8991     ||  cond->op_type == OP_PADAV
8992     ||  cond->op_type == OP_RV2HV
8993     ||  cond->op_type == OP_PADHV))
8994
8995         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8996
8997     else if(cond
8998     && (cond->op_type == OP_ASLICE
8999     ||  cond->op_type == OP_KVASLICE
9000     ||  cond->op_type == OP_HSLICE
9001     ||  cond->op_type == OP_KVHSLICE)) {
9002
9003         /* anonlist now needs a list from this op, was previously used in
9004          * scalar context */
9005         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9006         cond->op_flags |= OPf_WANT_LIST;
9007
9008         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9009     }
9010
9011     else
9012         return cond;
9013 }
9014
9015 /* These construct the optree fragments representing given()
9016    and when() blocks.
9017
9018    entergiven and enterwhen are LOGOPs; the op_other pointer
9019    points up to the associated leave op. We need this so we
9020    can put it in the context and make break/continue work.
9021    (Also, of course, pp_enterwhen will jump straight to
9022    op_other if the match fails.)
9023  */
9024
9025 STATIC OP *
9026 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9027                    I32 enter_opcode, I32 leave_opcode,
9028                    PADOFFSET entertarg)
9029 {
9030     dVAR;
9031     LOGOP *enterop;
9032     OP *o;
9033
9034     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9035     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9036
9037     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9038     enterop->op_targ = 0;
9039     enterop->op_private = 0;
9040
9041     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9042
9043     if (cond) {
9044         /* prepend cond if we have one */
9045         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9046
9047         o->op_next = LINKLIST(cond);
9048         cond->op_next = (OP *) enterop;
9049     }
9050     else {
9051         /* This is a default {} block */
9052         enterop->op_flags |= OPf_SPECIAL;
9053         o      ->op_flags |= OPf_SPECIAL;
9054
9055         o->op_next = (OP *) enterop;
9056     }
9057
9058     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9059                                        entergiven and enterwhen both
9060                                        use ck_null() */
9061
9062     enterop->op_next = LINKLIST(block);
9063     block->op_next = enterop->op_other = o;
9064
9065     return o;
9066 }
9067
9068 /* Does this look like a boolean operation? For these purposes
9069    a boolean operation is:
9070      - a subroutine call [*]
9071      - a logical connective
9072      - a comparison operator
9073      - a filetest operator, with the exception of -s -M -A -C
9074      - defined(), exists() or eof()
9075      - /$re/ or $foo =~ /$re/
9076
9077    [*] possibly surprising
9078  */
9079 STATIC bool
9080 S_looks_like_bool(pTHX_ const OP *o)
9081 {
9082     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9083
9084     switch(o->op_type) {
9085         case OP_OR:
9086         case OP_DOR:
9087             return looks_like_bool(cLOGOPo->op_first);
9088
9089         case OP_AND:
9090         {
9091             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9092             ASSUME(sibl);
9093             return (
9094                 looks_like_bool(cLOGOPo->op_first)
9095              && looks_like_bool(sibl));
9096         }
9097
9098         case OP_NULL:
9099         case OP_SCALAR:
9100             return (
9101                 o->op_flags & OPf_KIDS
9102             && looks_like_bool(cUNOPo->op_first));
9103
9104         case OP_ENTERSUB:
9105
9106         case OP_NOT:    case OP_XOR:
9107
9108         case OP_EQ:     case OP_NE:     case OP_LT:
9109         case OP_GT:     case OP_LE:     case OP_GE:
9110
9111         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9112         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9113
9114         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9115         case OP_SGT:    case OP_SLE:    case OP_SGE:
9116
9117         case OP_SMARTMATCH:
9118
9119         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9120         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9121         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9122         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9123         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9124         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9125         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9126         case OP_FTTEXT:   case OP_FTBINARY:
9127
9128         case OP_DEFINED: case OP_EXISTS:
9129         case OP_MATCH:   case OP_EOF:
9130
9131         case OP_FLOP:
9132
9133             return TRUE;
9134
9135         case OP_INDEX:
9136         case OP_RINDEX:
9137             /* optimised-away (index() != -1) or similar comparison */
9138             if (o->op_private & OPpTRUEBOOL)
9139                 return TRUE;
9140             return FALSE;
9141
9142         case OP_CONST:
9143             /* Detect comparisons that have been optimized away */
9144             if (cSVOPo->op_sv == &PL_sv_yes
9145             ||  cSVOPo->op_sv == &PL_sv_no)
9146
9147                 return TRUE;
9148             else
9149                 return FALSE;
9150         /* FALLTHROUGH */
9151         default:
9152             return FALSE;
9153     }
9154 }
9155
9156 /*
9157 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9158
9159 Constructs, checks, and returns an op tree expressing a C<given> block.
9160 C<cond> supplies the expression to whose value C<$_> will be locally
9161 aliased, and C<block> supplies the body of the C<given> construct; they
9162 are consumed by this function and become part of the constructed op tree.
9163 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9164
9165 =cut
9166 */
9167
9168 OP *
9169 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9170 {
9171     PERL_ARGS_ASSERT_NEWGIVENOP;
9172     PERL_UNUSED_ARG(defsv_off);
9173
9174     assert(!defsv_off);
9175     return newGIVWHENOP(
9176         ref_array_or_hash(cond),
9177         block,
9178         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9179         0);
9180 }
9181
9182 /*
9183 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9184
9185 Constructs, checks, and returns an op tree expressing a C<when> block.
9186 C<cond> supplies the test expression, and C<block> supplies the block
9187 that will be executed if the test evaluates to true; they are consumed
9188 by this function and become part of the constructed op tree.  C<cond>
9189 will be interpreted DWIMically, often as a comparison against C<$_>,
9190 and may be null to generate a C<default> block.
9191
9192 =cut
9193 */
9194
9195 OP *
9196 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9197 {
9198     const bool cond_llb = (!cond || looks_like_bool(cond));
9199     OP *cond_op;
9200
9201     PERL_ARGS_ASSERT_NEWWHENOP;
9202
9203     if (cond_llb)
9204         cond_op = cond;
9205     else {
9206         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9207                 newDEFSVOP(),
9208                 scalar(ref_array_or_hash(cond)));
9209     }
9210
9211     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9212 }
9213
9214 /* must not conflict with SVf_UTF8 */
9215 #define CV_CKPROTO_CURSTASH     0x1
9216
9217 void
9218 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9219                     const STRLEN len, const U32 flags)
9220 {
9221     SV *name = NULL, *msg;
9222     const char * cvp = SvROK(cv)
9223                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9224                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9225                            : ""
9226                         : CvPROTO(cv);
9227     STRLEN clen = CvPROTOLEN(cv), plen = len;
9228
9229     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9230
9231     if (p == NULL && cvp == NULL)
9232         return;
9233
9234     if (!ckWARN_d(WARN_PROTOTYPE))
9235         return;
9236
9237     if (p && cvp) {
9238         p = S_strip_spaces(aTHX_ p, &plen);
9239         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9240         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9241             if (plen == clen && memEQ(cvp, p, plen))
9242                 return;
9243         } else {
9244             if (flags & SVf_UTF8) {
9245                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9246                     return;
9247             }
9248             else {
9249                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9250                     return;
9251             }
9252         }
9253     }
9254
9255     msg = sv_newmortal();
9256
9257     if (gv)
9258     {
9259         if (isGV(gv))
9260             gv_efullname3(name = sv_newmortal(), gv, NULL);
9261         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9262             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9263         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9264             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9265             sv_catpvs(name, "::");
9266             if (SvROK(gv)) {
9267                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9268                 assert (CvNAMED(SvRV_const(gv)));
9269                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9270             }
9271             else sv_catsv(name, (SV *)gv);
9272         }
9273         else name = (SV *)gv;
9274     }
9275     sv_setpvs(msg, "Prototype mismatch:");
9276     if (name)
9277         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9278     if (cvp)
9279         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9280             UTF8fARG(SvUTF8(cv),clen,cvp)
9281         );
9282     else
9283         sv_catpvs(msg, ": none");
9284     sv_catpvs(msg, " vs ");
9285     if (p)
9286         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9287     else
9288         sv_catpvs(msg, "none");
9289     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9290 }
9291
9292 static void const_sv_xsub(pTHX_ CV* cv);
9293 static void const_av_xsub(pTHX_ CV* cv);
9294
9295 /*
9296
9297 =head1 Optree Manipulation Functions
9298
9299 =for apidoc cv_const_sv
9300
9301 If C<cv> is a constant sub eligible for inlining, returns the constant
9302 value returned by the sub.  Otherwise, returns C<NULL>.
9303
9304 Constant subs can be created with C<newCONSTSUB> or as described in
9305 L<perlsub/"Constant Functions">.
9306
9307 =cut
9308 */
9309 SV *
9310 Perl_cv_const_sv(const CV *const cv)
9311 {
9312     SV *sv;
9313     if (!cv)
9314         return NULL;
9315     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9316         return NULL;
9317     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9318     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9319     return sv;
9320 }
9321
9322 SV *
9323 Perl_cv_const_sv_or_av(const CV * const cv)
9324 {
9325     if (!cv)
9326         return NULL;
9327     if (SvROK(cv)) return SvRV((SV *)cv);
9328     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9329     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9330 }
9331
9332 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9333  * Can be called in 2 ways:
9334  *
9335  * !allow_lex
9336  *      look for a single OP_CONST with attached value: return the value
9337  *
9338  * allow_lex && !CvCONST(cv);
9339  *
9340  *      examine the clone prototype, and if contains only a single
9341  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9342  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9343  *      a candidate for "constizing" at clone time, and return NULL.
9344  */
9345
9346 static SV *
9347 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9348 {
9349     SV *sv = NULL;
9350     bool padsv = FALSE;
9351
9352     assert(o);
9353     assert(cv);
9354
9355     for (; o; o = o->op_next) {
9356         const OPCODE type = o->op_type;
9357
9358         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9359              || type == OP_NULL
9360              || type == OP_PUSHMARK)
9361                 continue;
9362         if (type == OP_DBSTATE)
9363                 continue;
9364         if (type == OP_LEAVESUB)
9365             break;
9366         if (sv)
9367             return NULL;
9368         if (type == OP_CONST && cSVOPo->op_sv)
9369             sv = cSVOPo->op_sv;
9370         else if (type == OP_UNDEF && !o->op_private) {
9371             sv = newSV(0);
9372             SAVEFREESV(sv);
9373         }
9374         else if (allow_lex && type == OP_PADSV) {
9375                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9376                 {
9377                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9378                     padsv = TRUE;
9379                 }
9380                 else
9381                     return NULL;
9382         }
9383         else {
9384             return NULL;
9385         }
9386     }
9387     if (padsv) {
9388         CvCONST_on(cv);
9389         return NULL;
9390     }
9391     return sv;
9392 }
9393
9394 static void
9395 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9396                         PADNAME * const name, SV ** const const_svp)
9397 {
9398     assert (cv);
9399     assert (o || name);
9400     assert (const_svp);
9401     if (!block) {
9402         if (CvFLAGS(PL_compcv)) {
9403             /* might have had built-in attrs applied */
9404             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9405             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9406              && ckWARN(WARN_MISC))
9407             {
9408                 /* protect against fatal warnings leaking compcv */
9409                 SAVEFREESV(PL_compcv);
9410                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9411                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9412             }
9413             CvFLAGS(cv) |=
9414                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9415                   & ~(CVf_LVALUE * pureperl));
9416         }
9417         return;
9418     }
9419
9420     /* redundant check for speed: */
9421     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9422         const line_t oldline = CopLINE(PL_curcop);
9423         SV *namesv = o
9424             ? cSVOPo->op_sv
9425             : sv_2mortal(newSVpvn_utf8(
9426                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9427               ));
9428         if (PL_parser && PL_parser->copline != NOLINE)
9429             /* This ensures that warnings are reported at the first
9430                line of a redefinition, not the last.  */
9431             CopLINE_set(PL_curcop, PL_parser->copline);
9432         /* protect against fatal warnings leaking compcv */
9433         SAVEFREESV(PL_compcv);
9434         report_redefined_cv(namesv, cv, const_svp);
9435         SvREFCNT_inc_simple_void_NN(PL_compcv);
9436         CopLINE_set(PL_curcop, oldline);
9437     }
9438     SAVEFREESV(cv);
9439     return;
9440 }
9441
9442 CV *
9443 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9444 {
9445     CV **spot;
9446     SV **svspot;
9447     const char *ps;
9448     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9449     U32 ps_utf8 = 0;
9450     CV *cv = NULL;
9451     CV *compcv = PL_compcv;
9452     SV *const_sv;
9453     PADNAME *name;
9454     PADOFFSET pax = o->op_targ;
9455     CV *outcv = CvOUTSIDE(PL_compcv);
9456     CV *clonee = NULL;
9457     HEK *hek = NULL;
9458     bool reusable = FALSE;
9459     OP *start = NULL;
9460 #ifdef PERL_DEBUG_READONLY_OPS
9461     OPSLAB *slab = NULL;
9462 #endif
9463
9464     PERL_ARGS_ASSERT_NEWMYSUB;
9465
9466     PL_hints |= HINT_BLOCK_SCOPE;
9467
9468     /* Find the pad slot for storing the new sub.
9469        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9470        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9471        ing sub.  And then we need to dig deeper if this is a lexical from
9472        outside, as in:
9473            my sub foo; sub { sub foo { } }
9474      */
9475   redo:
9476     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9477     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9478         pax = PARENT_PAD_INDEX(name);
9479         outcv = CvOUTSIDE(outcv);
9480         assert(outcv);
9481         goto redo;
9482     }
9483     svspot =
9484         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9485                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9486     spot = (CV **)svspot;
9487
9488     if (!(PL_parser && PL_parser->error_count))
9489         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9490
9491     if (proto) {
9492         assert(proto->op_type == OP_CONST);
9493         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9494         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9495     }
9496     else
9497         ps = NULL;
9498
9499     if (proto)
9500         SAVEFREEOP(proto);
9501     if (attrs)
9502         SAVEFREEOP(attrs);
9503
9504     if (PL_parser && PL_parser->error_count) {
9505         op_free(block);
9506         SvREFCNT_dec(PL_compcv);
9507         PL_compcv = 0;
9508         goto done;
9509     }
9510
9511     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9512         cv = *spot;
9513         svspot = (SV **)(spot = &clonee);
9514     }
9515     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9516         cv = *spot;
9517     else {
9518         assert (SvTYPE(*spot) == SVt_PVCV);
9519         if (CvNAMED(*spot))
9520             hek = CvNAME_HEK(*spot);
9521         else {
9522             dVAR;
9523             U32 hash;
9524             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9525             CvNAME_HEK_set(*spot, hek =
9526                 share_hek(
9527                     PadnamePV(name)+1,
9528                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9529                     hash
9530                 )
9531             );
9532             CvLEXICAL_on(*spot);
9533         }
9534         cv = PadnamePROTOCV(name);
9535         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9536     }
9537
9538     if (block) {
9539         /* This makes sub {}; work as expected.  */
9540         if (block->op_type == OP_STUB) {
9541             const line_t l = PL_parser->copline;
9542             op_free(block);
9543             block = newSTATEOP(0, NULL, 0);
9544             PL_parser->copline = l;
9545         }
9546         block = CvLVALUE(compcv)
9547              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9548                    ? newUNOP(OP_LEAVESUBLV, 0,
9549                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9550                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9551         start = LINKLIST(block);
9552         block->op_next = 0;
9553         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9554             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9555         else
9556             const_sv = NULL;
9557     }
9558     else
9559         const_sv = NULL;
9560
9561     if (cv) {
9562         const bool exists = CvROOT(cv) || CvXSUB(cv);
9563
9564         /* if the subroutine doesn't exist and wasn't pre-declared
9565          * with a prototype, assume it will be AUTOLOADed,
9566          * skipping the prototype check
9567          */
9568         if (exists || SvPOK(cv))
9569             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9570                                  ps_utf8);
9571         /* already defined? */
9572         if (exists) {
9573             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9574             if (block)
9575                 cv = NULL;
9576             else {
9577                 if (attrs)
9578                     goto attrs;
9579                 /* just a "sub foo;" when &foo is already defined */
9580                 SAVEFREESV(compcv);
9581                 goto done;
9582             }
9583         }
9584         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9585             cv = NULL;
9586             reusable = TRUE;
9587         }
9588     }
9589
9590     if (const_sv) {
9591         SvREFCNT_inc_simple_void_NN(const_sv);
9592         SvFLAGS(const_sv) |= SVs_PADTMP;
9593         if (cv) {
9594             assert(!CvROOT(cv) && !CvCONST(cv));
9595             cv_forget_slab(cv);
9596         }
9597         else {
9598             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9599             CvFILE_set_from_cop(cv, PL_curcop);
9600             CvSTASH_set(cv, PL_curstash);
9601             *spot = cv;
9602         }
9603         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9604         CvXSUBANY(cv).any_ptr = const_sv;
9605         CvXSUB(cv) = const_sv_xsub;
9606         CvCONST_on(cv);
9607         CvISXSUB_on(cv);
9608         PoisonPADLIST(cv);
9609         CvFLAGS(cv) |= CvMETHOD(compcv);
9610         op_free(block);
9611         SvREFCNT_dec(compcv);
9612         PL_compcv = NULL;
9613         goto setname;
9614     }
9615
9616     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9617        determine whether this sub definition is in the same scope as its
9618        declaration.  If this sub definition is inside an inner named pack-
9619        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9620        the package sub.  So check PadnameOUTER(name) too.
9621      */
9622     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9623         assert(!CvWEAKOUTSIDE(compcv));
9624         SvREFCNT_dec(CvOUTSIDE(compcv));
9625         CvWEAKOUTSIDE_on(compcv);
9626     }
9627     /* XXX else do we have a circular reference? */
9628
9629     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9630         /* transfer PL_compcv to cv */
9631         if (block) {
9632             cv_flags_t preserved_flags =
9633                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9634             PADLIST *const temp_padl = CvPADLIST(cv);
9635             CV *const temp_cv = CvOUTSIDE(cv);
9636             const cv_flags_t other_flags =
9637                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9638             OP * const cvstart = CvSTART(cv);
9639
9640             SvPOK_off(cv);
9641             CvFLAGS(cv) =
9642                 CvFLAGS(compcv) | preserved_flags;
9643             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9644             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9645             CvPADLIST_set(cv, CvPADLIST(compcv));
9646             CvOUTSIDE(compcv) = temp_cv;
9647             CvPADLIST_set(compcv, temp_padl);
9648             CvSTART(cv) = CvSTART(compcv);
9649             CvSTART(compcv) = cvstart;
9650             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9651             CvFLAGS(compcv) |= other_flags;
9652
9653             if (CvFILE(cv) && CvDYNFILE(cv)) {
9654                 Safefree(CvFILE(cv));
9655             }
9656
9657             /* inner references to compcv must be fixed up ... */
9658             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9659             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9660                 ++PL_sub_generation;
9661         }
9662         else {
9663             /* Might have had built-in attributes applied -- propagate them. */
9664             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9665         }
9666         /* ... before we throw it away */
9667         SvREFCNT_dec(compcv);
9668         PL_compcv = compcv = cv;
9669     }
9670     else {
9671         cv = compcv;
9672         *spot = cv;
9673     }
9674
9675   setname:
9676     CvLEXICAL_on(cv);
9677     if (!CvNAME_HEK(cv)) {
9678         if (hek) (void)share_hek_hek(hek);
9679         else {
9680             dVAR;
9681             U32 hash;
9682             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9683             hek = share_hek(PadnamePV(name)+1,
9684                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9685                       hash);
9686         }
9687         CvNAME_HEK_set(cv, hek);
9688     }
9689
9690     if (const_sv)
9691         goto clone;
9692
9693     CvFILE_set_from_cop(cv, PL_curcop);
9694     CvSTASH_set(cv, PL_curstash);
9695
9696     if (ps) {
9697         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9698         if (ps_utf8)
9699             SvUTF8_on(MUTABLE_SV(cv));
9700     }
9701
9702     if (block) {
9703         /* If we assign an optree to a PVCV, then we've defined a
9704          * subroutine that the debugger could be able to set a breakpoint
9705          * in, so signal to pp_entereval that it should not throw away any
9706          * saved lines at scope exit.  */
9707
9708         PL_breakable_sub_gen++;
9709         CvROOT(cv) = block;
9710         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9711            itself has a refcount. */
9712         CvSLABBED_off(cv);
9713         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9714 #ifdef PERL_DEBUG_READONLY_OPS
9715         slab = (OPSLAB *)CvSTART(cv);
9716 #endif
9717         S_process_optree(aTHX_ cv, block, start);
9718     }
9719
9720   attrs:
9721     if (attrs) {
9722         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9723         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9724     }
9725
9726     if (block) {
9727         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9728             SV * const tmpstr = sv_newmortal();
9729             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9730                                                   GV_ADDMULTI, SVt_PVHV);
9731             HV *hv;
9732             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9733                                           CopFILE(PL_curcop),
9734                                           (long)PL_subline,
9735                                           (long)CopLINE(PL_curcop));
9736             if (HvNAME_HEK(PL_curstash)) {
9737                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9738                 sv_catpvs(tmpstr, "::");
9739             }
9740             else
9741                 sv_setpvs(tmpstr, "__ANON__::");
9742
9743             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9744                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9745             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9746                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9747             hv = GvHVn(db_postponed);
9748             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9749                 CV * const pcv = GvCV(db_postponed);
9750                 if (pcv) {
9751                     dSP;
9752                     PUSHMARK(SP);
9753                     XPUSHs(tmpstr);
9754                     PUTBACK;
9755                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9756                 }
9757             }
9758         }
9759     }
9760
9761   clone:
9762     if (clonee) {
9763         assert(CvDEPTH(outcv));
9764         spot = (CV **)
9765             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9766         if (reusable)
9767             cv_clone_into(clonee, *spot);
9768         else *spot = cv_clone(clonee);
9769         SvREFCNT_dec_NN(clonee);
9770         cv = *spot;
9771     }
9772
9773     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9774         PADOFFSET depth = CvDEPTH(outcv);
9775         while (--depth) {
9776             SV *oldcv;
9777             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9778             oldcv = *svspot;
9779             *svspot = SvREFCNT_inc_simple_NN(cv);
9780             SvREFCNT_dec(oldcv);
9781         }
9782     }
9783
9784   done:
9785     if (PL_parser)
9786         PL_parser->copline = NOLINE;
9787     LEAVE_SCOPE(floor);
9788 #ifdef PERL_DEBUG_READONLY_OPS
9789     if (slab)
9790         Slab_to_ro(slab);
9791 #endif
9792     op_free(o);
9793     return cv;
9794 }
9795
9796 /*
9797 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9798
9799 Construct a Perl subroutine, also performing some surrounding jobs.
9800
9801 This function is expected to be called in a Perl compilation context,
9802 and some aspects of the subroutine are taken from global variables
9803 associated with compilation.  In particular, C<PL_compcv> represents
9804 the subroutine that is currently being compiled.  It must be non-null
9805 when this function is called, and some aspects of the subroutine being
9806 constructed are taken from it.  The constructed subroutine may actually
9807 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9808
9809 If C<block> is null then the subroutine will have no body, and for the
9810 time being it will be an error to call it.  This represents a forward
9811 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9812 non-null then it provides the Perl code of the subroutine body, which
9813 will be executed when the subroutine is called.  This body includes
9814 any argument unwrapping code resulting from a subroutine signature or
9815 similar.  The pad use of the code must correspond to the pad attached
9816 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9817 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9818 by this function and will become part of the constructed subroutine.
9819
9820 C<proto> specifies the subroutine's prototype, unless one is supplied
9821 as an attribute (see below).  If C<proto> is null, then the subroutine
9822 will not have a prototype.  If C<proto> is non-null, it must point to a
9823 C<const> op whose value is a string, and the subroutine will have that
9824 string as its prototype.  If a prototype is supplied as an attribute, the
9825 attribute takes precedence over C<proto>, but in that case C<proto> should
9826 preferably be null.  In any case, C<proto> is consumed by this function.
9827
9828 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9829 attributes take effect by built-in means, being applied to C<PL_compcv>
9830 immediately when seen.  Other attributes are collected up and attached
9831 to the subroutine by this route.  C<attrs> may be null to supply no
9832 attributes, or point to a C<const> op for a single attribute, or point
9833 to a C<list> op whose children apart from the C<pushmark> are C<const>
9834 ops for one or more attributes.  Each C<const> op must be a string,
9835 giving the attribute name optionally followed by parenthesised arguments,
9836 in the manner in which attributes appear in Perl source.  The attributes
9837 will be applied to the sub by this function.  C<attrs> is consumed by
9838 this function.
9839
9840 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9841 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9842 must point to a C<const> op, which will be consumed by this function,
9843 and its string value supplies a name for the subroutine.  The name may
9844 be qualified or unqualified, and if it is unqualified then a default
9845 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9846 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9847 by which the subroutine will be named.
9848
9849 If there is already a subroutine of the specified name, then the new
9850 sub will either replace the existing one in the glob or be merged with
9851 the existing one.  A warning may be generated about redefinition.
9852
9853 If the subroutine has one of a few special names, such as C<BEGIN> or
9854 C<END>, then it will be claimed by the appropriate queue for automatic
9855 running of phase-related subroutines.  In this case the relevant glob will
9856 be left not containing any subroutine, even if it did contain one before.
9857 In the case of C<BEGIN>, the subroutine will be executed and the reference
9858 to it disposed of before this function returns.
9859
9860 The function returns a pointer to the constructed subroutine.  If the sub
9861 is anonymous then ownership of one counted reference to the subroutine
9862 is transferred to the caller.  If the sub is named then the caller does
9863 not get ownership of a reference.  In most such cases, where the sub
9864 has a non-phase name, the sub will be alive at the point it is returned
9865 by virtue of being contained in the glob that names it.  A phase-named
9866 subroutine will usually be alive by virtue of the reference owned by the
9867 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9868 been executed, will quite likely have been destroyed already by the
9869 time this function returns, making it erroneous for the caller to make
9870 any use of the returned pointer.  It is the caller's responsibility to
9871 ensure that it knows which of these situations applies.
9872
9873 =cut
9874 */
9875
9876 /* _x = extended */
9877 CV *
9878 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9879                             OP *block, bool o_is_gv)
9880 {
9881     GV *gv;
9882     const char *ps;
9883     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9884     U32 ps_utf8 = 0;
9885     CV *cv = NULL;     /* the previous CV with this name, if any */
9886     SV *const_sv;
9887     const bool ec = PL_parser && PL_parser->error_count;
9888     /* If the subroutine has no body, no attributes, and no builtin attributes
9889        then it's just a sub declaration, and we may be able to get away with
9890        storing with a placeholder scalar in the symbol table, rather than a
9891        full CV.  If anything is present then it will take a full CV to
9892        store it.  */
9893     const I32 gv_fetch_flags
9894         = ec ? GV_NOADD_NOINIT :
9895         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9896         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9897     STRLEN namlen = 0;
9898     const char * const name =
9899          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9900     bool has_name;
9901     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9902     bool evanescent = FALSE;
9903     OP *start = NULL;
9904 #ifdef PERL_DEBUG_READONLY_OPS
9905     OPSLAB *slab = NULL;
9906 #endif
9907
9908     if (o_is_gv) {
9909         gv = (GV*)o;
9910         o = NULL;
9911         has_name = TRUE;
9912     } else if (name) {
9913         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9914            hek and CvSTASH pointer together can imply the GV.  If the name
9915            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9916            CvSTASH, so forego the optimisation if we find any.
9917            Also, we may be called from load_module at run time, so
9918            PL_curstash (which sets CvSTASH) may not point to the stash the
9919            sub is stored in.  */
9920         /* XXX This optimization is currently disabled for packages other
9921                than main, since there was too much CPAN breakage.  */
9922         const I32 flags =
9923            ec ? GV_NOADD_NOINIT
9924               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9925                || PL_curstash != PL_defstash
9926                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9927                     ? gv_fetch_flags
9928                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9929         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9930         has_name = TRUE;
9931     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9932         SV * const sv = sv_newmortal();
9933         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9934                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9935                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9936         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9937         has_name = TRUE;
9938     } else if (PL_curstash) {
9939         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9940         has_name = FALSE;
9941     } else {
9942         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9943         has_name = FALSE;
9944     }
9945
9946     if (!ec) {
9947         if (isGV(gv)) {
9948             move_proto_attr(&proto, &attrs, gv, 0);
9949         } else {
9950             assert(cSVOPo);
9951             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9952         }
9953     }
9954
9955     if (proto) {
9956         assert(proto->op_type == OP_CONST);
9957         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9958         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9959     }
9960     else
9961         ps = NULL;
9962
9963     if (o)
9964         SAVEFREEOP(o);
9965     if (proto)
9966         SAVEFREEOP(proto);
9967     if (attrs)
9968         SAVEFREEOP(attrs);
9969
9970     if (ec) {
9971         op_free(block);
9972
9973         if (name)
9974             SvREFCNT_dec(PL_compcv);
9975         else
9976             cv = PL_compcv;
9977
9978         PL_compcv = 0;
9979         if (name && block) {
9980             const char *s = (char *) my_memrchr(name, ':', namlen);
9981             s = s ? s+1 : name;
9982             if (strEQ(s, "BEGIN")) {
9983                 if (PL_in_eval & EVAL_KEEPERR)
9984                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9985                 else {
9986                     SV * const errsv = ERRSV;
9987                     /* force display of errors found but not reported */
9988                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9989                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9990                 }
9991             }
9992         }
9993         goto done;
9994     }
9995
9996     if (!block && SvTYPE(gv) != SVt_PVGV) {
9997         /* If we are not defining a new sub and the existing one is not a
9998            full GV + CV... */
9999         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10000             /* We are applying attributes to an existing sub, so we need it
10001                upgraded if it is a constant.  */
10002             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10003                 gv_init_pvn(gv, PL_curstash, name, namlen,
10004                             SVf_UTF8 * name_is_utf8);
10005         }
10006         else {                  /* Maybe prototype now, and had at maximum
10007                                    a prototype or const/sub ref before.  */
10008             if (SvTYPE(gv) > SVt_NULL) {
10009                 cv_ckproto_len_flags((const CV *)gv,
10010                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10011                                     ps_len, ps_utf8);
10012             }
10013
10014             if (!SvROK(gv)) {
10015                 if (ps) {
10016                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10017                     if (ps_utf8)
10018                         SvUTF8_on(MUTABLE_SV(gv));
10019                 }
10020                 else
10021                     sv_setiv(MUTABLE_SV(gv), -1);
10022             }
10023
10024             SvREFCNT_dec(PL_compcv);
10025             cv = PL_compcv = NULL;
10026             goto done;
10027         }
10028     }
10029
10030     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10031         ? NULL
10032         : isGV(gv)
10033             ? GvCV(gv)
10034             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10035                 ? (CV *)SvRV(gv)
10036                 : NULL;
10037
10038     if (block) {
10039         assert(PL_parser);
10040         /* This makes sub {}; work as expected.  */
10041         if (block->op_type == OP_STUB) {
10042             const line_t l = PL_parser->copline;
10043             op_free(block);
10044             block = newSTATEOP(0, NULL, 0);
10045             PL_parser->copline = l;
10046         }
10047         block = CvLVALUE(PL_compcv)
10048              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10049                     && (!isGV(gv) || !GvASSUMECV(gv)))
10050                    ? newUNOP(OP_LEAVESUBLV, 0,
10051                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10052                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10053         start = LINKLIST(block);
10054         block->op_next = 0;
10055         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10056             const_sv =
10057                 S_op_const_sv(aTHX_ start, PL_compcv,
10058                                         cBOOL(CvCLONE(PL_compcv)));
10059         else
10060             const_sv = NULL;
10061     }
10062     else
10063         const_sv = NULL;
10064
10065     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10066         cv_ckproto_len_flags((const CV *)gv,
10067                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10068                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10069         if (SvROK(gv)) {
10070             /* All the other code for sub redefinition warnings expects the
10071                clobbered sub to be a CV.  Instead of making all those code
10072                paths more complex, just inline the RV version here.  */
10073             const line_t oldline = CopLINE(PL_curcop);
10074             assert(IN_PERL_COMPILETIME);
10075             if (PL_parser && PL_parser->copline != NOLINE)
10076                 /* This ensures that warnings are reported at the first
10077                    line of a redefinition, not the last.  */
10078                 CopLINE_set(PL_curcop, PL_parser->copline);
10079             /* protect against fatal warnings leaking compcv */
10080             SAVEFREESV(PL_compcv);
10081
10082             if (ckWARN(WARN_REDEFINE)
10083              || (  ckWARN_d(WARN_REDEFINE)
10084                 && (  !const_sv || SvRV(gv) == const_sv
10085                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10086                 assert(cSVOPo);
10087                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10088                           "Constant subroutine %" SVf " redefined",
10089                           SVfARG(cSVOPo->op_sv));
10090             }
10091
10092             SvREFCNT_inc_simple_void_NN(PL_compcv);
10093             CopLINE_set(PL_curcop, oldline);
10094             SvREFCNT_dec(SvRV(gv));
10095         }
10096     }
10097
10098     if (cv) {
10099         const bool exists = CvROOT(cv) || CvXSUB(cv);
10100
10101         /* if the subroutine doesn't exist and wasn't pre-declared
10102          * with a prototype, assume it will be AUTOLOADed,
10103          * skipping the prototype check
10104          */
10105         if (exists || SvPOK(cv))
10106             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10107         /* already defined (or promised)? */
10108         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10109             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10110             if (block)
10111                 cv = NULL;
10112             else {
10113                 if (attrs)
10114                     goto attrs;
10115                 /* just a "sub foo;" when &foo is already defined */
10116                 SAVEFREESV(PL_compcv);
10117                 goto done;
10118             }
10119         }
10120     }
10121
10122     if (const_sv) {
10123         SvREFCNT_inc_simple_void_NN(const_sv);
10124         SvFLAGS(const_sv) |= SVs_PADTMP;
10125         if (cv) {
10126             assert(!CvROOT(cv) && !CvCONST(cv));
10127             cv_forget_slab(cv);
10128             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10129             CvXSUBANY(cv).any_ptr = const_sv;
10130             CvXSUB(cv) = const_sv_xsub;
10131             CvCONST_on(cv);
10132             CvISXSUB_on(cv);
10133             PoisonPADLIST(cv);
10134             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10135         }
10136         else {
10137             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10138                 if (name && isGV(gv))
10139                     GvCV_set(gv, NULL);
10140                 cv = newCONSTSUB_flags(
10141                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10142                     const_sv
10143                 );
10144                 assert(cv);
10145                 assert(SvREFCNT((SV*)cv) != 0);
10146                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10147             }
10148             else {
10149                 if (!SvROK(gv)) {
10150                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10151                     prepare_SV_for_RV((SV *)gv);
10152                     SvOK_off((SV *)gv);
10153                     SvROK_on(gv);
10154                 }
10155                 SvRV_set(gv, const_sv);
10156             }
10157         }
10158         op_free(block);
10159         SvREFCNT_dec(PL_compcv);
10160         PL_compcv = NULL;
10161         goto done;
10162     }
10163
10164     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10165     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10166         cv = NULL;
10167
10168     if (cv) {                           /* must reuse cv if autoloaded */
10169         /* transfer PL_compcv to cv */
10170         if (block) {
10171             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10172             PADLIST *const temp_av = CvPADLIST(cv);
10173             CV *const temp_cv = CvOUTSIDE(cv);
10174             const cv_flags_t other_flags =
10175                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10176             OP * const cvstart = CvSTART(cv);
10177
10178             if (isGV(gv)) {
10179                 CvGV_set(cv,gv);
10180                 assert(!CvCVGV_RC(cv));
10181                 assert(CvGV(cv) == gv);
10182             }
10183             else {
10184                 dVAR;
10185                 U32 hash;
10186                 PERL_HASH(hash, name, namlen);
10187                 CvNAME_HEK_set(cv,
10188                                share_hek(name,
10189                                          name_is_utf8
10190                                             ? -(SSize_t)namlen
10191                                             :  (SSize_t)namlen,
10192                                          hash));
10193             }
10194
10195             SvPOK_off(cv);
10196             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10197                                              | CvNAMED(cv);
10198             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10199             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10200             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10201             CvOUTSIDE(PL_compcv) = temp_cv;
10202             CvPADLIST_set(PL_compcv, temp_av);
10203             CvSTART(cv) = CvSTART(PL_compcv);
10204             CvSTART(PL_compcv) = cvstart;
10205             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10206             CvFLAGS(PL_compcv) |= other_flags;
10207
10208             if (CvFILE(cv) && CvDYNFILE(cv)) {
10209                 Safefree(CvFILE(cv));
10210             }
10211             CvFILE_set_from_cop(cv, PL_curcop);
10212             CvSTASH_set(cv, PL_curstash);
10213
10214             /* inner references to PL_compcv must be fixed up ... */
10215             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10216             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10217                 ++PL_sub_generation;
10218         }
10219         else {
10220             /* Might have had built-in attributes applied -- propagate them. */
10221             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10222         }
10223         /* ... before we throw it away */
10224         SvREFCNT_dec(PL_compcv);
10225         PL_compcv = cv;
10226     }
10227     else {
10228         cv = PL_compcv;
10229         if (name && isGV(gv)) {
10230             GvCV_set(gv, cv);
10231             GvCVGEN(gv) = 0;
10232             if (HvENAME_HEK(GvSTASH(gv)))
10233                 /* sub Foo::bar { (shift)+1 } */
10234                 gv_method_changed(gv);
10235         }
10236         else if (name) {
10237             if (!SvROK(gv)) {
10238                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10239                 prepare_SV_for_RV((SV *)gv);
10240                 SvOK_off((SV *)gv);
10241                 SvROK_on(gv);
10242             }
10243             SvRV_set(gv, (SV *)cv);
10244             if (HvENAME_HEK(PL_curstash))
10245                 mro_method_changed_in(PL_curstash);
10246         }
10247     }
10248     assert(cv);
10249     assert(SvREFCNT((SV*)cv) != 0);
10250
10251     if (!CvHASGV(cv)) {
10252         if (isGV(gv))
10253             CvGV_set(cv, gv);
10254         else {
10255             dVAR;
10256             U32 hash;
10257             PERL_HASH(hash, name, namlen);
10258             CvNAME_HEK_set(cv, share_hek(name,
10259                                          name_is_utf8
10260                                             ? -(SSize_t)namlen
10261                                             :  (SSize_t)namlen,
10262                                          hash));
10263         }
10264         CvFILE_set_from_cop(cv, PL_curcop);
10265         CvSTASH_set(cv, PL_curstash);
10266     }
10267
10268     if (ps) {
10269         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10270         if ( ps_utf8 )
10271             SvUTF8_on(MUTABLE_SV(cv));
10272     }
10273
10274     if (block) {
10275         /* If we assign an optree to a PVCV, then we've defined a
10276          * subroutine that the debugger could be able to set a breakpoint
10277          * in, so signal to pp_entereval that it should not throw away any
10278          * saved lines at scope exit.  */
10279
10280         PL_breakable_sub_gen++;
10281         CvROOT(cv) = block;
10282         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10283            itself has a refcount. */
10284         CvSLABBED_off(cv);
10285         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10286 #ifdef PERL_DEBUG_READONLY_OPS
10287         slab = (OPSLAB *)CvSTART(cv);
10288 #endif
10289         S_process_optree(aTHX_ cv, block, start);
10290     }
10291
10292   attrs:
10293     if (attrs) {
10294         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10295         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10296                         ? GvSTASH(CvGV(cv))
10297                         : PL_curstash;
10298         if (!name)
10299             SAVEFREESV(cv);
10300         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10301         if (!name)
10302             SvREFCNT_inc_simple_void_NN(cv);
10303     }
10304
10305     if (block && has_name) {
10306         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10307             SV * const tmpstr = cv_name(cv,NULL,0);
10308             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10309                                                   GV_ADDMULTI, SVt_PVHV);
10310             HV *hv;
10311             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10312                                           CopFILE(PL_curcop),
10313                                           (long)PL_subline,
10314                                           (long)CopLINE(PL_curcop));
10315             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10316                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10317             hv = GvHVn(db_postponed);
10318             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10319                 CV * const pcv = GvCV(db_postponed);
10320                 if (pcv) {
10321                     dSP;
10322                     PUSHMARK(SP);
10323                     XPUSHs(tmpstr);
10324                     PUTBACK;
10325                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10326                 }
10327             }
10328         }
10329
10330         if (name) {
10331             if (PL_parser && PL_parser->error_count)
10332                 clear_special_blocks(name, gv, cv);
10333             else
10334                 evanescent =
10335                     process_special_blocks(floor, name, gv, cv);
10336         }
10337     }
10338     assert(cv);
10339
10340   done:
10341     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10342     if (PL_parser)
10343         PL_parser->copline = NOLINE;
10344     LEAVE_SCOPE(floor);
10345
10346     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10347     if (!evanescent) {
10348 #ifdef PERL_DEBUG_READONLY_OPS
10349     if (slab)
10350         Slab_to_ro(slab);
10351 #endif
10352     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10353         pad_add_weakref(cv);
10354     }
10355     return cv;
10356 }
10357
10358 STATIC void
10359 S_clear_special_blocks(pTHX_ const char *const fullname,
10360                        GV *const gv, CV *const cv) {
10361     const char *colon;
10362     const char *name;
10363
10364     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10365
10366     colon = strrchr(fullname,':');
10367     name = colon ? colon + 1 : fullname;
10368
10369     if ((*name == 'B' && strEQ(name, "BEGIN"))
10370         || (*name == 'E' && strEQ(name, "END"))
10371         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10372         || (*name == 'C' && strEQ(name, "CHECK"))
10373         || (*name == 'I' && strEQ(name, "INIT"))) {
10374         if (!isGV(gv)) {
10375             (void)CvGV(cv);
10376             assert(isGV(gv));
10377         }
10378         GvCV_set(gv, NULL);
10379         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10380     }
10381 }
10382
10383 /* Returns true if the sub has been freed.  */
10384 STATIC bool
10385 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10386                          GV *const gv,
10387                          CV *const cv)
10388 {
10389     const char *const colon = strrchr(fullname,':');
10390     const char *const name = colon ? colon + 1 : fullname;
10391
10392     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10393
10394     if (*name == 'B') {
10395         if (strEQ(name, "BEGIN")) {
10396             const I32 oldscope = PL_scopestack_ix;
10397             dSP;
10398             (void)CvGV(cv);
10399             if (floor) LEAVE_SCOPE(floor);
10400             ENTER;
10401             PUSHSTACKi(PERLSI_REQUIRE);
10402             SAVECOPFILE(&PL_compiling);
10403             SAVECOPLINE(&PL_compiling);
10404             SAVEVPTR(PL_curcop);
10405
10406             DEBUG_x( dump_sub(gv) );
10407             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10408             GvCV_set(gv,0);             /* cv has been hijacked */
10409             call_list(oldscope, PL_beginav);
10410
10411             POPSTACK;
10412             LEAVE;
10413             return !PL_savebegin;
10414         }
10415         else
10416             return FALSE;
10417     } else {
10418         if (*name == 'E') {
10419             if strEQ(name, "END") {
10420                 DEBUG_x( dump_sub(gv) );
10421                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10422             } else
10423                 return FALSE;
10424         } else if (*name == 'U') {
10425             if (strEQ(name, "UNITCHECK")) {
10426                 /* It's never too late to run a unitcheck block */
10427                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10428             }
10429             else
10430                 return FALSE;
10431         } else if (*name == 'C') {
10432             if (strEQ(name, "CHECK")) {
10433                 if (PL_main_start)
10434                     /* diag_listed_as: Too late to run %s block */
10435                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10436                                    "Too late to run CHECK block");
10437                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10438             }
10439             else
10440                 return FALSE;
10441         } else if (*name == 'I') {
10442             if (strEQ(name, "INIT")) {
10443                 if (PL_main_start)
10444                     /* diag_listed_as: Too late to run %s block */
10445                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10446                                    "Too late to run INIT block");
10447                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10448             }
10449             else
10450                 return FALSE;
10451         } else
10452             return FALSE;
10453         DEBUG_x( dump_sub(gv) );
10454         (void)CvGV(cv);
10455         GvCV_set(gv,0);         /* cv has been hijacked */
10456         return FALSE;
10457     }
10458 }
10459
10460 /*
10461 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10462
10463 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10464 rather than of counted length, and no flags are set.  (This means that
10465 C<name> is always interpreted as Latin-1.)
10466
10467 =cut
10468 */
10469
10470 CV *
10471 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10472 {
10473     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10474 }
10475
10476 /*
10477 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10478
10479 Construct a constant subroutine, also performing some surrounding
10480 jobs.  A scalar constant-valued subroutine is eligible for inlining
10481 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10482 123 }>>.  Other kinds of constant subroutine have other treatment.
10483
10484 The subroutine will have an empty prototype and will ignore any arguments
10485 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10486 is null, the subroutine will yield an empty list.  If C<sv> points to a
10487 scalar, the subroutine will always yield that scalar.  If C<sv> points
10488 to an array, the subroutine will always yield a list of the elements of
10489 that array in list context, or the number of elements in the array in
10490 scalar context.  This function takes ownership of one counted reference
10491 to the scalar or array, and will arrange for the object to live as long
10492 as the subroutine does.  If C<sv> points to a scalar then the inlining
10493 assumes that the value of the scalar will never change, so the caller
10494 must ensure that the scalar is not subsequently written to.  If C<sv>
10495 points to an array then no such assumption is made, so it is ostensibly
10496 safe to mutate the array or its elements, but whether this is really
10497 supported has not been determined.
10498
10499 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10500 Other aspects of the subroutine will be left in their default state.
10501 The caller is free to mutate the subroutine beyond its initial state
10502 after this function has returned.
10503
10504 If C<name> is null then the subroutine will be anonymous, with its
10505 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10506 subroutine will be named accordingly, referenced by the appropriate glob.
10507 C<name> is a string of length C<len> bytes giving a sigilless symbol
10508 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10509 otherwise.  The name may be either qualified or unqualified.  If the
10510 name is unqualified then it defaults to being in the stash specified by
10511 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10512 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10513 semantics.
10514
10515 C<flags> should not have bits set other than C<SVf_UTF8>.
10516
10517 If there is already a subroutine of the specified name, then the new sub
10518 will replace the existing one in the glob.  A warning may be generated
10519 about the redefinition.
10520
10521 If the subroutine has one of a few special names, such as C<BEGIN> or
10522 C<END>, then it will be claimed by the appropriate queue for automatic
10523 running of phase-related subroutines.  In this case the relevant glob will
10524 be left not containing any subroutine, even if it did contain one before.
10525 Execution of the subroutine will likely be a no-op, unless C<sv> was
10526 a tied array or the caller modified the subroutine in some interesting
10527 way before it was executed.  In the case of C<BEGIN>, the treatment is
10528 buggy: the sub will be executed when only half built, and may be deleted
10529 prematurely, possibly causing a crash.
10530
10531 The function returns a pointer to the constructed subroutine.  If the sub
10532 is anonymous then ownership of one counted reference to the subroutine
10533 is transferred to the caller.  If the sub is named then the caller does
10534 not get ownership of a reference.  In most such cases, where the sub
10535 has a non-phase name, the sub will be alive at the point it is returned
10536 by virtue of being contained in the glob that names it.  A phase-named
10537 subroutine will usually be alive by virtue of the reference owned by
10538 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10539 destroyed already by the time this function returns, but currently bugs
10540 occur in that case before the caller gets control.  It is the caller's
10541 responsibility to ensure that it knows which of these situations applies.
10542
10543 =cut
10544 */
10545
10546 CV *
10547 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10548                              U32 flags, SV *sv)
10549 {
10550     CV* cv;
10551     const char *const file = CopFILE(PL_curcop);
10552
10553     ENTER;
10554
10555     if (IN_PERL_RUNTIME) {
10556         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10557          * an op shared between threads. Use a non-shared COP for our
10558          * dirty work */
10559          SAVEVPTR(PL_curcop);
10560          SAVECOMPILEWARNINGS();
10561          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10562          PL_curcop = &PL_compiling;
10563     }
10564     SAVECOPLINE(PL_curcop);
10565     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10566
10567     SAVEHINTS();
10568     PL_hints &= ~HINT_BLOCK_SCOPE;
10569
10570     if (stash) {
10571         SAVEGENERICSV(PL_curstash);
10572         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10573     }
10574
10575     /* Protect sv against leakage caused by fatal warnings. */
10576     if (sv) SAVEFREESV(sv);
10577
10578     /* file becomes the CvFILE. For an XS, it's usually static storage,
10579        and so doesn't get free()d.  (It's expected to be from the C pre-
10580        processor __FILE__ directive). But we need a dynamically allocated one,
10581        and we need it to get freed.  */
10582     cv = newXS_len_flags(name, len,
10583                          sv && SvTYPE(sv) == SVt_PVAV
10584                              ? const_av_xsub
10585                              : const_sv_xsub,
10586                          file ? file : "", "",
10587                          &sv, XS_DYNAMIC_FILENAME | flags);
10588     assert(cv);
10589     assert(SvREFCNT((SV*)cv) != 0);
10590     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10591     CvCONST_on(cv);
10592
10593     LEAVE;
10594
10595     return cv;
10596 }
10597
10598 /*
10599 =for apidoc U||newXS
10600
10601 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10602 static storage, as it is used directly as CvFILE(), without a copy being made.
10603
10604 =cut
10605 */
10606
10607 CV *
10608 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10609 {
10610     PERL_ARGS_ASSERT_NEWXS;
10611     return newXS_len_flags(
10612         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10613     );
10614 }
10615
10616 CV *
10617 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10618                  const char *const filename, const char *const proto,
10619                  U32 flags)
10620 {
10621     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10622     return newXS_len_flags(
10623        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10624     );
10625 }
10626
10627 CV *
10628 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10629 {
10630     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10631     return newXS_len_flags(
10632         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10633     );
10634 }
10635
10636 /*
10637 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10638
10639 Construct an XS subroutine, also performing some surrounding jobs.
10640
10641 The subroutine will have the entry point C<subaddr>.  It will have
10642 the prototype specified by the nul-terminated string C<proto>, or
10643 no prototype if C<proto> is null.  The prototype string is copied;
10644 the caller can mutate the supplied string afterwards.  If C<filename>
10645 is non-null, it must be a nul-terminated filename, and the subroutine
10646 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10647 point directly to the supplied string, which must be static.  If C<flags>
10648 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10649 be taken instead.
10650
10651 Other aspects of the subroutine will be left in their default state.
10652 If anything else needs to be done to the subroutine for it to function
10653 correctly, it is the caller's responsibility to do that after this
10654 function has constructed it.  However, beware of the subroutine
10655 potentially being destroyed before this function returns, as described
10656 below.
10657
10658 If C<name> is null then the subroutine will be anonymous, with its
10659 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10660 subroutine will be named accordingly, referenced by the appropriate glob.
10661 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10662 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10663 The name may be either qualified or unqualified, with the stash defaulting
10664 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10665 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10666 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10667 the stash if necessary, with C<GV_ADDMULTI> semantics.
10668
10669 If there is already a subroutine of the specified name, then the new sub
10670 will replace the existing one in the glob.  A warning may be generated
10671 about the redefinition.  If the old subroutine was C<CvCONST> then the
10672 decision about whether to warn is influenced by an expectation about
10673 whether the new subroutine will become a constant of similar value.
10674 That expectation is determined by C<const_svp>.  (Note that the call to
10675 this function doesn't make the new subroutine C<CvCONST> in any case;
10676 that is left to the caller.)  If C<const_svp> is null then it indicates
10677 that the new subroutine will not become a constant.  If C<const_svp>
10678 is non-null then it indicates that the new subroutine will become a
10679 constant, and it points to an C<SV*> that provides the constant value
10680 that the subroutine will have.
10681
10682 If the subroutine has one of a few special names, such as C<BEGIN> or
10683 C<END>, then it will be claimed by the appropriate queue for automatic
10684 running of phase-related subroutines.  In this case the relevant glob will
10685 be left not containing any subroutine, even if it did contain one before.
10686 In the case of C<BEGIN>, the subroutine will be executed and the reference
10687 to it disposed of before this function returns, and also before its
10688 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10689 constructed by this function to be ready for execution then the caller
10690 must prevent this happening by giving the subroutine a different name.
10691
10692 The function returns a pointer to the constructed subroutine.  If the sub
10693 is anonymous then ownership of one counted reference to the subroutine
10694 is transferred to the caller.  If the sub is named then the caller does
10695 not get ownership of a reference.  In most such cases, where the sub
10696 has a non-phase name, the sub will be alive at the point it is returned
10697 by virtue of being contained in the glob that names it.  A phase-named
10698 subroutine will usually be alive by virtue of the reference owned by the
10699 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10700 been executed, will quite likely have been destroyed already by the
10701 time this function returns, making it erroneous for the caller to make
10702 any use of the returned pointer.  It is the caller's responsibility to
10703 ensure that it knows which of these situations applies.
10704
10705 =cut
10706 */
10707
10708 CV *
10709 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10710                            XSUBADDR_t subaddr, const char *const filename,
10711                            const char *const proto, SV **const_svp,
10712                            U32 flags)
10713 {
10714     CV *cv;
10715     bool interleave = FALSE;
10716     bool evanescent = FALSE;
10717
10718     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10719
10720     {
10721         GV * const gv = gv_fetchpvn(
10722                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10723                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10724                                 sizeof("__ANON__::__ANON__") - 1,
10725                             GV_ADDMULTI | flags, SVt_PVCV);
10726
10727         if ((cv = (name ? GvCV(gv) : NULL))) {
10728             if (GvCVGEN(gv)) {
10729                 /* just a cached method */
10730                 SvREFCNT_dec(cv);
10731                 cv = NULL;
10732             }
10733             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10734                 /* already defined (or promised) */
10735                 /* Redundant check that allows us to avoid creating an SV
10736                    most of the time: */
10737                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10738                     report_redefined_cv(newSVpvn_flags(
10739                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10740                                         ),
10741                                         cv, const_svp);
10742                 }
10743                 interleave = TRUE;
10744                 ENTER;
10745                 SAVEFREESV(cv);
10746                 cv = NULL;
10747             }
10748         }
10749
10750         if (cv)                         /* must reuse cv if autoloaded */
10751             cv_undef(cv);
10752         else {
10753             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10754             if (name) {
10755                 GvCV_set(gv,cv);
10756                 GvCVGEN(gv) = 0;
10757                 if (HvENAME_HEK(GvSTASH(gv)))
10758                     gv_method_changed(gv); /* newXS */
10759             }
10760         }
10761         assert(cv);
10762         assert(SvREFCNT((SV*)cv) != 0);
10763
10764         CvGV_set(cv, gv);
10765         if(filename) {
10766             /* XSUBs can't be perl lang/perl5db.pl debugged
10767             if (PERLDB_LINE_OR_SAVESRC)
10768                 (void)gv_fetchfile(filename); */
10769             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10770             if (flags & XS_DYNAMIC_FILENAME) {
10771                 CvDYNFILE_on(cv);
10772                 CvFILE(cv) = savepv(filename);
10773             } else {
10774             /* NOTE: not copied, as it is expected to be an external constant string */
10775                 CvFILE(cv) = (char *)filename;
10776             }
10777         } else {
10778             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10779             CvFILE(cv) = (char*)PL_xsubfilename;
10780         }
10781         CvISXSUB_on(cv);
10782         CvXSUB(cv) = subaddr;
10783 #ifndef PERL_IMPLICIT_CONTEXT
10784         CvHSCXT(cv) = &PL_stack_sp;
10785 #else
10786         PoisonPADLIST(cv);
10787 #endif
10788
10789         if (name)
10790             evanescent = process_special_blocks(0, name, gv, cv);
10791         else
10792             CvANON_on(cv);
10793     } /* <- not a conditional branch */
10794
10795     assert(cv);
10796     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10797
10798     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10799     if (interleave) LEAVE;
10800     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10801     return cv;
10802 }
10803
10804 CV *
10805 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10806 {
10807     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10808     GV *cvgv;
10809     PERL_ARGS_ASSERT_NEWSTUB;
10810     assert(!GvCVu(gv));
10811     GvCV_set(gv, cv);
10812     GvCVGEN(gv) = 0;
10813     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10814         gv_method_changed(gv);
10815     if (SvFAKE(gv)) {
10816         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10817         SvFAKE_off(cvgv);
10818     }
10819     else cvgv = gv;
10820     CvGV_set(cv, cvgv);
10821     CvFILE_set_from_cop(cv, PL_curcop);
10822     CvSTASH_set(cv, PL_curstash);
10823     GvMULTI_on(gv);
10824     return cv;
10825 }
10826
10827 void
10828 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10829 {
10830     CV *cv;
10831     GV *gv;
10832     OP *root;
10833     OP *start;
10834
10835     if (PL_parser && PL_parser->error_count) {
10836         op_free(block);
10837         goto finish;
10838     }
10839
10840     gv = o
10841         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10842         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10843
10844     GvMULTI_on(gv);
10845     if ((cv = GvFORM(gv))) {
10846         if (ckWARN(WARN_REDEFINE)) {
10847             const line_t oldline = CopLINE(PL_curcop);
10848             if (PL_parser && PL_parser->copline != NOLINE)
10849                 CopLINE_set(PL_curcop, PL_parser->copline);
10850             if (o) {
10851                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10852                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10853             } else {
10854                 /* diag_listed_as: Format %s redefined */
10855                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10856                             "Format STDOUT redefined");
10857             }
10858             CopLINE_set(PL_curcop, oldline);
10859         }
10860         SvREFCNT_dec(cv);
10861     }
10862     cv = PL_compcv;
10863     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10864     CvGV_set(cv, gv);
10865     CvFILE_set_from_cop(cv, PL_curcop);
10866
10867
10868     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10869     CvROOT(cv) = root;
10870     start = LINKLIST(root);
10871     root->op_next = 0;
10872     S_process_optree(aTHX_ cv, root, start);
10873     cv_forget_slab(cv);
10874
10875   finish:
10876     op_free(o);
10877     if (PL_parser)
10878         PL_parser->copline = NOLINE;
10879     LEAVE_SCOPE(floor);
10880     PL_compiling.cop_seq = 0;
10881 }
10882
10883 OP *
10884 Perl_newANONLIST(pTHX_ OP *o)
10885 {
10886     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10887 }
10888
10889 OP *
10890 Perl_newANONHASH(pTHX_ OP *o)
10891 {
10892     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10893 }
10894
10895 OP *
10896 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10897 {
10898     return newANONATTRSUB(floor, proto, NULL, block);
10899 }
10900
10901 OP *
10902 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10903 {
10904     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10905     OP * anoncode =
10906         newSVOP(OP_ANONCODE, 0,
10907                 cv);
10908     if (CvANONCONST(cv))
10909         anoncode = newUNOP(OP_ANONCONST, 0,
10910                            op_convert_list(OP_ENTERSUB,
10911                                            OPf_STACKED|OPf_WANT_SCALAR,
10912                                            anoncode));
10913     return newUNOP(OP_REFGEN, 0, anoncode);
10914 }
10915
10916 OP *
10917 Perl_oopsAV(pTHX_ OP *o)
10918 {
10919     dVAR;
10920
10921     PERL_ARGS_ASSERT_OOPSAV;
10922
10923     switch (o->op_type) {
10924     case OP_PADSV:
10925     case OP_PADHV:
10926         OpTYPE_set(o, OP_PADAV);
10927         return ref(o, OP_RV2AV);
10928
10929     case OP_RV2SV:
10930     case OP_RV2HV:
10931         OpTYPE_set(o, OP_RV2AV);
10932         ref(o, OP_RV2AV);
10933         break;
10934
10935     default:
10936         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10937         break;
10938     }
10939     return o;
10940 }
10941
10942 OP *
10943 Perl_oopsHV(pTHX_ OP *o)
10944 {
10945     dVAR;
10946
10947     PERL_ARGS_ASSERT_OOPSHV;
10948
10949     switch (o->op_type) {
10950     case OP_PADSV:
10951     case OP_PADAV:
10952         OpTYPE_set(o, OP_PADHV);
10953         return ref(o, OP_RV2HV);
10954
10955     case OP_RV2SV:
10956     case OP_RV2AV:
10957         OpTYPE_set(o, OP_RV2HV);
10958         /* rv2hv steals the bottom bit for its own uses */
10959         o->op_private &= ~OPpARG1_MASK;
10960         ref(o, OP_RV2HV);
10961         break;
10962
10963     default:
10964         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10965         break;
10966     }
10967     return o;
10968 }
10969
10970 OP *
10971 Perl_newAVREF(pTHX_ OP *o)
10972 {
10973     dVAR;
10974
10975     PERL_ARGS_ASSERT_NEWAVREF;
10976
10977     if (o->op_type == OP_PADANY) {
10978         OpTYPE_set(o, OP_PADAV);
10979         return o;
10980     }
10981     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10982         Perl_croak(aTHX_ "Can't use an array as a reference");
10983     }
10984     return newUNOP(OP_RV2AV, 0, scalar(o));
10985 }
10986
10987 OP *
10988 Perl_newGVREF(pTHX_ I32 type, OP *o)
10989 {
10990     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10991         return newUNOP(OP_NULL, 0, o);
10992     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10993 }
10994
10995 OP *
10996 Perl_newHVREF(pTHX_ OP *o)
10997 {
10998     dVAR;
10999
11000     PERL_ARGS_ASSERT_NEWHVREF;
11001
11002     if (o->op_type == OP_PADANY) {
11003         OpTYPE_set(o, OP_PADHV);
11004         return o;
11005     }
11006     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11007         Perl_croak(aTHX_ "Can't use a hash as a reference");
11008     }
11009     return newUNOP(OP_RV2HV, 0, scalar(o));
11010 }
11011
11012 OP *
11013 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11014 {
11015     if (o->op_type == OP_PADANY) {
11016         dVAR;
11017         OpTYPE_set(o, OP_PADCV);
11018     }
11019     return newUNOP(OP_RV2CV, flags, scalar(o));
11020 }
11021
11022 OP *
11023 Perl_newSVREF(pTHX_ OP *o)
11024 {
11025     dVAR;
11026
11027     PERL_ARGS_ASSERT_NEWSVREF;
11028
11029     if (o->op_type == OP_PADANY) {
11030         OpTYPE_set(o, OP_PADSV);
11031         scalar(o);
11032         return o;
11033     }
11034     return newUNOP(OP_RV2SV, 0, scalar(o));
11035 }
11036
11037 /* Check routines. See the comments at the top of this file for details
11038  * on when these are called */
11039
11040 OP *
11041 Perl_ck_anoncode(pTHX_ OP *o)
11042 {
11043     PERL_ARGS_ASSERT_CK_ANONCODE;
11044
11045     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11046     cSVOPo->op_sv = NULL;
11047     return o;
11048 }
11049
11050 static void
11051 S_io_hints(pTHX_ OP *o)
11052 {
11053 #if O_BINARY != 0 || O_TEXT != 0
11054     HV * const table =
11055         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11056     if (table) {
11057         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11058         if (svp && *svp) {
11059             STRLEN len = 0;
11060             const char *d = SvPV_const(*svp, len);
11061             const I32 mode = mode_from_discipline(d, len);
11062             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11063 #  if O_BINARY != 0
11064             if (mode & O_BINARY)
11065                 o->op_private |= OPpOPEN_IN_RAW;
11066 #  endif
11067 #  if O_TEXT != 0
11068             if (mode & O_TEXT)
11069                 o->op_private |= OPpOPEN_IN_CRLF;
11070 #  endif
11071         }
11072
11073         svp = hv_fetchs(table, "open_OUT", FALSE);
11074         if (svp && *svp) {
11075             STRLEN len = 0;
11076             const char *d = SvPV_const(*svp, len);
11077             const I32 mode = mode_from_discipline(d, len);
11078             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11079 #  if O_BINARY != 0
11080             if (mode & O_BINARY)
11081                 o->op_private |= OPpOPEN_OUT_RAW;
11082 #  endif
11083 #  if O_TEXT != 0
11084             if (mode & O_TEXT)
11085                 o->op_private |= OPpOPEN_OUT_CRLF;
11086 #  endif
11087         }
11088     }
11089 #else
11090     PERL_UNUSED_CONTEXT;
11091     PERL_UNUSED_ARG(o);
11092 #endif
11093 }
11094
11095 OP *
11096 Perl_ck_backtick(pTHX_ OP *o)
11097 {
11098     GV *gv;
11099     OP *newop = NULL;
11100     OP *sibl;
11101     PERL_ARGS_ASSERT_CK_BACKTICK;
11102     o = ck_fun(o);
11103     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11104     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11105      && (gv = gv_override("readpipe",8)))
11106     {
11107         /* detach rest of siblings from o and its first child */
11108         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11109         newop = S_new_entersubop(aTHX_ gv, sibl);
11110     }
11111     else if (!(o->op_flags & OPf_KIDS))
11112         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11113     if (newop) {
11114         op_free(o);
11115         return newop;
11116     }
11117     S_io_hints(aTHX_ o);
11118     return o;
11119 }
11120
11121 OP *
11122 Perl_ck_bitop(pTHX_ OP *o)
11123 {
11124     PERL_ARGS_ASSERT_CK_BITOP;
11125
11126     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11127
11128     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11129             && OP_IS_INFIX_BIT(o->op_type))
11130     {
11131         const OP * const left = cBINOPo->op_first;
11132         const OP * const right = OpSIBLING(left);
11133         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11134                 (left->op_flags & OPf_PARENS) == 0) ||
11135             (OP_IS_NUMCOMPARE(right->op_type) &&
11136                 (right->op_flags & OPf_PARENS) == 0))
11137             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11138                           "Possible precedence problem on bitwise %s operator",
11139                            o->op_type ==  OP_BIT_OR
11140                          ||o->op_type == OP_NBIT_OR  ? "|"
11141                         :  o->op_type ==  OP_BIT_AND
11142                          ||o->op_type == OP_NBIT_AND ? "&"
11143                         :  o->op_type ==  OP_BIT_XOR
11144                          ||o->op_type == OP_NBIT_XOR ? "^"
11145                         :  o->op_type == OP_SBIT_OR  ? "|."
11146                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11147                            );
11148     }
11149     return o;
11150 }
11151
11152 PERL_STATIC_INLINE bool
11153 is_dollar_bracket(pTHX_ const OP * const o)
11154 {
11155     const OP *kid;
11156     PERL_UNUSED_CONTEXT;
11157     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11158         && (kid = cUNOPx(o)->op_first)
11159         && kid->op_type == OP_GV
11160         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11161 }
11162
11163 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11164
11165 OP *
11166 Perl_ck_cmp(pTHX_ OP *o)
11167 {
11168     bool is_eq;
11169     bool neg;
11170     bool reverse;
11171     bool iv0;
11172     OP *indexop, *constop, *start;
11173     SV *sv;
11174     IV iv;
11175
11176     PERL_ARGS_ASSERT_CK_CMP;
11177
11178     is_eq = (   o->op_type == OP_EQ
11179              || o->op_type == OP_NE
11180              || o->op_type == OP_I_EQ
11181              || o->op_type == OP_I_NE);
11182
11183     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11184         const OP *kid = cUNOPo->op_first;
11185         if (kid &&
11186             (
11187                 (   is_dollar_bracket(aTHX_ kid)
11188                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11189                 )
11190              || (   kid->op_type == OP_CONST
11191                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11192                 )
11193            )
11194         )
11195             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11196                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11197     }
11198
11199     /* convert (index(...) == -1) and variations into
11200      *   (r)index/BOOL(,NEG)
11201      */
11202
11203     reverse = FALSE;
11204
11205     indexop = cUNOPo->op_first;
11206     constop = OpSIBLING(indexop);
11207     start = NULL;
11208     if (indexop->op_type == OP_CONST) {
11209         constop = indexop;
11210         indexop = OpSIBLING(constop);
11211         start = constop;
11212         reverse = TRUE;
11213     }
11214
11215     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11216         return o;
11217
11218     /* ($lex = index(....)) == -1 */
11219     if (indexop->op_private & OPpTARGET_MY)
11220         return o;
11221
11222     if (constop->op_type != OP_CONST)
11223         return o;
11224
11225     sv = cSVOPx_sv(constop);
11226     if (!(sv && SvIOK_notUV(sv)))
11227         return o;
11228
11229     iv = SvIVX(sv);
11230     if (iv != -1 && iv != 0)
11231         return o;
11232     iv0 = (iv == 0);
11233
11234     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11235         if (!(iv0 ^ reverse))
11236             return o;
11237         neg = iv0;
11238     }
11239     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11240         if (iv0 ^ reverse)
11241             return o;
11242         neg = !iv0;
11243     }
11244     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11245         if (!(iv0 ^ reverse))
11246             return o;
11247         neg = !iv0;
11248     }
11249     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11250         if (iv0 ^ reverse)
11251             return o;
11252         neg = iv0;
11253     }
11254     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11255         if (iv0)
11256             return o;
11257         neg = TRUE;
11258     }
11259     else {
11260         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11261         if (iv0)
11262             return o;
11263         neg = FALSE;
11264     }
11265
11266     indexop->op_flags &= ~OPf_PARENS;
11267     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11268     indexop->op_private |= OPpTRUEBOOL;
11269     if (neg)
11270         indexop->op_private |= OPpINDEX_BOOLNEG;
11271     /* cut out the index op and free the eq,const ops */
11272     (void)op_sibling_splice(o, start, 1, NULL);
11273     op_free(o);
11274
11275     return indexop;
11276 }
11277
11278
11279 OP *
11280 Perl_ck_concat(pTHX_ OP *o)
11281 {
11282     const OP * const kid = cUNOPo->op_first;
11283
11284     PERL_ARGS_ASSERT_CK_CONCAT;
11285     PERL_UNUSED_CONTEXT;
11286
11287     /* reuse the padtmp returned by the concat child */
11288     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11289             !(kUNOP->op_first->op_flags & OPf_MOD))
11290     {
11291         o->op_flags |= OPf_STACKED;
11292         o->op_private |= OPpCONCAT_NESTED;
11293     }
11294     return o;
11295 }
11296
11297 OP *
11298 Perl_ck_spair(pTHX_ OP *o)
11299 {
11300     dVAR;
11301
11302     PERL_ARGS_ASSERT_CK_SPAIR;
11303
11304     if (o->op_flags & OPf_KIDS) {
11305         OP* newop;
11306         OP* kid;
11307         OP* kidkid;
11308         const OPCODE type = o->op_type;
11309         o = modkids(ck_fun(o), type);
11310         kid    = cUNOPo->op_first;
11311         kidkid = kUNOP->op_first;
11312         newop = OpSIBLING(kidkid);
11313         if (newop) {
11314             const OPCODE type = newop->op_type;
11315             if (OpHAS_SIBLING(newop))
11316                 return o;
11317             if (o->op_type == OP_REFGEN
11318              && (  type == OP_RV2CV
11319                 || (  !(newop->op_flags & OPf_PARENS)
11320                    && (  type == OP_RV2AV || type == OP_PADAV
11321                       || type == OP_RV2HV || type == OP_PADHV))))
11322                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11323             else if (OP_GIMME(newop,0) != G_SCALAR)
11324                 return o;
11325         }
11326         /* excise first sibling */
11327         op_sibling_splice(kid, NULL, 1, NULL);
11328         op_free(kidkid);
11329     }
11330     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11331      * and OP_CHOMP into OP_SCHOMP */
11332     o->op_ppaddr = PL_ppaddr[++o->op_type];
11333     return ck_fun(o);
11334 }
11335
11336 OP *
11337 Perl_ck_delete(pTHX_ OP *o)
11338 {
11339     PERL_ARGS_ASSERT_CK_DELETE;
11340
11341     o = ck_fun(o);
11342     o->op_private = 0;
11343     if (o->op_flags & OPf_KIDS) {
11344         OP * const kid = cUNOPo->op_first;
11345         switch (kid->op_type) {
11346         case OP_ASLICE:
11347             o->op_flags |= OPf_SPECIAL;
11348             /* FALLTHROUGH */
11349         case OP_HSLICE:
11350             o->op_private |= OPpSLICE;
11351             break;
11352         case OP_AELEM:
11353             o->op_flags |= OPf_SPECIAL;
11354             /* FALLTHROUGH */
11355         case OP_HELEM:
11356             break;
11357         case OP_KVASLICE:
11358             o->op_flags |= OPf_SPECIAL;
11359             /* FALLTHROUGH */
11360         case OP_KVHSLICE:
11361             o->op_private |= OPpKVSLICE;
11362             break;
11363         default:
11364             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11365                              "element or slice");
11366         }
11367         if (kid->op_private & OPpLVAL_INTRO)
11368             o->op_private |= OPpLVAL_INTRO;
11369         op_null(kid);
11370     }
11371     return o;
11372 }
11373
11374 OP *
11375 Perl_ck_eof(pTHX_ OP *o)
11376 {
11377     PERL_ARGS_ASSERT_CK_EOF;
11378
11379     if (o->op_flags & OPf_KIDS) {
11380         OP *kid;
11381         if (cLISTOPo->op_first->op_type == OP_STUB) {
11382             OP * const newop
11383                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11384             op_free(o);
11385             o = newop;
11386         }
11387         o = ck_fun(o);
11388         kid = cLISTOPo->op_first;
11389         if (kid->op_type == OP_RV2GV)
11390             kid->op_private |= OPpALLOW_FAKE;
11391     }
11392     return o;
11393 }
11394
11395
11396 OP *
11397 Perl_ck_eval(pTHX_ OP *o)
11398 {
11399     dVAR;
11400
11401     PERL_ARGS_ASSERT_CK_EVAL;
11402
11403     PL_hints |= HINT_BLOCK_SCOPE;
11404     if (o->op_flags & OPf_KIDS) {
11405         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11406         assert(kid);
11407
11408         if (o->op_type == OP_ENTERTRY) {
11409             LOGOP *enter;
11410
11411             /* cut whole sibling chain free from o */
11412             op_sibling_splice(o, NULL, -1, NULL);
11413             op_free(o);
11414
11415             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11416
11417             /* establish postfix order */
11418             enter->op_next = (OP*)enter;
11419
11420             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11421             OpTYPE_set(o, OP_LEAVETRY);
11422             enter->op_other = o;
11423             return o;
11424         }
11425         else {
11426             scalar((OP*)kid);
11427             S_set_haseval(aTHX);
11428         }
11429     }
11430     else {
11431         const U8 priv = o->op_private;
11432         op_free(o);
11433         /* the newUNOP will recursively call ck_eval(), which will handle
11434          * all the stuff at the end of this function, like adding
11435          * OP_HINTSEVAL
11436          */
11437         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11438     }
11439     o->op_targ = (PADOFFSET)PL_hints;
11440     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11441     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11442      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11443         /* Store a copy of %^H that pp_entereval can pick up. */
11444         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11445                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11446         /* append hhop to only child  */
11447         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11448
11449         o->op_private |= OPpEVAL_HAS_HH;
11450     }
11451     if (!(o->op_private & OPpEVAL_BYTES)
11452          && FEATURE_UNIEVAL_IS_ENABLED)
11453             o->op_private |= OPpEVAL_UNICODE;
11454     return o;
11455 }
11456
11457 OP *
11458 Perl_ck_exec(pTHX_ OP *o)
11459 {
11460     PERL_ARGS_ASSERT_CK_EXEC;
11461
11462     if (o->op_flags & OPf_STACKED) {
11463         OP *kid;
11464         o = ck_fun(o);
11465         kid = OpSIBLING(cUNOPo->op_first);
11466         if (kid->op_type == OP_RV2GV)
11467             op_null(kid);
11468     }
11469     else
11470         o = listkids(o);
11471     return o;
11472 }
11473
11474 OP *
11475 Perl_ck_exists(pTHX_ OP *o)
11476 {
11477     PERL_ARGS_ASSERT_CK_EXISTS;
11478
11479     o = ck_fun(o);
11480     if (o->op_flags & OPf_KIDS) {
11481         OP * const kid = cUNOPo->op_first;
11482         if (kid->op_type == OP_ENTERSUB) {
11483             (void) ref(kid, o->op_type);
11484             if (kid->op_type != OP_RV2CV
11485                         && !(PL_parser && PL_parser->error_count))
11486                 Perl_croak(aTHX_
11487                           "exists argument is not a subroutine name");
11488             o->op_private |= OPpEXISTS_SUB;
11489         }
11490         else if (kid->op_type == OP_AELEM)
11491             o->op_flags |= OPf_SPECIAL;
11492         else if (kid->op_type != OP_HELEM)
11493             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11494                              "element or a subroutine");
11495         op_null(kid);
11496     }
11497     return o;
11498 }
11499
11500 OP *
11501 Perl_ck_rvconst(pTHX_ OP *o)
11502 {
11503     dVAR;
11504     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11505
11506     PERL_ARGS_ASSERT_CK_RVCONST;
11507
11508     if (o->op_type == OP_RV2HV)
11509         /* rv2hv steals the bottom bit for its own uses */
11510         o->op_private &= ~OPpARG1_MASK;
11511
11512     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11513
11514     if (kid->op_type == OP_CONST) {
11515         int iscv;
11516         GV *gv;
11517         SV * const kidsv = kid->op_sv;
11518
11519         /* Is it a constant from cv_const_sv()? */
11520         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11521             return o;
11522         }
11523         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11524         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11525             const char *badthing;
11526             switch (o->op_type) {
11527             case OP_RV2SV:
11528                 badthing = "a SCALAR";
11529                 break;
11530             case OP_RV2AV:
11531                 badthing = "an ARRAY";
11532                 break;
11533             case OP_RV2HV:
11534                 badthing = "a HASH";
11535                 break;
11536             default:
11537                 badthing = NULL;
11538                 break;
11539             }
11540             if (badthing)
11541                 Perl_croak(aTHX_
11542                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11543                            SVfARG(kidsv), badthing);
11544         }
11545         /*
11546          * This is a little tricky.  We only want to add the symbol if we
11547          * didn't add it in the lexer.  Otherwise we get duplicate strict
11548          * warnings.  But if we didn't add it in the lexer, we must at
11549          * least pretend like we wanted to add it even if it existed before,
11550          * or we get possible typo warnings.  OPpCONST_ENTERED says
11551          * whether the lexer already added THIS instance of this symbol.
11552          */
11553         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11554         gv = gv_fetchsv(kidsv,
11555                 o->op_type == OP_RV2CV
11556                         && o->op_private & OPpMAY_RETURN_CONSTANT
11557                     ? GV_NOEXPAND
11558                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11559                 iscv
11560                     ? SVt_PVCV
11561                     : o->op_type == OP_RV2SV
11562                         ? SVt_PV
11563                         : o->op_type == OP_RV2AV
11564                             ? SVt_PVAV
11565                             : o->op_type == OP_RV2HV
11566                                 ? SVt_PVHV
11567                                 : SVt_PVGV);
11568         if (gv) {
11569             if (!isGV(gv)) {
11570                 assert(iscv);
11571                 assert(SvROK(gv));
11572                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11573                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11574                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11575             }
11576             OpTYPE_set(kid, OP_GV);
11577             SvREFCNT_dec(kid->op_sv);
11578 #ifdef USE_ITHREADS
11579             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11580             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11581             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11582             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11583             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11584 #else
11585             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11586 #endif
11587             kid->op_private = 0;
11588             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11589             SvFAKE_off(gv);
11590         }
11591     }
11592     return o;
11593 }
11594
11595 OP *
11596 Perl_ck_ftst(pTHX_ OP *o)
11597 {
11598     dVAR;
11599     const I32 type = o->op_type;
11600
11601     PERL_ARGS_ASSERT_CK_FTST;
11602
11603     if (o->op_flags & OPf_REF) {
11604         NOOP;
11605     }
11606     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11607         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11608         const OPCODE kidtype = kid->op_type;
11609
11610         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11611          && !kid->op_folded) {
11612             OP * const newop = newGVOP(type, OPf_REF,
11613                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11614             op_free(o);
11615             return newop;
11616         }
11617
11618         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11619             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11620             if (name) {
11621                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11622                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11623                             array_passed_to_stat, name);
11624             }
11625             else {
11626                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11627                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11628             }
11629        }
11630         scalar((OP *) kid);
11631         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11632             o->op_private |= OPpFT_ACCESS;
11633         if (type != OP_STAT && type != OP_LSTAT
11634             && PL_check[kidtype] == Perl_ck_ftst
11635             && kidtype != OP_STAT && kidtype != OP_LSTAT
11636         ) {
11637             o->op_private |= OPpFT_STACKED;
11638             kid->op_private |= OPpFT_STACKING;
11639             if (kidtype == OP_FTTTY && (
11640                    !(kid->op_private & OPpFT_STACKED)
11641                 || kid->op_private & OPpFT_AFTER_t
11642                ))
11643                 o->op_private |= OPpFT_AFTER_t;
11644         }
11645     }
11646     else {
11647         op_free(o);
11648         if (type == OP_FTTTY)
11649             o = newGVOP(type, OPf_REF, PL_stdingv);
11650         else
11651             o = newUNOP(type, 0, newDEFSVOP());
11652     }
11653     return o;
11654 }
11655
11656 OP *
11657 Perl_ck_fun(pTHX_ OP *o)
11658 {
11659     const int type = o->op_type;
11660     I32 oa = PL_opargs[type] >> OASHIFT;
11661
11662     PERL_ARGS_ASSERT_CK_FUN;
11663
11664     if (o->op_flags & OPf_STACKED) {
11665         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11666             oa &= ~OA_OPTIONAL;
11667         else
11668             return no_fh_allowed(o);
11669     }
11670
11671     if (o->op_flags & OPf_KIDS) {
11672         OP *prev_kid = NULL;
11673         OP *kid = cLISTOPo->op_first;
11674         I32 numargs = 0;
11675         bool seen_optional = FALSE;
11676
11677         if (kid->op_type == OP_PUSHMARK ||
11678             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11679         {
11680             prev_kid = kid;
11681             kid = OpSIBLING(kid);
11682         }
11683         if (kid && kid->op_type == OP_COREARGS) {
11684             bool optional = FALSE;
11685             while (oa) {
11686                 numargs++;
11687                 if (oa & OA_OPTIONAL) optional = TRUE;
11688                 oa = oa >> 4;
11689             }
11690             if (optional) o->op_private |= numargs;
11691             return o;
11692         }
11693
11694         while (oa) {
11695             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11696                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11697                     kid = newDEFSVOP();
11698                     /* append kid to chain */
11699                     op_sibling_splice(o, prev_kid, 0, kid);
11700                 }
11701                 seen_optional = TRUE;
11702             }
11703             if (!kid) break;
11704
11705             numargs++;
11706             switch (oa & 7) {
11707             case OA_SCALAR:
11708                 /* list seen where single (scalar) arg expected? */
11709                 if (numargs == 1 && !(oa >> 4)
11710                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11711                 {
11712                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11713                 }
11714                 if (type != OP_DELETE) scalar(kid);
11715                 break;
11716             case OA_LIST:
11717                 if (oa < 16) {
11718                     kid = 0;
11719                     continue;
11720                 }
11721                 else
11722                     list(kid);
11723                 break;
11724             case OA_AVREF:
11725                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11726                     && !OpHAS_SIBLING(kid))
11727                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11728                                    "Useless use of %s with no values",
11729                                    PL_op_desc[type]);
11730
11731                 if (kid->op_type == OP_CONST
11732                       && (  !SvROK(cSVOPx_sv(kid))
11733                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11734                         )
11735                     bad_type_pv(numargs, "array", o, kid);
11736                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11737                          || kid->op_type == OP_RV2GV) {
11738                     bad_type_pv(1, "array", o, kid);
11739                 }
11740                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11741                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11742                                          PL_op_desc[type]), 0);
11743                 }
11744                 else {
11745                     op_lvalue(kid, type);
11746                 }
11747                 break;
11748             case OA_HVREF:
11749                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11750                     bad_type_pv(numargs, "hash", o, kid);
11751                 op_lvalue(kid, type);
11752                 break;
11753             case OA_CVREF:
11754                 {
11755                     /* replace kid with newop in chain */
11756                     OP * const newop =
11757                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11758                     newop->op_next = newop;
11759                     kid = newop;
11760                 }
11761                 break;
11762             case OA_FILEREF:
11763                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11764                     if (kid->op_type == OP_CONST &&
11765                         (kid->op_private & OPpCONST_BARE))
11766                     {
11767                         OP * const newop = newGVOP(OP_GV, 0,
11768                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11769                         /* replace kid with newop in chain */
11770                         op_sibling_splice(o, prev_kid, 1, newop);
11771                         op_free(kid);
11772                         kid = newop;
11773                     }
11774                     else if (kid->op_type == OP_READLINE) {
11775                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11776                         bad_type_pv(numargs, "HANDLE", o, kid);
11777                     }
11778                     else {
11779                         I32 flags = OPf_SPECIAL;
11780                         I32 priv = 0;
11781                         PADOFFSET targ = 0;
11782
11783                         /* is this op a FH constructor? */
11784                         if (is_handle_constructor(o,numargs)) {
11785                             const char *name = NULL;
11786                             STRLEN len = 0;
11787                             U32 name_utf8 = 0;
11788                             bool want_dollar = TRUE;
11789
11790                             flags = 0;
11791                             /* Set a flag to tell rv2gv to vivify
11792                              * need to "prove" flag does not mean something
11793                              * else already - NI-S 1999/05/07
11794                              */
11795                             priv = OPpDEREF;
11796                             if (kid->op_type == OP_PADSV) {
11797                                 PADNAME * const pn
11798                                     = PAD_COMPNAME_SV(kid->op_targ);
11799                                 name = PadnamePV (pn);
11800                                 len  = PadnameLEN(pn);
11801                                 name_utf8 = PadnameUTF8(pn);
11802                             }
11803                             else if (kid->op_type == OP_RV2SV
11804                                      && kUNOP->op_first->op_type == OP_GV)
11805                             {
11806                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11807                                 name = GvNAME(gv);
11808                                 len = GvNAMELEN(gv);
11809                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11810                             }
11811                             else if (kid->op_type == OP_AELEM
11812                                      || kid->op_type == OP_HELEM)
11813                             {
11814                                  OP *firstop;
11815                                  OP *op = ((BINOP*)kid)->op_first;
11816                                  name = NULL;
11817                                  if (op) {
11818                                       SV *tmpstr = NULL;
11819                                       const char * const a =
11820                                            kid->op_type == OP_AELEM ?
11821                                            "[]" : "{}";
11822                                       if (((op->op_type == OP_RV2AV) ||
11823                                            (op->op_type == OP_RV2HV)) &&
11824                                           (firstop = ((UNOP*)op)->op_first) &&
11825                                           (firstop->op_type == OP_GV)) {
11826                                            /* packagevar $a[] or $h{} */
11827                                            GV * const gv = cGVOPx_gv(firstop);
11828                                            if (gv)
11829                                                 tmpstr =
11830                                                      Perl_newSVpvf(aTHX_
11831                                                                    "%s%c...%c",
11832                                                                    GvNAME(gv),
11833                                                                    a[0], a[1]);
11834                                       }
11835                                       else if (op->op_type == OP_PADAV
11836                                                || op->op_type == OP_PADHV) {
11837                                            /* lexicalvar $a[] or $h{} */
11838                                            const char * const padname =
11839                                                 PAD_COMPNAME_PV(op->op_targ);
11840                                            if (padname)
11841                                                 tmpstr =
11842                                                      Perl_newSVpvf(aTHX_
11843                                                                    "%s%c...%c",
11844                                                                    padname + 1,
11845                                                                    a[0], a[1]);
11846                                       }
11847                                       if (tmpstr) {
11848                                            name = SvPV_const(tmpstr, len);
11849                                            name_utf8 = SvUTF8(tmpstr);
11850                                            sv_2mortal(tmpstr);
11851                                       }
11852                                  }
11853                                  if (!name) {
11854                                       name = "__ANONIO__";
11855                                       len = 10;
11856                                       want_dollar = FALSE;
11857                                  }
11858                                  op_lvalue(kid, type);
11859                             }
11860                             if (name) {
11861                                 SV *namesv;
11862                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11863                                 namesv = PAD_SVl(targ);
11864                                 if (want_dollar && *name != '$')
11865                                     sv_setpvs(namesv, "$");
11866                                 else
11867                                     SvPVCLEAR(namesv);
11868                                 sv_catpvn(namesv, name, len);
11869                                 if ( name_utf8 ) SvUTF8_on(namesv);
11870                             }
11871                         }
11872                         scalar(kid);
11873                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11874                                     OP_RV2GV, flags);
11875                         kid->op_targ = targ;
11876                         kid->op_private |= priv;
11877                     }
11878                 }
11879                 scalar(kid);
11880                 break;
11881             case OA_SCALARREF:
11882                 if ((type == OP_UNDEF || type == OP_POS)
11883                     && numargs == 1 && !(oa >> 4)
11884                     && kid->op_type == OP_LIST)
11885                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11886                 op_lvalue(scalar(kid), type);
11887                 break;
11888             }
11889             oa >>= 4;
11890             prev_kid = kid;
11891             kid = OpSIBLING(kid);
11892         }
11893         /* FIXME - should the numargs or-ing move after the too many
11894          * arguments check? */
11895         o->op_private |= numargs;
11896         if (kid)
11897             return too_many_arguments_pv(o,OP_DESC(o), 0);
11898         listkids(o);
11899     }
11900     else if (PL_opargs[type] & OA_DEFGV) {
11901         /* Ordering of these two is important to keep f_map.t passing.  */
11902         op_free(o);
11903         return newUNOP(type, 0, newDEFSVOP());
11904     }
11905
11906     if (oa) {
11907         while (oa & OA_OPTIONAL)
11908             oa >>= 4;
11909         if (oa && oa != OA_LIST)
11910             return too_few_arguments_pv(o,OP_DESC(o), 0);
11911     }
11912     return o;
11913 }
11914
11915 OP *
11916 Perl_ck_glob(pTHX_ OP *o)
11917 {
11918     GV *gv;
11919
11920     PERL_ARGS_ASSERT_CK_GLOB;
11921
11922     o = ck_fun(o);
11923     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11924         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11925
11926     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11927     {
11928         /* convert
11929          *     glob
11930          *       \ null - const(wildcard)
11931          * into
11932          *     null
11933          *       \ enter
11934          *            \ list
11935          *                 \ mark - glob - rv2cv
11936          *                             |        \ gv(CORE::GLOBAL::glob)
11937          *                             |
11938          *                              \ null - const(wildcard)
11939          */
11940         o->op_flags |= OPf_SPECIAL;
11941         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11942         o = S_new_entersubop(aTHX_ gv, o);
11943         o = newUNOP(OP_NULL, 0, o);
11944         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11945         return o;
11946     }
11947     else o->op_flags &= ~OPf_SPECIAL;
11948 #if !defined(PERL_EXTERNAL_GLOB)
11949     if (!PL_globhook) {
11950         ENTER;
11951         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11952                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11953         LEAVE;
11954     }
11955 #endif /* !PERL_EXTERNAL_GLOB */
11956     gv = (GV *)newSV(0);
11957     gv_init(gv, 0, "", 0, 0);
11958     gv_IOadd(gv);
11959     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11960     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11961     scalarkids(o);
11962     return o;
11963 }
11964
11965 OP *
11966 Perl_ck_grep(pTHX_ OP *o)
11967 {
11968     LOGOP *gwop;
11969     OP *kid;
11970     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11971
11972     PERL_ARGS_ASSERT_CK_GREP;
11973
11974     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11975
11976     if (o->op_flags & OPf_STACKED) {
11977         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11978         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11979             return no_fh_allowed(o);
11980         o->op_flags &= ~OPf_STACKED;
11981     }
11982     kid = OpSIBLING(cLISTOPo->op_first);
11983     if (type == OP_MAPWHILE)
11984         list(kid);
11985     else
11986         scalar(kid);
11987     o = ck_fun(o);
11988     if (PL_parser && PL_parser->error_count)
11989         return o;
11990     kid = OpSIBLING(cLISTOPo->op_first);
11991     if (kid->op_type != OP_NULL)
11992         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11993     kid = kUNOP->op_first;
11994
11995     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11996     kid->op_next = (OP*)gwop;
11997     o->op_private = gwop->op_private = 0;
11998     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11999
12000     kid = OpSIBLING(cLISTOPo->op_first);
12001     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12002         op_lvalue(kid, OP_GREPSTART);
12003
12004     return (OP*)gwop;
12005 }
12006
12007 OP *
12008 Perl_ck_index(pTHX_ OP *o)
12009 {
12010     PERL_ARGS_ASSERT_CK_INDEX;
12011
12012     if (o->op_flags & OPf_KIDS) {
12013         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
12014         if (kid)
12015             kid = OpSIBLING(kid);                       /* get past "big" */
12016         if (kid && kid->op_type == OP_CONST) {
12017             const bool save_taint = TAINT_get;
12018             SV *sv = kSVOP->op_sv;
12019             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12020                 && SvOK(sv) && !SvROK(sv))
12021             {
12022                 sv = newSV(0);
12023                 sv_copypv(sv, kSVOP->op_sv);
12024                 SvREFCNT_dec_NN(kSVOP->op_sv);
12025                 kSVOP->op_sv = sv;
12026             }
12027             if (SvOK(sv)) fbm_compile(sv, 0);
12028             TAINT_set(save_taint);
12029 #ifdef NO_TAINT_SUPPORT
12030             PERL_UNUSED_VAR(save_taint);
12031 #endif
12032         }
12033     }
12034     return ck_fun(o);
12035 }
12036
12037 OP *
12038 Perl_ck_lfun(pTHX_ OP *o)
12039 {
12040     const OPCODE type = o->op_type;
12041
12042     PERL_ARGS_ASSERT_CK_LFUN;
12043
12044     return modkids(ck_fun(o), type);
12045 }
12046
12047 OP *
12048 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
12049 {
12050     PERL_ARGS_ASSERT_CK_DEFINED;
12051
12052     if ((o->op_flags & OPf_KIDS)) {
12053         switch (cUNOPo->op_first->op_type) {
12054         case OP_RV2AV:
12055         case OP_PADAV:
12056             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12057                              " (Maybe you should just omit the defined()?)");
12058             NOT_REACHED; /* NOTREACHED */
12059             break;
12060         case OP_RV2HV:
12061         case OP_PADHV:
12062             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12063                              " (Maybe you should just omit the defined()?)");
12064             NOT_REACHED; /* NOTREACHED */
12065             break;
12066         default:
12067             /* no warning */
12068             break;
12069         }
12070     }
12071     return ck_rfun(o);
12072 }
12073
12074 OP *
12075 Perl_ck_readline(pTHX_ OP *o)
12076 {
12077     PERL_ARGS_ASSERT_CK_READLINE;
12078
12079     if (o->op_flags & OPf_KIDS) {
12080          OP *kid = cLISTOPo->op_first;
12081          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12082     }
12083     else {
12084         OP * const newop
12085             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12086         op_free(o);
12087         return newop;
12088     }
12089     return o;
12090 }
12091
12092 OP *
12093 Perl_ck_rfun(pTHX_ OP *o)
12094 {
12095     const OPCODE type = o->op_type;
12096
12097     PERL_ARGS_ASSERT_CK_RFUN;
12098
12099     return refkids(ck_fun(o), type);
12100 }
12101
12102 OP *
12103 Perl_ck_listiob(pTHX_ OP *o)
12104 {
12105     OP *kid;
12106
12107     PERL_ARGS_ASSERT_CK_LISTIOB;
12108
12109     kid = cLISTOPo->op_first;
12110     if (!kid) {
12111         o = force_list(o, 1);
12112         kid = cLISTOPo->op_first;
12113     }
12114     if (kid->op_type == OP_PUSHMARK)
12115         kid = OpSIBLING(kid);
12116     if (kid && o->op_flags & OPf_STACKED)
12117         kid = OpSIBLING(kid);
12118     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12119         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12120          && !kid->op_folded) {
12121             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12122             scalar(kid);
12123             /* replace old const op with new OP_RV2GV parent */
12124             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12125                                         OP_RV2GV, OPf_REF);
12126             kid = OpSIBLING(kid);
12127         }
12128     }
12129
12130     if (!kid)
12131         op_append_elem(o->op_type, o, newDEFSVOP());
12132
12133     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12134     return listkids(o);
12135 }
12136
12137 OP *
12138 Perl_ck_smartmatch(pTHX_ OP *o)
12139 {
12140     dVAR;
12141     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12142     if (0 == (o->op_flags & OPf_SPECIAL)) {
12143         OP *first  = cBINOPo->op_first;
12144         OP *second = OpSIBLING(first);
12145
12146         /* Implicitly take a reference to an array or hash */
12147
12148         /* remove the original two siblings, then add back the
12149          * (possibly different) first and second sibs.
12150          */
12151         op_sibling_splice(o, NULL, 1, NULL);
12152         op_sibling_splice(o, NULL, 1, NULL);
12153         first  = ref_array_or_hash(first);
12154         second = ref_array_or_hash(second);
12155         op_sibling_splice(o, NULL, 0, second);
12156         op_sibling_splice(o, NULL, 0, first);
12157
12158         /* Implicitly take a reference to a regular expression */
12159         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12160             OpTYPE_set(first, OP_QR);
12161         }
12162         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12163             OpTYPE_set(second, OP_QR);
12164         }
12165     }
12166
12167     return o;
12168 }
12169
12170
12171 static OP *
12172 S_maybe_targlex(pTHX_ OP *o)
12173 {
12174     OP * const kid = cLISTOPo->op_first;
12175     /* has a disposable target? */
12176     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12177         && !(kid->op_flags & OPf_STACKED)
12178         /* Cannot steal the second time! */
12179         && !(kid->op_private & OPpTARGET_MY)
12180         )
12181     {
12182         OP * const kkid = OpSIBLING(kid);
12183
12184         /* Can just relocate the target. */
12185         if (kkid && kkid->op_type == OP_PADSV
12186             && (!(kkid->op_private & OPpLVAL_INTRO)
12187                || kkid->op_private & OPpPAD_STATE))
12188         {
12189             kid->op_targ = kkid->op_targ;
12190             kkid->op_targ = 0;
12191             /* Now we do not need PADSV and SASSIGN.
12192              * Detach kid and free the rest. */
12193             op_sibling_splice(o, NULL, 1, NULL);
12194             op_free(o);
12195             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12196             return kid;
12197         }
12198     }
12199     return o;
12200 }
12201
12202 OP *
12203 Perl_ck_sassign(pTHX_ OP *o)
12204 {
12205     dVAR;
12206     OP * const kid = cBINOPo->op_first;
12207
12208     PERL_ARGS_ASSERT_CK_SASSIGN;
12209
12210     if (OpHAS_SIBLING(kid)) {
12211         OP *kkid = OpSIBLING(kid);
12212         /* For state variable assignment with attributes, kkid is a list op
12213            whose op_last is a padsv. */
12214         if ((kkid->op_type == OP_PADSV ||
12215              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12216               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12217              )
12218             )
12219                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12220                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12221             return S_newONCEOP(aTHX_ o, kkid);
12222         }
12223     }
12224     return S_maybe_targlex(aTHX_ o);
12225 }
12226
12227
12228 OP *
12229 Perl_ck_match(pTHX_ OP *o)
12230 {
12231     PERL_UNUSED_CONTEXT;
12232     PERL_ARGS_ASSERT_CK_MATCH;
12233
12234     return o;
12235 }
12236
12237 OP *
12238 Perl_ck_method(pTHX_ OP *o)
12239 {
12240     SV *sv, *methsv, *rclass;
12241     const char* method;
12242     char* compatptr;
12243     int utf8;
12244     STRLEN len, nsplit = 0, i;
12245     OP* new_op;
12246     OP * const kid = cUNOPo->op_first;
12247
12248     PERL_ARGS_ASSERT_CK_METHOD;
12249     if (kid->op_type != OP_CONST) return o;
12250
12251     sv = kSVOP->op_sv;
12252
12253     /* replace ' with :: */
12254     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12255                                         SvEND(sv) - SvPVX(sv) )))
12256     {
12257         *compatptr = ':';
12258         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12259     }
12260
12261     method = SvPVX_const(sv);
12262     len = SvCUR(sv);
12263     utf8 = SvUTF8(sv) ? -1 : 1;
12264
12265     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12266         nsplit = i+1;
12267         break;
12268     }
12269
12270     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12271
12272     if (!nsplit) { /* $proto->method() */
12273         op_free(o);
12274         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12275     }
12276
12277     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12278         op_free(o);
12279         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12280     }
12281
12282     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12283     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12284         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12285         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12286     } else {
12287         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12288         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12289     }
12290 #ifdef USE_ITHREADS
12291     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12292 #else
12293     cMETHOPx(new_op)->op_rclass_sv = rclass;
12294 #endif
12295     op_free(o);
12296     return new_op;
12297 }
12298
12299 OP *
12300 Perl_ck_null(pTHX_ OP *o)
12301 {
12302     PERL_ARGS_ASSERT_CK_NULL;
12303     PERL_UNUSED_CONTEXT;
12304     return o;
12305 }
12306
12307 OP *
12308 Perl_ck_open(pTHX_ OP *o)
12309 {
12310     PERL_ARGS_ASSERT_CK_OPEN;
12311
12312     S_io_hints(aTHX_ o);
12313     {
12314          /* In case of three-arg dup open remove strictness
12315           * from the last arg if it is a bareword. */
12316          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12317          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12318          OP *oa;
12319          const char *mode;
12320
12321          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12322              (last->op_private & OPpCONST_BARE) &&
12323              (last->op_private & OPpCONST_STRICT) &&
12324              (oa = OpSIBLING(first)) &&         /* The fh. */
12325              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12326              (oa->op_type == OP_CONST) &&
12327              SvPOK(((SVOP*)oa)->op_sv) &&
12328              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12329              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12330              (last == OpSIBLING(oa)))                   /* The bareword. */
12331               last->op_private &= ~OPpCONST_STRICT;
12332     }
12333     return ck_fun(o);
12334 }
12335
12336 OP *
12337 Perl_ck_prototype(pTHX_ OP *o)
12338 {
12339     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12340     if (!(o->op_flags & OPf_KIDS)) {
12341         op_free(o);
12342         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12343     }
12344     return o;
12345 }
12346
12347 OP *
12348 Perl_ck_refassign(pTHX_ OP *o)
12349 {
12350     OP * const right = cLISTOPo->op_first;
12351     OP * const left = OpSIBLING(right);
12352     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12353     bool stacked = 0;
12354
12355     PERL_ARGS_ASSERT_CK_REFASSIGN;
12356     assert (left);
12357     assert (left->op_type == OP_SREFGEN);
12358
12359     o->op_private = 0;
12360     /* we use OPpPAD_STATE in refassign to mean either of those things,
12361      * and the code assumes the two flags occupy the same bit position
12362      * in the various ops below */
12363     assert(OPpPAD_STATE == OPpOUR_INTRO);
12364
12365     switch (varop->op_type) {
12366     case OP_PADAV:
12367         o->op_private |= OPpLVREF_AV;
12368         goto settarg;
12369     case OP_PADHV:
12370         o->op_private |= OPpLVREF_HV;
12371         /* FALLTHROUGH */
12372     case OP_PADSV:
12373       settarg:
12374         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12375         o->op_targ = varop->op_targ;
12376         varop->op_targ = 0;
12377         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12378         break;
12379
12380     case OP_RV2AV:
12381         o->op_private |= OPpLVREF_AV;
12382         goto checkgv;
12383         NOT_REACHED; /* NOTREACHED */
12384     case OP_RV2HV:
12385         o->op_private |= OPpLVREF_HV;
12386         /* FALLTHROUGH */
12387     case OP_RV2SV:
12388       checkgv:
12389         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12390         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12391       detach_and_stack:
12392         /* Point varop to its GV kid, detached.  */
12393         varop = op_sibling_splice(varop, NULL, -1, NULL);
12394         stacked = TRUE;
12395         break;
12396     case OP_RV2CV: {
12397         OP * const kidparent =
12398             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12399         OP * const kid = cUNOPx(kidparent)->op_first;
12400         o->op_private |= OPpLVREF_CV;
12401         if (kid->op_type == OP_GV) {
12402             varop = kidparent;
12403             goto detach_and_stack;
12404         }
12405         if (kid->op_type != OP_PADCV)   goto bad;
12406         o->op_targ = kid->op_targ;
12407         kid->op_targ = 0;
12408         break;
12409     }
12410     case OP_AELEM:
12411     case OP_HELEM:
12412         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12413         o->op_private |= OPpLVREF_ELEM;
12414         op_null(varop);
12415         stacked = TRUE;
12416         /* Detach varop.  */
12417         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12418         break;
12419     default:
12420       bad:
12421         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12422         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12423                                 "assignment",
12424                                  OP_DESC(varop)));
12425         return o;
12426     }
12427     if (!FEATURE_REFALIASING_IS_ENABLED)
12428         Perl_croak(aTHX_
12429                   "Experimental aliasing via reference not enabled");
12430     Perl_ck_warner_d(aTHX_
12431                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12432                     "Aliasing via reference is experimental");
12433     if (stacked) {
12434         o->op_flags |= OPf_STACKED;
12435         op_sibling_splice(o, right, 1, varop);
12436     }
12437     else {
12438         o->op_flags &=~ OPf_STACKED;
12439         op_sibling_splice(o, right, 1, NULL);
12440     }
12441     op_free(left);
12442     return o;
12443 }
12444
12445 OP *
12446 Perl_ck_repeat(pTHX_ OP *o)
12447 {
12448     PERL_ARGS_ASSERT_CK_REPEAT;
12449
12450     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12451         OP* kids;
12452         o->op_private |= OPpREPEAT_DOLIST;
12453         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12454         kids = force_list(kids, 1); /* promote it to a list */
12455         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12456     }
12457     else
12458         scalar(o);
12459     return o;
12460 }
12461
12462 OP *
12463 Perl_ck_require(pTHX_ OP *o)
12464 {
12465     GV* gv;
12466
12467     PERL_ARGS_ASSERT_CK_REQUIRE;
12468
12469     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12470         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12471         U32 hash;
12472         char *s;
12473         STRLEN len;
12474         if (kid->op_type == OP_CONST) {
12475           SV * const sv = kid->op_sv;
12476           U32 const was_readonly = SvREADONLY(sv);
12477           if (kid->op_private & OPpCONST_BARE) {
12478             dVAR;
12479             const char *end;
12480             HEK *hek;
12481
12482             if (was_readonly) {
12483                     SvREADONLY_off(sv);
12484             }
12485             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12486
12487             s = SvPVX(sv);
12488             len = SvCUR(sv);
12489             end = s + len;
12490             /* treat ::foo::bar as foo::bar */
12491             if (len >= 2 && s[0] == ':' && s[1] == ':')
12492                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12493             if (s == end)
12494                 DIE(aTHX_ "Bareword in require maps to empty filename");
12495
12496             for (; s < end; s++) {
12497                 if (*s == ':' && s[1] == ':') {
12498                     *s = '/';
12499                     Move(s+2, s+1, end - s - 1, char);
12500                     --end;
12501                 }
12502             }
12503             SvEND_set(sv, end);
12504             sv_catpvs(sv, ".pm");
12505             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12506             hek = share_hek(SvPVX(sv),
12507                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12508                             hash);
12509             sv_sethek(sv, hek);
12510             unshare_hek(hek);
12511             SvFLAGS(sv) |= was_readonly;
12512           }
12513           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12514                 && !SvVOK(sv)) {
12515             s = SvPV(sv, len);
12516             if (SvREFCNT(sv) > 1) {
12517                 kid->op_sv = newSVpvn_share(
12518                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12519                 SvREFCNT_dec_NN(sv);
12520             }
12521             else {
12522                 dVAR;
12523                 HEK *hek;
12524                 if (was_readonly) SvREADONLY_off(sv);
12525                 PERL_HASH(hash, s, len);
12526                 hek = share_hek(s,
12527                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12528                                 hash);
12529                 sv_sethek(sv, hek);
12530                 unshare_hek(hek);
12531                 SvFLAGS(sv) |= was_readonly;
12532             }
12533           }
12534         }
12535     }
12536
12537     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12538         /* handle override, if any */
12539      && (gv = gv_override("require", 7))) {
12540         OP *kid, *newop;
12541         if (o->op_flags & OPf_KIDS) {
12542             kid = cUNOPo->op_first;
12543             op_sibling_splice(o, NULL, -1, NULL);
12544         }
12545         else {
12546             kid = newDEFSVOP();
12547         }
12548         op_free(o);
12549         newop = S_new_entersubop(aTHX_ gv, kid);
12550         return newop;
12551     }
12552
12553     return ck_fun(o);
12554 }
12555
12556 OP *
12557 Perl_ck_return(pTHX_ OP *o)
12558 {
12559     OP *kid;
12560
12561     PERL_ARGS_ASSERT_CK_RETURN;
12562
12563     kid = OpSIBLING(cLISTOPo->op_first);
12564     if (PL_compcv && CvLVALUE(PL_compcv)) {
12565         for (; kid; kid = OpSIBLING(kid))
12566             op_lvalue(kid, OP_LEAVESUBLV);
12567     }
12568
12569     return o;
12570 }
12571
12572 OP *
12573 Perl_ck_select(pTHX_ OP *o)
12574 {
12575     dVAR;
12576     OP* kid;
12577
12578     PERL_ARGS_ASSERT_CK_SELECT;
12579
12580     if (o->op_flags & OPf_KIDS) {
12581         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12582         if (kid && OpHAS_SIBLING(kid)) {
12583             OpTYPE_set(o, OP_SSELECT);
12584             o = ck_fun(o);
12585             return fold_constants(op_integerize(op_std_init(o)));
12586         }
12587     }
12588     o = ck_fun(o);
12589     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12590     if (kid && kid->op_type == OP_RV2GV)
12591         kid->op_private &= ~HINT_STRICT_REFS;
12592     return o;
12593 }
12594
12595 OP *
12596 Perl_ck_shift(pTHX_ OP *o)
12597 {
12598     const I32 type = o->op_type;
12599
12600     PERL_ARGS_ASSERT_CK_SHIFT;
12601
12602     if (!(o->op_flags & OPf_KIDS)) {
12603         OP *argop;
12604
12605         if (!CvUNIQUE(PL_compcv)) {
12606             o->op_flags |= OPf_SPECIAL;
12607             return o;
12608         }
12609
12610         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12611         op_free(o);
12612         return newUNOP(type, 0, scalar(argop));
12613     }
12614     return scalar(ck_fun(o));
12615 }
12616
12617 OP *
12618 Perl_ck_sort(pTHX_ OP *o)
12619 {
12620     OP *firstkid;
12621     OP *kid;
12622     HV * const hinthv =
12623         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12624     U8 stacked;
12625
12626     PERL_ARGS_ASSERT_CK_SORT;
12627
12628     if (hinthv) {
12629             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12630             if (svp) {
12631                 const I32 sorthints = (I32)SvIV(*svp);
12632                 if ((sorthints & HINT_SORT_STABLE) != 0)
12633                     o->op_private |= OPpSORT_STABLE;
12634                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12635                     o->op_private |= OPpSORT_UNSTABLE;
12636             }
12637     }
12638
12639     if (o->op_flags & OPf_STACKED)
12640         simplify_sort(o);
12641     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12642
12643     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12644         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12645
12646         /* if the first arg is a code block, process it and mark sort as
12647          * OPf_SPECIAL */
12648         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12649             LINKLIST(kid);
12650             if (kid->op_type == OP_LEAVE)
12651                     op_null(kid);                       /* wipe out leave */
12652             /* Prevent execution from escaping out of the sort block. */
12653             kid->op_next = 0;
12654
12655             /* provide scalar context for comparison function/block */
12656             kid = scalar(firstkid);
12657             kid->op_next = kid;
12658             o->op_flags |= OPf_SPECIAL;
12659         }
12660         else if (kid->op_type == OP_CONST
12661               && kid->op_private & OPpCONST_BARE) {
12662             char tmpbuf[256];
12663             STRLEN len;
12664             PADOFFSET off;
12665             const char * const name = SvPV(kSVOP_sv, len);
12666             *tmpbuf = '&';
12667             assert (len < 256);
12668             Copy(name, tmpbuf+1, len, char);
12669             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12670             if (off != NOT_IN_PAD) {
12671                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12672                     SV * const fq =
12673                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12674                     sv_catpvs(fq, "::");
12675                     sv_catsv(fq, kSVOP_sv);
12676                     SvREFCNT_dec_NN(kSVOP_sv);
12677                     kSVOP->op_sv = fq;
12678                 }
12679                 else {
12680                     OP * const padop = newOP(OP_PADCV, 0);
12681                     padop->op_targ = off;
12682                     /* replace the const op with the pad op */
12683                     op_sibling_splice(firstkid, NULL, 1, padop);
12684                     op_free(kid);
12685                 }
12686             }
12687         }
12688
12689         firstkid = OpSIBLING(firstkid);
12690     }
12691
12692     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12693         /* provide list context for arguments */
12694         list(kid);
12695         if (stacked)
12696             op_lvalue(kid, OP_GREPSTART);
12697     }
12698
12699     return o;
12700 }
12701
12702 /* for sort { X } ..., where X is one of
12703  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12704  * elide the second child of the sort (the one containing X),
12705  * and set these flags as appropriate
12706         OPpSORT_NUMERIC;
12707         OPpSORT_INTEGER;
12708         OPpSORT_DESCEND;
12709  * Also, check and warn on lexical $a, $b.
12710  */
12711
12712 STATIC void
12713 S_simplify_sort(pTHX_ OP *o)
12714 {
12715     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12716     OP *k;
12717     int descending;
12718     GV *gv;
12719     const char *gvname;
12720     bool have_scopeop;
12721
12722     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12723
12724     kid = kUNOP->op_first;                              /* get past null */
12725     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12726      && kid->op_type != OP_LEAVE)
12727         return;
12728     kid = kLISTOP->op_last;                             /* get past scope */
12729     switch(kid->op_type) {
12730         case OP_NCMP:
12731         case OP_I_NCMP:
12732         case OP_SCMP:
12733             if (!have_scopeop) goto padkids;
12734             break;
12735         default:
12736             return;
12737     }
12738     k = kid;                                            /* remember this node*/
12739     if (kBINOP->op_first->op_type != OP_RV2SV
12740      || kBINOP->op_last ->op_type != OP_RV2SV)
12741     {
12742         /*
12743            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12744            then used in a comparison.  This catches most, but not
12745            all cases.  For instance, it catches
12746                sort { my($a); $a <=> $b }
12747            but not
12748                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12749            (although why you'd do that is anyone's guess).
12750         */
12751
12752        padkids:
12753         if (!ckWARN(WARN_SYNTAX)) return;
12754         kid = kBINOP->op_first;
12755         do {
12756             if (kid->op_type == OP_PADSV) {
12757                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12758                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12759                  && (  PadnamePV(name)[1] == 'a'
12760                     || PadnamePV(name)[1] == 'b'  ))
12761                     /* diag_listed_as: "my %s" used in sort comparison */
12762                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12763                                      "\"%s %s\" used in sort comparison",
12764                                       PadnameIsSTATE(name)
12765                                         ? "state"
12766                                         : "my",
12767                                       PadnamePV(name));
12768             }
12769         } while ((kid = OpSIBLING(kid)));
12770         return;
12771     }
12772     kid = kBINOP->op_first;                             /* get past cmp */
12773     if (kUNOP->op_first->op_type != OP_GV)
12774         return;
12775     kid = kUNOP->op_first;                              /* get past rv2sv */
12776     gv = kGVOP_gv;
12777     if (GvSTASH(gv) != PL_curstash)
12778         return;
12779     gvname = GvNAME(gv);
12780     if (*gvname == 'a' && gvname[1] == '\0')
12781         descending = 0;
12782     else if (*gvname == 'b' && gvname[1] == '\0')
12783         descending = 1;
12784     else
12785         return;
12786
12787     kid = k;                                            /* back to cmp */
12788     /* already checked above that it is rv2sv */
12789     kid = kBINOP->op_last;                              /* down to 2nd arg */
12790     if (kUNOP->op_first->op_type != OP_GV)
12791         return;
12792     kid = kUNOP->op_first;                              /* get past rv2sv */
12793     gv = kGVOP_gv;
12794     if (GvSTASH(gv) != PL_curstash)
12795         return;
12796     gvname = GvNAME(gv);
12797     if ( descending
12798          ? !(*gvname == 'a' && gvname[1] == '\0')
12799          : !(*gvname == 'b' && gvname[1] == '\0'))
12800         return;
12801     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12802     if (descending)
12803         o->op_private |= OPpSORT_DESCEND;
12804     if (k->op_type == OP_NCMP)
12805         o->op_private |= OPpSORT_NUMERIC;
12806     if (k->op_type == OP_I_NCMP)
12807         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12808     kid = OpSIBLING(cLISTOPo->op_first);
12809     /* cut out and delete old block (second sibling) */
12810     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12811     op_free(kid);
12812 }
12813
12814 OP *
12815 Perl_ck_split(pTHX_ OP *o)
12816 {
12817     dVAR;
12818     OP *kid;
12819     OP *sibs;
12820
12821     PERL_ARGS_ASSERT_CK_SPLIT;
12822
12823     assert(o->op_type == OP_LIST);
12824
12825     if (o->op_flags & OPf_STACKED)
12826         return no_fh_allowed(o);
12827
12828     kid = cLISTOPo->op_first;
12829     /* delete leading NULL node, then add a CONST if no other nodes */
12830     assert(kid->op_type == OP_NULL);
12831     op_sibling_splice(o, NULL, 1,
12832         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12833     op_free(kid);
12834     kid = cLISTOPo->op_first;
12835
12836     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12837         /* remove match expression, and replace with new optree with
12838          * a match op at its head */
12839         op_sibling_splice(o, NULL, 1, NULL);
12840         /* pmruntime will handle split " " behavior with flag==2 */
12841         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12842         op_sibling_splice(o, NULL, 0, kid);
12843     }
12844
12845     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12846
12847     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12848       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12849                      "Use of /g modifier is meaningless in split");
12850     }
12851
12852     /* eliminate the split op, and move the match op (plus any children)
12853      * into its place, then convert the match op into a split op. i.e.
12854      *
12855      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12856      *    |                        |                     |
12857      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12858      *    |                        |                     |
12859      *    R                        X - Y                 X - Y
12860      *    |
12861      *    X - Y
12862      *
12863      * (R, if it exists, will be a regcomp op)
12864      */
12865
12866     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12867     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12868     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12869     OpTYPE_set(kid, OP_SPLIT);
12870     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12871     kid->op_private = o->op_private;
12872     op_free(o);
12873     o = kid;
12874     kid = sibs; /* kid is now the string arg of the split */
12875
12876     if (!kid) {
12877         kid = newDEFSVOP();
12878         op_append_elem(OP_SPLIT, o, kid);
12879     }
12880     scalar(kid);
12881
12882     kid = OpSIBLING(kid);
12883     if (!kid) {
12884         kid = newSVOP(OP_CONST, 0, newSViv(0));
12885         op_append_elem(OP_SPLIT, o, kid);
12886         o->op_private |= OPpSPLIT_IMPLIM;
12887     }
12888     scalar(kid);
12889
12890     if (OpHAS_SIBLING(kid))
12891         return too_many_arguments_pv(o,OP_DESC(o), 0);
12892
12893     return o;
12894 }
12895
12896 OP *
12897 Perl_ck_stringify(pTHX_ OP *o)
12898 {
12899     OP * const kid = OpSIBLING(cUNOPo->op_first);
12900     PERL_ARGS_ASSERT_CK_STRINGIFY;
12901     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12902          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12903          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12904         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12905     {
12906         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12907         op_free(o);
12908         return kid;
12909     }
12910     return ck_fun(o);
12911 }
12912
12913 OP *
12914 Perl_ck_join(pTHX_ OP *o)
12915 {
12916     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12917
12918     PERL_ARGS_ASSERT_CK_JOIN;
12919
12920     if (kid && kid->op_type == OP_MATCH) {
12921         if (ckWARN(WARN_SYNTAX)) {
12922             const REGEXP *re = PM_GETRE(kPMOP);
12923             const SV *msg = re
12924                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12925                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12926                     : newSVpvs_flags( "STRING", SVs_TEMP );
12927             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12928                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12929                         SVfARG(msg), SVfARG(msg));
12930         }
12931     }
12932     if (kid
12933      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12934         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12935         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12936            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12937     {
12938         const OP * const bairn = OpSIBLING(kid); /* the list */
12939         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12940          && OP_GIMME(bairn,0) == G_SCALAR)
12941         {
12942             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12943                                      op_sibling_splice(o, kid, 1, NULL));
12944             op_free(o);
12945             return ret;
12946         }
12947     }
12948
12949     return ck_fun(o);
12950 }
12951
12952 /*
12953 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12954
12955 Examines an op, which is expected to identify a subroutine at runtime,
12956 and attempts to determine at compile time which subroutine it identifies.
12957 This is normally used during Perl compilation to determine whether
12958 a prototype can be applied to a function call.  C<cvop> is the op
12959 being considered, normally an C<rv2cv> op.  A pointer to the identified
12960 subroutine is returned, if it could be determined statically, and a null
12961 pointer is returned if it was not possible to determine statically.
12962
12963 Currently, the subroutine can be identified statically if the RV that the
12964 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12965 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12966 suitable if the constant value must be an RV pointing to a CV.  Details of
12967 this process may change in future versions of Perl.  If the C<rv2cv> op
12968 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12969 the subroutine statically: this flag is used to suppress compile-time
12970 magic on a subroutine call, forcing it to use default runtime behaviour.
12971
12972 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12973 of a GV reference is modified.  If a GV was examined and its CV slot was
12974 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12975 If the op is not optimised away, and the CV slot is later populated with
12976 a subroutine having a prototype, that flag eventually triggers the warning
12977 "called too early to check prototype".
12978
12979 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12980 of returning a pointer to the subroutine it returns a pointer to the
12981 GV giving the most appropriate name for the subroutine in this context.
12982 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12983 (C<CvANON>) subroutine that is referenced through a GV it will be the
12984 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12985 A null pointer is returned as usual if there is no statically-determinable
12986 subroutine.
12987
12988 =cut
12989 */
12990
12991 /* shared by toke.c:yylex */
12992 CV *
12993 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12994 {
12995     PADNAME *name = PAD_COMPNAME(off);
12996     CV *compcv = PL_compcv;
12997     while (PadnameOUTER(name)) {
12998         assert(PARENT_PAD_INDEX(name));
12999         compcv = CvOUTSIDE(compcv);
13000         name = PadlistNAMESARRAY(CvPADLIST(compcv))
13001                 [off = PARENT_PAD_INDEX(name)];
13002     }
13003     assert(!PadnameIsOUR(name));
13004     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13005         return PadnamePROTOCV(name);
13006     }
13007     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13008 }
13009
13010 CV *
13011 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13012 {
13013     OP *rvop;
13014     CV *cv;
13015     GV *gv;
13016     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13017     if (flags & ~RV2CVOPCV_FLAG_MASK)
13018         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13019     if (cvop->op_type != OP_RV2CV)
13020         return NULL;
13021     if (cvop->op_private & OPpENTERSUB_AMPER)
13022         return NULL;
13023     if (!(cvop->op_flags & OPf_KIDS))
13024         return NULL;
13025     rvop = cUNOPx(cvop)->op_first;
13026     switch (rvop->op_type) {
13027         case OP_GV: {
13028             gv = cGVOPx_gv(rvop);
13029             if (!isGV(gv)) {
13030                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13031                     cv = MUTABLE_CV(SvRV(gv));
13032                     gv = NULL;
13033                     break;
13034                 }
13035                 if (flags & RV2CVOPCV_RETURN_STUB)
13036                     return (CV *)gv;
13037                 else return NULL;
13038             }
13039             cv = GvCVu(gv);
13040             if (!cv) {
13041                 if (flags & RV2CVOPCV_MARK_EARLY)
13042                     rvop->op_private |= OPpEARLY_CV;
13043                 return NULL;
13044             }
13045         } break;
13046         case OP_CONST: {
13047             SV *rv = cSVOPx_sv(rvop);
13048             if (!SvROK(rv))
13049                 return NULL;
13050             cv = (CV*)SvRV(rv);
13051             gv = NULL;
13052         } break;
13053         case OP_PADCV: {
13054             cv = find_lexical_cv(rvop->op_targ);
13055             gv = NULL;
13056         } break;
13057         default: {
13058             return NULL;
13059         } NOT_REACHED; /* NOTREACHED */
13060     }
13061     if (SvTYPE((SV*)cv) != SVt_PVCV)
13062         return NULL;
13063     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13064         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13065             gv = CvGV(cv);
13066         return (CV*)gv;
13067     }
13068     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13069         if (CvLEXICAL(cv) || CvNAMED(cv))
13070             return NULL;
13071         if (!CvANON(cv) || !gv)
13072             gv = CvGV(cv);
13073         return (CV*)gv;
13074
13075     } else {
13076         return cv;
13077     }
13078 }
13079
13080 /*
13081 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13082
13083 Performs the default fixup of the arguments part of an C<entersub>
13084 op tree.  This consists of applying list context to each of the
13085 argument ops.  This is the standard treatment used on a call marked
13086 with C<&>, or a method call, or a call through a subroutine reference,
13087 or any other call where the callee can't be identified at compile time,
13088 or a call where the callee has no prototype.
13089
13090 =cut
13091 */
13092
13093 OP *
13094 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13095 {
13096     OP *aop;
13097
13098     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13099
13100     aop = cUNOPx(entersubop)->op_first;
13101     if (!OpHAS_SIBLING(aop))
13102         aop = cUNOPx(aop)->op_first;
13103     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13104         /* skip the extra attributes->import() call implicitly added in
13105          * something like foo(my $x : bar)
13106          */
13107         if (   aop->op_type == OP_ENTERSUB
13108             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13109         )
13110             continue;
13111         list(aop);
13112         op_lvalue(aop, OP_ENTERSUB);
13113     }
13114     return entersubop;
13115 }
13116
13117 /*
13118 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13119
13120 Performs the fixup of the arguments part of an C<entersub> op tree
13121 based on a subroutine prototype.  This makes various modifications to
13122 the argument ops, from applying context up to inserting C<refgen> ops,
13123 and checking the number and syntactic types of arguments, as directed by
13124 the prototype.  This is the standard treatment used on a subroutine call,
13125 not marked with C<&>, where the callee can be identified at compile time
13126 and has a prototype.
13127
13128 C<protosv> supplies the subroutine prototype to be applied to the call.
13129 It may be a normal defined scalar, of which the string value will be used.
13130 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13131 that has been cast to C<SV*>) which has a prototype.  The prototype
13132 supplied, in whichever form, does not need to match the actual callee
13133 referenced by the op tree.
13134
13135 If the argument ops disagree with the prototype, for example by having
13136 an unacceptable number of arguments, a valid op tree is returned anyway.
13137 The error is reflected in the parser state, normally resulting in a single
13138 exception at the top level of parsing which covers all the compilation
13139 errors that occurred.  In the error message, the callee is referred to
13140 by the name defined by the C<namegv> parameter.
13141
13142 =cut
13143 */
13144
13145 OP *
13146 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13147 {
13148     STRLEN proto_len;
13149     const char *proto, *proto_end;
13150     OP *aop, *prev, *cvop, *parent;
13151     int optional = 0;
13152     I32 arg = 0;
13153     I32 contextclass = 0;
13154     const char *e = NULL;
13155     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13156     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13157         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13158                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13159     if (SvTYPE(protosv) == SVt_PVCV)
13160          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13161     else proto = SvPV(protosv, proto_len);
13162     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13163     proto_end = proto + proto_len;
13164     parent = entersubop;
13165     aop = cUNOPx(entersubop)->op_first;
13166     if (!OpHAS_SIBLING(aop)) {
13167         parent = aop;
13168         aop = cUNOPx(aop)->op_first;
13169     }
13170     prev = aop;
13171     aop = OpSIBLING(aop);
13172     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13173     while (aop != cvop) {
13174         OP* o3 = aop;
13175
13176         if (proto >= proto_end)
13177         {
13178             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13179             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13180                                         SVfARG(namesv)), SvUTF8(namesv));
13181             return entersubop;
13182         }
13183
13184         switch (*proto) {
13185             case ';':
13186                 optional = 1;
13187                 proto++;
13188                 continue;
13189             case '_':
13190                 /* _ must be at the end */
13191                 if (proto[1] && !strchr(";@%", proto[1]))
13192                     goto oops;
13193                 /* FALLTHROUGH */
13194             case '$':
13195                 proto++;
13196                 arg++;
13197                 scalar(aop);
13198                 break;
13199             case '%':
13200             case '@':
13201                 list(aop);
13202                 arg++;
13203                 break;
13204             case '&':
13205                 proto++;
13206                 arg++;
13207                 if (    o3->op_type != OP_UNDEF
13208                     && (o3->op_type != OP_SREFGEN
13209                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13210                                 != OP_ANONCODE
13211                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13212                                 != OP_RV2CV)))
13213                     bad_type_gv(arg, namegv, o3,
13214                             arg == 1 ? "block or sub {}" : "sub {}");
13215                 break;
13216             case '*':
13217                 /* '*' allows any scalar type, including bareword */
13218                 proto++;
13219                 arg++;
13220                 if (o3->op_type == OP_RV2GV)
13221                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13222                 else if (o3->op_type == OP_CONST)
13223                     o3->op_private &= ~OPpCONST_STRICT;
13224                 scalar(aop);
13225                 break;
13226             case '+':
13227                 proto++;
13228                 arg++;
13229                 if (o3->op_type == OP_RV2AV ||
13230                     o3->op_type == OP_PADAV ||
13231                     o3->op_type == OP_RV2HV ||
13232                     o3->op_type == OP_PADHV
13233                 ) {
13234                     goto wrapref;
13235                 }
13236                 scalar(aop);
13237                 break;
13238             case '[': case ']':
13239                 goto oops;
13240
13241             case '\\':
13242                 proto++;
13243                 arg++;
13244             again:
13245                 switch (*proto++) {
13246                     case '[':
13247                         if (contextclass++ == 0) {
13248                             e = (char *) memchr(proto, ']', proto_end - proto);
13249                             if (!e || e == proto)
13250                                 goto oops;
13251                         }
13252                         else
13253                             goto oops;
13254                         goto again;
13255
13256                     case ']':
13257                         if (contextclass) {
13258                             const char *p = proto;
13259                             const char *const end = proto;
13260                             contextclass = 0;
13261                             while (*--p != '[')
13262                                 /* \[$] accepts any scalar lvalue */
13263                                 if (*p == '$'
13264                                  && Perl_op_lvalue_flags(aTHX_
13265                                      scalar(o3),
13266                                      OP_READ, /* not entersub */
13267                                      OP_LVALUE_NO_CROAK
13268                                     )) goto wrapref;
13269                             bad_type_gv(arg, namegv, o3,
13270                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13271                         } else
13272                             goto oops;
13273                         break;
13274                     case '*':
13275                         if (o3->op_type == OP_RV2GV)
13276                             goto wrapref;
13277                         if (!contextclass)
13278                             bad_type_gv(arg, namegv, o3, "symbol");
13279                         break;
13280                     case '&':
13281                         if (o3->op_type == OP_ENTERSUB
13282                          && !(o3->op_flags & OPf_STACKED))
13283                             goto wrapref;
13284                         if (!contextclass)
13285                             bad_type_gv(arg, namegv, o3, "subroutine");
13286                         break;
13287                     case '$':
13288                         if (o3->op_type == OP_RV2SV ||
13289                                 o3->op_type == OP_PADSV ||
13290                                 o3->op_type == OP_HELEM ||
13291                                 o3->op_type == OP_AELEM)
13292                             goto wrapref;
13293                         if (!contextclass) {
13294                             /* \$ accepts any scalar lvalue */
13295                             if (Perl_op_lvalue_flags(aTHX_
13296                                     scalar(o3),
13297                                     OP_READ,  /* not entersub */
13298                                     OP_LVALUE_NO_CROAK
13299                                )) goto wrapref;
13300                             bad_type_gv(arg, namegv, o3, "scalar");
13301                         }
13302                         break;
13303                     case '@':
13304                         if (o3->op_type == OP_RV2AV ||
13305                                 o3->op_type == OP_PADAV)
13306                         {
13307                             o3->op_flags &=~ OPf_PARENS;
13308                             goto wrapref;
13309                         }
13310                         if (!contextclass)
13311                             bad_type_gv(arg, namegv, o3, "array");
13312                         break;
13313                     case '%':
13314                         if (o3->op_type == OP_RV2HV ||
13315                                 o3->op_type == OP_PADHV)
13316                         {
13317                             o3->op_flags &=~ OPf_PARENS;
13318                             goto wrapref;
13319                         }
13320                         if (!contextclass)
13321                             bad_type_gv(arg, namegv, o3, "hash");
13322                         break;
13323                     wrapref:
13324                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13325                                                 OP_REFGEN, 0);
13326                         if (contextclass && e) {
13327                             proto = e + 1;
13328                             contextclass = 0;
13329                         }
13330                         break;
13331                     default: goto oops;
13332                 }
13333                 if (contextclass)
13334                     goto again;
13335                 break;
13336             case ' ':
13337                 proto++;
13338                 continue;
13339             default:
13340             oops: {
13341                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13342                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13343                                   SVfARG(protosv));
13344             }
13345         }
13346
13347         op_lvalue(aop, OP_ENTERSUB);
13348         prev = aop;
13349         aop = OpSIBLING(aop);
13350     }
13351     if (aop == cvop && *proto == '_') {
13352         /* generate an access to $_ */
13353         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13354     }
13355     if (!optional && proto_end > proto &&
13356         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13357     {
13358         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13359         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13360                                     SVfARG(namesv)), SvUTF8(namesv));
13361     }
13362     return entersubop;
13363 }
13364
13365 /*
13366 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13367
13368 Performs the fixup of the arguments part of an C<entersub> op tree either
13369 based on a subroutine prototype or using default list-context processing.
13370 This is the standard treatment used on a subroutine call, not marked
13371 with C<&>, where the callee can be identified at compile time.
13372
13373 C<protosv> supplies the subroutine prototype to be applied to the call,
13374 or indicates that there is no prototype.  It may be a normal scalar,
13375 in which case if it is defined then the string value will be used
13376 as a prototype, and if it is undefined then there is no prototype.
13377 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13378 that has been cast to C<SV*>), of which the prototype will be used if it
13379 has one.  The prototype (or lack thereof) supplied, in whichever form,
13380 does not need to match the actual callee referenced by the op tree.
13381
13382 If the argument ops disagree with the prototype, for example by having
13383 an unacceptable number of arguments, a valid op tree is returned anyway.
13384 The error is reflected in the parser state, normally resulting in a single
13385 exception at the top level of parsing which covers all the compilation
13386 errors that occurred.  In the error message, the callee is referred to
13387 by the name defined by the C<namegv> parameter.
13388
13389 =cut
13390 */
13391
13392 OP *
13393 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13394         GV *namegv, SV *protosv)
13395 {
13396     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13397     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13398         return ck_entersub_args_proto(entersubop, namegv, protosv);
13399     else
13400         return ck_entersub_args_list(entersubop);
13401 }
13402
13403 OP *
13404 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13405 {
13406     IV cvflags = SvIVX(protosv);
13407     int opnum = cvflags & 0xffff;
13408     OP *aop = cUNOPx(entersubop)->op_first;
13409
13410     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13411
13412     if (!opnum) {
13413         OP *cvop;
13414         if (!OpHAS_SIBLING(aop))
13415             aop = cUNOPx(aop)->op_first;
13416         aop = OpSIBLING(aop);
13417         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13418         if (aop != cvop) {
13419             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13420             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13421                 SVfARG(namesv)), SvUTF8(namesv));
13422         }
13423
13424         op_free(entersubop);
13425         switch(cvflags >> 16) {
13426         case 'F': return newSVOP(OP_CONST, 0,
13427                                         newSVpv(CopFILE(PL_curcop),0));
13428         case 'L': return newSVOP(
13429                            OP_CONST, 0,
13430                            Perl_newSVpvf(aTHX_
13431                              "%" IVdf, (IV)CopLINE(PL_curcop)
13432                            )
13433                          );
13434         case 'P': return newSVOP(OP_CONST, 0,
13435                                    (PL_curstash
13436                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13437                                      : &PL_sv_undef
13438                                    )
13439                                 );
13440         }
13441         NOT_REACHED; /* NOTREACHED */
13442     }
13443     else {
13444         OP *prev, *cvop, *first, *parent;
13445         U32 flags = 0;
13446
13447         parent = entersubop;
13448         if (!OpHAS_SIBLING(aop)) {
13449             parent = aop;
13450             aop = cUNOPx(aop)->op_first;
13451         }
13452
13453         first = prev = aop;
13454         aop = OpSIBLING(aop);
13455         /* find last sibling */
13456         for (cvop = aop;
13457              OpHAS_SIBLING(cvop);
13458              prev = cvop, cvop = OpSIBLING(cvop))
13459             ;
13460         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13461             /* Usually, OPf_SPECIAL on an op with no args means that it had
13462              * parens, but these have their own meaning for that flag: */
13463             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13464             && opnum != OP_DELETE && opnum != OP_EXISTS)
13465                 flags |= OPf_SPECIAL;
13466         /* excise cvop from end of sibling chain */
13467         op_sibling_splice(parent, prev, 1, NULL);
13468         op_free(cvop);
13469         if (aop == cvop) aop = NULL;
13470
13471         /* detach remaining siblings from the first sibling, then
13472          * dispose of original optree */
13473
13474         if (aop)
13475             op_sibling_splice(parent, first, -1, NULL);
13476         op_free(entersubop);
13477
13478         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13479             flags |= OPpEVAL_BYTES <<8;
13480
13481         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13482         case OA_UNOP:
13483         case OA_BASEOP_OR_UNOP:
13484         case OA_FILESTATOP:
13485             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13486         case OA_BASEOP:
13487             if (aop) {
13488                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13489                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13490                     SVfARG(namesv)), SvUTF8(namesv));
13491                 op_free(aop);
13492             }
13493             return opnum == OP_RUNCV
13494                 ? newPVOP(OP_RUNCV,0,NULL)
13495                 : newOP(opnum,0);
13496         default:
13497             return op_convert_list(opnum,0,aop);
13498         }
13499     }
13500     NOT_REACHED; /* NOTREACHED */
13501     return entersubop;
13502 }
13503
13504 /*
13505 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13506
13507 Retrieves the function that will be used to fix up a call to C<cv>.
13508 Specifically, the function is applied to an C<entersub> op tree for a
13509 subroutine call, not marked with C<&>, where the callee can be identified
13510 at compile time as C<cv>.
13511
13512 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13513 for it is returned in C<*ckobj_p>, and control flags are returned in
13514 C<*ckflags_p>.  The function is intended to be called in this manner:
13515
13516  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13517
13518 In this call, C<entersubop> is a pointer to the C<entersub> op,
13519 which may be replaced by the check function, and C<namegv> supplies
13520 the name that should be used by the check function to refer
13521 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13522 It is permitted to apply the check function in non-standard situations,
13523 such as to a call to a different subroutine or to a method call.
13524
13525 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13526 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13527 instead, anything that can be used as the first argument to L</cv_name>.
13528 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13529 check function requires C<namegv> to be a genuine GV.
13530
13531 By default, the check function is
13532 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13533 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13534 flag is clear.  This implements standard prototype processing.  It can
13535 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13536
13537 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13538 indicates that the caller only knows about the genuine GV version of
13539 C<namegv>, and accordingly the corresponding bit will always be set in
13540 C<*ckflags_p>, regardless of the check function's recorded requirements.
13541 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13542 indicates the caller knows about the possibility of passing something
13543 other than a GV as C<namegv>, and accordingly the corresponding bit may
13544 be either set or clear in C<*ckflags_p>, indicating the check function's
13545 recorded requirements.
13546
13547 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13548 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13549 (for which see above).  All other bits should be clear.
13550
13551 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13552
13553 The original form of L</cv_get_call_checker_flags>, which does not return
13554 checker flags.  When using a checker function returned by this function,
13555 it is only safe to call it with a genuine GV as its C<namegv> argument.
13556
13557 =cut
13558 */
13559
13560 void
13561 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13562         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13563 {
13564     MAGIC *callmg;
13565     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13566     PERL_UNUSED_CONTEXT;
13567     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13568     if (callmg) {
13569         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13570         *ckobj_p = callmg->mg_obj;
13571         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13572     } else {
13573         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13574         *ckobj_p = (SV*)cv;
13575         *ckflags_p = gflags & MGf_REQUIRE_GV;
13576     }
13577 }
13578
13579 void
13580 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13581 {
13582     U32 ckflags;
13583     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13584     PERL_UNUSED_CONTEXT;
13585     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13586         &ckflags);
13587 }
13588
13589 /*
13590 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13591
13592 Sets the function that will be used to fix up a call to C<cv>.
13593 Specifically, the function is applied to an C<entersub> op tree for a
13594 subroutine call, not marked with C<&>, where the callee can be identified
13595 at compile time as C<cv>.
13596
13597 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13598 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13599 The function should be defined like this:
13600
13601     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13602
13603 It is intended to be called in this manner:
13604
13605     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13606
13607 In this call, C<entersubop> is a pointer to the C<entersub> op,
13608 which may be replaced by the check function, and C<namegv> supplies
13609 the name that should be used by the check function to refer
13610 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13611 It is permitted to apply the check function in non-standard situations,
13612 such as to a call to a different subroutine or to a method call.
13613
13614 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13615 CV or other SV instead.  Whatever is passed can be used as the first
13616 argument to L</cv_name>.  You can force perl to pass a GV by including
13617 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13618
13619 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13620 bit currently has a defined meaning (for which see above).  All other
13621 bits should be clear.
13622
13623 The current setting for a particular CV can be retrieved by
13624 L</cv_get_call_checker_flags>.
13625
13626 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13627
13628 The original form of L</cv_set_call_checker_flags>, which passes it the
13629 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13630 of that flag setting is that the check function is guaranteed to get a
13631 genuine GV as its C<namegv> argument.
13632
13633 =cut
13634 */
13635
13636 void
13637 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13638 {
13639     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13640     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13641 }
13642
13643 void
13644 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13645                                      SV *ckobj, U32 ckflags)
13646 {
13647     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13648     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13649         if (SvMAGICAL((SV*)cv))
13650             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13651     } else {
13652         MAGIC *callmg;
13653         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13654         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13655         assert(callmg);
13656         if (callmg->mg_flags & MGf_REFCOUNTED) {
13657             SvREFCNT_dec(callmg->mg_obj);
13658             callmg->mg_flags &= ~MGf_REFCOUNTED;
13659         }
13660         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13661         callmg->mg_obj = ckobj;
13662         if (ckobj != (SV*)cv) {
13663             SvREFCNT_inc_simple_void_NN(ckobj);
13664             callmg->mg_flags |= MGf_REFCOUNTED;
13665         }
13666         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13667                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13668     }
13669 }
13670
13671 static void
13672 S_entersub_alloc_targ(pTHX_ OP * const o)
13673 {
13674     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13675     o->op_private |= OPpENTERSUB_HASTARG;
13676 }
13677
13678 OP *
13679 Perl_ck_subr(pTHX_ OP *o)
13680 {
13681     OP *aop, *cvop;
13682     CV *cv;
13683     GV *namegv;
13684     SV **const_class = NULL;
13685
13686     PERL_ARGS_ASSERT_CK_SUBR;
13687
13688     aop = cUNOPx(o)->op_first;
13689     if (!OpHAS_SIBLING(aop))
13690         aop = cUNOPx(aop)->op_first;
13691     aop = OpSIBLING(aop);
13692     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13693     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13694     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13695
13696     o->op_private &= ~1;
13697     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13698     if (PERLDB_SUB && PL_curstash != PL_debstash)
13699         o->op_private |= OPpENTERSUB_DB;
13700     switch (cvop->op_type) {
13701         case OP_RV2CV:
13702             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13703             op_null(cvop);
13704             break;
13705         case OP_METHOD:
13706         case OP_METHOD_NAMED:
13707         case OP_METHOD_SUPER:
13708         case OP_METHOD_REDIR:
13709         case OP_METHOD_REDIR_SUPER:
13710             o->op_flags |= OPf_REF;
13711             if (aop->op_type == OP_CONST) {
13712                 aop->op_private &= ~OPpCONST_STRICT;
13713                 const_class = &cSVOPx(aop)->op_sv;
13714             }
13715             else if (aop->op_type == OP_LIST) {
13716                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13717                 if (sib && sib->op_type == OP_CONST) {
13718                     sib->op_private &= ~OPpCONST_STRICT;
13719                     const_class = &cSVOPx(sib)->op_sv;
13720                 }
13721             }
13722             /* make class name a shared cow string to speedup method calls */
13723             /* constant string might be replaced with object, f.e. bigint */
13724             if (const_class && SvPOK(*const_class)) {
13725                 STRLEN len;
13726                 const char* str = SvPV(*const_class, len);
13727                 if (len) {
13728                     SV* const shared = newSVpvn_share(
13729                         str, SvUTF8(*const_class)
13730                                     ? -(SSize_t)len : (SSize_t)len,
13731                         0
13732                     );
13733                     if (SvREADONLY(*const_class))
13734                         SvREADONLY_on(shared);
13735                     SvREFCNT_dec(*const_class);
13736                     *const_class = shared;
13737                 }
13738             }
13739             break;
13740     }
13741
13742     if (!cv) {
13743         S_entersub_alloc_targ(aTHX_ o);
13744         return ck_entersub_args_list(o);
13745     } else {
13746         Perl_call_checker ckfun;
13747         SV *ckobj;
13748         U32 ckflags;
13749         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13750         if (CvISXSUB(cv) || !CvROOT(cv))
13751             S_entersub_alloc_targ(aTHX_ o);
13752         if (!namegv) {
13753             /* The original call checker API guarantees that a GV will be
13754                be provided with the right name.  So, if the old API was
13755                used (or the REQUIRE_GV flag was passed), we have to reify
13756                the CV’s GV, unless this is an anonymous sub.  This is not
13757                ideal for lexical subs, as its stringification will include
13758                the package.  But it is the best we can do.  */
13759             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13760                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13761                     namegv = CvGV(cv);
13762             }
13763             else namegv = MUTABLE_GV(cv);
13764             /* After a syntax error in a lexical sub, the cv that
13765                rv2cv_op_cv returns may be a nameless stub. */
13766             if (!namegv) return ck_entersub_args_list(o);
13767
13768         }
13769         return ckfun(aTHX_ o, namegv, ckobj);
13770     }
13771 }
13772
13773 OP *
13774 Perl_ck_svconst(pTHX_ OP *o)
13775 {
13776     SV * const sv = cSVOPo->op_sv;
13777     PERL_ARGS_ASSERT_CK_SVCONST;
13778     PERL_UNUSED_CONTEXT;
13779 #ifdef PERL_COPY_ON_WRITE
13780     /* Since the read-only flag may be used to protect a string buffer, we
13781        cannot do copy-on-write with existing read-only scalars that are not
13782        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13783        that constant, mark the constant as COWable here, if it is not
13784        already read-only. */
13785     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13786         SvIsCOW_on(sv);
13787         CowREFCNT(sv) = 0;
13788 # ifdef PERL_DEBUG_READONLY_COW
13789         sv_buf_to_ro(sv);
13790 # endif
13791     }
13792 #endif
13793     SvREADONLY_on(sv);
13794     return o;
13795 }
13796
13797 OP *
13798 Perl_ck_trunc(pTHX_ OP *o)
13799 {
13800     PERL_ARGS_ASSERT_CK_TRUNC;
13801
13802     if (o->op_flags & OPf_KIDS) {
13803         SVOP *kid = (SVOP*)cUNOPo->op_first;
13804
13805         if (kid->op_type == OP_NULL)
13806             kid = (SVOP*)OpSIBLING(kid);
13807         if (kid && kid->op_type == OP_CONST &&
13808             (kid->op_private & OPpCONST_BARE) &&
13809             !kid->op_folded)
13810         {
13811             o->op_flags |= OPf_SPECIAL;
13812             kid->op_private &= ~OPpCONST_STRICT;
13813         }
13814     }
13815     return ck_fun(o);
13816 }
13817
13818 OP *
13819 Perl_ck_substr(pTHX_ OP *o)
13820 {
13821     PERL_ARGS_ASSERT_CK_SUBSTR;
13822
13823     o = ck_fun(o);
13824     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13825         OP *kid = cLISTOPo->op_first;
13826
13827         if (kid->op_type == OP_NULL)
13828             kid = OpSIBLING(kid);
13829         if (kid)
13830             /* Historically, substr(delete $foo{bar},...) has been allowed
13831                with 4-arg substr.  Keep it working by applying entersub
13832                lvalue context.  */
13833             op_lvalue(kid, OP_ENTERSUB);
13834
13835     }
13836     return o;
13837 }
13838
13839 OP *
13840 Perl_ck_tell(pTHX_ OP *o)
13841 {
13842     PERL_ARGS_ASSERT_CK_TELL;
13843     o = ck_fun(o);
13844     if (o->op_flags & OPf_KIDS) {
13845      OP *kid = cLISTOPo->op_first;
13846      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13847      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13848     }
13849     return o;
13850 }
13851
13852 OP *
13853 Perl_ck_each(pTHX_ OP *o)
13854 {
13855     dVAR;
13856     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13857     const unsigned orig_type  = o->op_type;
13858
13859     PERL_ARGS_ASSERT_CK_EACH;
13860
13861     if (kid) {
13862         switch (kid->op_type) {
13863             case OP_PADHV:
13864             case OP_RV2HV:
13865                 break;
13866             case OP_PADAV:
13867             case OP_RV2AV:
13868                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13869                             : orig_type == OP_KEYS ? OP_AKEYS
13870                             :                        OP_AVALUES);
13871                 break;
13872             case OP_CONST:
13873                 if (kid->op_private == OPpCONST_BARE
13874                  || !SvROK(cSVOPx_sv(kid))
13875                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13876                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13877                    )
13878                     goto bad;
13879                 /* FALLTHROUGH */
13880             default:
13881                 qerror(Perl_mess(aTHX_
13882                     "Experimental %s on scalar is now forbidden",
13883                      PL_op_desc[orig_type]));
13884                bad:
13885                 bad_type_pv(1, "hash or array", o, kid);
13886                 return o;
13887         }
13888     }
13889     return ck_fun(o);
13890 }
13891
13892 OP *
13893 Perl_ck_length(pTHX_ OP *o)
13894 {
13895     PERL_ARGS_ASSERT_CK_LENGTH;
13896
13897     o = ck_fun(o);
13898
13899     if (ckWARN(WARN_SYNTAX)) {
13900         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13901
13902         if (kid) {
13903             SV *name = NULL;
13904             const bool hash = kid->op_type == OP_PADHV
13905                            || kid->op_type == OP_RV2HV;
13906             switch (kid->op_type) {
13907                 case OP_PADHV:
13908                 case OP_PADAV:
13909                 case OP_RV2HV:
13910                 case OP_RV2AV:
13911                     name = S_op_varname(aTHX_ kid);
13912                     break;
13913                 default:
13914                     return o;
13915             }
13916             if (name)
13917                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13918                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13919                     ")\"?)",
13920                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13921                 );
13922             else if (hash)
13923      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13924                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13925                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13926             else
13927      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13928                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13929                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13930         }
13931     }
13932
13933     return o;
13934 }
13935
13936
13937
13938 /*
13939    ---------------------------------------------------------
13940
13941    Common vars in list assignment
13942
13943    There now follows some enums and static functions for detecting
13944    common variables in list assignments. Here is a little essay I wrote
13945    for myself when trying to get my head around this. DAPM.
13946
13947    ----
13948
13949    First some random observations:
13950
13951    * If a lexical var is an alias of something else, e.g.
13952        for my $x ($lex, $pkg, $a[0]) {...}
13953      then the act of aliasing will increase the reference count of the SV
13954
13955    * If a package var is an alias of something else, it may still have a
13956      reference count of 1, depending on how the alias was created, e.g.
13957      in *a = *b, $a may have a refcount of 1 since the GP is shared
13958      with a single GvSV pointer to the SV. So If it's an alias of another
13959      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13960      a lexical var or an array element, then it will have RC > 1.
13961
13962    * There are many ways to create a package alias; ultimately, XS code
13963      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13964      run-time tracing mechanisms are unlikely to be able to catch all cases.
13965
13966    * When the LHS is all my declarations, the same vars can't appear directly
13967      on the RHS, but they can indirectly via closures, aliasing and lvalue
13968      subs. But those techniques all involve an increase in the lexical
13969      scalar's ref count.
13970
13971    * When the LHS is all lexical vars (but not necessarily my declarations),
13972      it is possible for the same lexicals to appear directly on the RHS, and
13973      without an increased ref count, since the stack isn't refcounted.
13974      This case can be detected at compile time by scanning for common lex
13975      vars with PL_generation.
13976
13977    * lvalue subs defeat common var detection, but they do at least
13978      return vars with a temporary ref count increment. Also, you can't
13979      tell at compile time whether a sub call is lvalue.
13980
13981
13982    So...
13983
13984    A: There are a few circumstances where there definitely can't be any
13985      commonality:
13986
13987        LHS empty:  () = (...);
13988        RHS empty:  (....) = ();
13989        RHS contains only constants or other 'can't possibly be shared'
13990            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13991            i.e. they only contain ops not marked as dangerous, whose children
13992            are also not dangerous;
13993        LHS ditto;
13994        LHS contains a single scalar element: e.g. ($x) = (....); because
13995            after $x has been modified, it won't be used again on the RHS;
13996        RHS contains a single element with no aggregate on LHS: e.g.
13997            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13998            won't be used again.
13999
14000    B: If LHS are all 'my' lexical var declarations (or safe ops, which
14001      we can ignore):
14002
14003        my ($a, $b, @c) = ...;
14004
14005        Due to closure and goto tricks, these vars may already have content.
14006        For the same reason, an element on the RHS may be a lexical or package
14007        alias of one of the vars on the left, or share common elements, for
14008        example:
14009
14010            my ($x,$y) = f(); # $x and $y on both sides
14011            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14012
14013        and
14014
14015            my $ra = f();
14016            my @a = @$ra;  # elements of @a on both sides
14017            sub f { @a = 1..4; \@a }
14018
14019
14020        First, just consider scalar vars on LHS:
14021
14022            RHS is safe only if (A), or in addition,
14023                * contains only lexical *scalar* vars, where neither side's
14024                  lexicals have been flagged as aliases
14025
14026            If RHS is not safe, then it's always legal to check LHS vars for
14027            RC==1, since the only RHS aliases will always be associated
14028            with an RC bump.
14029
14030            Note that in particular, RHS is not safe if:
14031
14032                * it contains package scalar vars; e.g.:
14033
14034                    f();
14035                    my ($x, $y) = (2, $x_alias);
14036                    sub f { $x = 1; *x_alias = \$x; }
14037
14038                * It contains other general elements, such as flattened or
14039                * spliced or single array or hash elements, e.g.
14040
14041                    f();
14042                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14043
14044                    sub f {
14045                        ($x, $y) = (1,2);
14046                        use feature 'refaliasing';
14047                        \($a[0], $a[1]) = \($y,$x);
14048                    }
14049
14050                  It doesn't matter if the array/hash is lexical or package.
14051
14052                * it contains a function call that happens to be an lvalue
14053                  sub which returns one or more of the above, e.g.
14054
14055                    f();
14056                    my ($x,$y) = f();
14057
14058                    sub f : lvalue {
14059                        ($x, $y) = (1,2);
14060                        *x1 = \$x;
14061                        $y, $x1;
14062                    }
14063
14064                    (so a sub call on the RHS should be treated the same
14065                    as having a package var on the RHS).
14066
14067                * any other "dangerous" thing, such an op or built-in that
14068                  returns one of the above, e.g. pp_preinc
14069
14070
14071            If RHS is not safe, what we can do however is at compile time flag
14072            that the LHS are all my declarations, and at run time check whether
14073            all the LHS have RC == 1, and if so skip the full scan.
14074
14075        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14076
14077            Here the issue is whether there can be elements of @a on the RHS
14078            which will get prematurely freed when @a is cleared prior to
14079            assignment. This is only a problem if the aliasing mechanism
14080            is one which doesn't increase the refcount - only if RC == 1
14081            will the RHS element be prematurely freed.
14082
14083            Because the array/hash is being INTROed, it or its elements
14084            can't directly appear on the RHS:
14085
14086                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14087
14088            but can indirectly, e.g.:
14089
14090                my $r = f();
14091                my (@a) = @$r;
14092                sub f { @a = 1..3; \@a }
14093
14094            So if the RHS isn't safe as defined by (A), we must always
14095            mortalise and bump the ref count of any remaining RHS elements
14096            when assigning to a non-empty LHS aggregate.
14097
14098            Lexical scalars on the RHS aren't safe if they've been involved in
14099            aliasing, e.g.
14100
14101                use feature 'refaliasing';
14102
14103                f();
14104                \(my $lex) = \$pkg;
14105                my @a = ($lex,3); # equivalent to ($a[0],3)
14106
14107                sub f {
14108                    @a = (1,2);
14109                    \$pkg = \$a[0];
14110                }
14111
14112            Similarly with lexical arrays and hashes on the RHS:
14113
14114                f();
14115                my @b;
14116                my @a = (@b);
14117
14118                sub f {
14119                    @a = (1,2);
14120                    \$b[0] = \$a[1];
14121                    \$b[1] = \$a[0];
14122                }
14123
14124
14125
14126    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14127        my $a; ($a, my $b) = (....);
14128
14129        The difference between (B) and (C) is that it is now physically
14130        possible for the LHS vars to appear on the RHS too, where they
14131        are not reference counted; but in this case, the compile-time
14132        PL_generation sweep will detect such common vars.
14133
14134        So the rules for (C) differ from (B) in that if common vars are
14135        detected, the runtime "test RC==1" optimisation can no longer be used,
14136        and a full mark and sweep is required
14137
14138    D: As (C), but in addition the LHS may contain package vars.
14139
14140        Since package vars can be aliased without a corresponding refcount
14141        increase, all bets are off. It's only safe if (A). E.g.
14142
14143            my ($x, $y) = (1,2);
14144
14145            for $x_alias ($x) {
14146                ($x_alias, $y) = (3, $x); # whoops
14147            }
14148
14149        Ditto for LHS aggregate package vars.
14150
14151    E: Any other dangerous ops on LHS, e.g.
14152            (f(), $a[0], @$r) = (...);
14153
14154        this is similar to (E) in that all bets are off. In addition, it's
14155        impossible to determine at compile time whether the LHS
14156        contains a scalar or an aggregate, e.g.
14157
14158            sub f : lvalue { @a }
14159            (f()) = 1..3;
14160
14161 * ---------------------------------------------------------
14162 */
14163
14164
14165 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14166  * that at least one of the things flagged was seen.
14167  */
14168
14169 enum {
14170     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14171     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14172     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14173     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14174     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14175     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14176     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14177     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14178                                          that's flagged OA_DANGEROUS */
14179     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14180                                         not in any of the categories above */
14181     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14182 };
14183
14184
14185
14186 /* helper function for S_aassign_scan().
14187  * check a PAD-related op for commonality and/or set its generation number.
14188  * Returns a boolean indicating whether its shared */
14189
14190 static bool
14191 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14192 {
14193     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14194         /* lexical used in aliasing */
14195         return TRUE;
14196
14197     if (rhs)
14198         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14199     else
14200         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14201
14202     return FALSE;
14203 }
14204
14205
14206 /*
14207   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14208   It scans the left or right hand subtree of the aassign op, and returns a
14209   set of flags indicating what sorts of things it found there.
14210   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14211   set PL_generation on lexical vars; if the latter, we see if
14212   PL_generation matches.
14213   'top' indicates whether we're recursing or at the top level.
14214   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14215   This fn will increment it by the number seen. It's not intended to
14216   be an accurate count (especially as many ops can push a variable
14217   number of SVs onto the stack); rather it's used as to test whether there
14218   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14219 */
14220
14221 static int
14222 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14223 {
14224     int flags = 0;
14225     bool kid_top = FALSE;
14226
14227     /* first, look for a solitary @_ on the RHS */
14228     if (   rhs
14229         && top
14230         && (o->op_flags & OPf_KIDS)
14231         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14232     ) {
14233         OP *kid = cUNOPo->op_first;
14234         if (   (   kid->op_type == OP_PUSHMARK
14235                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14236             && ((kid = OpSIBLING(kid)))
14237             && !OpHAS_SIBLING(kid)
14238             && kid->op_type == OP_RV2AV
14239             && !(kid->op_flags & OPf_REF)
14240             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14241             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14242             && ((kid = cUNOPx(kid)->op_first))
14243             && kid->op_type == OP_GV
14244             && cGVOPx_gv(kid) == PL_defgv
14245         )
14246             flags |= AAS_DEFAV;
14247     }
14248
14249     switch (o->op_type) {
14250     case OP_GVSV:
14251         (*scalars_p)++;
14252         return AAS_PKG_SCALAR;
14253
14254     case OP_PADAV:
14255     case OP_PADHV:
14256         (*scalars_p) += 2;
14257         /* if !top, could be e.g. @a[0,1] */
14258         if (top && (o->op_flags & OPf_REF))
14259             return (o->op_private & OPpLVAL_INTRO)
14260                 ? AAS_MY_AGG : AAS_LEX_AGG;
14261         return AAS_DANGEROUS;
14262
14263     case OP_PADSV:
14264         {
14265             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14266                         ?  AAS_LEX_SCALAR_COMM : 0;
14267             (*scalars_p)++;
14268             return (o->op_private & OPpLVAL_INTRO)
14269                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14270         }
14271
14272     case OP_RV2AV:
14273     case OP_RV2HV:
14274         (*scalars_p) += 2;
14275         if (cUNOPx(o)->op_first->op_type != OP_GV)
14276             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14277         /* @pkg, %pkg */
14278         /* if !top, could be e.g. @a[0,1] */
14279         if (top && (o->op_flags & OPf_REF))
14280             return AAS_PKG_AGG;
14281         return AAS_DANGEROUS;
14282
14283     case OP_RV2SV:
14284         (*scalars_p)++;
14285         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14286             (*scalars_p) += 2;
14287             return AAS_DANGEROUS; /* ${expr} */
14288         }
14289         return AAS_PKG_SCALAR; /* $pkg */
14290
14291     case OP_SPLIT:
14292         if (o->op_private & OPpSPLIT_ASSIGN) {
14293             /* the assign in @a = split() has been optimised away
14294              * and the @a attached directly to the split op
14295              * Treat the array as appearing on the RHS, i.e.
14296              *    ... = (@a = split)
14297              * is treated like
14298              *    ... = @a;
14299              */
14300
14301             if (o->op_flags & OPf_STACKED)
14302                 /* @{expr} = split() - the array expression is tacked
14303                  * on as an extra child to split - process kid */
14304                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14305                                         top, scalars_p);
14306
14307             /* ... else array is directly attached to split op */
14308             (*scalars_p) += 2;
14309             if (PL_op->op_private & OPpSPLIT_LEX)
14310                 return (o->op_private & OPpLVAL_INTRO)
14311                     ? AAS_MY_AGG : AAS_LEX_AGG;
14312             else
14313                 return AAS_PKG_AGG;
14314         }
14315         (*scalars_p)++;
14316         /* other args of split can't be returned */
14317         return AAS_SAFE_SCALAR;
14318
14319     case OP_UNDEF:
14320         /* undef counts as a scalar on the RHS:
14321          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14322          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14323          */
14324         if (rhs)
14325             (*scalars_p)++;
14326         flags = AAS_SAFE_SCALAR;
14327         break;
14328
14329     case OP_PUSHMARK:
14330     case OP_STUB:
14331         /* these are all no-ops; they don't push a potentially common SV
14332          * onto the stack, so they are neither AAS_DANGEROUS nor
14333          * AAS_SAFE_SCALAR */
14334         return 0;
14335
14336     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14337         break;
14338
14339     case OP_NULL:
14340     case OP_LIST:
14341         /* these do nothing but may have children; but their children
14342          * should also be treated as top-level */
14343         kid_top = top;
14344         break;
14345
14346     default:
14347         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14348             (*scalars_p) += 2;
14349             flags = AAS_DANGEROUS;
14350             break;
14351         }
14352
14353         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14354             && (o->op_private & OPpTARGET_MY))
14355         {
14356             (*scalars_p)++;
14357             return S_aassign_padcheck(aTHX_ o, rhs)
14358                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14359         }
14360
14361         /* if its an unrecognised, non-dangerous op, assume that it
14362          * it the cause of at least one safe scalar */
14363         (*scalars_p)++;
14364         flags = AAS_SAFE_SCALAR;
14365         break;
14366     }
14367
14368     /* XXX this assumes that all other ops are "transparent" - i.e. that
14369      * they can return some of their children. While this true for e.g.
14370      * sort and grep, it's not true for e.g. map. We really need a
14371      * 'transparent' flag added to regen/opcodes
14372      */
14373     if (o->op_flags & OPf_KIDS) {
14374         OP *kid;
14375         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14376             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14377     }
14378     return flags;
14379 }
14380
14381
14382 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14383    and modify the optree to make them work inplace */
14384
14385 STATIC void
14386 S_inplace_aassign(pTHX_ OP *o) {
14387
14388     OP *modop, *modop_pushmark;
14389     OP *oright;
14390     OP *oleft, *oleft_pushmark;
14391
14392     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14393
14394     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14395
14396     assert(cUNOPo->op_first->op_type == OP_NULL);
14397     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14398     assert(modop_pushmark->op_type == OP_PUSHMARK);
14399     modop = OpSIBLING(modop_pushmark);
14400
14401     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14402         return;
14403
14404     /* no other operation except sort/reverse */
14405     if (OpHAS_SIBLING(modop))
14406         return;
14407
14408     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14409     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14410
14411     if (modop->op_flags & OPf_STACKED) {
14412         /* skip sort subroutine/block */
14413         assert(oright->op_type == OP_NULL);
14414         oright = OpSIBLING(oright);
14415     }
14416
14417     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14418     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14419     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14420     oleft = OpSIBLING(oleft_pushmark);
14421
14422     /* Check the lhs is an array */
14423     if (!oleft ||
14424         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14425         || OpHAS_SIBLING(oleft)
14426         || (oleft->op_private & OPpLVAL_INTRO)
14427     )
14428         return;
14429
14430     /* Only one thing on the rhs */
14431     if (OpHAS_SIBLING(oright))
14432         return;
14433
14434     /* check the array is the same on both sides */
14435     if (oleft->op_type == OP_RV2AV) {
14436         if (oright->op_type != OP_RV2AV
14437             || !cUNOPx(oright)->op_first
14438             || cUNOPx(oright)->op_first->op_type != OP_GV
14439             || cUNOPx(oleft )->op_first->op_type != OP_GV
14440             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14441                cGVOPx_gv(cUNOPx(oright)->op_first)
14442         )
14443             return;
14444     }
14445     else if (oright->op_type != OP_PADAV
14446         || oright->op_targ != oleft->op_targ
14447     )
14448         return;
14449
14450     /* This actually is an inplace assignment */
14451
14452     modop->op_private |= OPpSORT_INPLACE;
14453
14454     /* transfer MODishness etc from LHS arg to RHS arg */
14455     oright->op_flags = oleft->op_flags;
14456
14457     /* remove the aassign op and the lhs */
14458     op_null(o);
14459     op_null(oleft_pushmark);
14460     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14461         op_null(cUNOPx(oleft)->op_first);
14462     op_null(oleft);
14463 }
14464
14465
14466
14467 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14468  * that potentially represent a series of one or more aggregate derefs
14469  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14470  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14471  * additional ops left in too).
14472  *
14473  * The caller will have already verified that the first few ops in the
14474  * chain following 'start' indicate a multideref candidate, and will have
14475  * set 'orig_o' to the point further on in the chain where the first index
14476  * expression (if any) begins.  'orig_action' specifies what type of
14477  * beginning has already been determined by the ops between start..orig_o
14478  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14479  *
14480  * 'hints' contains any hints flags that need adding (currently just
14481  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14482  */
14483
14484 STATIC void
14485 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14486 {
14487     dVAR;
14488     int pass;
14489     UNOP_AUX_item *arg_buf = NULL;
14490     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14491     int index_skip         = -1;    /* don't output index arg on this action */
14492
14493     /* similar to regex compiling, do two passes; the first pass
14494      * determines whether the op chain is convertible and calculates the
14495      * buffer size; the second pass populates the buffer and makes any
14496      * changes necessary to ops (such as moving consts to the pad on
14497      * threaded builds).
14498      *
14499      * NB: for things like Coverity, note that both passes take the same
14500      * path through the logic tree (except for 'if (pass)' bits), since
14501      * both passes are following the same op_next chain; and in
14502      * particular, if it would return early on the second pass, it would
14503      * already have returned early on the first pass.
14504      */
14505     for (pass = 0; pass < 2; pass++) {
14506         OP *o                = orig_o;
14507         UV action            = orig_action;
14508         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14509         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14510         int action_count     = 0;     /* number of actions seen so far */
14511         int action_ix        = 0;     /* action_count % (actions per IV) */
14512         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14513         bool is_last         = FALSE; /* no more derefs to follow */
14514         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14515         UNOP_AUX_item *arg     = arg_buf;
14516         UNOP_AUX_item *action_ptr = arg_buf;
14517
14518         if (pass)
14519             action_ptr->uv = 0;
14520         arg++;
14521
14522         switch (action) {
14523         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14524         case MDEREF_HV_gvhv_helem:
14525             next_is_hash = TRUE;
14526             /* FALLTHROUGH */
14527         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14528         case MDEREF_AV_gvav_aelem:
14529             if (pass) {
14530 #ifdef USE_ITHREADS
14531                 arg->pad_offset = cPADOPx(start)->op_padix;
14532                 /* stop it being swiped when nulled */
14533                 cPADOPx(start)->op_padix = 0;
14534 #else
14535                 arg->sv = cSVOPx(start)->op_sv;
14536                 cSVOPx(start)->op_sv = NULL;
14537 #endif
14538             }
14539             arg++;
14540             break;
14541
14542         case MDEREF_HV_padhv_helem:
14543         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14544             next_is_hash = TRUE;
14545             /* FALLTHROUGH */
14546         case MDEREF_AV_padav_aelem:
14547         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14548             if (pass) {
14549                 arg->pad_offset = start->op_targ;
14550                 /* we skip setting op_targ = 0 for now, since the intact
14551                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14552                 reset_start_targ = TRUE;
14553             }
14554             arg++;
14555             break;
14556
14557         case MDEREF_HV_pop_rv2hv_helem:
14558             next_is_hash = TRUE;
14559             /* FALLTHROUGH */
14560         case MDEREF_AV_pop_rv2av_aelem:
14561             break;
14562
14563         default:
14564             NOT_REACHED; /* NOTREACHED */
14565             return;
14566         }
14567
14568         while (!is_last) {
14569             /* look for another (rv2av/hv; get index;
14570              * aelem/helem/exists/delele) sequence */
14571
14572             OP *kid;
14573             bool is_deref;
14574             bool ok;
14575             UV index_type = MDEREF_INDEX_none;
14576
14577             if (action_count) {
14578                 /* if this is not the first lookup, consume the rv2av/hv  */
14579
14580                 /* for N levels of aggregate lookup, we normally expect
14581                  * that the first N-1 [ah]elem ops will be flagged as
14582                  * /DEREF (so they autovivifiy if necessary), and the last
14583                  * lookup op not to be.
14584                  * For other things (like @{$h{k1}{k2}}) extra scope or
14585                  * leave ops can appear, so abandon the effort in that
14586                  * case */
14587                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14588                     return;
14589
14590                 /* rv2av or rv2hv sKR/1 */
14591
14592                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14593                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14594                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14595                     return;
14596
14597                 /* at this point, we wouldn't expect any of these
14598                  * possible private flags:
14599                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14600                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14601                  */
14602                 ASSUME(!(o->op_private &
14603                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14604
14605                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14606
14607                 /* make sure the type of the previous /DEREF matches the
14608                  * type of the next lookup */
14609                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14610                 top_op = o;
14611
14612                 action = next_is_hash
14613                             ? MDEREF_HV_vivify_rv2hv_helem
14614                             : MDEREF_AV_vivify_rv2av_aelem;
14615                 o = o->op_next;
14616             }
14617
14618             /* if this is the second pass, and we're at the depth where
14619              * previously we encountered a non-simple index expression,
14620              * stop processing the index at this point */
14621             if (action_count != index_skip) {
14622
14623                 /* look for one or more simple ops that return an array
14624                  * index or hash key */
14625
14626                 switch (o->op_type) {
14627                 case OP_PADSV:
14628                     /* it may be a lexical var index */
14629                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14630                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14631                     ASSUME(!(o->op_private &
14632                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14633
14634                     if (   OP_GIMME(o,0) == G_SCALAR
14635                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14636                         && o->op_private == 0)
14637                     {
14638                         if (pass)
14639                             arg->pad_offset = o->op_targ;
14640                         arg++;
14641                         index_type = MDEREF_INDEX_padsv;
14642                         o = o->op_next;
14643                     }
14644                     break;
14645
14646                 case OP_CONST:
14647                     if (next_is_hash) {
14648                         /* it's a constant hash index */
14649                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14650                             /* "use constant foo => FOO; $h{+foo}" for
14651                              * some weird FOO, can leave you with constants
14652                              * that aren't simple strings. It's not worth
14653                              * the extra hassle for those edge cases */
14654                             break;
14655
14656                         if (pass) {
14657                             UNOP *rop = NULL;
14658                             OP * helem_op = o->op_next;
14659
14660                             ASSUME(   helem_op->op_type == OP_HELEM
14661                                    || helem_op->op_type == OP_NULL);
14662                             if (helem_op->op_type == OP_HELEM) {
14663                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14664                                 if (   helem_op->op_private & OPpLVAL_INTRO
14665                                     || rop->op_type != OP_RV2HV
14666                                 )
14667                                     rop = NULL;
14668                             }
14669                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14670
14671 #ifdef USE_ITHREADS
14672                             /* Relocate sv to the pad for thread safety */
14673                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14674                             arg->pad_offset = o->op_targ;
14675                             o->op_targ = 0;
14676 #else
14677                             arg->sv = cSVOPx_sv(o);
14678 #endif
14679                         }
14680                     }
14681                     else {
14682                         /* it's a constant array index */
14683                         IV iv;
14684                         SV *ix_sv = cSVOPo->op_sv;
14685                         if (!SvIOK(ix_sv))
14686                             break;
14687                         iv = SvIV(ix_sv);
14688
14689                         if (   action_count == 0
14690                             && iv >= -128
14691                             && iv <= 127
14692                             && (   action == MDEREF_AV_padav_aelem
14693                                 || action == MDEREF_AV_gvav_aelem)
14694                         )
14695                             maybe_aelemfast = TRUE;
14696
14697                         if (pass) {
14698                             arg->iv = iv;
14699                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14700                         }
14701                     }
14702                     if (pass)
14703                         /* we've taken ownership of the SV */
14704                         cSVOPo->op_sv = NULL;
14705                     arg++;
14706                     index_type = MDEREF_INDEX_const;
14707                     o = o->op_next;
14708                     break;
14709
14710                 case OP_GV:
14711                     /* it may be a package var index */
14712
14713                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14714                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14715                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14716                         || o->op_private != 0
14717                     )
14718                         break;
14719
14720                     kid = o->op_next;
14721                     if (kid->op_type != OP_RV2SV)
14722                         break;
14723
14724                     ASSUME(!(kid->op_flags &
14725                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14726                              |OPf_SPECIAL|OPf_PARENS)));
14727                     ASSUME(!(kid->op_private &
14728                                     ~(OPpARG1_MASK
14729                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14730                                      |OPpDEREF|OPpLVAL_INTRO)));
14731                     if(   (kid->op_flags &~ OPf_PARENS)
14732                             != (OPf_WANT_SCALAR|OPf_KIDS)
14733                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14734                     )
14735                         break;
14736
14737                     if (pass) {
14738 #ifdef USE_ITHREADS
14739                         arg->pad_offset = cPADOPx(o)->op_padix;
14740                         /* stop it being swiped when nulled */
14741                         cPADOPx(o)->op_padix = 0;
14742 #else
14743                         arg->sv = cSVOPx(o)->op_sv;
14744                         cSVOPo->op_sv = NULL;
14745 #endif
14746                     }
14747                     arg++;
14748                     index_type = MDEREF_INDEX_gvsv;
14749                     o = kid->op_next;
14750                     break;
14751
14752                 } /* switch */
14753             } /* action_count != index_skip */
14754
14755             action |= index_type;
14756
14757
14758             /* at this point we have either:
14759              *   * detected what looks like a simple index expression,
14760              *     and expect the next op to be an [ah]elem, or
14761              *     an nulled  [ah]elem followed by a delete or exists;
14762              *  * found a more complex expression, so something other
14763              *    than the above follows.
14764              */
14765
14766             /* possibly an optimised away [ah]elem (where op_next is
14767              * exists or delete) */
14768             if (o->op_type == OP_NULL)
14769                 o = o->op_next;
14770
14771             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14772              * OP_EXISTS or OP_DELETE */
14773
14774             /* if a custom array/hash access checker is in scope,
14775              * abandon optimisation attempt */
14776             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14777                && PL_check[o->op_type] != Perl_ck_null)
14778                 return;
14779             /* similarly for customised exists and delete */
14780             if (  (o->op_type == OP_EXISTS)
14781                && PL_check[o->op_type] != Perl_ck_exists)
14782                 return;
14783             if (  (o->op_type == OP_DELETE)
14784                && PL_check[o->op_type] != Perl_ck_delete)
14785                 return;
14786
14787             if (   o->op_type != OP_AELEM
14788                 || (o->op_private &
14789                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14790                 )
14791                 maybe_aelemfast = FALSE;
14792
14793             /* look for aelem/helem/exists/delete. If it's not the last elem
14794              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14795              * flags; if it's the last, then it mustn't have
14796              * OPpDEREF_AV/HV, but may have lots of other flags, like
14797              * OPpLVAL_INTRO etc
14798              */
14799
14800             if (   index_type == MDEREF_INDEX_none
14801                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14802                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14803             )
14804                 ok = FALSE;
14805             else {
14806                 /* we have aelem/helem/exists/delete with valid simple index */
14807
14808                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14809                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14810                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14811
14812                 /* This doesn't make much sense but is legal:
14813                  *    @{ local $x[0][0] } = 1
14814                  * Since scope exit will undo the autovivification,
14815                  * don't bother in the first place. The OP_LEAVE
14816                  * assertion is in case there are other cases of both
14817                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14818                  * exit that would undo the local - in which case this
14819                  * block of code would need rethinking.
14820                  */
14821                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14822 #ifdef DEBUGGING
14823                     OP *n = o->op_next;
14824                     while (n && (  n->op_type == OP_NULL
14825                                 || n->op_type == OP_LIST))
14826                         n = n->op_next;
14827                     assert(n && n->op_type == OP_LEAVE);
14828 #endif
14829                     o->op_private &= ~OPpDEREF;
14830                     is_deref = FALSE;
14831                 }
14832
14833                 if (is_deref) {
14834                     ASSUME(!(o->op_flags &
14835                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14836                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14837
14838                     ok =    (o->op_flags &~ OPf_PARENS)
14839                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14840                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14841                 }
14842                 else if (o->op_type == OP_EXISTS) {
14843                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14844                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14845                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14846                     ok =  !(o->op_private & ~OPpARG1_MASK);
14847                 }
14848                 else if (o->op_type == OP_DELETE) {
14849                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14850                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14851                     ASSUME(!(o->op_private &
14852                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14853                     /* don't handle slices or 'local delete'; the latter
14854                      * is fairly rare, and has a complex runtime */
14855                     ok =  !(o->op_private & ~OPpARG1_MASK);
14856                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14857                         /* skip handling run-tome error */
14858                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14859                 }
14860                 else {
14861                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14862                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14863                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14864                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14865                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14866                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14867                 }
14868             }
14869
14870             if (ok) {
14871                 if (!first_elem_op)
14872                     first_elem_op = o;
14873                 top_op = o;
14874                 if (is_deref) {
14875                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14876                     o = o->op_next;
14877                 }
14878                 else {
14879                     is_last = TRUE;
14880                     action |= MDEREF_FLAG_last;
14881                 }
14882             }
14883             else {
14884                 /* at this point we have something that started
14885                  * promisingly enough (with rv2av or whatever), but failed
14886                  * to find a simple index followed by an
14887                  * aelem/helem/exists/delete. If this is the first action,
14888                  * give up; but if we've already seen at least one
14889                  * aelem/helem, then keep them and add a new action with
14890                  * MDEREF_INDEX_none, which causes it to do the vivify
14891                  * from the end of the previous lookup, and do the deref,
14892                  * but stop at that point. So $a[0][expr] will do one
14893                  * av_fetch, vivify and deref, then continue executing at
14894                  * expr */
14895                 if (!action_count)
14896                     return;
14897                 is_last = TRUE;
14898                 index_skip = action_count;
14899                 action |= MDEREF_FLAG_last;
14900                 if (index_type != MDEREF_INDEX_none)
14901                     arg--;
14902             }
14903
14904             if (pass)
14905                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14906             action_ix++;
14907             action_count++;
14908             /* if there's no space for the next action, create a new slot
14909              * for it *before* we start adding args for that action */
14910             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14911                 action_ptr = arg;
14912                 if (pass)
14913                     arg->uv = 0;
14914                 arg++;
14915                 action_ix = 0;
14916             }
14917         } /* while !is_last */
14918
14919         /* success! */
14920
14921         if (pass) {
14922             OP *mderef;
14923             OP *p, *q;
14924
14925             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14926             if (index_skip == -1) {
14927                 mderef->op_flags = o->op_flags
14928                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14929                 if (o->op_type == OP_EXISTS)
14930                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14931                 else if (o->op_type == OP_DELETE)
14932                     mderef->op_private = OPpMULTIDEREF_DELETE;
14933                 else
14934                     mderef->op_private = o->op_private
14935                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14936             }
14937             /* accumulate strictness from every level (although I don't think
14938              * they can actually vary) */
14939             mderef->op_private |= hints;
14940
14941             /* integrate the new multideref op into the optree and the
14942              * op_next chain.
14943              *
14944              * In general an op like aelem or helem has two child
14945              * sub-trees: the aggregate expression (a_expr) and the
14946              * index expression (i_expr):
14947              *
14948              *     aelem
14949              *       |
14950              *     a_expr - i_expr
14951              *
14952              * The a_expr returns an AV or HV, while the i-expr returns an
14953              * index. In general a multideref replaces most or all of a
14954              * multi-level tree, e.g.
14955              *
14956              *     exists
14957              *       |
14958              *     ex-aelem
14959              *       |
14960              *     rv2av  - i_expr1
14961              *       |
14962              *     helem
14963              *       |
14964              *     rv2hv  - i_expr2
14965              *       |
14966              *     aelem
14967              *       |
14968              *     a_expr - i_expr3
14969              *
14970              * With multideref, all the i_exprs will be simple vars or
14971              * constants, except that i_expr1 may be arbitrary in the case
14972              * of MDEREF_INDEX_none.
14973              *
14974              * The bottom-most a_expr will be either:
14975              *   1) a simple var (so padXv or gv+rv2Xv);
14976              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14977              *      so a simple var with an extra rv2Xv;
14978              *   3) or an arbitrary expression.
14979              *
14980              * 'start', the first op in the execution chain, will point to
14981              *   1),2): the padXv or gv op;
14982              *   3):    the rv2Xv which forms the last op in the a_expr
14983              *          execution chain, and the top-most op in the a_expr
14984              *          subtree.
14985              *
14986              * For all cases, the 'start' node is no longer required,
14987              * but we can't free it since one or more external nodes
14988              * may point to it. E.g. consider
14989              *     $h{foo} = $a ? $b : $c
14990              * Here, both the op_next and op_other branches of the
14991              * cond_expr point to the gv[*h] of the hash expression, so
14992              * we can't free the 'start' op.
14993              *
14994              * For expr->[...], we need to save the subtree containing the
14995              * expression; for the other cases, we just need to save the
14996              * start node.
14997              * So in all cases, we null the start op and keep it around by
14998              * making it the child of the multideref op; for the expr->
14999              * case, the expr will be a subtree of the start node.
15000              *
15001              * So in the simple 1,2 case the  optree above changes to
15002              *
15003              *     ex-exists
15004              *       |
15005              *     multideref
15006              *       |
15007              *     ex-gv (or ex-padxv)
15008              *
15009              *  with the op_next chain being
15010              *
15011              *  -> ex-gv -> multideref -> op-following-ex-exists ->
15012              *
15013              *  In the 3 case, we have
15014              *
15015              *     ex-exists
15016              *       |
15017              *     multideref
15018              *       |
15019              *     ex-rv2xv
15020              *       |
15021              *    rest-of-a_expr
15022              *      subtree
15023              *
15024              *  and
15025              *
15026              *  -> rest-of-a_expr subtree ->
15027              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
15028              *
15029              *
15030              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15031              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15032              * multideref attached as the child, e.g.
15033              *
15034              *     exists
15035              *       |
15036              *     ex-aelem
15037              *       |
15038              *     ex-rv2av  - i_expr1
15039              *       |
15040              *     multideref
15041              *       |
15042              *     ex-whatever
15043              *
15044              */
15045
15046             /* if we free this op, don't free the pad entry */
15047             if (reset_start_targ)
15048                 start->op_targ = 0;
15049
15050
15051             /* Cut the bit we need to save out of the tree and attach to
15052              * the multideref op, then free the rest of the tree */
15053
15054             /* find parent of node to be detached (for use by splice) */
15055             p = first_elem_op;
15056             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
15057                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15058             {
15059                 /* there is an arbitrary expression preceding us, e.g.
15060                  * expr->[..]? so we need to save the 'expr' subtree */
15061                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15062                     p = cUNOPx(p)->op_first;
15063                 ASSUME(   start->op_type == OP_RV2AV
15064                        || start->op_type == OP_RV2HV);
15065             }
15066             else {
15067                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15068                  * above for exists/delete. */
15069                 while (   (p->op_flags & OPf_KIDS)
15070                        && cUNOPx(p)->op_first != start
15071                 )
15072                     p = cUNOPx(p)->op_first;
15073             }
15074             ASSUME(cUNOPx(p)->op_first == start);
15075
15076             /* detach from main tree, and re-attach under the multideref */
15077             op_sibling_splice(mderef, NULL, 0,
15078                     op_sibling_splice(p, NULL, 1, NULL));
15079             op_null(start);
15080
15081             start->op_next = mderef;
15082
15083             mderef->op_next = index_skip == -1 ? o->op_next : o;
15084
15085             /* excise and free the original tree, and replace with
15086              * the multideref op */
15087             p = op_sibling_splice(top_op, NULL, -1, mderef);
15088             while (p) {
15089                 q = OpSIBLING(p);
15090                 op_free(p);
15091                 p = q;
15092             }
15093             op_null(top_op);
15094         }
15095         else {
15096             Size_t size = arg - arg_buf;
15097
15098             if (maybe_aelemfast && action_count == 1)
15099                 return;
15100
15101             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15102                                 sizeof(UNOP_AUX_item) * (size + 1));
15103             /* for dumping etc: store the length in a hidden first slot;
15104              * we set the op_aux pointer to the second slot */
15105             arg_buf->uv = size;
15106             arg_buf++;
15107         }
15108     } /* for (pass = ...) */
15109 }
15110
15111 /* See if the ops following o are such that o will always be executed in
15112  * boolean context: that is, the SV which o pushes onto the stack will
15113  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15114  * If so, set a suitable private flag on o. Normally this will be
15115  * bool_flag; but see below why maybe_flag is needed too.
15116  *
15117  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15118  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15119  * already be taken, so you'll have to give that op two different flags.
15120  *
15121  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15122  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15123  * those underlying ops) short-circuit, which means that rather than
15124  * necessarily returning a truth value, they may return the LH argument,
15125  * which may not be boolean. For example in $x = (keys %h || -1), keys
15126  * should return a key count rather than a boolean, even though its
15127  * sort-of being used in boolean context.
15128  *
15129  * So we only consider such logical ops to provide boolean context to
15130  * their LH argument if they themselves are in void or boolean context.
15131  * However, sometimes the context isn't known until run-time. In this
15132  * case the op is marked with the maybe_flag flag it.
15133  *
15134  * Consider the following.
15135  *
15136  *     sub f { ....;  if (%h) { .... } }
15137  *
15138  * This is actually compiled as
15139  *
15140  *     sub f { ....;  %h && do { .... } }
15141  *
15142  * Here we won't know until runtime whether the final statement (and hence
15143  * the &&) is in void context and so is safe to return a boolean value.
15144  * So mark o with maybe_flag rather than the bool_flag.
15145  * Note that there is cost associated with determining context at runtime
15146  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15147  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15148  * boolean costs savings are marginal.
15149  *
15150  * However, we can do slightly better with && (compared to || and //):
15151  * this op only returns its LH argument when that argument is false. In
15152  * this case, as long as the op promises to return a false value which is
15153  * valid in both boolean and scalar contexts, we can mark an op consumed
15154  * by && with bool_flag rather than maybe_flag.
15155  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15156  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15157  * op which promises to handle this case is indicated by setting safe_and
15158  * to true.
15159  */
15160
15161 static void
15162 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15163 {
15164     OP *lop;
15165     U8 flag = 0;
15166
15167     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15168
15169     /* OPpTARGET_MY and boolean context probably don't mix well.
15170      * If someone finds a valid use case, maybe add an extra flag to this
15171      * function which indicates its safe to do so for this op? */
15172     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15173              && (o->op_private & OPpTARGET_MY)));
15174
15175     lop = o->op_next;
15176
15177     while (lop) {
15178         switch (lop->op_type) {
15179         case OP_NULL:
15180         case OP_SCALAR:
15181             break;
15182
15183         /* these two consume the stack argument in the scalar case,
15184          * and treat it as a boolean in the non linenumber case */
15185         case OP_FLIP:
15186         case OP_FLOP:
15187             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15188                 || (lop->op_private & OPpFLIP_LINENUM))
15189             {
15190                 lop = NULL;
15191                 break;
15192             }
15193             /* FALLTHROUGH */
15194         /* these never leave the original value on the stack */
15195         case OP_NOT:
15196         case OP_XOR:
15197         case OP_COND_EXPR:
15198         case OP_GREPWHILE:
15199             flag = bool_flag;
15200             lop = NULL;
15201             break;
15202
15203         /* OR DOR and AND evaluate their arg as a boolean, but then may
15204          * leave the original scalar value on the stack when following the
15205          * op_next route. If not in void context, we need to ensure
15206          * that whatever follows consumes the arg only in boolean context
15207          * too.
15208          */
15209         case OP_AND:
15210             if (safe_and) {
15211                 flag = bool_flag;
15212                 lop = NULL;
15213                 break;
15214             }
15215             /* FALLTHROUGH */
15216         case OP_OR:
15217         case OP_DOR:
15218             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15219                 flag = bool_flag;
15220                 lop = NULL;
15221             }
15222             else if (!(lop->op_flags & OPf_WANT)) {
15223                 /* unknown context - decide at runtime */
15224                 flag = maybe_flag;
15225                 lop = NULL;
15226             }
15227             break;
15228
15229         default:
15230             lop = NULL;
15231             break;
15232         }
15233
15234         if (lop)
15235             lop = lop->op_next;
15236     }
15237
15238     o->op_private |= flag;
15239 }
15240
15241
15242
15243 /* mechanism for deferring recursion in rpeep() */
15244
15245 #define MAX_DEFERRED 4
15246
15247 #define DEFER(o) \
15248   STMT_START { \
15249     if (defer_ix == (MAX_DEFERRED-1)) { \
15250         OP **defer = defer_queue[defer_base]; \
15251         CALL_RPEEP(*defer); \
15252         S_prune_chain_head(defer); \
15253         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15254         defer_ix--; \
15255     } \
15256     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15257   } STMT_END
15258
15259 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15260 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15261
15262
15263 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15264  * See the comments at the top of this file for more details about when
15265  * peep() is called */
15266
15267 void
15268 Perl_rpeep(pTHX_ OP *o)
15269 {
15270     dVAR;
15271     OP* oldop = NULL;
15272     OP* oldoldop = NULL;
15273     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15274     int defer_base = 0;
15275     int defer_ix = -1;
15276
15277     if (!o || o->op_opt)
15278         return;
15279
15280     assert(o->op_type != OP_FREED);
15281
15282     ENTER;
15283     SAVEOP();
15284     SAVEVPTR(PL_curcop);
15285     for (;; o = o->op_next) {
15286         if (o && o->op_opt)
15287             o = NULL;
15288         if (!o) {
15289             while (defer_ix >= 0) {
15290                 OP **defer =
15291                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15292                 CALL_RPEEP(*defer);
15293                 S_prune_chain_head(defer);
15294             }
15295             break;
15296         }
15297
15298       redo:
15299
15300         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15301         assert(!oldoldop || oldoldop->op_next == oldop);
15302         assert(!oldop    || oldop->op_next    == o);
15303
15304         /* By default, this op has now been optimised. A couple of cases below
15305            clear this again.  */
15306         o->op_opt = 1;
15307         PL_op = o;
15308
15309         /* look for a series of 1 or more aggregate derefs, e.g.
15310          *   $a[1]{foo}[$i]{$k}
15311          * and replace with a single OP_MULTIDEREF op.
15312          * Each index must be either a const, or a simple variable,
15313          *
15314          * First, look for likely combinations of starting ops,
15315          * corresponding to (global and lexical variants of)
15316          *     $a[...]   $h{...}
15317          *     $r->[...] $r->{...}
15318          *     (preceding expression)->[...]
15319          *     (preceding expression)->{...}
15320          * and if so, call maybe_multideref() to do a full inspection
15321          * of the op chain and if appropriate, replace with an
15322          * OP_MULTIDEREF
15323          */
15324         {
15325             UV action;
15326             OP *o2 = o;
15327             U8 hints = 0;
15328
15329             switch (o2->op_type) {
15330             case OP_GV:
15331                 /* $pkg[..]   :   gv[*pkg]
15332                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15333
15334                 /* Fail if there are new op flag combinations that we're
15335                  * not aware of, rather than:
15336                  *  * silently failing to optimise, or
15337                  *  * silently optimising the flag away.
15338                  * If this ASSUME starts failing, examine what new flag
15339                  * has been added to the op, and decide whether the
15340                  * optimisation should still occur with that flag, then
15341                  * update the code accordingly. This applies to all the
15342                  * other ASSUMEs in the block of code too.
15343                  */
15344                 ASSUME(!(o2->op_flags &
15345                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15346                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15347
15348                 o2 = o2->op_next;
15349
15350                 if (o2->op_type == OP_RV2AV) {
15351                     action = MDEREF_AV_gvav_aelem;
15352                     goto do_deref;
15353                 }
15354
15355                 if (o2->op_type == OP_RV2HV) {
15356                     action = MDEREF_HV_gvhv_helem;
15357                     goto do_deref;
15358                 }
15359
15360                 if (o2->op_type != OP_RV2SV)
15361                     break;
15362
15363                 /* at this point we've seen gv,rv2sv, so the only valid
15364                  * construct left is $pkg->[] or $pkg->{} */
15365
15366                 ASSUME(!(o2->op_flags & OPf_STACKED));
15367                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15368                             != (OPf_WANT_SCALAR|OPf_MOD))
15369                     break;
15370
15371                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15372                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15373                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15374                     break;
15375                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15376                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15377                     break;
15378
15379                 o2 = o2->op_next;
15380                 if (o2->op_type == OP_RV2AV) {
15381                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15382                     goto do_deref;
15383                 }
15384                 if (o2->op_type == OP_RV2HV) {
15385                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15386                     goto do_deref;
15387                 }
15388                 break;
15389
15390             case OP_PADSV:
15391                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15392
15393                 ASSUME(!(o2->op_flags &
15394                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15395                 if ((o2->op_flags &
15396                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15397                      != (OPf_WANT_SCALAR|OPf_MOD))
15398                     break;
15399
15400                 ASSUME(!(o2->op_private &
15401                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15402                 /* skip if state or intro, or not a deref */
15403                 if (      o2->op_private != OPpDEREF_AV
15404                        && o2->op_private != OPpDEREF_HV)
15405                     break;
15406
15407                 o2 = o2->op_next;
15408                 if (o2->op_type == OP_RV2AV) {
15409                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15410                     goto do_deref;
15411                 }
15412                 if (o2->op_type == OP_RV2HV) {
15413                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15414                     goto do_deref;
15415                 }
15416                 break;
15417
15418             case OP_PADAV:
15419             case OP_PADHV:
15420                 /*    $lex[..]:  padav[@lex:1,2] sR *
15421                  * or $lex{..}:  padhv[%lex:1,2] sR */
15422                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15423                                             OPf_REF|OPf_SPECIAL)));
15424                 if ((o2->op_flags &
15425                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15426                      != (OPf_WANT_SCALAR|OPf_REF))
15427                     break;
15428                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15429                     break;
15430                 /* OPf_PARENS isn't currently used in this case;
15431                  * if that changes, let us know! */
15432                 ASSUME(!(o2->op_flags & OPf_PARENS));
15433
15434                 /* at this point, we wouldn't expect any of the remaining
15435                  * possible private flags:
15436                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15437                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15438                  *
15439                  * OPpSLICEWARNING shouldn't affect runtime
15440                  */
15441                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15442
15443                 action = o2->op_type == OP_PADAV
15444                             ? MDEREF_AV_padav_aelem
15445                             : MDEREF_HV_padhv_helem;
15446                 o2 = o2->op_next;
15447                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15448                 break;
15449
15450
15451             case OP_RV2AV:
15452             case OP_RV2HV:
15453                 action = o2->op_type == OP_RV2AV
15454                             ? MDEREF_AV_pop_rv2av_aelem
15455                             : MDEREF_HV_pop_rv2hv_helem;
15456                 /* FALLTHROUGH */
15457             do_deref:
15458                 /* (expr)->[...]:  rv2av sKR/1;
15459                  * (expr)->{...}:  rv2hv sKR/1; */
15460
15461                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15462
15463                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15464                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15465                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15466                     break;
15467
15468                 /* at this point, we wouldn't expect any of these
15469                  * possible private flags:
15470                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15471                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15472                  */
15473                 ASSUME(!(o2->op_private &
15474                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15475                      |OPpOUR_INTRO)));
15476                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15477
15478                 o2 = o2->op_next;
15479
15480                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15481                 break;
15482
15483             default:
15484                 break;
15485             }
15486         }
15487
15488
15489         switch (o->op_type) {
15490         case OP_DBSTATE:
15491             PL_curcop = ((COP*)o);              /* for warnings */
15492             break;
15493         case OP_NEXTSTATE:
15494             PL_curcop = ((COP*)o);              /* for warnings */
15495
15496             /* Optimise a "return ..." at the end of a sub to just be "...".
15497              * This saves 2 ops. Before:
15498              * 1  <;> nextstate(main 1 -e:1) v ->2
15499              * 4  <@> return K ->5
15500              * 2    <0> pushmark s ->3
15501              * -    <1> ex-rv2sv sK/1 ->4
15502              * 3      <#> gvsv[*cat] s ->4
15503              *
15504              * After:
15505              * -  <@> return K ->-
15506              * -    <0> pushmark s ->2
15507              * -    <1> ex-rv2sv sK/1 ->-
15508              * 2      <$> gvsv(*cat) s ->3
15509              */
15510             {
15511                 OP *next = o->op_next;
15512                 OP *sibling = OpSIBLING(o);
15513                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15514                     && OP_TYPE_IS(sibling, OP_RETURN)
15515                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15516                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15517                        ||OP_TYPE_IS(sibling->op_next->op_next,
15518                                     OP_LEAVESUBLV))
15519                     && cUNOPx(sibling)->op_first == next
15520                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15521                     && next->op_next
15522                 ) {
15523                     /* Look through the PUSHMARK's siblings for one that
15524                      * points to the RETURN */
15525                     OP *top = OpSIBLING(next);
15526                     while (top && top->op_next) {
15527                         if (top->op_next == sibling) {
15528                             top->op_next = sibling->op_next;
15529                             o->op_next = next->op_next;
15530                             break;
15531                         }
15532                         top = OpSIBLING(top);
15533                     }
15534                 }
15535             }
15536
15537             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15538              *
15539              * This latter form is then suitable for conversion into padrange
15540              * later on. Convert:
15541              *
15542              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15543              *
15544              * into:
15545              *
15546              *   nextstate1 ->     listop     -> nextstate3
15547              *                 /            \
15548              *         pushmark -> padop1 -> padop2
15549              */
15550             if (o->op_next && (
15551                     o->op_next->op_type == OP_PADSV
15552                  || o->op_next->op_type == OP_PADAV
15553                  || o->op_next->op_type == OP_PADHV
15554                 )
15555                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15556                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15557                 && o->op_next->op_next->op_next && (
15558                     o->op_next->op_next->op_next->op_type == OP_PADSV
15559                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15560                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15561                 )
15562                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15563                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15564                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15565                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15566             ) {
15567                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15568
15569                 pad1 =    o->op_next;
15570                 ns2  = pad1->op_next;
15571                 pad2 =  ns2->op_next;
15572                 ns3  = pad2->op_next;
15573
15574                 /* we assume here that the op_next chain is the same as
15575                  * the op_sibling chain */
15576                 assert(OpSIBLING(o)    == pad1);
15577                 assert(OpSIBLING(pad1) == ns2);
15578                 assert(OpSIBLING(ns2)  == pad2);
15579                 assert(OpSIBLING(pad2) == ns3);
15580
15581                 /* excise and delete ns2 */
15582                 op_sibling_splice(NULL, pad1, 1, NULL);
15583                 op_free(ns2);
15584
15585                 /* excise pad1 and pad2 */
15586                 op_sibling_splice(NULL, o, 2, NULL);
15587
15588                 /* create new listop, with children consisting of:
15589                  * a new pushmark, pad1, pad2. */
15590                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15591                 newop->op_flags |= OPf_PARENS;
15592                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15593
15594                 /* insert newop between o and ns3 */
15595                 op_sibling_splice(NULL, o, 0, newop);
15596
15597                 /*fixup op_next chain */
15598                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15599                 o    ->op_next = newpm;
15600                 newpm->op_next = pad1;
15601                 pad1 ->op_next = pad2;
15602                 pad2 ->op_next = newop; /* listop */
15603                 newop->op_next = ns3;
15604
15605                 /* Ensure pushmark has this flag if padops do */
15606                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15607                     newpm->op_flags |= OPf_MOD;
15608                 }
15609
15610                 break;
15611             }
15612
15613             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15614                to carry two labels. For now, take the easier option, and skip
15615                this optimisation if the first NEXTSTATE has a label.  */
15616             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15617                 OP *nextop = o->op_next;
15618                 while (nextop && nextop->op_type == OP_NULL)
15619                     nextop = nextop->op_next;
15620
15621                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15622                     op_null(o);
15623                     if (oldop)
15624                         oldop->op_next = nextop;
15625                     o = nextop;
15626                     /* Skip (old)oldop assignment since the current oldop's
15627                        op_next already points to the next op.  */
15628                     goto redo;
15629                 }
15630             }
15631             break;
15632
15633         case OP_CONCAT:
15634             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15635                 if (o->op_next->op_private & OPpTARGET_MY) {
15636                     if (o->op_flags & OPf_STACKED) /* chained concats */
15637                         break; /* ignore_optimization */
15638                     else {
15639                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15640                         o->op_targ = o->op_next->op_targ;
15641                         o->op_next->op_targ = 0;
15642                         o->op_private |= OPpTARGET_MY;
15643                     }
15644                 }
15645                 op_null(o->op_next);
15646             }
15647             break;
15648         case OP_STUB:
15649             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15650                 break; /* Scalar stub must produce undef.  List stub is noop */
15651             }
15652             goto nothin;
15653         case OP_NULL:
15654             if (o->op_targ == OP_NEXTSTATE
15655                 || o->op_targ == OP_DBSTATE)
15656             {
15657                 PL_curcop = ((COP*)o);
15658             }
15659             /* XXX: We avoid setting op_seq here to prevent later calls
15660                to rpeep() from mistakenly concluding that optimisation
15661                has already occurred. This doesn't fix the real problem,
15662                though (See 20010220.007 (#5874)). AMS 20010719 */
15663             /* op_seq functionality is now replaced by op_opt */
15664             o->op_opt = 0;
15665             /* FALLTHROUGH */
15666         case OP_SCALAR:
15667         case OP_LINESEQ:
15668         case OP_SCOPE:
15669         nothin:
15670             if (oldop) {
15671                 oldop->op_next = o->op_next;
15672                 o->op_opt = 0;
15673                 continue;
15674             }
15675             break;
15676
15677         case OP_PUSHMARK:
15678
15679             /* Given
15680                  5 repeat/DOLIST
15681                  3   ex-list
15682                  1     pushmark
15683                  2     scalar or const
15684                  4   const[0]
15685                convert repeat into a stub with no kids.
15686              */
15687             if (o->op_next->op_type == OP_CONST
15688              || (  o->op_next->op_type == OP_PADSV
15689                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15690              || (  o->op_next->op_type == OP_GV
15691                 && o->op_next->op_next->op_type == OP_RV2SV
15692                 && !(o->op_next->op_next->op_private
15693                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15694             {
15695                 const OP *kid = o->op_next->op_next;
15696                 if (o->op_next->op_type == OP_GV)
15697                    kid = kid->op_next;
15698                 /* kid is now the ex-list.  */
15699                 if (kid->op_type == OP_NULL
15700                  && (kid = kid->op_next)->op_type == OP_CONST
15701                     /* kid is now the repeat count.  */
15702                  && kid->op_next->op_type == OP_REPEAT
15703                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15704                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15705                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15706                  && oldop)
15707                 {
15708                     o = kid->op_next; /* repeat */
15709                     oldop->op_next = o;
15710                     op_free(cBINOPo->op_first);
15711                     op_free(cBINOPo->op_last );
15712                     o->op_flags &=~ OPf_KIDS;
15713                     /* stub is a baseop; repeat is a binop */
15714                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15715                     OpTYPE_set(o, OP_STUB);
15716                     o->op_private = 0;
15717                     break;
15718                 }
15719             }
15720
15721             /* Convert a series of PAD ops for my vars plus support into a
15722              * single padrange op. Basically
15723              *
15724              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15725              *
15726              * becomes, depending on circumstances, one of
15727              *
15728              *    padrange  ----------------------------------> (list) -> rest
15729              *    padrange  --------------------------------------------> rest
15730              *
15731              * where all the pad indexes are sequential and of the same type
15732              * (INTRO or not).
15733              * We convert the pushmark into a padrange op, then skip
15734              * any other pad ops, and possibly some trailing ops.
15735              * Note that we don't null() the skipped ops, to make it
15736              * easier for Deparse to undo this optimisation (and none of
15737              * the skipped ops are holding any resourses). It also makes
15738              * it easier for find_uninit_var(), as it can just ignore
15739              * padrange, and examine the original pad ops.
15740              */
15741         {
15742             OP *p;
15743             OP *followop = NULL; /* the op that will follow the padrange op */
15744             U8 count = 0;
15745             U8 intro = 0;
15746             PADOFFSET base = 0; /* init only to stop compiler whining */
15747             bool gvoid = 0;     /* init only to stop compiler whining */
15748             bool defav = 0;  /* seen (...) = @_ */
15749             bool reuse = 0;  /* reuse an existing padrange op */
15750
15751             /* look for a pushmark -> gv[_] -> rv2av */
15752
15753             {
15754                 OP *rv2av, *q;
15755                 p = o->op_next;
15756                 if (   p->op_type == OP_GV
15757                     && cGVOPx_gv(p) == PL_defgv
15758                     && (rv2av = p->op_next)
15759                     && rv2av->op_type == OP_RV2AV
15760                     && !(rv2av->op_flags & OPf_REF)
15761                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15762                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15763                 ) {
15764                     q = rv2av->op_next;
15765                     if (q->op_type == OP_NULL)
15766                         q = q->op_next;
15767                     if (q->op_type == OP_PUSHMARK) {
15768                         defav = 1;
15769                         p = q;
15770                     }
15771                 }
15772             }
15773             if (!defav) {
15774                 p = o;
15775             }
15776
15777             /* scan for PAD ops */
15778
15779             for (p = p->op_next; p; p = p->op_next) {
15780                 if (p->op_type == OP_NULL)
15781                     continue;
15782
15783                 if ((     p->op_type != OP_PADSV
15784                        && p->op_type != OP_PADAV
15785                        && p->op_type != OP_PADHV
15786                     )
15787                       /* any private flag other than INTRO? e.g. STATE */
15788                    || (p->op_private & ~OPpLVAL_INTRO)
15789                 )
15790                     break;
15791
15792                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15793                  * instead */
15794                 if (   p->op_type == OP_PADAV
15795                     && p->op_next
15796                     && p->op_next->op_type == OP_CONST
15797                     && p->op_next->op_next
15798                     && p->op_next->op_next->op_type == OP_AELEM
15799                 )
15800                     break;
15801
15802                 /* for 1st padop, note what type it is and the range
15803                  * start; for the others, check that it's the same type
15804                  * and that the targs are contiguous */
15805                 if (count == 0) {
15806                     intro = (p->op_private & OPpLVAL_INTRO);
15807                     base = p->op_targ;
15808                     gvoid = OP_GIMME(p,0) == G_VOID;
15809                 }
15810                 else {
15811                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15812                         break;
15813                     /* Note that you'd normally  expect targs to be
15814                      * contiguous in my($a,$b,$c), but that's not the case
15815                      * when external modules start doing things, e.g.
15816                      * Function::Parameters */
15817                     if (p->op_targ != base + count)
15818                         break;
15819                     assert(p->op_targ == base + count);
15820                     /* Either all the padops or none of the padops should
15821                        be in void context.  Since we only do the optimisa-
15822                        tion for av/hv when the aggregate itself is pushed
15823                        on to the stack (one item), there is no need to dis-
15824                        tinguish list from scalar context.  */
15825                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15826                         break;
15827                 }
15828
15829                 /* for AV, HV, only when we're not flattening */
15830                 if (   p->op_type != OP_PADSV
15831                     && !gvoid
15832                     && !(p->op_flags & OPf_REF)
15833                 )
15834                     break;
15835
15836                 if (count >= OPpPADRANGE_COUNTMASK)
15837                     break;
15838
15839                 /* there's a biggest base we can fit into a
15840                  * SAVEt_CLEARPADRANGE in pp_padrange.
15841                  * (The sizeof() stuff will be constant-folded, and is
15842                  * intended to avoid getting "comparison is always false"
15843                  * compiler warnings. See the comments above
15844                  * MEM_WRAP_CHECK for more explanation on why we do this
15845                  * in a weird way to avoid compiler warnings.)
15846                  */
15847                 if (   intro
15848                     && (8*sizeof(base) >
15849                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15850                         ? (Size_t)base
15851                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15852                         ) >
15853                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15854                 )
15855                     break;
15856
15857                 /* Success! We've got another valid pad op to optimise away */
15858                 count++;
15859                 followop = p->op_next;
15860             }
15861
15862             if (count < 1 || (count == 1 && !defav))
15863                 break;
15864
15865             /* pp_padrange in specifically compile-time void context
15866              * skips pushing a mark and lexicals; in all other contexts
15867              * (including unknown till runtime) it pushes a mark and the
15868              * lexicals. We must be very careful then, that the ops we
15869              * optimise away would have exactly the same effect as the
15870              * padrange.
15871              * In particular in void context, we can only optimise to
15872              * a padrange if we see the complete sequence
15873              *     pushmark, pad*v, ...., list
15874              * which has the net effect of leaving the markstack as it
15875              * was.  Not pushing onto the stack (whereas padsv does touch
15876              * the stack) makes no difference in void context.
15877              */
15878             assert(followop);
15879             if (gvoid) {
15880                 if (followop->op_type == OP_LIST
15881                         && OP_GIMME(followop,0) == G_VOID
15882                    )
15883                 {
15884                     followop = followop->op_next; /* skip OP_LIST */
15885
15886                     /* consolidate two successive my(...);'s */
15887
15888                     if (   oldoldop
15889                         && oldoldop->op_type == OP_PADRANGE
15890                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15891                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15892                         && !(oldoldop->op_flags & OPf_SPECIAL)
15893                     ) {
15894                         U8 old_count;
15895                         assert(oldoldop->op_next == oldop);
15896                         assert(   oldop->op_type == OP_NEXTSTATE
15897                                || oldop->op_type == OP_DBSTATE);
15898                         assert(oldop->op_next == o);
15899
15900                         old_count
15901                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15902
15903                        /* Do not assume pad offsets for $c and $d are con-
15904                           tiguous in
15905                             my ($a,$b,$c);
15906                             my ($d,$e,$f);
15907                         */
15908                         if (  oldoldop->op_targ + old_count == base
15909                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15910                             base = oldoldop->op_targ;
15911                             count += old_count;
15912                             reuse = 1;
15913                         }
15914                     }
15915
15916                     /* if there's any immediately following singleton
15917                      * my var's; then swallow them and the associated
15918                      * nextstates; i.e.
15919                      *    my ($a,$b); my $c; my $d;
15920                      * is treated as
15921                      *    my ($a,$b,$c,$d);
15922                      */
15923
15924                     while (    ((p = followop->op_next))
15925                             && (  p->op_type == OP_PADSV
15926                                || p->op_type == OP_PADAV
15927                                || p->op_type == OP_PADHV)
15928                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15929                             && (p->op_private & OPpLVAL_INTRO) == intro
15930                             && !(p->op_private & ~OPpLVAL_INTRO)
15931                             && p->op_next
15932                             && (   p->op_next->op_type == OP_NEXTSTATE
15933                                 || p->op_next->op_type == OP_DBSTATE)
15934                             && count < OPpPADRANGE_COUNTMASK
15935                             && base + count == p->op_targ
15936                     ) {
15937                         count++;
15938                         followop = p->op_next;
15939                     }
15940                 }
15941                 else
15942                     break;
15943             }
15944
15945             if (reuse) {
15946                 assert(oldoldop->op_type == OP_PADRANGE);
15947                 oldoldop->op_next = followop;
15948                 oldoldop->op_private = (intro | count);
15949                 o = oldoldop;
15950                 oldop = NULL;
15951                 oldoldop = NULL;
15952             }
15953             else {
15954                 /* Convert the pushmark into a padrange.
15955                  * To make Deparse easier, we guarantee that a padrange was
15956                  * *always* formerly a pushmark */
15957                 assert(o->op_type == OP_PUSHMARK);
15958                 o->op_next = followop;
15959                 OpTYPE_set(o, OP_PADRANGE);
15960                 o->op_targ = base;
15961                 /* bit 7: INTRO; bit 6..0: count */
15962                 o->op_private = (intro | count);
15963                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15964                               | gvoid * OPf_WANT_VOID
15965                               | (defav ? OPf_SPECIAL : 0));
15966             }
15967             break;
15968         }
15969
15970         case OP_RV2AV:
15971             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15972                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15973             break;
15974
15975         case OP_RV2HV:
15976         case OP_PADHV:
15977             /*'keys %h' in void or scalar context: skip the OP_KEYS
15978              * and perform the functionality directly in the RV2HV/PADHV
15979              * op
15980              */
15981             if (o->op_flags & OPf_REF) {
15982                 OP *k = o->op_next;
15983                 U8 want = (k->op_flags & OPf_WANT);
15984                 if (   k
15985                     && k->op_type == OP_KEYS
15986                     && (   want == OPf_WANT_VOID
15987                         || want == OPf_WANT_SCALAR)
15988                     && !(k->op_private & OPpMAYBE_LVSUB)
15989                     && !(k->op_flags & OPf_MOD)
15990                 ) {
15991                     o->op_next     = k->op_next;
15992                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15993                     o->op_flags   |= want;
15994                     o->op_private |= (o->op_type == OP_PADHV ?
15995                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15996                     /* for keys(%lex), hold onto the OP_KEYS's targ
15997                      * since padhv doesn't have its own targ to return
15998                      * an int with */
15999                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16000                         op_null(k);
16001                 }
16002             }
16003
16004             /* see if %h is used in boolean context */
16005             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16006                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16007
16008
16009             if (o->op_type != OP_PADHV)
16010                 break;
16011             /* FALLTHROUGH */
16012         case OP_PADAV:
16013             if (   o->op_type == OP_PADAV
16014                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16015             )
16016                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16017             /* FALLTHROUGH */
16018         case OP_PADSV:
16019             /* Skip over state($x) in void context.  */
16020             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16021              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16022             {
16023                 oldop->op_next = o->op_next;
16024                 goto redo_nextstate;
16025             }
16026             if (o->op_type != OP_PADAV)
16027                 break;
16028             /* FALLTHROUGH */
16029         case OP_GV:
16030             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16031                 OP* const pop = (o->op_type == OP_PADAV) ?
16032                             o->op_next : o->op_next->op_next;
16033                 IV i;
16034                 if (pop && pop->op_type == OP_CONST &&
16035                     ((PL_op = pop->op_next)) &&
16036                     pop->op_next->op_type == OP_AELEM &&
16037                     !(pop->op_next->op_private &
16038                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16039                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16040                 {
16041                     GV *gv;
16042                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16043                         no_bareword_allowed(pop);
16044                     if (o->op_type == OP_GV)
16045                         op_null(o->op_next);
16046                     op_null(pop->op_next);
16047                     op_null(pop);
16048                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16049                     o->op_next = pop->op_next->op_next;
16050                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16051                     o->op_private = (U8)i;
16052                     if (o->op_type == OP_GV) {
16053                         gv = cGVOPo_gv;
16054                         GvAVn(gv);
16055                         o->op_type = OP_AELEMFAST;
16056                     }
16057                     else
16058                         o->op_type = OP_AELEMFAST_LEX;
16059                 }
16060                 if (o->op_type != OP_GV)
16061                     break;
16062             }
16063
16064             /* Remove $foo from the op_next chain in void context.  */
16065             if (oldop
16066              && (  o->op_next->op_type == OP_RV2SV
16067                 || o->op_next->op_type == OP_RV2AV
16068                 || o->op_next->op_type == OP_RV2HV  )
16069              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16070              && !(o->op_next->op_private & OPpLVAL_INTRO))
16071             {
16072                 oldop->op_next = o->op_next->op_next;
16073                 /* Reprocess the previous op if it is a nextstate, to
16074                    allow double-nextstate optimisation.  */
16075               redo_nextstate:
16076                 if (oldop->op_type == OP_NEXTSTATE) {
16077                     oldop->op_opt = 0;
16078                     o = oldop;
16079                     oldop = oldoldop;
16080                     oldoldop = NULL;
16081                     goto redo;
16082                 }
16083                 o = oldop->op_next;
16084                 goto redo;
16085             }
16086             else if (o->op_next->op_type == OP_RV2SV) {
16087                 if (!(o->op_next->op_private & OPpDEREF)) {
16088                     op_null(o->op_next);
16089                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16090                                                                | OPpOUR_INTRO);
16091                     o->op_next = o->op_next->op_next;
16092                     OpTYPE_set(o, OP_GVSV);
16093                 }
16094             }
16095             else if (o->op_next->op_type == OP_READLINE
16096                     && o->op_next->op_next->op_type == OP_CONCAT
16097                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16098             {
16099                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16100                 OpTYPE_set(o, OP_RCATLINE);
16101                 o->op_flags |= OPf_STACKED;
16102                 op_null(o->op_next->op_next);
16103                 op_null(o->op_next);
16104             }
16105
16106             break;
16107
16108         case OP_NOT:
16109             break;
16110
16111         case OP_AND:
16112         case OP_OR:
16113         case OP_DOR:
16114             while (cLOGOP->op_other->op_type == OP_NULL)
16115                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16116             while (o->op_next && (   o->op_type == o->op_next->op_type
16117                                   || o->op_next->op_type == OP_NULL))
16118                 o->op_next = o->op_next->op_next;
16119
16120             /* If we're an OR and our next is an AND in void context, we'll
16121                follow its op_other on short circuit, same for reverse.
16122                We can't do this with OP_DOR since if it's true, its return
16123                value is the underlying value which must be evaluated
16124                by the next op. */
16125             if (o->op_next &&
16126                 (
16127                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16128                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16129                 )
16130                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16131             ) {
16132                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16133             }
16134             DEFER(cLOGOP->op_other);
16135             o->op_opt = 1;
16136             break;
16137
16138         case OP_GREPWHILE:
16139             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16140                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16141             /* FALLTHROUGH */
16142         case OP_COND_EXPR:
16143         case OP_MAPWHILE:
16144         case OP_ANDASSIGN:
16145         case OP_ORASSIGN:
16146         case OP_DORASSIGN:
16147         case OP_RANGE:
16148         case OP_ONCE:
16149         case OP_ARGDEFELEM:
16150             while (cLOGOP->op_other->op_type == OP_NULL)
16151                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16152             DEFER(cLOGOP->op_other);
16153             break;
16154
16155         case OP_ENTERLOOP:
16156         case OP_ENTERITER:
16157             while (cLOOP->op_redoop->op_type == OP_NULL)
16158                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16159             while (cLOOP->op_nextop->op_type == OP_NULL)
16160                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16161             while (cLOOP->op_lastop->op_type == OP_NULL)
16162                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16163             /* a while(1) loop doesn't have an op_next that escapes the
16164              * loop, so we have to explicitly follow the op_lastop to
16165              * process the rest of the code */
16166             DEFER(cLOOP->op_lastop);
16167             break;
16168
16169         case OP_ENTERTRY:
16170             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16171             DEFER(cLOGOPo->op_other);
16172             break;
16173
16174         case OP_SUBST:
16175             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16176                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16177             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16178             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16179                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16180                 cPMOP->op_pmstashstartu.op_pmreplstart
16181                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16182             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16183             break;
16184
16185         case OP_SORT: {
16186             OP *oright;
16187
16188             if (o->op_flags & OPf_SPECIAL) {
16189                 /* first arg is a code block */
16190                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16191                 OP * kid          = cUNOPx(nullop)->op_first;
16192
16193                 assert(nullop->op_type == OP_NULL);
16194                 assert(kid->op_type == OP_SCOPE
16195                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16196                 /* since OP_SORT doesn't have a handy op_other-style
16197                  * field that can point directly to the start of the code
16198                  * block, store it in the otherwise-unused op_next field
16199                  * of the top-level OP_NULL. This will be quicker at
16200                  * run-time, and it will also allow us to remove leading
16201                  * OP_NULLs by just messing with op_nexts without
16202                  * altering the basic op_first/op_sibling layout. */
16203                 kid = kLISTOP->op_first;
16204                 assert(
16205                       (kid->op_type == OP_NULL
16206                       && (  kid->op_targ == OP_NEXTSTATE
16207                          || kid->op_targ == OP_DBSTATE  ))
16208                     || kid->op_type == OP_STUB
16209                     || kid->op_type == OP_ENTER
16210                     || (PL_parser && PL_parser->error_count));
16211                 nullop->op_next = kid->op_next;
16212                 DEFER(nullop->op_next);
16213             }
16214
16215             /* check that RHS of sort is a single plain array */
16216             oright = cUNOPo->op_first;
16217             if (!oright || oright->op_type != OP_PUSHMARK)
16218                 break;
16219
16220             if (o->op_private & OPpSORT_INPLACE)
16221                 break;
16222
16223             /* reverse sort ... can be optimised.  */
16224             if (!OpHAS_SIBLING(cUNOPo)) {
16225                 /* Nothing follows us on the list. */
16226                 OP * const reverse = o->op_next;
16227
16228                 if (reverse->op_type == OP_REVERSE &&
16229                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16230                     OP * const pushmark = cUNOPx(reverse)->op_first;
16231                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16232                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16233                         /* reverse -> pushmark -> sort */
16234                         o->op_private |= OPpSORT_REVERSE;
16235                         op_null(reverse);
16236                         pushmark->op_next = oright->op_next;
16237                         op_null(oright);
16238                     }
16239                 }
16240             }
16241
16242             break;
16243         }
16244
16245         case OP_REVERSE: {
16246             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16247             OP *gvop = NULL;
16248             LISTOP *enter, *exlist;
16249
16250             if (o->op_private & OPpSORT_INPLACE)
16251                 break;
16252
16253             enter = (LISTOP *) o->op_next;
16254             if (!enter)
16255                 break;
16256             if (enter->op_type == OP_NULL) {
16257                 enter = (LISTOP *) enter->op_next;
16258                 if (!enter)
16259                     break;
16260             }
16261             /* for $a (...) will have OP_GV then OP_RV2GV here.
16262                for (...) just has an OP_GV.  */
16263             if (enter->op_type == OP_GV) {
16264                 gvop = (OP *) enter;
16265                 enter = (LISTOP *) enter->op_next;
16266                 if (!enter)
16267                     break;
16268                 if (enter->op_type == OP_RV2GV) {
16269                   enter = (LISTOP *) enter->op_next;
16270                   if (!enter)
16271                     break;
16272                 }
16273             }
16274
16275             if (enter->op_type != OP_ENTERITER)
16276                 break;
16277
16278             iter = enter->op_next;
16279             if (!iter || iter->op_type != OP_ITER)
16280                 break;
16281
16282             expushmark = enter->op_first;
16283             if (!expushmark || expushmark->op_type != OP_NULL
16284                 || expushmark->op_targ != OP_PUSHMARK)
16285                 break;
16286
16287             exlist = (LISTOP *) OpSIBLING(expushmark);
16288             if (!exlist || exlist->op_type != OP_NULL
16289                 || exlist->op_targ != OP_LIST)
16290                 break;
16291
16292             if (exlist->op_last != o) {
16293                 /* Mmm. Was expecting to point back to this op.  */
16294                 break;
16295             }
16296             theirmark = exlist->op_first;
16297             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16298                 break;
16299
16300             if (OpSIBLING(theirmark) != o) {
16301                 /* There's something between the mark and the reverse, eg
16302                    for (1, reverse (...))
16303                    so no go.  */
16304                 break;
16305             }
16306
16307             ourmark = ((LISTOP *)o)->op_first;
16308             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16309                 break;
16310
16311             ourlast = ((LISTOP *)o)->op_last;
16312             if (!ourlast || ourlast->op_next != o)
16313                 break;
16314
16315             rv2av = OpSIBLING(ourmark);
16316             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16317                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16318                 /* We're just reversing a single array.  */
16319                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16320                 enter->op_flags |= OPf_STACKED;
16321             }
16322
16323             /* We don't have control over who points to theirmark, so sacrifice
16324                ours.  */
16325             theirmark->op_next = ourmark->op_next;
16326             theirmark->op_flags = ourmark->op_flags;
16327             ourlast->op_next = gvop ? gvop : (OP *) enter;
16328             op_null(ourmark);
16329             op_null(o);
16330             enter->op_private |= OPpITER_REVERSED;
16331             iter->op_private |= OPpITER_REVERSED;
16332
16333             oldoldop = NULL;
16334             oldop    = ourlast;
16335             o        = oldop->op_next;
16336             goto redo;
16337             NOT_REACHED; /* NOTREACHED */
16338             break;
16339         }
16340
16341         case OP_QR:
16342         case OP_MATCH:
16343             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16344                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16345             }
16346             break;
16347
16348         case OP_RUNCV:
16349             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16350              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16351             {
16352                 SV *sv;
16353                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16354                 else {
16355                     sv = newRV((SV *)PL_compcv);
16356                     sv_rvweaken(sv);
16357                     SvREADONLY_on(sv);
16358                 }
16359                 OpTYPE_set(o, OP_CONST);
16360                 o->op_flags |= OPf_SPECIAL;
16361                 cSVOPo->op_sv = sv;
16362             }
16363             break;
16364
16365         case OP_SASSIGN:
16366             if (OP_GIMME(o,0) == G_VOID
16367              || (  o->op_next->op_type == OP_LINESEQ
16368                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16369                    || (  o->op_next->op_next->op_type == OP_RETURN
16370                       && !CvLVALUE(PL_compcv)))))
16371             {
16372                 OP *right = cBINOP->op_first;
16373                 if (right) {
16374                     /*   sassign
16375                     *      RIGHT
16376                     *      substr
16377                     *         pushmark
16378                     *         arg1
16379                     *         arg2
16380                     *         ...
16381                     * becomes
16382                     *
16383                     *  ex-sassign
16384                     *     substr
16385                     *        pushmark
16386                     *        RIGHT
16387                     *        arg1
16388                     *        arg2
16389                     *        ...
16390                     */
16391                     OP *left = OpSIBLING(right);
16392                     if (left->op_type == OP_SUBSTR
16393                          && (left->op_private & 7) < 4) {
16394                         op_null(o);
16395                         /* cut out right */
16396                         op_sibling_splice(o, NULL, 1, NULL);
16397                         /* and insert it as second child of OP_SUBSTR */
16398                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16399                                     right);
16400                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16401                         left->op_flags =
16402                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16403                     }
16404                 }
16405             }
16406             break;
16407
16408         case OP_AASSIGN: {
16409             int l, r, lr, lscalars, rscalars;
16410
16411             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16412                Note that we do this now rather than in newASSIGNOP(),
16413                since only by now are aliased lexicals flagged as such
16414
16415                See the essay "Common vars in list assignment" above for
16416                the full details of the rationale behind all the conditions
16417                below.
16418
16419                PL_generation sorcery:
16420                To detect whether there are common vars, the global var
16421                PL_generation is incremented for each assign op we scan.
16422                Then we run through all the lexical variables on the LHS,
16423                of the assignment, setting a spare slot in each of them to
16424                PL_generation.  Then we scan the RHS, and if any lexicals
16425                already have that value, we know we've got commonality.
16426                Also, if the generation number is already set to
16427                PERL_INT_MAX, then the variable is involved in aliasing, so
16428                we also have potential commonality in that case.
16429              */
16430
16431             PL_generation++;
16432             /* scan LHS */
16433             lscalars = 0;
16434             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16435             /* scan RHS */
16436             rscalars = 0;
16437             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16438             lr = (l|r);
16439
16440
16441             /* After looking for things which are *always* safe, this main
16442              * if/else chain selects primarily based on the type of the
16443              * LHS, gradually working its way down from the more dangerous
16444              * to the more restrictive and thus safer cases */
16445
16446             if (   !l                      /* () = ....; */
16447                 || !r                      /* .... = (); */
16448                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16449                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16450                 || (lscalars < 2)          /* ($x, undef) = ... */
16451             ) {
16452                 NOOP; /* always safe */
16453             }
16454             else if (l & AAS_DANGEROUS) {
16455                 /* always dangerous */
16456                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16457                 o->op_private |= OPpASSIGN_COMMON_AGG;
16458             }
16459             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16460                 /* package vars are always dangerous - too many
16461                  * aliasing possibilities */
16462                 if (l & AAS_PKG_SCALAR)
16463                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16464                 if (l & AAS_PKG_AGG)
16465                     o->op_private |= OPpASSIGN_COMMON_AGG;
16466             }
16467             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16468                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16469             {
16470                 /* LHS contains only lexicals and safe ops */
16471
16472                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16473                     o->op_private |= OPpASSIGN_COMMON_AGG;
16474
16475                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16476                     if (lr & AAS_LEX_SCALAR_COMM)
16477                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16478                     else if (   !(l & AAS_LEX_SCALAR)
16479                              && (r & AAS_DEFAV))
16480                     {
16481                         /* falsely mark
16482                          *    my (...) = @_
16483                          * as scalar-safe for performance reasons.
16484                          * (it will still have been marked _AGG if necessary */
16485                         NOOP;
16486                     }
16487                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16488                         /* if there are only lexicals on the LHS and no
16489                          * common ones on the RHS, then we assume that the
16490                          * only way those lexicals could also get
16491                          * on the RHS is via some sort of dereffing or
16492                          * closure, e.g.
16493                          *    $r = \$lex;
16494                          *    ($lex, $x) = (1, $$r)
16495                          * and in this case we assume the var must have
16496                          *  a bumped ref count. So if its ref count is 1,
16497                          *  it must only be on the LHS.
16498                          */
16499                         o->op_private |= OPpASSIGN_COMMON_RC1;
16500                 }
16501             }
16502
16503             /* ... = ($x)
16504              * may have to handle aggregate on LHS, but we can't
16505              * have common scalars. */
16506             if (rscalars < 2)
16507                 o->op_private &=
16508                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16509
16510             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16511                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16512             break;
16513         }
16514
16515         case OP_REF:
16516             /* see if ref() is used in boolean context */
16517             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16518                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16519             break;
16520
16521         case OP_LENGTH:
16522             /* see if the op is used in known boolean context,
16523              * but not if OA_TARGLEX optimisation is enabled */
16524             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16525                 && !(o->op_private & OPpTARGET_MY)
16526             )
16527                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16528             break;
16529
16530         case OP_POS:
16531             /* see if the op is used in known boolean context */
16532             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16533                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16534             break;
16535
16536         case OP_CUSTOM: {
16537             Perl_cpeep_t cpeep =
16538                 XopENTRYCUSTOM(o, xop_peep);
16539             if (cpeep)
16540                 cpeep(aTHX_ o, oldop);
16541             break;
16542         }
16543
16544         }
16545         /* did we just null the current op? If so, re-process it to handle
16546          * eliding "empty" ops from the chain */
16547         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16548             o->op_opt = 0;
16549             o = oldop;
16550         }
16551         else {
16552             oldoldop = oldop;
16553             oldop = o;
16554         }
16555     }
16556     LEAVE;
16557 }
16558
16559 void
16560 Perl_peep(pTHX_ OP *o)
16561 {
16562     CALL_RPEEP(o);
16563 }
16564
16565 /*
16566 =head1 Custom Operators
16567
16568 =for apidoc Ao||custom_op_xop
16569 Return the XOP structure for a given custom op.  This macro should be
16570 considered internal to C<OP_NAME> and the other access macros: use them instead.
16571 This macro does call a function.  Prior
16572 to 5.19.6, this was implemented as a
16573 function.
16574
16575 =cut
16576 */
16577
16578 XOPRETANY
16579 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16580 {
16581     SV *keysv;
16582     HE *he = NULL;
16583     XOP *xop;
16584
16585     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16586
16587     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16588     assert(o->op_type == OP_CUSTOM);
16589
16590     /* This is wrong. It assumes a function pointer can be cast to IV,
16591      * which isn't guaranteed, but this is what the old custom OP code
16592      * did. In principle it should be safer to Copy the bytes of the
16593      * pointer into a PV: since the new interface is hidden behind
16594      * functions, this can be changed later if necessary.  */
16595     /* Change custom_op_xop if this ever happens */
16596     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16597
16598     if (PL_custom_ops)
16599         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16600
16601     /* assume noone will have just registered a desc */
16602     if (!he && PL_custom_op_names &&
16603         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16604     ) {
16605         const char *pv;
16606         STRLEN l;
16607
16608         /* XXX does all this need to be shared mem? */
16609         Newxz(xop, 1, XOP);
16610         pv = SvPV(HeVAL(he), l);
16611         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16612         if (PL_custom_op_descs &&
16613             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16614         ) {
16615             pv = SvPV(HeVAL(he), l);
16616             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16617         }
16618         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16619     }
16620     else {
16621         if (!he)
16622             xop = (XOP *)&xop_null;
16623         else
16624             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16625     }
16626     {
16627         XOPRETANY any;
16628         if(field == XOPe_xop_ptr) {
16629             any.xop_ptr = xop;
16630         } else {
16631             const U32 flags = XopFLAGS(xop);
16632             if(flags & field) {
16633                 switch(field) {
16634                 case XOPe_xop_name:
16635                     any.xop_name = xop->xop_name;
16636                     break;
16637                 case XOPe_xop_desc:
16638                     any.xop_desc = xop->xop_desc;
16639                     break;
16640                 case XOPe_xop_class:
16641                     any.xop_class = xop->xop_class;
16642                     break;
16643                 case XOPe_xop_peep:
16644                     any.xop_peep = xop->xop_peep;
16645                     break;
16646                 default:
16647                     NOT_REACHED; /* NOTREACHED */
16648                     break;
16649                 }
16650             } else {
16651                 switch(field) {
16652                 case XOPe_xop_name:
16653                     any.xop_name = XOPd_xop_name;
16654                     break;
16655                 case XOPe_xop_desc:
16656                     any.xop_desc = XOPd_xop_desc;
16657                     break;
16658                 case XOPe_xop_class:
16659                     any.xop_class = XOPd_xop_class;
16660                     break;
16661                 case XOPe_xop_peep:
16662                     any.xop_peep = XOPd_xop_peep;
16663                     break;
16664                 default:
16665                     NOT_REACHED; /* NOTREACHED */
16666                     break;
16667                 }
16668             }
16669         }
16670         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16671          * op.c: In function 'Perl_custom_op_get_field':
16672          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16673          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16674          * expands to assert(0), which expands to ((0) ? (void)0 :
16675          * __assert(...)), and gcc doesn't know that __assert can never return. */
16676         return any;
16677     }
16678 }
16679
16680 /*
16681 =for apidoc Ao||custom_op_register
16682 Register a custom op.  See L<perlguts/"Custom Operators">.
16683
16684 =cut
16685 */
16686
16687 void
16688 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16689 {
16690     SV *keysv;
16691
16692     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16693
16694     /* see the comment in custom_op_xop */
16695     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16696
16697     if (!PL_custom_ops)
16698         PL_custom_ops = newHV();
16699
16700     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16701         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16702 }
16703
16704 /*
16705
16706 =for apidoc core_prototype
16707
16708 This function assigns the prototype of the named core function to C<sv>, or
16709 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16710 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16711 by C<keyword()>.  It must not be equal to 0.
16712
16713 =cut
16714 */
16715
16716 SV *
16717 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16718                           int * const opnum)
16719 {
16720     int i = 0, n = 0, seen_question = 0, defgv = 0;
16721     I32 oa;
16722 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16723     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16724     bool nullret = FALSE;
16725
16726     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16727
16728     assert (code);
16729
16730     if (!sv) sv = sv_newmortal();
16731
16732 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16733
16734     switch (code < 0 ? -code : code) {
16735     case KEY_and   : case KEY_chop: case KEY_chomp:
16736     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16737     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16738     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16739     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16740     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16741     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16742     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16743     case KEY_x     : case KEY_xor    :
16744         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16745     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16746     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16747     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16748     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16749     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16750     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16751         retsetpvs("", 0);
16752     case KEY_evalbytes:
16753         name = "entereval"; break;
16754     case KEY_readpipe:
16755         name = "backtick";
16756     }
16757
16758 #undef retsetpvs
16759
16760   findopnum:
16761     while (i < MAXO) {  /* The slow way. */
16762         if (strEQ(name, PL_op_name[i])
16763             || strEQ(name, PL_op_desc[i]))
16764         {
16765             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16766             goto found;
16767         }
16768         i++;
16769     }
16770     return NULL;
16771   found:
16772     defgv = PL_opargs[i] & OA_DEFGV;
16773     oa = PL_opargs[i] >> OASHIFT;
16774     while (oa) {
16775         if (oa & OA_OPTIONAL && !seen_question && (
16776               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16777         )) {
16778             seen_question = 1;
16779             str[n++] = ';';
16780         }
16781         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16782             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16783             /* But globs are already references (kinda) */
16784             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16785         ) {
16786             str[n++] = '\\';
16787         }
16788         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16789          && !scalar_mod_type(NULL, i)) {
16790             str[n++] = '[';
16791             str[n++] = '$';
16792             str[n++] = '@';
16793             str[n++] = '%';
16794             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16795             str[n++] = '*';
16796             str[n++] = ']';
16797         }
16798         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16799         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16800             str[n-1] = '_'; defgv = 0;
16801         }
16802         oa = oa >> 4;
16803     }
16804     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16805     str[n++] = '\0';
16806     sv_setpvn(sv, str, n - 1);
16807     if (opnum) *opnum = i;
16808     return sv;
16809 }
16810
16811 OP *
16812 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16813                       const int opnum)
16814 {
16815     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16816     OP *o;
16817
16818     PERL_ARGS_ASSERT_CORESUB_OP;
16819
16820     switch(opnum) {
16821     case 0:
16822         return op_append_elem(OP_LINESEQ,
16823                        argop,
16824                        newSLICEOP(0,
16825                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16826                                   newOP(OP_CALLER,0)
16827                        )
16828                );
16829     case OP_EACH:
16830     case OP_KEYS:
16831     case OP_VALUES:
16832         o = newUNOP(OP_AVHVSWITCH,0,argop);
16833         o->op_private = opnum-OP_EACH;
16834         return o;
16835     case OP_SELECT: /* which represents OP_SSELECT as well */
16836         if (code)
16837             return newCONDOP(
16838                          0,
16839                          newBINOP(OP_GT, 0,
16840                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16841                                   newSVOP(OP_CONST, 0, newSVuv(1))
16842                                  ),
16843                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16844                                     OP_SSELECT),
16845                          coresub_op(coreargssv, 0, OP_SELECT)
16846                    );
16847         /* FALLTHROUGH */
16848     default:
16849         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16850         case OA_BASEOP:
16851             return op_append_elem(
16852                         OP_LINESEQ, argop,
16853                         newOP(opnum,
16854                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16855                                 ? OPpOFFBYONE << 8 : 0)
16856                    );
16857         case OA_BASEOP_OR_UNOP:
16858             if (opnum == OP_ENTEREVAL) {
16859                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16860                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16861             }
16862             else o = newUNOP(opnum,0,argop);
16863             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16864             else {
16865           onearg:
16866               if (is_handle_constructor(o, 1))
16867                 argop->op_private |= OPpCOREARGS_DEREF1;
16868               if (scalar_mod_type(NULL, opnum))
16869                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16870             }
16871             return o;
16872         default:
16873             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16874             if (is_handle_constructor(o, 2))
16875                 argop->op_private |= OPpCOREARGS_DEREF2;
16876             if (opnum == OP_SUBSTR) {
16877                 o->op_private |= OPpMAYBE_LVSUB;
16878                 return o;
16879             }
16880             else goto onearg;
16881         }
16882     }
16883 }
16884
16885 void
16886 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16887                                SV * const *new_const_svp)
16888 {
16889     const char *hvname;
16890     bool is_const = !!CvCONST(old_cv);
16891     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16892
16893     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16894
16895     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16896         return;
16897         /* They are 2 constant subroutines generated from
16898            the same constant. This probably means that
16899            they are really the "same" proxy subroutine
16900            instantiated in 2 places. Most likely this is
16901            when a constant is exported twice.  Don't warn.
16902         */
16903     if (
16904         (ckWARN(WARN_REDEFINE)
16905          && !(
16906                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16907              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16908              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16909                  strEQ(hvname, "autouse"))
16910              )
16911         )
16912      || (is_const
16913          && ckWARN_d(WARN_REDEFINE)
16914          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16915         )
16916     )
16917         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16918                           is_const
16919                             ? "Constant subroutine %" SVf " redefined"
16920                             : "Subroutine %" SVf " redefined",
16921                           SVfARG(name));
16922 }
16923
16924 /*
16925 =head1 Hook manipulation
16926
16927 These functions provide convenient and thread-safe means of manipulating
16928 hook variables.
16929
16930 =cut
16931 */
16932
16933 /*
16934 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16935
16936 Puts a C function into the chain of check functions for a specified op
16937 type.  This is the preferred way to manipulate the L</PL_check> array.
16938 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16939 is a pointer to the C function that is to be added to that opcode's
16940 check chain, and C<old_checker_p> points to the storage location where a
16941 pointer to the next function in the chain will be stored.  The value of
16942 C<new_checker> is written into the L</PL_check> array, while the value
16943 previously stored there is written to C<*old_checker_p>.
16944
16945 L</PL_check> is global to an entire process, and a module wishing to
16946 hook op checking may find itself invoked more than once per process,
16947 typically in different threads.  To handle that situation, this function
16948 is idempotent.  The location C<*old_checker_p> must initially (once
16949 per process) contain a null pointer.  A C variable of static duration
16950 (declared at file scope, typically also marked C<static> to give
16951 it internal linkage) will be implicitly initialised appropriately,
16952 if it does not have an explicit initialiser.  This function will only
16953 actually modify the check chain if it finds C<*old_checker_p> to be null.
16954 This function is also thread safe on the small scale.  It uses appropriate
16955 locking to avoid race conditions in accessing L</PL_check>.
16956
16957 When this function is called, the function referenced by C<new_checker>
16958 must be ready to be called, except for C<*old_checker_p> being unfilled.
16959 In a threading situation, C<new_checker> may be called immediately,
16960 even before this function has returned.  C<*old_checker_p> will always
16961 be appropriately set before C<new_checker> is called.  If C<new_checker>
16962 decides not to do anything special with an op that it is given (which
16963 is the usual case for most uses of op check hooking), it must chain the
16964 check function referenced by C<*old_checker_p>.
16965
16966 Taken all together, XS code to hook an op checker should typically look
16967 something like this:
16968
16969     static Perl_check_t nxck_frob;
16970     static OP *myck_frob(pTHX_ OP *op) {
16971         ...
16972         op = nxck_frob(aTHX_ op);
16973         ...
16974         return op;
16975     }
16976     BOOT:
16977         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16978
16979 If you want to influence compilation of calls to a specific subroutine,
16980 then use L</cv_set_call_checker_flags> rather than hooking checking of
16981 all C<entersub> ops.
16982
16983 =cut
16984 */
16985
16986 void
16987 Perl_wrap_op_checker(pTHX_ Optype opcode,
16988     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16989 {
16990     dVAR;
16991
16992     PERL_UNUSED_CONTEXT;
16993     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16994     if (*old_checker_p) return;
16995     OP_CHECK_MUTEX_LOCK;
16996     if (!*old_checker_p) {
16997         *old_checker_p = PL_check[opcode];
16998         PL_check[opcode] = new_checker;
16999     }
17000     OP_CHECK_MUTEX_UNLOCK;
17001 }
17002
17003 #include "XSUB.h"
17004
17005 /* Efficient sub that returns a constant scalar value. */
17006 static void
17007 const_sv_xsub(pTHX_ CV* cv)
17008 {
17009     dXSARGS;
17010     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17011     PERL_UNUSED_ARG(items);
17012     if (!sv) {
17013         XSRETURN(0);
17014     }
17015     EXTEND(sp, 1);
17016     ST(0) = sv;
17017     XSRETURN(1);
17018 }
17019
17020 static void
17021 const_av_xsub(pTHX_ CV* cv)
17022 {
17023     dXSARGS;
17024     AV * const av = MUTABLE_AV(XSANY.any_ptr);
17025     SP -= items;
17026     assert(av);
17027 #ifndef DEBUGGING
17028     if (!av) {
17029         XSRETURN(0);
17030     }
17031 #endif
17032     if (SvRMAGICAL(av))
17033         Perl_croak(aTHX_ "Magical list constants are not supported");
17034     if (GIMME_V != G_ARRAY) {
17035         EXTEND(SP, 1);
17036         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17037         XSRETURN(1);
17038     }
17039     EXTEND(SP, AvFILLp(av)+1);
17040     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17041     XSRETURN(AvFILLp(av)+1);
17042 }
17043
17044
17045 /*
17046  * ex: set ts=8 sts=4 sw=4 et:
17047  */