op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 /* make freed ops die if they're inadvertently executed */
 423 #ifdef DEBUGGING
 424 static OP *
 425 S_pp_freed(pTHX)
 426 {
 427     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 428 }
 429 #endif
 430
 431 void
 432 Perl_Slab_Free(pTHX_ void *op)
 433 {
 434     OP * const o = (OP *)op;
 435     OPSLAB *slab;
 436
 437     PERL_ARGS_ASSERT_SLAB_FREE;
 438
 439 #ifdef DEBUGGING
 440     o->op_ppaddr = S_pp_freed;
 441 #endif
 442
 443     if (!o->op_slabbed) {
 444         if (!o->op_static)
 445             PerlMemShared_free(op);
 446         return;
 447     }
 448
 449     slab = OpSLAB(o);
 450     /* If this op is already freed, our refcount will get screwy. */
 451     assert(o->op_type != OP_FREED);
 452     o->op_type = OP_FREED;
 453     o->op_next = slab->opslab_freed;
 454     slab->opslab_freed = o;
 455     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 456     OpslabREFCNT_dec_padok(slab);
 457 }
 458
 459 void
 460 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 461 {
 462     const bool havepad = !!PL_comppad;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 464     if (havepad) {
 465         ENTER;
 466         PAD_SAVE_SETNULLPAD();
 467     }
 468     opslab_free(slab);
 469     if (havepad) LEAVE;
 470 }
 471
 472 void
 473 Perl_opslab_free(pTHX_ OPSLAB *slab)
 474 {
 475     OPSLAB *slab2;
 476     PERL_ARGS_ASSERT_OPSLAB_FREE;
 477     PERL_UNUSED_CONTEXT;
 478     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 479     assert(slab->opslab_refcnt == 1);
 480     do {
 481         slab2 = slab->opslab_next;
 482 #ifdef DEBUGGING
 483         slab->opslab_refcnt = ~(size_t)0;
 484 #endif
 485 #ifdef PERL_DEBUG_READONLY_OPS
 486         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 487                                                (void*)slab));
 488         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 489             perror("munmap failed");
 490             abort();
 491         }
 492 #else
 493         PerlMemShared_free(slab);
 494 #endif
 495         slab = slab2;
 496     } while (slab);
 497 }
 498
 499 void
 500 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 501 {
 502     OPSLAB *slab2;
 503 #ifdef DEBUGGING
 504     size_t savestack_count = 0;
 505 #endif
 506     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 507     slab2 = slab;
 508     do {
 509         OPSLOT *slot;
 510         for (slot = slab2->opslab_first;
 511              slot->opslot_next;
 512              slot = slot->opslot_next) {
 513             if (slot->opslot_op.op_type != OP_FREED
 514              && !(slot->opslot_op.op_savefree
 515 #ifdef DEBUGGING
 516                   && ++savestack_count
 517 #endif
 518                  )
 519             ) {
 520                 assert(slot->opslot_op.op_slabbed);
 521                 op_free(&slot->opslot_op);
 522                 if (slab->opslab_refcnt == 1) goto free;
 523             }
 524         }
 525     } while ((slab2 = slab2->opslab_next));
 526     /* > 1 because the CV still holds a reference count. */
 527     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 528 #ifdef DEBUGGING
 529         assert(savestack_count == slab->opslab_refcnt-1);
 530 #endif
 531         /* Remove the CV’s reference count. */
 532         slab->opslab_refcnt--;
 533         return;
 534     }
 535    free:
 536     opslab_free(slab);
 537 }
 538
 539 #ifdef PERL_DEBUG_READONLY_OPS
 540 OP *
 541 Perl_op_refcnt_inc(pTHX_ OP *o)
 542 {
 543     if(o) {
 544         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 545         if (slab && slab->opslab_readonly) {
 546             Slab_to_rw(slab);
 547             ++o->op_targ;
 548             Slab_to_ro(slab);
 549         } else {
 550             ++o->op_targ;
 551         }
 552     }
 553     return o;
 554
 555 }
 556
 557 PADOFFSET
 558 Perl_op_refcnt_dec(pTHX_ OP *o)
 559 {
 560     PADOFFSET result;
 561     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 562
 563     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 564
 565     if (slab && slab->opslab_readonly) {
 566         Slab_to_rw(slab);
 567         result = --o->op_targ;
 568         Slab_to_ro(slab);
 569     } else {
 570         result = --o->op_targ;
 571     }
 572     return result;
 573 }
 574 #endif
 575 /*
 576  * In the following definition, the ", (OP*)0" is just to make the compiler
 577  * think the expression is of the right type: croak actually does a Siglongjmp.
 578  */
 579 #define CHECKOP(type,o) \
 580     ((PL_op_mask && PL_op_mask[type])                           \
 581      ? ( op_free((OP*)o),                                       \
 582          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 583          (OP*)0 )                                               \
 584      : PL_check[type](aTHX_ (OP*)o))
 585
 586 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 587
 588 #define OpTYPE_set(o,type) \
 589     STMT_START {                                \
 590         o->op_type = (OPCODE)type;              \
 591         o->op_ppaddr = PL_ppaddr[type];         \
 592     } STMT_END
 593
 594 STATIC OP *
 595 S_no_fh_allowed(pTHX_ OP *o)
 596 {
 597     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 598
 599     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 600                  OP_DESC(o)));
 601     return o;
 602 }
 603
 604 STATIC OP *
 605 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 606 {
 607     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 608     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 609     return o;
 610 }
 611
 612 STATIC OP *
 613 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 614 {
 615     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 616
 617     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 618     return o;
 619 }
 620
 621 STATIC void
 622 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 623 {
 624     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 625
 626     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 627                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 628 }
 629
 630 /* remove flags var, its unused in all callers, move to to right end since gv
 631   and kid are always the same */
 632 STATIC void
 633 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 634 {
 635     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 636     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 637
 638     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 639                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 640 }
 641
 642 STATIC void
 643 S_no_bareword_allowed(pTHX_ OP *o)
 644 {
 645     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 646
 647     qerror(Perl_mess(aTHX_
 648                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 649                      SVfARG(cSVOPo_sv)));
 650     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 651 }
 652
 653 /* "register" allocation */
 654
 655 PADOFFSET
 656 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 657 {
 658     PADOFFSET off;
 659     const bool is_our = (PL_parser->in_my == KEY_our);
 660
 661     PERL_ARGS_ASSERT_ALLOCMY;
 662
 663     if (flags & ~SVf_UTF8)
 664         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 665                    (UV)flags);
 666
 667     /* complain about "my $<special_var>" etc etc */
 668     if (   len
 669         && !(  is_our
 670             || isALPHA(name[1])
 671             || (   (flags & SVf_UTF8)
 672                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 673             || (name[1] == '_' && len > 2)))
 674     {
 675         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 676          && isASCII(name[1])
 677          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 678             /* diag_listed_as: Can't use global %s in "%s" */
 679             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 680                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 681                               PL_parser->in_my == KEY_state ? "state" : "my"));
 682         } else {
 683             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 684                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 685         }
 686     }
 687
 688     /* allocate a spare slot and store the name in that slot */
 689
 690     off = pad_add_name_pvn(name, len,
 691                        (is_our ? padadd_OUR :
 692                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 693                     PL_parser->in_my_stash,
 694                     (is_our
 695                         /* $_ is always in main::, even with our */
 696                         ? (PL_curstash && !memEQs(name,len,"$_")
 697                             ? PL_curstash
 698                             : PL_defstash)
 699                         : NULL
 700                     )
 701     );
 702     /* anon sub prototypes contains state vars should always be cloned,
 703      * otherwise the state var would be shared between anon subs */
 704
 705     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 706         CvCLONE_on(PL_compcv);
 707
 708     return off;
 709 }
 710
 711 /*
 712 =head1 Optree Manipulation Functions
 713
 714 =for apidoc alloccopstash
 715
 716 Available only under threaded builds, this function allocates an entry in
 717 C<PL_stashpad> for the stash passed to it.
 718
 719 =cut
 720 */
 721
 722 #ifdef USE_ITHREADS
 723 PADOFFSET
 724 Perl_alloccopstash(pTHX_ HV *hv)
 725 {
 726     PADOFFSET off = 0, o = 1;
 727     bool found_slot = FALSE;
 728
 729     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 730
 731     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 732
 733     for (; o < PL_stashpadmax; ++o) {
 734         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 735         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 736             found_slot = TRUE, off = o;
 737     }
 738     if (!found_slot) {
 739         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 740         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 741         off = PL_stashpadmax;
 742         PL_stashpadmax += 10;
 743     }
 744
 745     PL_stashpad[PL_stashpadix = off] = hv;
 746     return off;
 747 }
 748 #endif
 749
 750 /* free the body of an op without examining its contents.
 751  * Always use this rather than FreeOp directly */
 752
 753 static void
 754 S_op_destroy(pTHX_ OP *o)
 755 {
 756     FreeOp(o);
 757 }
 758
 759 /* Destructor */
 760
 761 /*
 762 =for apidoc Am|void|op_free|OP *o
 763
 764 Free an op.  Only use this when an op is no longer linked to from any
 765 optree.
 766
 767 =cut
 768 */
 769
 770 void
 771 Perl_op_free(pTHX_ OP *o)
 772 {
 773     dVAR;
 774     OPCODE type;
 775     SSize_t defer_ix = -1;
 776     SSize_t defer_stack_alloc = 0;
 777     OP **defer_stack = NULL;
 778
 779     do {
 780
 781         /* Though ops may be freed twice, freeing the op after its slab is a
 782            big no-no. */
 783         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 784         /* During the forced freeing of ops after compilation failure, kidops
 785            may be freed before their parents. */
 786         if (!o || o->op_type == OP_FREED)
 787             continue;
 788
 789         type = o->op_type;
 790
 791         /* an op should only ever acquire op_private flags that we know about.
 792          * If this fails, you may need to fix something in regen/op_private.
 793          * Don't bother testing if:
 794          *   * the op_ppaddr doesn't match the op; someone may have
 795          *     overridden the op and be doing strange things with it;
 796          *   * we've errored, as op flags are often left in an
 797          *     inconsistent state then. Note that an error when
 798          *     compiling the main program leaves PL_parser NULL, so
 799          *     we can't spot faults in the main code, only
 800          *     evaled/required code */
 801 #ifdef DEBUGGING
 802         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 803             && PL_parser
 804             && !PL_parser->error_count)
 805         {
 806             assert(!(o->op_private & ~PL_op_private_valid[type]));
 807         }
 808 #endif
 809
 810         if (o->op_private & OPpREFCOUNTED) {
 811             switch (type) {
 812             case OP_LEAVESUB:
 813             case OP_LEAVESUBLV:
 814             case OP_LEAVEEVAL:
 815             case OP_LEAVE:
 816             case OP_SCOPE:
 817             case OP_LEAVEWRITE:
 818                 {
 819                 PADOFFSET refcnt;
 820                 OP_REFCNT_LOCK;
 821                 refcnt = OpREFCNT_dec(o);
 822                 OP_REFCNT_UNLOCK;
 823                 if (refcnt) {
 824                     /* Need to find and remove any pattern match ops from the list
 825                        we maintain for reset().  */
 826                     find_and_forget_pmops(o);
 827                     continue;
 828                 }
 829                 }
 830                 break;
 831             default:
 832                 break;
 833             }
 834         }
 835
 836         /* Call the op_free hook if it has been set. Do it now so that it's called
 837          * at the right time for refcounted ops, but still before all of the kids
 838          * are freed. */
 839         CALL_OPFREEHOOK(o);
 840
 841         if (o->op_flags & OPf_KIDS) {
 842             OP *kid, *nextkid;
 843             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 844                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 845                 if (!kid || kid->op_type == OP_FREED)
 846                     /* During the forced freeing of ops after
 847                        compilation failure, kidops may be freed before
 848                        their parents. */
 849                     continue;
 850                 if (!(kid->op_flags & OPf_KIDS))
 851                     /* If it has no kids, just free it now */
 852                     op_free(kid);
 853                 else
 854                     DEFER_OP(kid);
 855             }
 856         }
 857         if (type == OP_NULL)
 858             type = (OPCODE)o->op_targ;
 859
 860         if (o->op_slabbed)
 861             Slab_to_rw(OpSLAB(o));
 862
 863         /* COP* is not cleared by op_clear() so that we may track line
 864          * numbers etc even after null() */
 865         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 866             cop_free((COP*)o);
 867         }
 868
 869         op_clear(o);
 870         FreeOp(o);
 871         if (PL_op == o)
 872             PL_op = NULL;
 873     } while ( (o = POP_DEFERRED_OP()) );
 874
 875     Safefree(defer_stack);
 876 }
 877
 878 /* S_op_clear_gv(): free a GV attached to an OP */
 879
 880 STATIC
 881 #ifdef USE_ITHREADS
 882 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 883 #else
 884 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 885 #endif
 886 {
 887
 888     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 889             || o->op_type == OP_MULTIDEREF)
 890 #ifdef USE_ITHREADS
 891                 && PL_curpad
 892                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 893 #else
 894                 ? (GV*)(*svp) : NULL;
 895 #endif
 896     /* It's possible during global destruction that the GV is freed
 897        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 898        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 899        will trigger an assertion failure, because the entry to sv_clear
 900        checks that the scalar is not already freed.  A check of for
 901        !SvIS_FREED(gv) turns out to be invalid, because during global
 902        destruction the reference count can be forced down to zero
 903        (with SVf_BREAK set).  In which case raising to 1 and then
 904        dropping to 0 triggers cleanup before it should happen.  I
 905        *think* that this might actually be a general, systematic,
 906        weakness of the whole idea of SVf_BREAK, in that code *is*
 907        allowed to raise and lower references during global destruction,
 908        so any *valid* code that happens to do this during global
 909        destruction might well trigger premature cleanup.  */
 910     bool still_valid = gv && SvREFCNT(gv);
 911
 912     if (still_valid)
 913         SvREFCNT_inc_simple_void(gv);
 914 #ifdef USE_ITHREADS
 915     if (*ixp > 0) {
 916         pad_swipe(*ixp, TRUE);
 917         *ixp = 0;
 918     }
 919 #else
 920     SvREFCNT_dec(*svp);
 921     *svp = NULL;
 922 #endif
 923     if (still_valid) {
 924         int try_downgrade = SvREFCNT(gv) == 2;
 925         SvREFCNT_dec_NN(gv);
 926         if (try_downgrade)
 927             gv_try_downgrade(gv);
 928     }
 929 }
 930
 931
 932 void
 933 Perl_op_clear(pTHX_ OP *o)
 934 {
 935
 936     dVAR;
 937
 938     PERL_ARGS_ASSERT_OP_CLEAR;
 939
 940     switch (o->op_type) {
 941     case OP_NULL:       /* Was holding old type, if any. */
 942         /* FALLTHROUGH */
 943     case OP_ENTERTRY:
 944     case OP_ENTEREVAL:  /* Was holding hints. */
 945     case OP_ARGDEFELEM: /* Was holding signature index. */
 946         o->op_targ = 0;
 947         break;
 948     default:
 949         if (!(o->op_flags & OPf_REF)
 950             || (PL_check[o->op_type] != Perl_ck_ftst))
 951             break;
 952         /* FALLTHROUGH */
 953     case OP_GVSV:
 954     case OP_GV:
 955     case OP_AELEMFAST:
 956 #ifdef USE_ITHREADS
 957             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 958 #else
 959             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 960 #endif
 961         break;
 962     case OP_METHOD_REDIR:
 963     case OP_METHOD_REDIR_SUPER:
 964 #ifdef USE_ITHREADS
 965         if (cMETHOPx(o)->op_rclass_targ) {
 966             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 967             cMETHOPx(o)->op_rclass_targ = 0;
 968         }
 969 #else
 970         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 971         cMETHOPx(o)->op_rclass_sv = NULL;
 972 #endif
 973         /* FALLTHROUGH */
 974     case OP_METHOD_NAMED:
 975     case OP_METHOD_SUPER:
 976         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 977         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 978 #ifdef USE_ITHREADS
 979         if (o->op_targ) {
 980             pad_swipe(o->op_targ, 1);
 981             o->op_targ = 0;
 982         }
 983 #endif
 984         break;
 985     case OP_CONST:
 986     case OP_HINTSEVAL:
 987         SvREFCNT_dec(cSVOPo->op_sv);
 988         cSVOPo->op_sv = NULL;
 989 #ifdef USE_ITHREADS
 990         /** Bug #15654
 991           Even if op_clear does a pad_free for the target of the op,
 992           pad_free doesn't actually remove the sv that exists in the pad;
 993           instead it lives on. This results in that it could be reused as
 994           a target later on when the pad was reallocated.
 995         **/
 996         if(o->op_targ) {
 997           pad_swipe(o->op_targ,1);
 998           o->op_targ = 0;
 999         }
1000 #endif
1001         break;
1002     case OP_DUMP:
1003     case OP_GOTO:
1004     case OP_NEXT:
1005     case OP_LAST:
1006     case OP_REDO:
1007         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1008             break;
1009         /* FALLTHROUGH */
1010     case OP_TRANS:
1011     case OP_TRANSR:
1012         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1013             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1014         {
1015 #ifdef USE_ITHREADS
1016             if (cPADOPo->op_padix > 0) {
1017                 pad_swipe(cPADOPo->op_padix, TRUE);
1018                 cPADOPo->op_padix = 0;
1019             }
1020 #else
1021             SvREFCNT_dec(cSVOPo->op_sv);
1022             cSVOPo->op_sv = NULL;
1023 #endif
1024         }
1025         else {
1026             PerlMemShared_free(cPVOPo->op_pv);
1027             cPVOPo->op_pv = NULL;
1028         }
1029         break;
1030     case OP_SUBST:
1031         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1032         goto clear_pmop;
1033
1034     case OP_SPLIT:
1035         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1036             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1037         {
1038             if (o->op_private & OPpSPLIT_LEX)
1039                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1040             else
1041 #ifdef USE_ITHREADS
1042                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1043 #else
1044                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1045 #endif
1046         }
1047         /* FALLTHROUGH */
1048     case OP_MATCH:
1049     case OP_QR:
1050     clear_pmop:
1051         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1052             op_free(cPMOPo->op_code_list);
1053         cPMOPo->op_code_list = NULL;
1054         forget_pmop(cPMOPo);
1055         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1056         /* we use the same protection as the "SAFE" version of the PM_ macros
1057          * here since sv_clean_all might release some PMOPs
1058          * after PL_regex_padav has been cleared
1059          * and the clearing of PL_regex_padav needs to
1060          * happen before sv_clean_all
1061          */
1062 #ifdef USE_ITHREADS
1063         if(PL_regex_pad) {        /* We could be in destruction */
1064             const IV offset = (cPMOPo)->op_pmoffset;
1065             ReREFCNT_dec(PM_GETRE(cPMOPo));
1066             PL_regex_pad[offset] = &PL_sv_undef;
1067             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1068                            sizeof(offset));
1069         }
1070 #else
1071         ReREFCNT_dec(PM_GETRE(cPMOPo));
1072         PM_SETRE(cPMOPo, NULL);
1073 #endif
1074
1075         break;
1076
1077     case OP_ARGCHECK:
1078         PerlMemShared_free(cUNOP_AUXo->op_aux);
1079         break;
1080
1081     case OP_MULTICONCAT:
1082         {
1083             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1084             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1085              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1086              * utf8 shared strings */
1087             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1088             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1089             if (p1)
1090                 PerlMemShared_free(p1);
1091             if (p2 && p1 != p2)
1092                 PerlMemShared_free(p2);
1093             PerlMemShared_free(aux);
1094         }
1095         break;
1096
1097     case OP_MULTIDEREF:
1098         {
1099             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1100             UV actions = items->uv;
1101             bool last = 0;
1102             bool is_hash = FALSE;
1103
1104             while (!last) {
1105                 switch (actions & MDEREF_ACTION_MASK) {
1106
1107                 case MDEREF_reload:
1108                     actions = (++items)->uv;
1109                     continue;
1110
1111                 case MDEREF_HV_padhv_helem:
1112                     is_hash = TRUE;
1113                     /* FALLTHROUGH */
1114                 case MDEREF_AV_padav_aelem:
1115                     pad_free((++items)->pad_offset);
1116                     goto do_elem;
1117
1118                 case MDEREF_HV_gvhv_helem:
1119                     is_hash = TRUE;
1120                     /* FALLTHROUGH */
1121                 case MDEREF_AV_gvav_aelem:
1122 #ifdef USE_ITHREADS
1123                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1124 #else
1125                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1126 #endif
1127                     goto do_elem;
1128
1129                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1130                     is_hash = TRUE;
1131                     /* FALLTHROUGH */
1132                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1133 #ifdef USE_ITHREADS
1134                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1135 #else
1136                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1137 #endif
1138                     goto do_vivify_rv2xv_elem;
1139
1140                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1141                     is_hash = TRUE;
1142                     /* FALLTHROUGH */
1143                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1144                     pad_free((++items)->pad_offset);
1145                     goto do_vivify_rv2xv_elem;
1146
1147                 case MDEREF_HV_pop_rv2hv_helem:
1148                 case MDEREF_HV_vivify_rv2hv_helem:
1149                     is_hash = TRUE;
1150                     /* FALLTHROUGH */
1151                 do_vivify_rv2xv_elem:
1152                 case MDEREF_AV_pop_rv2av_aelem:
1153                 case MDEREF_AV_vivify_rv2av_aelem:
1154                 do_elem:
1155                     switch (actions & MDEREF_INDEX_MASK) {
1156                     case MDEREF_INDEX_none:
1157                         last = 1;
1158                         break;
1159                     case MDEREF_INDEX_const:
1160                         if (is_hash) {
1161 #ifdef USE_ITHREADS
1162                             /* see RT #15654 */
1163                             pad_swipe((++items)->pad_offset, 1);
1164 #else
1165                             SvREFCNT_dec((++items)->sv);
1166 #endif
1167                         }
1168                         else
1169                             items++;
1170                         break;
1171                     case MDEREF_INDEX_padsv:
1172                         pad_free((++items)->pad_offset);
1173                         break;
1174                     case MDEREF_INDEX_gvsv:
1175 #ifdef USE_ITHREADS
1176                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1177 #else
1178                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1179 #endif
1180                         break;
1181                     }
1182
1183                     if (actions & MDEREF_FLAG_last)
1184                         last = 1;
1185                     is_hash = FALSE;
1186
1187                     break;
1188
1189                 default:
1190                     assert(0);
1191                     last = 1;
1192                     break;
1193
1194                 } /* switch */
1195
1196                 actions >>= MDEREF_SHIFT;
1197             } /* while */
1198
1199             /* start of malloc is at op_aux[-1], where the length is
1200              * stored */
1201             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1202         }
1203         break;
1204     }
1205
1206     if (o->op_targ > 0) {
1207         pad_free(o->op_targ);
1208         o->op_targ = 0;
1209     }
1210 }
1211
1212 STATIC void
1213 S_cop_free(pTHX_ COP* cop)
1214 {
1215     PERL_ARGS_ASSERT_COP_FREE;
1216
1217     CopFILE_free(cop);
1218     if (! specialWARN(cop->cop_warnings))
1219         PerlMemShared_free(cop->cop_warnings);
1220     cophh_free(CopHINTHASH_get(cop));
1221     if (PL_curcop == cop)
1222        PL_curcop = NULL;
1223 }
1224
1225 STATIC void
1226 S_forget_pmop(pTHX_ PMOP *const o
1227               )
1228 {
1229     HV * const pmstash = PmopSTASH(o);
1230
1231     PERL_ARGS_ASSERT_FORGET_PMOP;
1232
1233     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1234         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1235         if (mg) {
1236             PMOP **const array = (PMOP**) mg->mg_ptr;
1237             U32 count = mg->mg_len / sizeof(PMOP**);
1238             U32 i = count;
1239
1240             while (i--) {
1241                 if (array[i] == o) {
1242                     /* Found it. Move the entry at the end to overwrite it.  */
1243                     array[i] = array[--count];
1244                     mg->mg_len = count * sizeof(PMOP**);
1245                     /* Could realloc smaller at this point always, but probably
1246                        not worth it. Probably worth free()ing if we're the
1247                        last.  */
1248                     if(!count) {
1249                         Safefree(mg->mg_ptr);
1250                         mg->mg_ptr = NULL;
1251                     }
1252                     break;
1253                 }
1254             }
1255         }
1256     }
1257     if (PL_curpm == o)
1258         PL_curpm = NULL;
1259 }
1260
1261 STATIC void
1262 S_find_and_forget_pmops(pTHX_ OP *o)
1263 {
1264     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1265
1266     if (o->op_flags & OPf_KIDS) {
1267         OP *kid = cUNOPo->op_first;
1268         while (kid) {
1269             switch (kid->op_type) {
1270             case OP_SUBST:
1271             case OP_SPLIT:
1272             case OP_MATCH:
1273             case OP_QR:
1274                 forget_pmop((PMOP*)kid);
1275             }
1276             find_and_forget_pmops(kid);
1277             kid = OpSIBLING(kid);
1278         }
1279     }
1280 }
1281
1282 /*
1283 =for apidoc Am|void|op_null|OP *o
1284
1285 Neutralizes an op when it is no longer needed, but is still linked to from
1286 other ops.
1287
1288 =cut
1289 */
1290
1291 void
1292 Perl_op_null(pTHX_ OP *o)
1293 {
1294     dVAR;
1295
1296     PERL_ARGS_ASSERT_OP_NULL;
1297
1298     if (o->op_type == OP_NULL)
1299         return;
1300     op_clear(o);
1301     o->op_targ = o->op_type;
1302     OpTYPE_set(o, OP_NULL);
1303 }
1304
1305 void
1306 Perl_op_refcnt_lock(pTHX)
1307   PERL_TSA_ACQUIRE(PL_op_mutex)
1308 {
1309 #ifdef USE_ITHREADS
1310     dVAR;
1311 #endif
1312     PERL_UNUSED_CONTEXT;
1313     OP_REFCNT_LOCK;
1314 }
1315
1316 void
1317 Perl_op_refcnt_unlock(pTHX)
1318   PERL_TSA_RELEASE(PL_op_mutex)
1319 {
1320 #ifdef USE_ITHREADS
1321     dVAR;
1322 #endif
1323     PERL_UNUSED_CONTEXT;
1324     OP_REFCNT_UNLOCK;
1325 }
1326
1327
1328 /*
1329 =for apidoc op_sibling_splice
1330
1331 A general function for editing the structure of an existing chain of
1332 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1333 you to delete zero or more sequential nodes, replacing them with zero or
1334 more different nodes.  Performs the necessary op_first/op_last
1335 housekeeping on the parent node and op_sibling manipulation on the
1336 children.  The last deleted node will be marked as as the last node by
1337 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1338
1339 Note that op_next is not manipulated, and nodes are not freed; that is the
1340 responsibility of the caller.  It also won't create a new list op for an
1341 empty list etc; use higher-level functions like op_append_elem() for that.
1342
1343 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1344 the splicing doesn't affect the first or last op in the chain.
1345
1346 C<start> is the node preceding the first node to be spliced.  Node(s)
1347 following it will be deleted, and ops will be inserted after it.  If it is
1348 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1349 beginning.
1350
1351 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1352 If -1 or greater than or equal to the number of remaining kids, all
1353 remaining kids are deleted.
1354
1355 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1356 If C<NULL>, no nodes are inserted.
1357
1358 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1359 deleted.
1360
1361 For example:
1362
1363     action                    before      after         returns
1364     ------                    -----       -----         -------
1365
1366                               P           P
1367     splice(P, A, 2, X-Y-Z)    |           |             B-C
1368                               A-B-C-D     A-X-Y-Z-D
1369
1370                               P           P
1371     splice(P, NULL, 1, X-Y)   |           |             A
1372                               A-B-C-D     X-Y-B-C-D
1373
1374                               P           P
1375     splice(P, NULL, 3, NULL)  |           |             A-B-C
1376                               A-B-C-D     D
1377
1378                               P           P
1379     splice(P, B, 0, X-Y)      |           |             NULL
1380                               A-B-C-D     A-B-X-Y-C-D
1381
1382
1383 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1384 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1385
1386 =cut
1387 */
1388
1389 OP *
1390 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1391 {
1392     OP *first;
1393     OP *rest;
1394     OP *last_del = NULL;
1395     OP *last_ins = NULL;
1396
1397     if (start)
1398         first = OpSIBLING(start);
1399     else if (!parent)
1400         goto no_parent;
1401     else
1402         first = cLISTOPx(parent)->op_first;
1403
1404     assert(del_count >= -1);
1405
1406     if (del_count && first) {
1407         last_del = first;
1408         while (--del_count && OpHAS_SIBLING(last_del))
1409             last_del = OpSIBLING(last_del);
1410         rest = OpSIBLING(last_del);
1411         OpLASTSIB_set(last_del, NULL);
1412     }
1413     else
1414         rest = first;
1415
1416     if (insert) {
1417         last_ins = insert;
1418         while (OpHAS_SIBLING(last_ins))
1419             last_ins = OpSIBLING(last_ins);
1420         OpMAYBESIB_set(last_ins, rest, NULL);
1421     }
1422     else
1423         insert = rest;
1424
1425     if (start) {
1426         OpMAYBESIB_set(start, insert, NULL);
1427     }
1428     else {
1429         if (!parent)
1430             goto no_parent;
1431         cLISTOPx(parent)->op_first = insert;
1432         if (insert)
1433             parent->op_flags |= OPf_KIDS;
1434         else
1435             parent->op_flags &= ~OPf_KIDS;
1436     }
1437
1438     if (!rest) {
1439         /* update op_last etc */
1440         U32 type;
1441         OP *lastop;
1442
1443         if (!parent)
1444             goto no_parent;
1445
1446         /* ought to use OP_CLASS(parent) here, but that can't handle
1447          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1448          * either */
1449         type = parent->op_type;
1450         if (type == OP_CUSTOM) {
1451             dTHX;
1452             type = XopENTRYCUSTOM(parent, xop_class);
1453         }
1454         else {
1455             if (type == OP_NULL)
1456                 type = parent->op_targ;
1457             type = PL_opargs[type] & OA_CLASS_MASK;
1458         }
1459
1460         lastop = last_ins ? last_ins : start ? start : NULL;
1461         if (   type == OA_BINOP
1462             || type == OA_LISTOP
1463             || type == OA_PMOP
1464             || type == OA_LOOP
1465         )
1466             cLISTOPx(parent)->op_last = lastop;
1467
1468         if (lastop)
1469             OpLASTSIB_set(lastop, parent);
1470     }
1471     return last_del ? first : NULL;
1472
1473   no_parent:
1474     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1475 }
1476
1477
1478 #ifdef PERL_OP_PARENT
1479
1480 /*
1481 =for apidoc op_parent
1482
1483 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1484 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1485
1486 =cut
1487 */
1488
1489 OP *
1490 Perl_op_parent(OP *o)
1491 {
1492     PERL_ARGS_ASSERT_OP_PARENT;
1493     while (OpHAS_SIBLING(o))
1494         o = OpSIBLING(o);
1495     return o->op_sibparent;
1496 }
1497
1498 #endif
1499
1500
1501 /* replace the sibling following start with a new UNOP, which becomes
1502  * the parent of the original sibling; e.g.
1503  *
1504  *  op_sibling_newUNOP(P, A, unop-args...)
1505  *
1506  *  P              P
1507  *  |      becomes |
1508  *  A-B-C          A-U-C
1509  *                   |
1510  *                   B
1511  *
1512  * where U is the new UNOP.
1513  *
1514  * parent and start args are the same as for op_sibling_splice();
1515  * type and flags args are as newUNOP().
1516  *
1517  * Returns the new UNOP.
1518  */
1519
1520 STATIC OP *
1521 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1522 {
1523     OP *kid, *newop;
1524
1525     kid = op_sibling_splice(parent, start, 1, NULL);
1526     newop = newUNOP(type, flags, kid);
1527     op_sibling_splice(parent, start, 0, newop);
1528     return newop;
1529 }
1530
1531
1532 /* lowest-level newLOGOP-style function - just allocates and populates
1533  * the struct. Higher-level stuff should be done by S_new_logop() /
1534  * newLOGOP(). This function exists mainly to avoid op_first assignment
1535  * being spread throughout this file.
1536  */
1537
1538 LOGOP *
1539 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1540 {
1541     dVAR;
1542     LOGOP *logop;
1543     OP *kid = first;
1544     NewOp(1101, logop, 1, LOGOP);
1545     OpTYPE_set(logop, type);
1546     logop->op_first = first;
1547     logop->op_other = other;
1548     if (first)
1549         logop->op_flags = OPf_KIDS;
1550     while (kid && OpHAS_SIBLING(kid))
1551         kid = OpSIBLING(kid);
1552     if (kid)
1553         OpLASTSIB_set(kid, (OP*)logop);
1554     return logop;
1555 }
1556
1557
1558 /* Contextualizers */
1559
1560 /*
1561 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1562
1563 Applies a syntactic context to an op tree representing an expression.
1564 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1565 or C<G_VOID> to specify the context to apply.  The modified op tree
1566 is returned.
1567
1568 =cut
1569 */
1570
1571 OP *
1572 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1573 {
1574     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1575     switch (context) {
1576         case G_SCALAR: return scalar(o);
1577         case G_ARRAY:  return list(o);
1578         case G_VOID:   return scalarvoid(o);
1579         default:
1580             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1581                        (long) context);
1582     }
1583 }
1584
1585 /*
1586
1587 =for apidoc Am|OP*|op_linklist|OP *o
1588 This function is the implementation of the L</LINKLIST> macro.  It should
1589 not be called directly.
1590
1591 =cut
1592 */
1593
1594 OP *
1595 Perl_op_linklist(pTHX_ OP *o)
1596 {
1597     OP *first;
1598
1599     PERL_ARGS_ASSERT_OP_LINKLIST;
1600
1601     if (o->op_next)
1602         return o->op_next;
1603
1604     /* establish postfix order */
1605     first = cUNOPo->op_first;
1606     if (first) {
1607         OP *kid;
1608         o->op_next = LINKLIST(first);
1609         kid = first;
1610         for (;;) {
1611             OP *sibl = OpSIBLING(kid);
1612             if (sibl) {
1613                 kid->op_next = LINKLIST(sibl);
1614                 kid = sibl;
1615             } else {
1616                 kid->op_next = o;
1617                 break;
1618             }
1619         }
1620     }
1621     else
1622         o->op_next = o;
1623
1624     return o->op_next;
1625 }
1626
1627 static OP *
1628 S_scalarkids(pTHX_ OP *o)
1629 {
1630     if (o && o->op_flags & OPf_KIDS) {
1631         OP *kid;
1632         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1633             scalar(kid);
1634     }
1635     return o;
1636 }
1637
1638 STATIC OP *
1639 S_scalarboolean(pTHX_ OP *o)
1640 {
1641     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1642
1643     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1644          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1645         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1646          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1647          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1648         if (ckWARN(WARN_SYNTAX)) {
1649             const line_t oldline = CopLINE(PL_curcop);
1650
1651             if (PL_parser && PL_parser->copline != NOLINE) {
1652                 /* This ensures that warnings are reported at the first line
1653                    of the conditional, not the last.  */
1654                 CopLINE_set(PL_curcop, PL_parser->copline);
1655             }
1656             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1657             CopLINE_set(PL_curcop, oldline);
1658         }
1659     }
1660     return scalar(o);
1661 }
1662
1663 static SV *
1664 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1665 {
1666     assert(o);
1667     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1668            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1669     {
1670         const char funny  = o->op_type == OP_PADAV
1671                          || o->op_type == OP_RV2AV ? '@' : '%';
1672         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1673             GV *gv;
1674             if (cUNOPo->op_first->op_type != OP_GV
1675              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1676                 return NULL;
1677             return varname(gv, funny, 0, NULL, 0, subscript_type);
1678         }
1679         return
1680             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1681     }
1682 }
1683
1684 static SV *
1685 S_op_varname(pTHX_ const OP *o)
1686 {
1687     return S_op_varname_subscript(aTHX_ o, 1);
1688 }
1689
1690 static void
1691 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1692 { /* or not so pretty :-) */
1693     if (o->op_type == OP_CONST) {
1694         *retsv = cSVOPo_sv;
1695         if (SvPOK(*retsv)) {
1696             SV *sv = *retsv;
1697             *retsv = sv_newmortal();
1698             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1699                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1700         }
1701         else if (!SvOK(*retsv))
1702             *retpv = "undef";
1703     }
1704     else *retpv = "...";
1705 }
1706
1707 static void
1708 S_scalar_slice_warning(pTHX_ const OP *o)
1709 {
1710     OP *kid;
1711     const bool h = o->op_type == OP_HSLICE
1712                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1713     const char lbrack =
1714         h ? '{' : '[';
1715     const char rbrack =
1716         h ? '}' : ']';
1717     SV *name;
1718     SV *keysv = NULL; /* just to silence compiler warnings */
1719     const char *key = NULL;
1720
1721     if (!(o->op_private & OPpSLICEWARNING))
1722         return;
1723     if (PL_parser && PL_parser->error_count)
1724         /* This warning can be nonsensical when there is a syntax error. */
1725         return;
1726
1727     kid = cLISTOPo->op_first;
1728     kid = OpSIBLING(kid); /* get past pushmark */
1729     /* weed out false positives: any ops that can return lists */
1730     switch (kid->op_type) {
1731     case OP_BACKTICK:
1732     case OP_GLOB:
1733     case OP_READLINE:
1734     case OP_MATCH:
1735     case OP_RV2AV:
1736     case OP_EACH:
1737     case OP_VALUES:
1738     case OP_KEYS:
1739     case OP_SPLIT:
1740     case OP_LIST:
1741     case OP_SORT:
1742     case OP_REVERSE:
1743     case OP_ENTERSUB:
1744     case OP_CALLER:
1745     case OP_LSTAT:
1746     case OP_STAT:
1747     case OP_READDIR:
1748     case OP_SYSTEM:
1749     case OP_TMS:
1750     case OP_LOCALTIME:
1751     case OP_GMTIME:
1752     case OP_ENTEREVAL:
1753         return;
1754     }
1755
1756     /* Don't warn if we have a nulled list either. */
1757     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1758         return;
1759
1760     assert(OpSIBLING(kid));
1761     name = S_op_varname(aTHX_ OpSIBLING(kid));
1762     if (!name) /* XS module fiddling with the op tree */
1763         return;
1764     S_op_pretty(aTHX_ kid, &keysv, &key);
1765     assert(SvPOK(name));
1766     sv_chop(name,SvPVX(name)+1);
1767     if (key)
1768        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1769         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1770                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1771                    "%c%s%c",
1772                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1773                     lbrack, key, rbrack);
1774     else
1775        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1776         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1777                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1778                     SVf "%c%" SVf "%c",
1779                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1780                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1781 }
1782
1783 OP *
1784 Perl_scalar(pTHX_ OP *o)
1785 {
1786     OP *kid;
1787
1788     /* assumes no premature commitment */
1789     if (!o || (PL_parser && PL_parser->error_count)
1790          || (o->op_flags & OPf_WANT)
1791          || o->op_type == OP_RETURN)
1792     {
1793         return o;
1794     }
1795
1796     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1797
1798     switch (o->op_type) {
1799     case OP_REPEAT:
1800         scalar(cBINOPo->op_first);
1801         if (o->op_private & OPpREPEAT_DOLIST) {
1802             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1803             assert(kid->op_type == OP_PUSHMARK);
1804             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1805                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1806                 o->op_private &=~ OPpREPEAT_DOLIST;
1807             }
1808         }
1809         break;
1810     case OP_OR:
1811     case OP_AND:
1812     case OP_COND_EXPR:
1813         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1814             scalar(kid);
1815         break;
1816         /* FALLTHROUGH */
1817     case OP_SPLIT:
1818     case OP_MATCH:
1819     case OP_QR:
1820     case OP_SUBST:
1821     case OP_NULL:
1822     default:
1823         if (o->op_flags & OPf_KIDS) {
1824             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1825                 scalar(kid);
1826         }
1827         break;
1828     case OP_LEAVE:
1829     case OP_LEAVETRY:
1830         kid = cLISTOPo->op_first;
1831         scalar(kid);
1832         kid = OpSIBLING(kid);
1833     do_kids:
1834         while (kid) {
1835             OP *sib = OpSIBLING(kid);
1836             if (sib && kid->op_type != OP_LEAVEWHEN
1837              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1838                 || (  sib->op_targ != OP_NEXTSTATE
1839                    && sib->op_targ != OP_DBSTATE  )))
1840                 scalarvoid(kid);
1841             else
1842                 scalar(kid);
1843             kid = sib;
1844         }
1845         PL_curcop = &PL_compiling;
1846         break;
1847     case OP_SCOPE:
1848     case OP_LINESEQ:
1849     case OP_LIST:
1850         kid = cLISTOPo->op_first;
1851         goto do_kids;
1852     case OP_SORT:
1853         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1854         break;
1855     case OP_KVHSLICE:
1856     case OP_KVASLICE:
1857     {
1858         /* Warn about scalar context */
1859         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1860         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1861         SV *name;
1862         SV *keysv;
1863         const char *key = NULL;
1864
1865         /* This warning can be nonsensical when there is a syntax error. */
1866         if (PL_parser && PL_parser->error_count)
1867             break;
1868
1869         if (!ckWARN(WARN_SYNTAX)) break;
1870
1871         kid = cLISTOPo->op_first;
1872         kid = OpSIBLING(kid); /* get past pushmark */
1873         assert(OpSIBLING(kid));
1874         name = S_op_varname(aTHX_ OpSIBLING(kid));
1875         if (!name) /* XS module fiddling with the op tree */
1876             break;
1877         S_op_pretty(aTHX_ kid, &keysv, &key);
1878         assert(SvPOK(name));
1879         sv_chop(name,SvPVX(name)+1);
1880         if (key)
1881   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1882             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1883                        "%%%" SVf "%c%s%c in scalar context better written "
1884                        "as $%" SVf "%c%s%c",
1885                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1886                         lbrack, key, rbrack);
1887         else
1888   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1889             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1890                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1891                        "written as $%" SVf "%c%" SVf "%c",
1892                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1893                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1894     }
1895     }
1896     return o;
1897 }
1898
1899 OP *
1900 Perl_scalarvoid(pTHX_ OP *arg)
1901 {
1902     dVAR;
1903     OP *kid;
1904     SV* sv;
1905     SSize_t defer_stack_alloc = 0;
1906     SSize_t defer_ix = -1;
1907     OP **defer_stack = NULL;
1908     OP *o = arg;
1909
1910     PERL_ARGS_ASSERT_SCALARVOID;
1911
1912     do {
1913         U8 want;
1914         SV *useless_sv = NULL;
1915         const char* useless = NULL;
1916
1917         if (o->op_type == OP_NEXTSTATE
1918             || o->op_type == OP_DBSTATE
1919             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1920                                           || o->op_targ == OP_DBSTATE)))
1921             PL_curcop = (COP*)o;                /* for warning below */
1922
1923         /* assumes no premature commitment */
1924         want = o->op_flags & OPf_WANT;
1925         if ((want && want != OPf_WANT_SCALAR)
1926             || (PL_parser && PL_parser->error_count)
1927             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1928         {
1929             continue;
1930         }
1931
1932         if ((o->op_private & OPpTARGET_MY)
1933             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1934         {
1935             /* newASSIGNOP has already applied scalar context, which we
1936                leave, as if this op is inside SASSIGN.  */
1937             continue;
1938         }
1939
1940         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1941
1942         switch (o->op_type) {
1943         default:
1944             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1945                 break;
1946             /* FALLTHROUGH */
1947         case OP_REPEAT:
1948             if (o->op_flags & OPf_STACKED)
1949                 break;
1950             if (o->op_type == OP_REPEAT)
1951                 scalar(cBINOPo->op_first);
1952             goto func_ops;
1953         case OP_CONCAT:
1954             if ((o->op_flags & OPf_STACKED) &&
1955                     !(o->op_private & OPpCONCAT_NESTED))
1956                 break;
1957             goto func_ops;
1958         case OP_SUBSTR:
1959             if (o->op_private == 4)
1960                 break;
1961             /* FALLTHROUGH */
1962         case OP_WANTARRAY:
1963         case OP_GV:
1964         case OP_SMARTMATCH:
1965         case OP_AV2ARYLEN:
1966         case OP_REF:
1967         case OP_REFGEN:
1968         case OP_SREFGEN:
1969         case OP_DEFINED:
1970         case OP_HEX:
1971         case OP_OCT:
1972         case OP_LENGTH:
1973         case OP_VEC:
1974         case OP_INDEX:
1975         case OP_RINDEX:
1976         case OP_SPRINTF:
1977         case OP_KVASLICE:
1978         case OP_KVHSLICE:
1979         case OP_UNPACK:
1980         case OP_PACK:
1981         case OP_JOIN:
1982         case OP_LSLICE:
1983         case OP_ANONLIST:
1984         case OP_ANONHASH:
1985         case OP_SORT:
1986         case OP_REVERSE:
1987         case OP_RANGE:
1988         case OP_FLIP:
1989         case OP_FLOP:
1990         case OP_CALLER:
1991         case OP_FILENO:
1992         case OP_EOF:
1993         case OP_TELL:
1994         case OP_GETSOCKNAME:
1995         case OP_GETPEERNAME:
1996         case OP_READLINK:
1997         case OP_TELLDIR:
1998         case OP_GETPPID:
1999         case OP_GETPGRP:
2000         case OP_GETPRIORITY:
2001         case OP_TIME:
2002         case OP_TMS:
2003         case OP_LOCALTIME:
2004         case OP_GMTIME:
2005         case OP_GHBYNAME:
2006         case OP_GHBYADDR:
2007         case OP_GHOSTENT:
2008         case OP_GNBYNAME:
2009         case OP_GNBYADDR:
2010         case OP_GNETENT:
2011         case OP_GPBYNAME:
2012         case OP_GPBYNUMBER:
2013         case OP_GPROTOENT:
2014         case OP_GSBYNAME:
2015         case OP_GSBYPORT:
2016         case OP_GSERVENT:
2017         case OP_GPWNAM:
2018         case OP_GPWUID:
2019         case OP_GGRNAM:
2020         case OP_GGRGID:
2021         case OP_GETLOGIN:
2022         case OP_PROTOTYPE:
2023         case OP_RUNCV:
2024         func_ops:
2025             useless = OP_DESC(o);
2026             break;
2027
2028         case OP_GVSV:
2029         case OP_PADSV:
2030         case OP_PADAV:
2031         case OP_PADHV:
2032         case OP_PADANY:
2033         case OP_AELEM:
2034         case OP_AELEMFAST:
2035         case OP_AELEMFAST_LEX:
2036         case OP_ASLICE:
2037         case OP_HELEM:
2038         case OP_HSLICE:
2039             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2040                 /* Otherwise it's "Useless use of grep iterator" */
2041                 useless = OP_DESC(o);
2042             break;
2043
2044         case OP_SPLIT:
2045             if (!(o->op_private & OPpSPLIT_ASSIGN))
2046                 useless = OP_DESC(o);
2047             break;
2048
2049         case OP_NOT:
2050             kid = cUNOPo->op_first;
2051             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2052                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2053                 goto func_ops;
2054             }
2055             useless = "negative pattern binding (!~)";
2056             break;
2057
2058         case OP_SUBST:
2059             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2060                 useless = "non-destructive substitution (s///r)";
2061             break;
2062
2063         case OP_TRANSR:
2064             useless = "non-destructive transliteration (tr///r)";
2065             break;
2066
2067         case OP_RV2GV:
2068         case OP_RV2SV:
2069         case OP_RV2AV:
2070         case OP_RV2HV:
2071             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2072                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2073                 useless = "a variable";
2074             break;
2075
2076         case OP_CONST:
2077             sv = cSVOPo_sv;
2078             if (cSVOPo->op_private & OPpCONST_STRICT)
2079                 no_bareword_allowed(o);
2080             else {
2081                 if (ckWARN(WARN_VOID)) {
2082                     NV nv;
2083                     /* don't warn on optimised away booleans, eg
2084                      * use constant Foo, 5; Foo || print; */
2085                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2086                         useless = NULL;
2087                     /* the constants 0 and 1 are permitted as they are
2088                        conventionally used as dummies in constructs like
2089                        1 while some_condition_with_side_effects;  */
2090                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2091                         useless = NULL;
2092                     else if (SvPOK(sv)) {
2093                         SV * const dsv = newSVpvs("");
2094                         useless_sv
2095                             = Perl_newSVpvf(aTHX_
2096                                             "a constant (%s)",
2097                                             pv_pretty(dsv, SvPVX_const(sv),
2098                                                       SvCUR(sv), 32, NULL, NULL,
2099                                                       PERL_PV_PRETTY_DUMP
2100                                                       | PERL_PV_ESCAPE_NOCLEAR
2101                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2102                         SvREFCNT_dec_NN(dsv);
2103                     }
2104                     else if (SvOK(sv)) {
2105                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2106                     }
2107                     else
2108                         useless = "a constant (undef)";
2109                 }
2110             }
2111             op_null(o);         /* don't execute or even remember it */
2112             break;
2113
2114         case OP_POSTINC:
2115             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2116             break;
2117
2118         case OP_POSTDEC:
2119             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2120             break;
2121
2122         case OP_I_POSTINC:
2123             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2124             break;
2125
2126         case OP_I_POSTDEC:
2127             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2128             break;
2129
2130         case OP_SASSIGN: {
2131             OP *rv2gv;
2132             UNOP *refgen, *rv2cv;
2133             LISTOP *exlist;
2134
2135             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2136                 break;
2137
2138             rv2gv = ((BINOP *)o)->op_last;
2139             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2140                 break;
2141
2142             refgen = (UNOP *)((BINOP *)o)->op_first;
2143
2144             if (!refgen || (refgen->op_type != OP_REFGEN
2145                             && refgen->op_type != OP_SREFGEN))
2146                 break;
2147
2148             exlist = (LISTOP *)refgen->op_first;
2149             if (!exlist || exlist->op_type != OP_NULL
2150                 || exlist->op_targ != OP_LIST)
2151                 break;
2152
2153             if (exlist->op_first->op_type != OP_PUSHMARK
2154                 && exlist->op_first != exlist->op_last)
2155                 break;
2156
2157             rv2cv = (UNOP*)exlist->op_last;
2158
2159             if (rv2cv->op_type != OP_RV2CV)
2160                 break;
2161
2162             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2163             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2164             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2165
2166             o->op_private |= OPpASSIGN_CV_TO_GV;
2167             rv2gv->op_private |= OPpDONT_INIT_GV;
2168             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2169
2170             break;
2171         }
2172
2173         case OP_AASSIGN: {
2174             inplace_aassign(o);
2175             break;
2176         }
2177
2178         case OP_OR:
2179         case OP_AND:
2180             kid = cLOGOPo->op_first;
2181             if (kid->op_type == OP_NOT
2182                 && (kid->op_flags & OPf_KIDS)) {
2183                 if (o->op_type == OP_AND) {
2184                     OpTYPE_set(o, OP_OR);
2185                 } else {
2186                     OpTYPE_set(o, OP_AND);
2187                 }
2188                 op_null(kid);
2189             }
2190             /* FALLTHROUGH */
2191
2192         case OP_DOR:
2193         case OP_COND_EXPR:
2194         case OP_ENTERGIVEN:
2195         case OP_ENTERWHEN:
2196             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2197                 if (!(kid->op_flags & OPf_KIDS))
2198                     scalarvoid(kid);
2199                 else
2200                     DEFER_OP(kid);
2201         break;
2202
2203         case OP_NULL:
2204             if (o->op_flags & OPf_STACKED)
2205                 break;
2206             /* FALLTHROUGH */
2207         case OP_NEXTSTATE:
2208         case OP_DBSTATE:
2209         case OP_ENTERTRY:
2210         case OP_ENTER:
2211             if (!(o->op_flags & OPf_KIDS))
2212                 break;
2213             /* FALLTHROUGH */
2214         case OP_SCOPE:
2215         case OP_LEAVE:
2216         case OP_LEAVETRY:
2217         case OP_LEAVELOOP:
2218         case OP_LINESEQ:
2219         case OP_LEAVEGIVEN:
2220         case OP_LEAVEWHEN:
2221         kids:
2222             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2223                 if (!(kid->op_flags & OPf_KIDS))
2224                     scalarvoid(kid);
2225                 else
2226                     DEFER_OP(kid);
2227             break;
2228         case OP_LIST:
2229             /* If the first kid after pushmark is something that the padrange
2230                optimisation would reject, then null the list and the pushmark.
2231             */
2232             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2233                 && (  !(kid = OpSIBLING(kid))
2234                       || (  kid->op_type != OP_PADSV
2235                             && kid->op_type != OP_PADAV
2236                             && kid->op_type != OP_PADHV)
2237                       || kid->op_private & ~OPpLVAL_INTRO
2238                       || !(kid = OpSIBLING(kid))
2239                       || (  kid->op_type != OP_PADSV
2240                             && kid->op_type != OP_PADAV
2241                             && kid->op_type != OP_PADHV)
2242                       || kid->op_private & ~OPpLVAL_INTRO)
2243             ) {
2244                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2245                 op_null(o); /* NULL the list */
2246             }
2247             goto kids;
2248         case OP_ENTEREVAL:
2249             scalarkids(o);
2250             break;
2251         case OP_SCALAR:
2252             scalar(o);
2253             break;
2254         }
2255
2256         if (useless_sv) {
2257             /* mortalise it, in case warnings are fatal.  */
2258             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2259                            "Useless use of %" SVf " in void context",
2260                            SVfARG(sv_2mortal(useless_sv)));
2261         }
2262         else if (useless) {
2263             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2264                            "Useless use of %s in void context",
2265                            useless);
2266         }
2267     } while ( (o = POP_DEFERRED_OP()) );
2268
2269     Safefree(defer_stack);
2270
2271     return arg;
2272 }
2273
2274 static OP *
2275 S_listkids(pTHX_ OP *o)
2276 {
2277     if (o && o->op_flags & OPf_KIDS) {
2278         OP *kid;
2279         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2280             list(kid);
2281     }
2282     return o;
2283 }
2284
2285 OP *
2286 Perl_list(pTHX_ OP *o)
2287 {
2288     OP *kid;
2289
2290     /* assumes no premature commitment */
2291     if (!o || (o->op_flags & OPf_WANT)
2292          || (PL_parser && PL_parser->error_count)
2293          || o->op_type == OP_RETURN)
2294     {
2295         return o;
2296     }
2297
2298     if ((o->op_private & OPpTARGET_MY)
2299         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2300     {
2301         return o;                               /* As if inside SASSIGN */
2302     }
2303
2304     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2305
2306     switch (o->op_type) {
2307     case OP_FLOP:
2308         list(cBINOPo->op_first);
2309         break;
2310     case OP_REPEAT:
2311         if (o->op_private & OPpREPEAT_DOLIST
2312          && !(o->op_flags & OPf_STACKED))
2313         {
2314             list(cBINOPo->op_first);
2315             kid = cBINOPo->op_last;
2316             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2317              && SvIVX(kSVOP_sv) == 1)
2318             {
2319                 op_null(o); /* repeat */
2320                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2321                 /* const (rhs): */
2322                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2323             }
2324         }
2325         break;
2326     case OP_OR:
2327     case OP_AND:
2328     case OP_COND_EXPR:
2329         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2330             list(kid);
2331         break;
2332     default:
2333     case OP_MATCH:
2334     case OP_QR:
2335     case OP_SUBST:
2336     case OP_NULL:
2337         if (!(o->op_flags & OPf_KIDS))
2338             break;
2339         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2340             list(cBINOPo->op_first);
2341             return gen_constant_list(o);
2342         }
2343         listkids(o);
2344         break;
2345     case OP_LIST:
2346         listkids(o);
2347         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2348             op_null(cUNOPo->op_first); /* NULL the pushmark */
2349             op_null(o); /* NULL the list */
2350         }
2351         break;
2352     case OP_LEAVE:
2353     case OP_LEAVETRY:
2354         kid = cLISTOPo->op_first;
2355         list(kid);
2356         kid = OpSIBLING(kid);
2357     do_kids:
2358         while (kid) {
2359             OP *sib = OpSIBLING(kid);
2360             if (sib && kid->op_type != OP_LEAVEWHEN)
2361                 scalarvoid(kid);
2362             else
2363                 list(kid);
2364             kid = sib;
2365         }
2366         PL_curcop = &PL_compiling;
2367         break;
2368     case OP_SCOPE:
2369     case OP_LINESEQ:
2370         kid = cLISTOPo->op_first;
2371         goto do_kids;
2372     }
2373     return o;
2374 }
2375
2376 static OP *
2377 S_scalarseq(pTHX_ OP *o)
2378 {
2379     if (o) {
2380         const OPCODE type = o->op_type;
2381
2382         if (type == OP_LINESEQ || type == OP_SCOPE ||
2383             type == OP_LEAVE || type == OP_LEAVETRY)
2384         {
2385             OP *kid, *sib;
2386             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2387                 if ((sib = OpSIBLING(kid))
2388                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2389                     || (  sib->op_targ != OP_NEXTSTATE
2390                        && sib->op_targ != OP_DBSTATE  )))
2391                 {
2392                     scalarvoid(kid);
2393                 }
2394             }
2395             PL_curcop = &PL_compiling;
2396         }
2397         o->op_flags &= ~OPf_PARENS;
2398         if (PL_hints & HINT_BLOCK_SCOPE)
2399             o->op_flags |= OPf_PARENS;
2400     }
2401     else
2402         o = newOP(OP_STUB, 0);
2403     return o;
2404 }
2405
2406 STATIC OP *
2407 S_modkids(pTHX_ OP *o, I32 type)
2408 {
2409     if (o && o->op_flags & OPf_KIDS) {
2410         OP *kid;
2411         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2412             op_lvalue(kid, type);
2413     }
2414     return o;
2415 }
2416
2417
2418 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2419  * const fields. Also, convert CONST keys to HEK-in-SVs.
2420  * rop is the op that retrieves the hash;
2421  * key_op is the first key
2422  */
2423
2424 STATIC void
2425 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2426 {
2427     PADNAME *lexname;
2428     GV **fields;
2429     bool check_fields;
2430
2431     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2432     if (rop) {
2433         if (rop->op_first->op_type == OP_PADSV)
2434             /* @$hash{qw(keys here)} */
2435             rop = (UNOP*)rop->op_first;
2436         else {
2437             /* @{$hash}{qw(keys here)} */
2438             if (rop->op_first->op_type == OP_SCOPE
2439                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2440                 {
2441                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2442                 }
2443             else
2444                 rop = NULL;
2445         }
2446     }
2447
2448     lexname = NULL; /* just to silence compiler warnings */
2449     fields  = NULL; /* just to silence compiler warnings */
2450
2451     check_fields =
2452             rop
2453          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2454              SvPAD_TYPED(lexname))
2455          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2456          && isGV(*fields) && GvHV(*fields);
2457
2458     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2459         SV **svp, *sv;
2460         if (key_op->op_type != OP_CONST)
2461             continue;
2462         svp = cSVOPx_svp(key_op);
2463
2464         /* make sure it's not a bareword under strict subs */
2465         if (key_op->op_private & OPpCONST_BARE &&
2466             key_op->op_private & OPpCONST_STRICT)
2467         {
2468             no_bareword_allowed((OP*)key_op);
2469         }
2470
2471         /* Make the CONST have a shared SV */
2472         if (   !SvIsCOW_shared_hash(sv = *svp)
2473             && SvTYPE(sv) < SVt_PVMG
2474             && SvOK(sv)
2475             && !SvROK(sv))
2476         {
2477             SSize_t keylen;
2478             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2479             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2480             SvREFCNT_dec_NN(sv);
2481             *svp = nsv;
2482         }
2483
2484         if (   check_fields
2485             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2486         {
2487             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2488                         "in variable %" PNf " of type %" HEKf,
2489                         SVfARG(*svp), PNfARG(lexname),
2490                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2491         }
2492     }
2493 }
2494
2495 /* info returned by S_sprintf_is_multiconcatable() */
2496
2497 struct sprintf_ismc_info {
2498     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2499     char  *start;     /* start of raw format string */
2500     char  *end;       /* bytes after end of raw format string */
2501     STRLEN total_len; /* total length (in bytes) of format string, not
2502                          including '%s' and  half of '%%' */
2503     STRLEN variant;   /* number of bytes by which total_len_p would grow
2504                          if upgraded to utf8 */
2505     bool   utf8;      /* whether the format is utf8 */
2506 };
2507
2508
2509 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2510  * i.e. its format argument is a const string with only '%s' and '%%'
2511  * formats, and the number of args is known, e.g.
2512  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2513  * but not
2514  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2515  *
2516  * If successful, the sprintf_ismc_info struct pointed to by info will be
2517  * populated.
2518  */
2519
2520 STATIC bool
2521 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2522 {
2523     OP    *pm, *constop, *kid;
2524     SV    *sv;
2525     char  *s, *e, *p;
2526     SSize_t nargs, nformats;
2527     STRLEN cur, total_len, variant;
2528     bool   utf8;
2529
2530     /* if sprintf's behaviour changes, die here so that someone
2531      * can decide whether to enhance this function or skip optimising
2532      * under those new circumstances */
2533     assert(!(o->op_flags & OPf_STACKED));
2534     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2535     assert(!(o->op_private & ~OPpARG4_MASK));
2536
2537     pm = cUNOPo->op_first;
2538     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2539         return FALSE;
2540     constop = OpSIBLING(pm);
2541     if (!constop || constop->op_type != OP_CONST)
2542         return FALSE;
2543     sv = cSVOPx_sv(constop);
2544     if (SvMAGICAL(sv) || !SvPOK(sv))
2545         return FALSE;
2546
2547     s = SvPV(sv, cur);
2548     e = s + cur;
2549
2550     /* Scan format for %% and %s and work out how many %s there are.
2551      * Abandon if other format types are found.
2552      */
2553
2554     nformats  = 0;
2555     total_len = 0;
2556     variant   = 0;
2557
2558     for (p = s; p < e; p++) {
2559         if (*p != '%') {
2560             total_len++;
2561             if (!UTF8_IS_INVARIANT(*p))
2562                 variant++;
2563             continue;
2564         }
2565         p++;
2566         if (p >= e)
2567             return FALSE; /* lone % at end gives "Invalid conversion" */
2568         if (*p == '%')
2569             total_len++;
2570         else if (*p == 's')
2571             nformats++;
2572         else
2573             return FALSE;
2574     }
2575
2576     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2577         return FALSE;
2578
2579     utf8 = cBOOL(SvUTF8(sv));
2580     if (utf8)
2581         variant = 0;
2582
2583     /* scan args; they must all be in scalar cxt */
2584
2585     nargs = 0;
2586     kid = OpSIBLING(constop);
2587
2588     while (kid) {
2589         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2590             return FALSE;
2591         nargs++;
2592         kid = OpSIBLING(kid);
2593     }
2594
2595     if (nargs != nformats)
2596         return FALSE; /* e.g. sprintf("%s%s", $a); */
2597
2598
2599     info->nargs      = nargs;
2600     info->start      = s;
2601     info->end        = e;
2602     info->total_len  = total_len;
2603     info->variant    = variant;
2604     info->utf8       = utf8;
2605
2606     return TRUE;
2607 }
2608
2609
2610
2611 /* S_maybe_multiconcat():
2612  *
2613  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2614  * convert it (and its children) into an OP_MULTICONCAT. See the code
2615  * comments just before pp_multiconcat() for the full details of what
2616  * OP_MULTICONCAT supports.
2617  *
2618  * Basically we're looking for an optree with a chain of OP_CONCATS down
2619  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2620  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2621  *
2622  *      $x = "$a$b-$c"
2623  *
2624  *  looks like
2625  *
2626  *      SASSIGN
2627  *         |
2628  *      STRINGIFY   -- PADSV[$x]
2629  *         |
2630  *         |
2631  *      ex-PUSHMARK -- CONCAT/S
2632  *                        |
2633  *                     CONCAT/S  -- PADSV[$d]
2634  *                        |
2635  *                     CONCAT    -- CONST["-"]
2636  *                        |
2637  *                     PADSV[$a] -- PADSV[$b]
2638  *
2639  * Note that at this stage the OP_SASSIGN may have already been optimised
2640  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2641  */
2642
2643 STATIC void
2644 S_maybe_multiconcat(pTHX_ OP *o)
2645 {
2646     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2647     OP *topop;       /* the top-most op in the concat tree (often equals o,
2648                         unless there are assign/stringify ops above it */
2649     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2650     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2651     OP *targetop;    /* the op corresponding to target=... or target.=... */
2652     OP *stringop;    /* the OP_STRINGIFY op, if any */
2653     OP *nextop;      /* used for recreating the op_next chain without consts */
2654     OP *kid;         /* general-purpose op pointer */
2655     UNOP_AUX_item *aux;
2656     UNOP_AUX_item *lenp;
2657     char *const_str, *p;
2658     struct sprintf_ismc_info sprintf_info;
2659
2660                      /* store info about each arg in args[];
2661                       * toparg is the highest used slot; argp is a general
2662                       * pointer to args[] slots */
2663     struct {
2664         void *p;      /* initially points to const sv (or null for op);
2665                          later, set to SvPV(constsv), with ... */
2666         STRLEN len;   /* ... len set to SvPV(..., len) */
2667     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2668
2669     SSize_t nargs  = 0;
2670     SSize_t nconst = 0;
2671     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2672     STRLEN variant;
2673     bool utf8 = FALSE;
2674     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2675                                  the last-processed arg will the LHS of one,
2676                                  as args are processed in reverse order */
2677     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2678     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2679     U8 flags          = 0;   /* what will become the op_flags and ... */
2680     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2681     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2682     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2683     bool prev_was_const = FALSE; /* previous arg was a const */
2684
2685     /* -----------------------------------------------------------------
2686      * Phase 1:
2687      *
2688      * Examine the optree non-destructively to determine whether it's
2689      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2690      * information about the optree in args[].
2691      */
2692
2693     argp     = args;
2694     targmyop = NULL;
2695     targetop = NULL;
2696     stringop = NULL;
2697     topop    = o;
2698     parentop = o;
2699
2700     assert(   o->op_type == OP_SASSIGN
2701            || o->op_type == OP_CONCAT
2702            || o->op_type == OP_SPRINTF
2703            || o->op_type == OP_STRINGIFY);
2704
2705     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2706
2707     /* first see if, at the top of the tree, there is an assign,
2708      * append and/or stringify */
2709
2710     if (topop->op_type == OP_SASSIGN) {
2711         /* expr = ..... */
2712         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2713             return;
2714         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2715             return;
2716         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2717
2718         parentop = topop;
2719         topop = cBINOPo->op_first;
2720         targetop = OpSIBLING(topop);
2721         if (!targetop) /* probably some sort of syntax error */
2722             return;
2723     }
2724     else if (   topop->op_type == OP_CONCAT
2725              && (topop->op_flags & OPf_STACKED)
2726              && (cUNOPo->op_first->op_flags & OPf_MOD)
2727              && (!(topop->op_private & OPpCONCAT_NESTED))
2728             )
2729     {
2730         /* expr .= ..... */
2731
2732         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2733          * decide what to do about it */
2734         assert(!(o->op_private & OPpTARGET_MY));
2735
2736         /* barf on unknown flags */
2737         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2738         private_flags |= OPpMULTICONCAT_APPEND;
2739         targetop = cBINOPo->op_first;
2740         parentop = topop;
2741         topop    = OpSIBLING(targetop);
2742
2743         /* $x .= <FOO> gets optimised to rcatline instead */
2744         if (topop->op_type == OP_READLINE)
2745             return;
2746     }
2747
2748     if (targetop) {
2749         /* Can targetop (the LHS) if it's a padsv, be be optimised
2750          * away and use OPpTARGET_MY instead?
2751          */
2752         if (    (targetop->op_type == OP_PADSV)
2753             && !(targetop->op_private & OPpDEREF)
2754             && !(targetop->op_private & OPpPAD_STATE)
2755                /* we don't support 'my $x .= ...' */
2756             && (   o->op_type == OP_SASSIGN
2757                 || !(targetop->op_private & OPpLVAL_INTRO))
2758         )
2759             is_targable = TRUE;
2760     }
2761
2762     if (topop->op_type == OP_STRINGIFY) {
2763         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2764             return;
2765         stringop = topop;
2766
2767         /* barf on unknown flags */
2768         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2769
2770         if ((topop->op_private & OPpTARGET_MY)) {
2771             if (o->op_type == OP_SASSIGN)
2772                 return; /* can't have two assigns */
2773             targmyop = topop;
2774         }
2775
2776         private_flags |= OPpMULTICONCAT_STRINGIFY;
2777         parentop = topop;
2778         topop = cBINOPx(topop)->op_first;
2779         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2780         topop = OpSIBLING(topop);
2781     }
2782
2783     if (topop->op_type == OP_SPRINTF) {
2784         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2785             return;
2786         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2787             nargs     = sprintf_info.nargs;
2788             total_len = sprintf_info.total_len;
2789             variant   = sprintf_info.variant;
2790             utf8      = sprintf_info.utf8;
2791             is_sprintf = TRUE;
2792             private_flags |= OPpMULTICONCAT_FAKE;
2793             toparg = argp;
2794             /* we have an sprintf op rather than a concat optree.
2795              * Skip most of the code below which is associated with
2796              * processing that optree. We also skip phase 2, determining
2797              * whether its cost effective to optimise, since for sprintf,
2798              * multiconcat is *always* faster */
2799             goto create_aux;
2800         }
2801         /* note that even if the sprintf itself isn't multiconcatable,
2802          * the expression as a whole may be, e.g. in
2803          *    $x .= sprintf("%d",...)
2804          * the sprintf op will be left as-is, but the concat/S op may
2805          * be upgraded to multiconcat
2806          */
2807     }
2808     else if (topop->op_type == OP_CONCAT) {
2809         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2810             return;
2811
2812         if ((topop->op_private & OPpTARGET_MY)) {
2813             if (o->op_type == OP_SASSIGN || targmyop)
2814                 return; /* can't have two assigns */
2815             targmyop = topop;
2816         }
2817     }
2818
2819     /* Is it safe to convert a sassign/stringify/concat op into
2820      * a multiconcat? */
2821     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2822     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2823     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2824     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2825     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2826                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2827     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2828                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2829
2830     /* Now scan the down the tree looking for a series of
2831      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2832      * stacked). For example this tree:
2833      *
2834      *     |
2835      *   CONCAT/STACKED
2836      *     |
2837      *   CONCAT/STACKED -- EXPR5
2838      *     |
2839      *   CONCAT/STACKED -- EXPR4
2840      *     |
2841      *   CONCAT -- EXPR3
2842      *     |
2843      *   EXPR1  -- EXPR2
2844      *
2845      * corresponds to an expression like
2846      *
2847      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2848      *
2849      * Record info about each EXPR in args[]: in particular, whether it is
2850      * a stringifiable OP_CONST and if so what the const sv is.
2851      *
2852      * The reason why the last concat can't be STACKED is the difference
2853      * between
2854      *
2855      *    ((($a .= $a) .= $a) .= $a) .= $a
2856      *
2857      * and
2858      *    $a . $a . $a . $a . $a
2859      *
2860      * The main difference between the optrees for those two constructs
2861      * is the presence of the last STACKED. As well as modifying $a,
2862      * the former sees the changed $a between each concat, so if $s is
2863      * initially 'a', the first returns 'a' x 16, while the latter returns
2864      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2865      */
2866
2867     kid = topop;
2868
2869     for (;;) {
2870         OP *argop;
2871         SV *sv;
2872         bool last = FALSE;
2873
2874         if (    kid->op_type == OP_CONCAT
2875             && !kid_is_last
2876         ) {
2877             OP *k1, *k2;
2878             k1 = cUNOPx(kid)->op_first;
2879             k2 = OpSIBLING(k1);
2880             /* shouldn't happen except maybe after compile err? */
2881             if (!k2)
2882                 return;
2883
2884             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2885             if (kid->op_private & OPpTARGET_MY)
2886                 kid_is_last = TRUE;
2887
2888             stacked_last = (kid->op_flags & OPf_STACKED);
2889             if (!stacked_last)
2890                 kid_is_last = TRUE;
2891
2892             kid   = k1;
2893             argop = k2;
2894         }
2895         else {
2896             argop = kid;
2897             last = TRUE;
2898         }
2899
2900         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2901             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2902         {
2903             /* At least two spare slots are needed to decompose both
2904              * concat args. If there are no slots left, continue to
2905              * examine the rest of the optree, but don't push new values
2906              * on args[]. If the optree as a whole is legal for conversion
2907              * (in particular that the last concat isn't STACKED), then
2908              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2909              * can be converted into an OP_MULTICONCAT now, with the first
2910              * child of that op being the remainder of the optree -
2911              * which may itself later be converted to a multiconcat op
2912              * too.
2913              */
2914             if (last) {
2915                 /* the last arg is the rest of the optree */
2916                 argp++->p = NULL;
2917                 nargs++;
2918             }
2919         }
2920         else if (   argop->op_type == OP_CONST
2921             && ((sv = cSVOPx_sv(argop)))
2922             /* defer stringification until runtime of 'constant'
2923              * things that might stringify variantly, e.g. the radix
2924              * point of NVs, or overloaded RVs */
2925             && (SvPOK(sv) || SvIOK(sv))
2926             && (!SvGMAGICAL(sv))
2927         ) {
2928             argp++->p = sv;
2929             utf8   |= cBOOL(SvUTF8(sv));
2930             nconst++;
2931             if (prev_was_const)
2932                 /* this const may be demoted back to a plain arg later;
2933                  * make sure we have enough arg slots left */
2934                 nadjconst++;
2935             prev_was_const = !prev_was_const;
2936         }
2937         else {
2938             argp++->p = NULL;
2939             nargs++;
2940             prev_was_const = FALSE;
2941         }
2942
2943         if (last)
2944             break;
2945     }
2946
2947     toparg = argp - 1;
2948
2949     if (stacked_last)
2950         return; /* we don't support ((A.=B).=C)...) */
2951
2952     /* look for two adjacent consts and don't fold them together:
2953      *     $o . "a" . "b"
2954      * should do
2955      *     $o->concat("a")->concat("b")
2956      * rather than
2957      *     $o->concat("ab")
2958      * (but $o .=  "a" . "b" should still fold)
2959      */
2960     {
2961         bool seen_nonconst = FALSE;
2962         for (argp = toparg; argp >= args; argp--) {
2963             if (argp->p == NULL) {
2964                 seen_nonconst = TRUE;
2965                 continue;
2966             }
2967             if (!seen_nonconst)
2968                 continue;
2969             if (argp[1].p) {
2970                 /* both previous and current arg were constants;
2971                  * leave the current OP_CONST as-is */
2972                 argp->p = NULL;
2973                 nconst--;
2974                 nargs++;
2975             }
2976         }
2977     }
2978
2979     /* -----------------------------------------------------------------
2980      * Phase 2:
2981      *
2982      * At this point we have determined that the optree *can* be converted
2983      * into a multiconcat. Having gathered all the evidence, we now decide
2984      * whether it *should*.
2985      */
2986
2987
2988     /* we need at least one concat action, e.g.:
2989      *
2990      *  Y . Z
2991      *  X = Y . Z
2992      *  X .= Y
2993      *
2994      * otherwise we could be doing something like $x = "foo", which
2995      * if treated as as a concat, would fail to COW.
2996      */
2997     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2998         return;
2999
3000     /* Benchmarking seems to indicate that we gain if:
3001      * * we optimise at least two actions into a single multiconcat
3002      *    (e.g concat+concat, sassign+concat);
3003      * * or if we can eliminate at least 1 OP_CONST;
3004      * * or if we can eliminate a padsv via OPpTARGET_MY
3005      */
3006
3007     if (
3008            /* eliminated at least one OP_CONST */
3009            nconst >= 1
3010            /* eliminated an OP_SASSIGN */
3011         || o->op_type == OP_SASSIGN
3012            /* eliminated an OP_PADSV */
3013         || (!targmyop && is_targable)
3014     )
3015         /* definitely a net gain to optimise */
3016         goto optimise;
3017
3018     /* ... if not, what else? */
3019
3020     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3021      * multiconcat is faster (due to not creating a temporary copy of
3022      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3023      * faster.
3024      */
3025     if (   nconst == 0
3026          && nargs == 2
3027          && targmyop
3028          && topop->op_type == OP_CONCAT
3029     ) {
3030         PADOFFSET t = targmyop->op_targ;
3031         OP *k1 = cBINOPx(topop)->op_first;
3032         OP *k2 = cBINOPx(topop)->op_last;
3033         if (   k2->op_type == OP_PADSV
3034             && k2->op_targ == t
3035             && (   k1->op_type != OP_PADSV
3036                 || k1->op_targ != t)
3037         )
3038             goto optimise;
3039     }
3040
3041     /* need at least two concats */
3042     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3043         return;
3044
3045
3046
3047     /* -----------------------------------------------------------------
3048      * Phase 3:
3049      *
3050      * At this point the optree has been verified as ok to be optimised
3051      * into an OP_MULTICONCAT. Now start changing things.
3052      */
3053
3054    optimise:
3055
3056     /* stringify all const args and determine utf8ness */
3057
3058     variant = 0;
3059     for (argp = args; argp <= toparg; argp++) {
3060         SV *sv = (SV*)argp->p;
3061         if (!sv)
3062             continue; /* not a const op */
3063         if (utf8 && !SvUTF8(sv))
3064             sv_utf8_upgrade_nomg(sv);
3065         argp->p = SvPV_nomg(sv, argp->len);
3066         total_len += argp->len;
3067
3068         /* see if any strings would grow if converted to utf8 */
3069         if (!utf8) {
3070             char *p    = (char*)argp->p;
3071             STRLEN len = argp->len;
3072             while (len--) {
3073                 U8 c = *p++;
3074                 if (!UTF8_IS_INVARIANT(c))
3075                     variant++;
3076             }
3077         }
3078     }
3079
3080     /* create and populate aux struct */
3081
3082   create_aux:
3083
3084     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3085                     sizeof(UNOP_AUX_item)
3086                     *  (
3087                            PERL_MULTICONCAT_HEADER_SIZE
3088                          + ((nargs + 1) * (variant ? 2 : 1))
3089                         )
3090                     );
3091     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3092
3093     /* Extract all the non-const expressions from the concat tree then
3094      * dispose of the old tree, e.g. convert the tree from this:
3095      *
3096      *  o => SASSIGN
3097      *         |
3098      *       STRINGIFY   -- TARGET
3099      *         |
3100      *       ex-PUSHMARK -- CONCAT
3101      *                        |
3102      *                      CONCAT -- EXPR5
3103      *                        |
3104      *                      CONCAT -- EXPR4
3105      *                        |
3106      *                      CONCAT -- EXPR3
3107      *                        |
3108      *                      EXPR1  -- EXPR2
3109      *
3110      *
3111      * to:
3112      *
3113      *  o => MULTICONCAT
3114      *         |
3115      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3116      *
3117      * except that if EXPRi is an OP_CONST, it's discarded.
3118      *
3119      * During the conversion process, EXPR ops are stripped from the tree
3120      * and unshifted onto o. Finally, any of o's remaining original
3121      * childen are discarded and o is converted into an OP_MULTICONCAT.
3122      *
3123      * In this middle of this, o may contain both: unshifted args on the
3124      * left, and some remaining original args on the right. lastkidop
3125      * is set to point to the right-most unshifted arg to delineate
3126      * between the two sets.
3127      */
3128
3129
3130     if (is_sprintf) {
3131         /* create a copy of the format with the %'s removed, and record
3132          * the sizes of the const string segments in the aux struct */
3133         char *q, *oldq;
3134         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3135
3136         p    = sprintf_info.start;
3137         q    = const_str;
3138         oldq = q;
3139         for (; p < sprintf_info.end; p++) {
3140             if (*p == '%') {
3141                 p++;
3142                 if (*p != '%') {
3143                     (lenp++)->ssize = q - oldq;
3144                     oldq = q;
3145                     continue;
3146                 }
3147             }
3148             *q++ = *p;
3149         }
3150         lenp->ssize = q - oldq;
3151         assert((STRLEN)(q - const_str) == total_len);
3152
3153         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3154          * may or may not be topop) The pushmark and const ops need to be
3155          * kept in case they're an op_next entry point.
3156          */
3157         lastkidop = cLISTOPx(topop)->op_last;
3158         kid = cUNOPx(topop)->op_first; /* pushmark */
3159         op_null(kid);
3160         op_null(OpSIBLING(kid));       /* const */
3161         if (o != topop) {
3162             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3163             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3164             lastkidop->op_next = o;
3165         }
3166     }
3167     else {
3168         p = const_str;
3169         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3170
3171         lenp->ssize = -1;
3172
3173         /* Concatenate all const strings into const_str.
3174          * Note that args[] contains the RHS args in reverse order, so
3175          * we scan args[] from top to bottom to get constant strings
3176          * in L-R order
3177          */
3178         for (argp = toparg; argp >= args; argp--) {
3179             if (!argp->p)
3180                 /* not a const op */
3181                 (++lenp)->ssize = -1;
3182             else {
3183                 STRLEN l = argp->len;
3184                 Copy(argp->p, p, l, char);
3185                 p += l;
3186                 if (lenp->ssize == -1)
3187                     lenp->ssize = l;
3188                 else
3189                     lenp->ssize += l;
3190             }
3191         }
3192
3193         kid = topop;
3194         nextop = o;
3195         lastkidop = NULL;
3196
3197         for (argp = args; argp <= toparg; argp++) {
3198             /* only keep non-const args, except keep the first-in-next-chain
3199              * arg no matter what it is (but nulled if OP_CONST), because it
3200              * may be the entry point to this subtree from the previous
3201              * op_next.
3202              */
3203             bool last = (argp == toparg);
3204             OP *prev;
3205
3206             /* set prev to the sibling *before* the arg to be cut out,
3207              * e.g. when cutting EXPR:
3208              *
3209              *         |
3210              * kid=  CONCAT
3211              *         |
3212              * prev= CONCAT -- EXPR
3213              *         |
3214              */
3215             if (argp == args && kid->op_type != OP_CONCAT) {
3216                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3217                  * so the expression to be cut isn't kid->op_last but
3218                  * kid itself */
3219                 OP *o1, *o2;
3220                 /* find the op before kid */
3221                 o1 = NULL;
3222                 o2 = cUNOPx(parentop)->op_first;
3223                 while (o2 && o2 != kid) {
3224                     o1 = o2;
3225                     o2 = OpSIBLING(o2);
3226                 }
3227                 assert(o2 == kid);
3228                 prev = o1;
3229                 kid  = parentop;
3230             }
3231             else if (kid == o && lastkidop)
3232                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3233             else
3234                 prev = last ? NULL : cUNOPx(kid)->op_first;
3235
3236             if (!argp->p || last) {
3237                 /* cut RH op */
3238                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3239                 /* and unshift to front of o */
3240                 op_sibling_splice(o, NULL, 0, aop);
3241                 /* record the right-most op added to o: later we will
3242                  * free anything to the right of it */
3243                 if (!lastkidop)
3244                     lastkidop = aop;
3245                 aop->op_next = nextop;
3246                 if (last) {
3247                     if (argp->p)
3248                         /* null the const at start of op_next chain */
3249                         op_null(aop);
3250                 }
3251                 else if (prev)
3252                     nextop = prev->op_next;
3253             }
3254
3255             /* the last two arguments are both attached to the same concat op */
3256             if (argp < toparg - 1)
3257                 kid = prev;
3258         }
3259     }
3260
3261     /* Populate the aux struct */
3262
3263     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3264     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3265     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3266     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3267     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3268
3269     /* if variant > 0, calculate a variant const string and lengths where
3270      * the utf8 version of the string will take 'variant' more bytes than
3271      * the plain one. */
3272
3273     if (variant) {
3274         char              *p = const_str;
3275         STRLEN          ulen = total_len + variant;
3276         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3277         UNOP_AUX_item *ulens = lens + (nargs + 1);
3278         char             *up = (char*)PerlMemShared_malloc(ulen);
3279         SSize_t            n;
3280
3281         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3282         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3283
3284         for (n = 0; n < (nargs + 1); n++) {
3285             SSize_t i;
3286             char * orig_up = up;
3287             for (i = (lens++)->ssize; i > 0; i--) {
3288                 U8 c = *p++;
3289                 append_utf8_from_native_byte(c, (U8**)&up);
3290             }
3291             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3292         }
3293     }
3294
3295     if (stringop) {
3296         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3297          * that op's first child - an ex-PUSHMARK - because the op_next of
3298          * the previous op may point to it (i.e. it's the entry point for
3299          * the o optree)
3300          */
3301         OP *pmop =
3302             (stringop == o)
3303                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3304                 : op_sibling_splice(stringop, NULL, 1, NULL);
3305         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3306         op_sibling_splice(o, NULL, 0, pmop);
3307         if (!lastkidop)
3308             lastkidop = pmop;
3309     }
3310
3311     /* Optimise
3312      *    target  = A.B.C...
3313      *    target .= A.B.C...
3314      */
3315
3316     if (targetop) {
3317         assert(!targmyop);
3318
3319         if (o->op_type == OP_SASSIGN) {
3320             /* Move the target subtree from being the last of o's children
3321              * to being the last of o's preserved children.
3322              * Note the difference between 'target = ...' and 'target .= ...':
3323              * for the former, target is executed last; for the latter,
3324              * first.
3325              */
3326             kid = OpSIBLING(lastkidop);
3327             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3328             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3329             lastkidop->op_next = kid->op_next;
3330             lastkidop = targetop;
3331         }
3332         else {
3333             /* Move the target subtree from being the first of o's
3334              * original children to being the first of *all* o's children.
3335              */
3336             if (lastkidop) {
3337                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3338                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3339             }
3340             else {
3341                 /* if the RHS of .= doesn't contain a concat (e.g.
3342                  * $x .= "foo"), it gets missed by the "strip ops from the
3343                  * tree and add to o" loop earlier */
3344                 assert(topop->op_type != OP_CONCAT);
3345                 if (stringop) {
3346                     /* in e.g. $x .= "$y", move the $y expression
3347                      * from being a child of OP_STRINGIFY to being the
3348                      * second child of the OP_CONCAT
3349                      */
3350                     assert(cUNOPx(stringop)->op_first == topop);
3351                     op_sibling_splice(stringop, NULL, 1, NULL);
3352                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3353                 }
3354                 assert(topop == OpSIBLING(cBINOPo->op_first));
3355                 if (toparg->p)
3356                     op_null(topop);
3357                 lastkidop = topop;
3358             }
3359         }
3360
3361         if (is_targable) {
3362             /* optimise
3363              *  my $lex  = A.B.C...
3364              *     $lex  = A.B.C...
3365              *     $lex .= A.B.C...
3366              * The original padsv op is kept but nulled in case it's the
3367              * entry point for the optree (which it will be for
3368              * '$lex .=  ... '
3369              */
3370             private_flags |= OPpTARGET_MY;
3371             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3372             o->op_targ = targetop->op_targ;
3373             targetop->op_targ = 0;
3374             op_null(targetop);
3375         }
3376         else
3377             flags |= OPf_STACKED;
3378     }
3379     else if (targmyop) {
3380         private_flags |= OPpTARGET_MY;
3381         if (o != targmyop) {
3382             o->op_targ = targmyop->op_targ;
3383             targmyop->op_targ = 0;
3384         }
3385     }
3386
3387     /* detach the emaciated husk of the sprintf/concat optree and free it */
3388     for (;;) {
3389         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3390         if (!kid)
3391             break;
3392         op_free(kid);
3393     }
3394
3395     /* and convert o into a multiconcat */
3396
3397     o->op_flags        = (flags|OPf_KIDS|stacked_last
3398                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3399     o->op_private      = private_flags;
3400     o->op_type         = OP_MULTICONCAT;
3401     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3402     cUNOP_AUXo->op_aux = aux;
3403 }
3404
3405
3406 /* do all the final processing on an optree (e.g. running the peephole
3407  * optimiser on it), then attach it to cv (if cv is non-null)
3408  */
3409
3410 static void
3411 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3412 {
3413     OP **startp;
3414
3415     /* XXX for some reason, evals, require and main optrees are
3416      * never attached to their CV; instead they just hang off
3417      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3418      * and get manually freed when appropriate */
3419     if (cv)
3420         startp = &CvSTART(cv);
3421     else
3422         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3423
3424     *startp = start;
3425     optree->op_private |= OPpREFCOUNTED;
3426     OpREFCNT_set(optree, 1);
3427     optimize_optree(optree);
3428     CALL_PEEP(*startp);
3429     finalize_optree(optree);
3430     S_prune_chain_head(startp);
3431
3432     if (cv) {
3433         /* now that optimizer has done its work, adjust pad values */
3434         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3435                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3436     }
3437 }
3438
3439
3440 /*
3441 =for apidoc optimize_optree
3442
3443 This function applies some optimisations to the optree in top-down order.
3444 It is called before the peephole optimizer, which processes ops in
3445 execution order. Note that finalize_optree() also does a top-down scan,
3446 but is called *after* the peephole optimizer.
3447
3448 =cut
3449 */
3450
3451 void
3452 Perl_optimize_optree(pTHX_ OP* o)
3453 {
3454     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3455
3456     ENTER;
3457     SAVEVPTR(PL_curcop);
3458
3459     optimize_op(o);
3460
3461     LEAVE;
3462 }
3463
3464
3465 /* helper for optimize_optree() which optimises on op then recurses
3466  * to optimise any children.
3467  */
3468
3469 STATIC void
3470 S_optimize_op(pTHX_ OP* o)
3471 {
3472     OP *kid;
3473
3474     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3475     assert(o->op_type != OP_FREED);
3476
3477     switch (o->op_type) {
3478     case OP_NEXTSTATE:
3479     case OP_DBSTATE:
3480         PL_curcop = ((COP*)o);          /* for warnings */
3481         break;
3482
3483
3484     case OP_CONCAT:
3485     case OP_SASSIGN:
3486     case OP_STRINGIFY:
3487     case OP_SPRINTF:
3488         S_maybe_multiconcat(aTHX_ o);
3489         break;
3490
3491     case OP_SUBST:
3492         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3493             optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3494         break;
3495
3496     default:
3497         break;
3498     }
3499
3500     if (!(o->op_flags & OPf_KIDS))
3501         return;
3502
3503     for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3504         optimize_op(kid);
3505 }
3506
3507
3508 /*
3509 =for apidoc finalize_optree
3510
3511 This function finalizes the optree.  Should be called directly after
3512 the complete optree is built.  It does some additional
3513 checking which can't be done in the normal C<ck_>xxx functions and makes
3514 the tree thread-safe.
3515
3516 =cut
3517 */
3518 void
3519 Perl_finalize_optree(pTHX_ OP* o)
3520 {
3521     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3522
3523     ENTER;
3524     SAVEVPTR(PL_curcop);
3525
3526     finalize_op(o);
3527
3528     LEAVE;
3529 }
3530
3531 #ifdef USE_ITHREADS
3532 /* Relocate sv to the pad for thread safety.
3533  * Despite being a "constant", the SV is written to,
3534  * for reference counts, sv_upgrade() etc. */
3535 PERL_STATIC_INLINE void
3536 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3537 {
3538     PADOFFSET ix;
3539     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3540     if (!*svp) return;
3541     ix = pad_alloc(OP_CONST, SVf_READONLY);
3542     SvREFCNT_dec(PAD_SVl(ix));
3543     PAD_SETSV(ix, *svp);
3544     /* XXX I don't know how this isn't readonly already. */
3545     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3546     *svp = NULL;
3547     *targp = ix;
3548 }
3549 #endif
3550
3551
3552 STATIC void
3553 S_finalize_op(pTHX_ OP* o)
3554 {
3555     PERL_ARGS_ASSERT_FINALIZE_OP;
3556
3557     assert(o->op_type != OP_FREED);
3558
3559     switch (o->op_type) {
3560     case OP_NEXTSTATE:
3561     case OP_DBSTATE:
3562         PL_curcop = ((COP*)o);          /* for warnings */
3563         break;
3564     case OP_EXEC:
3565         if (OpHAS_SIBLING(o)) {
3566             OP *sib = OpSIBLING(o);
3567             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3568                 && ckWARN(WARN_EXEC)
3569                 && OpHAS_SIBLING(sib))
3570             {
3571                     const OPCODE type = OpSIBLING(sib)->op_type;
3572                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3573                         const line_t oldline = CopLINE(PL_curcop);
3574                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3575                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3576                             "Statement unlikely to be reached");
3577                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3578                             "\t(Maybe you meant system() when you said exec()?)\n");
3579                         CopLINE_set(PL_curcop, oldline);
3580                     }
3581             }
3582         }
3583         break;
3584
3585     case OP_GV:
3586         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3587             GV * const gv = cGVOPo_gv;
3588             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3589                 /* XXX could check prototype here instead of just carping */
3590                 SV * const sv = sv_newmortal();
3591                 gv_efullname3(sv, gv, NULL);
3592                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3593                     "%" SVf "() called too early to check prototype",
3594                     SVfARG(sv));
3595             }
3596         }
3597         break;
3598
3599     case OP_CONST:
3600         if (cSVOPo->op_private & OPpCONST_STRICT)
3601             no_bareword_allowed(o);
3602 #ifdef USE_ITHREADS
3603         /* FALLTHROUGH */
3604     case OP_HINTSEVAL:
3605         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3606 #endif
3607         break;
3608
3609 #ifdef USE_ITHREADS
3610     /* Relocate all the METHOP's SVs to the pad for thread safety. */
3611     case OP_METHOD_NAMED:
3612     case OP_METHOD_SUPER:
3613     case OP_METHOD_REDIR:
3614     case OP_METHOD_REDIR_SUPER:
3615         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3616         break;
3617 #endif
3618
3619     case OP_HELEM: {
3620         UNOP *rop;
3621         SVOP *key_op;
3622         OP *kid;
3623
3624         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3625             break;
3626
3627         rop = (UNOP*)((BINOP*)o)->op_first;
3628
3629         goto check_keys;
3630
3631     case OP_HSLICE:
3632         S_scalar_slice_warning(aTHX_ o);
3633         /* FALLTHROUGH */
3634
3635     case OP_KVHSLICE:
3636         kid = OpSIBLING(cLISTOPo->op_first);
3637         if (/* I bet there's always a pushmark... */
3638             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3639             && OP_TYPE_ISNT_NN(kid, OP_CONST))
3640         {
3641             break;
3642         }
3643
3644         key_op = (SVOP*)(kid->op_type == OP_CONST
3645                                 ? kid
3646                                 : OpSIBLING(kLISTOP->op_first));
3647
3648         rop = (UNOP*)((LISTOP*)o)->op_last;
3649
3650       check_keys:
3651         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3652             rop = NULL;
3653         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3654         break;
3655     }
3656     case OP_NULL:
3657         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3658             break;
3659         /* FALLTHROUGH */
3660     case OP_ASLICE:
3661         S_scalar_slice_warning(aTHX_ o);
3662         break;
3663
3664     case OP_SUBST: {
3665         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3666             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3667         break;
3668     }
3669     default:
3670         break;
3671     }
3672
3673     if (o->op_flags & OPf_KIDS) {
3674         OP *kid;
3675
3676 #ifdef DEBUGGING
3677         /* check that op_last points to the last sibling, and that
3678          * the last op_sibling/op_sibparent field points back to the
3679          * parent, and that the only ops with KIDS are those which are
3680          * entitled to them */
3681         U32 type = o->op_type;
3682         U32 family;
3683         bool has_last;
3684
3685         if (type == OP_NULL) {
3686             type = o->op_targ;
3687             /* ck_glob creates a null UNOP with ex-type GLOB
3688              * (which is a list op. So pretend it wasn't a listop */
3689             if (type == OP_GLOB)
3690                 type = OP_NULL;
3691         }
3692         family = PL_opargs[type] & OA_CLASS_MASK;
3693
3694         has_last = (   family == OA_BINOP
3695                     || family == OA_LISTOP
3696                     || family == OA_PMOP
3697                     || family == OA_LOOP
3698                    );
3699         assert(  has_last /* has op_first and op_last, or ...
3700               ... has (or may have) op_first: */
3701               || family == OA_UNOP
3702               || family == OA_UNOP_AUX
3703               || family == OA_LOGOP
3704               || family == OA_BASEOP_OR_UNOP
3705               || family == OA_FILESTATOP
3706               || family == OA_LOOPEXOP
3707               || family == OA_METHOP
3708               || type == OP_CUSTOM
3709               || type == OP_NULL /* new_logop does this */
3710               );
3711
3712         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3713 #  ifdef PERL_OP_PARENT
3714             if (!OpHAS_SIBLING(kid)) {
3715                 if (has_last)
3716                     assert(kid == cLISTOPo->op_last);
3717                 assert(kid->op_sibparent == o);
3718             }
3719 #  else
3720             if (has_last && !OpHAS_SIBLING(kid))
3721                 assert(kid == cLISTOPo->op_last);
3722 #  endif
3723         }
3724 #endif
3725
3726         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3727             finalize_op(kid);
3728     }
3729 }
3730
3731 /*
3732 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3733
3734 Propagate lvalue ("modifiable") context to an op and its children.
3735 C<type> represents the context type, roughly based on the type of op that
3736 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3737 because it has no op type of its own (it is signalled by a flag on
3738 the lvalue op).
3739
3740 This function detects things that can't be modified, such as C<$x+1>, and
3741 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3742 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3743
3744 It also flags things that need to behave specially in an lvalue context,
3745 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3746
3747 =cut
3748 */
3749
3750 static void
3751 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3752 {
3753     CV *cv = PL_compcv;
3754     PadnameLVALUE_on(pn);
3755     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3756         cv = CvOUTSIDE(cv);
3757         /* RT #127786: cv can be NULL due to an eval within the DB package
3758          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3759          * unless they contain an eval, but calling eval within DB
3760          * pretends the eval was done in the caller's scope.
3761          */
3762         if (!cv)
3763             break;
3764         assert(CvPADLIST(cv));
3765         pn =
3766            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3767         assert(PadnameLEN(pn));
3768         PadnameLVALUE_on(pn);
3769     }
3770 }
3771
3772 static bool
3773 S_vivifies(const OPCODE type)
3774 {
3775     switch(type) {
3776     case OP_RV2AV:     case   OP_ASLICE:
3777     case OP_RV2HV:     case OP_KVASLICE:
3778     case OP_RV2SV:     case   OP_HSLICE:
3779     case OP_AELEMFAST: case OP_KVHSLICE:
3780     case OP_HELEM:
3781     case OP_AELEM:
3782         return 1;
3783     }
3784     return 0;
3785 }
3786
3787 static void
3788 S_lvref(pTHX_ OP *o, I32 type)
3789 {
3790     dVAR;
3791     OP *kid;
3792     switch (o->op_type) {
3793     case OP_COND_EXPR:
3794         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3795              kid = OpSIBLING(kid))
3796             S_lvref(aTHX_ kid, type);
3797         /* FALLTHROUGH */
3798     case OP_PUSHMARK:
3799         return;
3800     case OP_RV2AV:
3801         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3802         o->op_flags |= OPf_STACKED;
3803         if (o->op_flags & OPf_PARENS) {
3804             if (o->op_private & OPpLVAL_INTRO) {
3805                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3806                       "localized parenthesized array in list assignment"));
3807                 return;
3808             }
3809           slurpy:
3810             OpTYPE_set(o, OP_LVAVREF);
3811             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3812             o->op_flags |= OPf_MOD|OPf_REF;
3813             return;
3814         }
3815         o->op_private |= OPpLVREF_AV;
3816         goto checkgv;
3817     case OP_RV2CV:
3818         kid = cUNOPo->op_first;
3819         if (kid->op_type == OP_NULL)
3820             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3821                 ->op_first;
3822         o->op_private = OPpLVREF_CV;
3823         if (kid->op_type == OP_GV)
3824             o->op_flags |= OPf_STACKED;
3825         else if (kid->op_type == OP_PADCV) {
3826             o->op_targ = kid->op_targ;
3827             kid->op_targ = 0;
3828             op_free(cUNOPo->op_first);
3829             cUNOPo->op_first = NULL;
3830             o->op_flags &=~ OPf_KIDS;
3831         }
3832         else goto badref;
3833         break;
3834     case OP_RV2HV:
3835         if (o->op_flags & OPf_PARENS) {
3836           parenhash:
3837             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3838                                  "parenthesized hash in list assignment"));
3839                 return;
3840         }
3841         o->op_private |= OPpLVREF_HV;
3842         /* FALLTHROUGH */
3843     case OP_RV2SV:
3844       checkgv:
3845         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3846         o->op_flags |= OPf_STACKED;
3847         break;
3848     case OP_PADHV:
3849         if (o->op_flags & OPf_PARENS) goto parenhash;
3850         o->op_private |= OPpLVREF_HV;
3851         /* FALLTHROUGH */
3852     case OP_PADSV:
3853         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3854         break;
3855     case OP_PADAV:
3856         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3857         if (o->op_flags & OPf_PARENS) goto slurpy;
3858         o->op_private |= OPpLVREF_AV;
3859         break;
3860     case OP_AELEM:
3861     case OP_HELEM:
3862         o->op_private |= OPpLVREF_ELEM;
3863         o->op_flags   |= OPf_STACKED;
3864         break;
3865     case OP_ASLICE:
3866     case OP_HSLICE:
3867         OpTYPE_set(o, OP_LVREFSLICE);
3868         o->op_private &= OPpLVAL_INTRO;
3869         return;
3870     case OP_NULL:
3871         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3872             goto badref;
3873         else if (!(o->op_flags & OPf_KIDS))
3874             return;
3875         if (o->op_targ != OP_LIST) {
3876             S_lvref(aTHX_ cBINOPo->op_first, type);
3877             return;
3878         }
3879         /* FALLTHROUGH */
3880     case OP_LIST:
3881         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3882             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3883             S_lvref(aTHX_ kid, type);
3884         }
3885         return;
3886     case OP_STUB:
3887         if (o->op_flags & OPf_PARENS)
3888             return;
3889         /* FALLTHROUGH */
3890     default:
3891       badref:
3892         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3893         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3894                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3895                       ? "do block"
3896                       : OP_DESC(o),
3897                      PL_op_desc[type]));
3898         return;
3899     }
3900     OpTYPE_set(o, OP_LVREF);
3901     o->op_private &=
3902         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3903     if (type == OP_ENTERLOOP)
3904         o->op_private |= OPpLVREF_ITER;
3905 }
3906
3907 PERL_STATIC_INLINE bool
3908 S_potential_mod_type(I32 type)
3909 {
3910     /* Types that only potentially result in modification.  */
3911     return type == OP_GREPSTART || type == OP_ENTERSUB
3912         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3913 }
3914
3915 OP *
3916 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3917 {
3918     dVAR;
3919     OP *kid;
3920     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3921     int localize = -1;
3922
3923     if (!o || (PL_parser && PL_parser->error_count))
3924         return o;
3925
3926     if ((o->op_private & OPpTARGET_MY)
3927         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3928     {
3929         return o;
3930     }
3931
3932     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3933
3934     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3935
3936     switch (o->op_type) {
3937     case OP_UNDEF:
3938         PL_modcount++;
3939         return o;
3940     case OP_STUB:
3941         if ((o->op_flags & OPf_PARENS))
3942             break;
3943         goto nomod;
3944     case OP_ENTERSUB:
3945         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3946             !(o->op_flags & OPf_STACKED)) {
3947             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3948             assert(cUNOPo->op_first->op_type == OP_NULL);
3949             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3950             break;
3951         }
3952         else {                          /* lvalue subroutine call */
3953             o->op_private |= OPpLVAL_INTRO;
3954             PL_modcount = RETURN_UNLIMITED_NUMBER;
3955             if (S_potential_mod_type(type)) {
3956                 o->op_private |= OPpENTERSUB_INARGS;
3957                 break;
3958             }
3959             else {                      /* Compile-time error message: */
3960                 OP *kid = cUNOPo->op_first;
3961                 CV *cv;
3962                 GV *gv;
3963                 SV *namesv;
3964
3965                 if (kid->op_type != OP_PUSHMARK) {
3966                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3967                         Perl_croak(aTHX_
3968                                 "panic: unexpected lvalue entersub "
3969                                 "args: type/targ %ld:%" UVuf,
3970                                 (long)kid->op_type, (UV)kid->op_targ);
3971                     kid = kLISTOP->op_first;
3972                 }
3973                 while (OpHAS_SIBLING(kid))
3974                     kid = OpSIBLING(kid);
3975                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3976                     break;      /* Postpone until runtime */
3977                 }
3978
3979                 kid = kUNOP->op_first;
3980                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3981                     kid = kUNOP->op_first;
3982                 if (kid->op_type == OP_NULL)
3983                     Perl_croak(aTHX_
3984                                "Unexpected constant lvalue entersub "
3985                                "entry via type/targ %ld:%" UVuf,
3986                                (long)kid->op_type, (UV)kid->op_targ);
3987                 if (kid->op_type != OP_GV) {
3988                     break;
3989                 }
3990
3991                 gv = kGVOP_gv;
3992                 cv = isGV(gv)
3993                     ? GvCV(gv)
3994                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3995                         ? MUTABLE_CV(SvRV(gv))
3996                         : NULL;
3997                 if (!cv)
3998                     break;
3999                 if (CvLVALUE(cv))
4000                     break;
4001                 if (flags & OP_LVALUE_NO_CROAK)
4002                     return NULL;
4003
4004                 namesv = cv_name(cv, NULL, 0);
4005                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4006                                      "subroutine call of &%" SVf " in %s",
4007                                      SVfARG(namesv), PL_op_desc[type]),
4008                            SvUTF8(namesv));
4009                 return o;
4010             }
4011         }
4012         /* FALLTHROUGH */
4013     default:
4014       nomod:
4015         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4016         /* grep, foreach, subcalls, refgen */
4017         if (S_potential_mod_type(type))
4018             break;
4019         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4020                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4021                       ? "do block"
4022                       : OP_DESC(o)),
4023                      type ? PL_op_desc[type] : "local"));
4024         return o;
4025
4026     case OP_PREINC:
4027     case OP_PREDEC:
4028     case OP_POW:
4029     case OP_MULTIPLY:
4030     case OP_DIVIDE:
4031     case OP_MODULO:
4032     case OP_ADD:
4033     case OP_SUBTRACT:
4034     case OP_CONCAT:
4035     case OP_LEFT_SHIFT:
4036     case OP_RIGHT_SHIFT:
4037     case OP_BIT_AND:
4038     case OP_BIT_XOR:
4039     case OP_BIT_OR:
4040     case OP_I_MULTIPLY:
4041     case OP_I_DIVIDE:
4042     case OP_I_MODULO:
4043     case OP_I_ADD:
4044     case OP_I_SUBTRACT:
4045         if (!(o->op_flags & OPf_STACKED))
4046             goto nomod;
4047         PL_modcount++;
4048         break;
4049
4050     case OP_REPEAT:
4051         if (o->op_flags & OPf_STACKED) {
4052             PL_modcount++;
4053             break;
4054         }
4055         if (!(o->op_private & OPpREPEAT_DOLIST))
4056             goto nomod;
4057         else {
4058             const I32 mods = PL_modcount;
4059             modkids(cBINOPo->op_first, type);
4060             if (type != OP_AASSIGN)
4061                 goto nomod;
4062             kid = cBINOPo->op_last;
4063             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4064                 const IV iv = SvIV(kSVOP_sv);
4065                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4066                     PL_modcount =
4067                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4068             }
4069             else
4070                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4071         }
4072         break;
4073
4074     case OP_COND_EXPR:
4075         localize = 1;
4076         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4077             op_lvalue(kid, type);
4078         break;
4079
4080     case OP_RV2AV:
4081     case OP_RV2HV:
4082         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4083            PL_modcount = RETURN_UNLIMITED_NUMBER;
4084            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4085               fiable since some contexts need to know.  */
4086            o->op_flags |= OPf_MOD;
4087            return o;
4088         }
4089         /* FALLTHROUGH */
4090     case OP_RV2GV:
4091         if (scalar_mod_type(o, type))
4092             goto nomod;
4093         ref(cUNOPo->op_first, o->op_type);
4094         /* FALLTHROUGH */
4095     case OP_ASLICE:
4096     case OP_HSLICE:
4097         localize = 1;
4098         /* FALLTHROUGH */
4099     case OP_AASSIGN:
4100         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4101         if (type == OP_LEAVESUBLV && (
4102                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4103              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4104            ))
4105             o->op_private |= OPpMAYBE_LVSUB;
4106         /* FALLTHROUGH */
4107     case OP_NEXTSTATE:
4108     case OP_DBSTATE:
4109        PL_modcount = RETURN_UNLIMITED_NUMBER;
4110         break;
4111     case OP_KVHSLICE:
4112     case OP_KVASLICE:
4113     case OP_AKEYS:
4114         if (type == OP_LEAVESUBLV)
4115             o->op_private |= OPpMAYBE_LVSUB;
4116         goto nomod;
4117     case OP_AVHVSWITCH:
4118         if (type == OP_LEAVESUBLV
4119          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4120             o->op_private |= OPpMAYBE_LVSUB;
4121         goto nomod;
4122     case OP_AV2ARYLEN:
4123         PL_hints |= HINT_BLOCK_SCOPE;
4124         if (type == OP_LEAVESUBLV)
4125             o->op_private |= OPpMAYBE_LVSUB;
4126         PL_modcount++;
4127         break;
4128     case OP_RV2SV:
4129         ref(cUNOPo->op_first, o->op_type);
4130         localize = 1;
4131         /* FALLTHROUGH */
4132     case OP_GV:
4133         PL_hints |= HINT_BLOCK_SCOPE;
4134         /* FALLTHROUGH */
4135     case OP_SASSIGN:
4136     case OP_ANDASSIGN:
4137     case OP_ORASSIGN:
4138     case OP_DORASSIGN:
4139         PL_modcount++;
4140         break;
4141
4142     case OP_AELEMFAST:
4143     case OP_AELEMFAST_LEX:
4144         localize = -1;
4145         PL_modcount++;
4146         break;
4147
4148     case OP_PADAV:
4149     case OP_PADHV:
4150        PL_modcount = RETURN_UNLIMITED_NUMBER;
4151         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4152         {
4153            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4154               fiable since some contexts need to know.  */
4155             o->op_flags |= OPf_MOD;
4156             return o;
4157         }
4158         if (scalar_mod_type(o, type))
4159             goto nomod;
4160         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4161           && type == OP_LEAVESUBLV)
4162             o->op_private |= OPpMAYBE_LVSUB;
4163         /* FALLTHROUGH */
4164     case OP_PADSV:
4165         PL_modcount++;
4166         if (!type) /* local() */
4167             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4168                               PNfARG(PAD_COMPNAME(o->op_targ)));
4169         if (!(o->op_private & OPpLVAL_INTRO)
4170          || (  type != OP_SASSIGN && type != OP_AASSIGN
4171             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4172             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4173         break;
4174
4175     case OP_PUSHMARK:
4176         localize = 0;
4177         break;
4178
4179     case OP_KEYS:
4180         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4181             goto nomod;
4182         goto lvalue_func;
4183     case OP_SUBSTR:
4184         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4185             goto nomod;
4186         /* FALLTHROUGH */
4187     case OP_POS:
4188     case OP_VEC:
4189       lvalue_func:
4190         if (type == OP_LEAVESUBLV)
4191             o->op_private |= OPpMAYBE_LVSUB;
4192         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4193             /* substr and vec */
4194             /* If this op is in merely potential (non-fatal) modifiable
4195                context, then apply OP_ENTERSUB context to
4196                the kid op (to avoid croaking).  Other-
4197                wise pass this op’s own type so the correct op is mentioned
4198                in error messages.  */
4199             op_lvalue(OpSIBLING(cBINOPo->op_first),
4200                       S_potential_mod_type(type)
4201                         ? (I32)OP_ENTERSUB
4202                         : o->op_type);
4203         }
4204         break;
4205
4206     case OP_AELEM:
4207     case OP_HELEM:
4208         ref(cBINOPo->op_first, o->op_type);
4209         if (type == OP_ENTERSUB &&
4210              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4211             o->op_private |= OPpLVAL_DEFER;
4212         if (type == OP_LEAVESUBLV)
4213             o->op_private |= OPpMAYBE_LVSUB;
4214         localize = 1;
4215         PL_modcount++;
4216         break;
4217
4218     case OP_LEAVE:
4219     case OP_LEAVELOOP:
4220         o->op_private |= OPpLVALUE;
4221         /* FALLTHROUGH */
4222     case OP_SCOPE:
4223     case OP_ENTER:
4224     case OP_LINESEQ:
4225         localize = 0;
4226         if (o->op_flags & OPf_KIDS)
4227             op_lvalue(cLISTOPo->op_last, type);
4228         break;
4229
4230     case OP_NULL:
4231         localize = 0;
4232         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4233             goto nomod;
4234         else if (!(o->op_flags & OPf_KIDS))
4235             break;
4236
4237         if (o->op_targ != OP_LIST) {
4238             OP *sib = OpSIBLING(cLISTOPo->op_first);
4239             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4240              * that looks like
4241              *
4242              *   null
4243              *      arg
4244              *      trans
4245              *
4246              * compared with things like OP_MATCH which have the argument
4247              * as a child:
4248              *
4249              *   match
4250              *      arg
4251              *
4252              * so handle specially to correctly get "Can't modify" croaks etc
4253              */
4254
4255             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4256             {
4257                 /* this should trigger a "Can't modify transliteration" err */
4258                 op_lvalue(sib, type);
4259             }
4260             op_lvalue(cBINOPo->op_first, type);
4261             break;
4262         }
4263         /* FALLTHROUGH */
4264     case OP_LIST:
4265         localize = 0;
4266         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4267             /* elements might be in void context because the list is
4268                in scalar context or because they are attribute sub calls */
4269             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4270                 op_lvalue(kid, type);
4271         break;
4272
4273     case OP_COREARGS:
4274         return o;
4275
4276     case OP_AND:
4277     case OP_OR:
4278         if (type == OP_LEAVESUBLV
4279          || !S_vivifies(cLOGOPo->op_first->op_type))
4280             op_lvalue(cLOGOPo->op_first, type);
4281         if (type == OP_LEAVESUBLV
4282          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4283             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4284         goto nomod;
4285
4286     case OP_SREFGEN:
4287         if (type == OP_NULL) { /* local */
4288           local_refgen:
4289             if (!FEATURE_MYREF_IS_ENABLED)
4290                 Perl_croak(aTHX_ "The experimental declared_refs "
4291                                  "feature is not enabled");
4292             Perl_ck_warner_d(aTHX_
4293                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4294                     "Declaring references is experimental");
4295             op_lvalue(cUNOPo->op_first, OP_NULL);
4296             return o;
4297         }
4298         if (type != OP_AASSIGN && type != OP_SASSIGN
4299          && type != OP_ENTERLOOP)
4300             goto nomod;
4301         /* Don’t bother applying lvalue context to the ex-list.  */
4302         kid = cUNOPx(cUNOPo->op_first)->op_first;
4303         assert (!OpHAS_SIBLING(kid));
4304         goto kid_2lvref;
4305     case OP_REFGEN:
4306         if (type == OP_NULL) /* local */
4307             goto local_refgen;
4308         if (type != OP_AASSIGN) goto nomod;
4309         kid = cUNOPo->op_first;
4310       kid_2lvref:
4311         {
4312             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4313             S_lvref(aTHX_ kid, type);
4314             if (!PL_parser || PL_parser->error_count == ec) {
4315                 if (!FEATURE_REFALIASING_IS_ENABLED)
4316                     Perl_croak(aTHX_
4317                        "Experimental aliasing via reference not enabled");
4318                 Perl_ck_warner_d(aTHX_
4319                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4320                                 "Aliasing via reference is experimental");
4321             }
4322         }
4323         if (o->op_type == OP_REFGEN)
4324             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4325         op_null(o);
4326         return o;
4327
4328     case OP_SPLIT:
4329         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4330             /* This is actually @array = split.  */
4331             PL_modcount = RETURN_UNLIMITED_NUMBER;
4332             break;
4333         }
4334         goto nomod;
4335
4336     case OP_SCALAR:
4337         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4338         goto nomod;
4339     }
4340
4341     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4342        their argument is a filehandle; thus \stat(".") should not set
4343        it. AMS 20011102 */
4344     if (type == OP_REFGEN &&
4345         PL_check[o->op_type] == Perl_ck_ftst)
4346         return o;
4347
4348     if (type != OP_LEAVESUBLV)
4349         o->op_flags |= OPf_MOD;
4350
4351     if (type == OP_AASSIGN || type == OP_SASSIGN)
4352         o->op_flags |= OPf_SPECIAL
4353                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4354     else if (!type) { /* local() */
4355         switch (localize) {
4356         case 1:
4357             o->op_private |= OPpLVAL_INTRO;
4358             o->op_flags &= ~OPf_SPECIAL;
4359             PL_hints |= HINT_BLOCK_SCOPE;
4360             break;
4361         case 0:
4362             break;
4363         case -1:
4364             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4365                            "Useless localization of %s", OP_DESC(o));
4366         }
4367     }
4368     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4369              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4370         o->op_flags |= OPf_REF;
4371     return o;
4372 }
4373
4374 STATIC bool
4375 S_scalar_mod_type(const OP *o, I32 type)
4376 {
4377     switch (type) {
4378     case OP_POS:
4379     case OP_SASSIGN:
4380         if (o && o->op_type == OP_RV2GV)
4381             return FALSE;
4382         /* FALLTHROUGH */
4383     case OP_PREINC:
4384     case OP_PREDEC:
4385     case OP_POSTINC:
4386     case OP_POSTDEC:
4387     case OP_I_PREINC:
4388     case OP_I_PREDEC:
4389     case OP_I_POSTINC:
4390     case OP_I_POSTDEC:
4391     case OP_POW:
4392     case OP_MULTIPLY:
4393     case OP_DIVIDE:
4394     case OP_MODULO:
4395     case OP_REPEAT:
4396     case OP_ADD:
4397     case OP_SUBTRACT:
4398     case OP_I_MULTIPLY:
4399     case OP_I_DIVIDE:
4400     case OP_I_MODULO:
4401     case OP_I_ADD:
4402     case OP_I_SUBTRACT:
4403     case OP_LEFT_SHIFT:
4404     case OP_RIGHT_SHIFT:
4405     case OP_BIT_AND:
4406     case OP_BIT_XOR:
4407     case OP_BIT_OR:
4408     case OP_NBIT_AND:
4409     case OP_NBIT_XOR:
4410     case OP_NBIT_OR:
4411     case OP_SBIT_AND:
4412     case OP_SBIT_XOR:
4413     case OP_SBIT_OR:
4414     case OP_CONCAT:
4415     case OP_SUBST:
4416     case OP_TRANS:
4417     case OP_TRANSR:
4418     case OP_READ:
4419     case OP_SYSREAD:
4420     case OP_RECV:
4421     case OP_ANDASSIGN:
4422     case OP_ORASSIGN:
4423     case OP_DORASSIGN:
4424     case OP_VEC:
4425     case OP_SUBSTR:
4426         return TRUE;
4427     default:
4428         return FALSE;
4429     }
4430 }
4431
4432 STATIC bool
4433 S_is_handle_constructor(const OP *o, I32 numargs)
4434 {
4435     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4436
4437     switch (o->op_type) {
4438     case OP_PIPE_OP:
4439     case OP_SOCKPAIR:
4440         if (numargs == 2)
4441             return TRUE;
4442         /* FALLTHROUGH */
4443     case OP_SYSOPEN:
4444     case OP_OPEN:
4445     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4446     case OP_SOCKET:
4447     case OP_OPEN_DIR:
4448     case OP_ACCEPT:
4449         if (numargs == 1)
4450             return TRUE;
4451         /* FALLTHROUGH */
4452     default:
4453         return FALSE;
4454     }
4455 }
4456
4457 static OP *
4458 S_refkids(pTHX_ OP *o, I32 type)
4459 {
4460     if (o && o->op_flags & OPf_KIDS) {
4461         OP *kid;
4462         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4463             ref(kid, type);
4464     }
4465     return o;
4466 }
4467
4468 OP *
4469 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4470 {
4471     dVAR;
4472     OP *kid;
4473
4474     PERL_ARGS_ASSERT_DOREF;
4475
4476     if (PL_parser && PL_parser->error_count)
4477         return o;
4478
4479     switch (o->op_type) {
4480     case OP_ENTERSUB:
4481         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4482             !(o->op_flags & OPf_STACKED)) {
4483             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4484             assert(cUNOPo->op_first->op_type == OP_NULL);
4485             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4486             o->op_flags |= OPf_SPECIAL;
4487         }
4488         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4489             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4490                               : type == OP_RV2HV ? OPpDEREF_HV
4491                               : OPpDEREF_SV);
4492             o->op_flags |= OPf_MOD;
4493         }
4494
4495         break;
4496
4497     case OP_COND_EXPR:
4498         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4499             doref(kid, type, set_op_ref);
4500         break;
4501     case OP_RV2SV:
4502         if (type == OP_DEFINED)
4503             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4504         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4505         /* FALLTHROUGH */
4506     case OP_PADSV:
4507         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4508             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4509                               : type == OP_RV2HV ? OPpDEREF_HV
4510                               : OPpDEREF_SV);
4511             o->op_flags |= OPf_MOD;
4512         }
4513         break;
4514
4515     case OP_RV2AV:
4516     case OP_RV2HV:
4517         if (set_op_ref)
4518             o->op_flags |= OPf_REF;
4519         /* FALLTHROUGH */
4520     case OP_RV2GV:
4521         if (type == OP_DEFINED)
4522             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4523         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4524         break;
4525
4526     case OP_PADAV:
4527     case OP_PADHV:
4528         if (set_op_ref)
4529             o->op_flags |= OPf_REF;
4530         break;
4531
4532     case OP_SCALAR:
4533     case OP_NULL:
4534         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4535             break;
4536         doref(cBINOPo->op_first, type, set_op_ref);
4537         break;
4538     case OP_AELEM:
4539     case OP_HELEM:
4540         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4541         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4542             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4543                               : type == OP_RV2HV ? OPpDEREF_HV
4544                               : OPpDEREF_SV);
4545             o->op_flags |= OPf_MOD;
4546         }
4547         break;
4548
4549     case OP_SCOPE:
4550     case OP_LEAVE:
4551         set_op_ref = FALSE;
4552         /* FALLTHROUGH */
4553     case OP_ENTER:
4554     case OP_LIST:
4555         if (!(o->op_flags & OPf_KIDS))
4556             break;
4557         doref(cLISTOPo->op_last, type, set_op_ref);
4558         break;
4559     default:
4560         break;
4561     }
4562     return scalar(o);
4563
4564 }
4565
4566 STATIC OP *
4567 S_dup_attrlist(pTHX_ OP *o)
4568 {
4569     OP *rop;
4570
4571     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4572
4573     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4574      * where the first kid is OP_PUSHMARK and the remaining ones
4575      * are OP_CONST.  We need to push the OP_CONST values.
4576      */
4577     if (o->op_type == OP_CONST)
4578         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4579     else {
4580         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4581         rop = NULL;
4582         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4583             if (o->op_type == OP_CONST)
4584                 rop = op_append_elem(OP_LIST, rop,
4585                                   newSVOP(OP_CONST, o->op_flags,
4586                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4587         }
4588     }
4589     return rop;
4590 }
4591
4592 STATIC void
4593 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4594 {
4595     PERL_ARGS_ASSERT_APPLY_ATTRS;
4596     {
4597         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4598
4599         /* fake up C<use attributes $pkg,$rv,@attrs> */
4600
4601 #define ATTRSMODULE "attributes"
4602 #define ATTRSMODULE_PM "attributes.pm"
4603
4604         Perl_load_module(
4605           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4606           newSVpvs(ATTRSMODULE),
4607           NULL,
4608           op_prepend_elem(OP_LIST,
4609                           newSVOP(OP_CONST, 0, stashsv),
4610                           op_prepend_elem(OP_LIST,
4611                                           newSVOP(OP_CONST, 0,
4612                                                   newRV(target)),
4613                                           dup_attrlist(attrs))));
4614     }
4615 }
4616
4617 STATIC void
4618 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4619 {
4620     OP *pack, *imop, *arg;
4621     SV *meth, *stashsv, **svp;
4622
4623     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4624
4625     if (!attrs)
4626         return;
4627
4628     assert(target->op_type == OP_PADSV ||
4629            target->op_type == OP_PADHV ||
4630            target->op_type == OP_PADAV);
4631
4632     /* Ensure that attributes.pm is loaded. */
4633     /* Don't force the C<use> if we don't need it. */
4634     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4635     if (svp && *svp != &PL_sv_undef)
4636         NOOP;   /* already in %INC */
4637     else
4638         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4639                                newSVpvs(ATTRSMODULE), NULL);
4640
4641     /* Need package name for method call. */
4642     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4643
4644     /* Build up the real arg-list. */
4645     stashsv = newSVhek(HvNAME_HEK(stash));
4646
4647     arg = newOP(OP_PADSV, 0);
4648     arg->op_targ = target->op_targ;
4649     arg = op_prepend_elem(OP_LIST,
4650                        newSVOP(OP_CONST, 0, stashsv),
4651                        op_prepend_elem(OP_LIST,
4652                                     newUNOP(OP_REFGEN, 0,
4653                                             arg),
4654                                     dup_attrlist(attrs)));
4655
4656     /* Fake up a method call to import */
4657     meth = newSVpvs_share("import");
4658     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4659                    op_append_elem(OP_LIST,
4660                                op_prepend_elem(OP_LIST, pack, arg),
4661                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4662
4663     /* Combine the ops. */
4664     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4665 }
4666
4667 /*
4668 =notfor apidoc apply_attrs_string
4669
4670 Attempts to apply a list of attributes specified by the C<attrstr> and
4671 C<len> arguments to the subroutine identified by the C<cv> argument which
4672 is expected to be associated with the package identified by the C<stashpv>
4673 argument (see L<attributes>).  It gets this wrong, though, in that it
4674 does not correctly identify the boundaries of the individual attribute
4675 specifications within C<attrstr>.  This is not really intended for the
4676 public API, but has to be listed here for systems such as AIX which
4677 need an explicit export list for symbols.  (It's called from XS code
4678 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4679 to respect attribute syntax properly would be welcome.
4680
4681 =cut
4682 */
4683
4684 void
4685 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4686                         const char *attrstr, STRLEN len)
4687 {
4688     OP *attrs = NULL;
4689
4690     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4691
4692     if (!len) {
4693         len = strlen(attrstr);
4694     }
4695
4696     while (len) {
4697         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4698         if (len) {
4699             const char * const sstr = attrstr;
4700             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4701             attrs = op_append_elem(OP_LIST, attrs,
4702                                 newSVOP(OP_CONST, 0,
4703                                         newSVpvn(sstr, attrstr-sstr)));
4704         }
4705     }
4706
4707     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4708                      newSVpvs(ATTRSMODULE),
4709                      NULL, op_prepend_elem(OP_LIST,
4710                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4711                                   op_prepend_elem(OP_LIST,
4712                                                newSVOP(OP_CONST, 0,
4713                                                        newRV(MUTABLE_SV(cv))),
4714                                                attrs)));
4715 }
4716
4717 STATIC void
4718 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4719                         bool curstash)
4720 {
4721     OP *new_proto = NULL;
4722     STRLEN pvlen;
4723     char *pv;
4724     OP *o;
4725
4726     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4727
4728     if (!*attrs)
4729         return;
4730
4731     o = *attrs;
4732     if (o->op_type == OP_CONST) {
4733         pv = SvPV(cSVOPo_sv, pvlen);
4734         if (memBEGINs(pv, pvlen, "prototype(")) {
4735             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4736             SV ** const tmpo = cSVOPx_svp(o);
4737             SvREFCNT_dec(cSVOPo_sv);
4738             *tmpo = tmpsv;
4739             new_proto = o;
4740             *attrs = NULL;
4741         }
4742     } else if (o->op_type == OP_LIST) {
4743         OP * lasto;
4744         assert(o->op_flags & OPf_KIDS);
4745         lasto = cLISTOPo->op_first;
4746         assert(lasto->op_type == OP_PUSHMARK);
4747         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4748             if (o->op_type == OP_CONST) {
4749                 pv = SvPV(cSVOPo_sv, pvlen);
4750                 if (memBEGINs(pv, pvlen, "prototype(")) {
4751                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4752                     SV ** const tmpo = cSVOPx_svp(o);
4753                     SvREFCNT_dec(cSVOPo_sv);
4754                     *tmpo = tmpsv;
4755                     if (new_proto && ckWARN(WARN_MISC)) {
4756                         STRLEN new_len;
4757                         const char * newp = SvPV(cSVOPo_sv, new_len);
4758                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4759                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4760                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4761                         op_free(new_proto);
4762                     }
4763                     else if (new_proto)
4764                         op_free(new_proto);
4765                     new_proto = o;
4766                     /* excise new_proto from the list */
4767                     op_sibling_splice(*attrs, lasto, 1, NULL);
4768                     o = lasto;
4769                     continue;
4770                 }
4771             }
4772             lasto = o;
4773         }
4774         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4775            would get pulled in with no real need */
4776         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4777             op_free(*attrs);
4778             *attrs = NULL;
4779         }
4780     }
4781
4782     if (new_proto) {
4783         SV *svname;
4784         if (isGV(name)) {
4785             svname = sv_newmortal();
4786             gv_efullname3(svname, name, NULL);
4787         }
4788         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4789             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4790         else
4791             svname = (SV *)name;
4792         if (ckWARN(WARN_ILLEGALPROTO))
4793             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4794                                  curstash);
4795         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4796             STRLEN old_len, new_len;
4797             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4798             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4799
4800             if (curstash && svname == (SV *)name
4801              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4802                 svname = sv_2mortal(newSVsv(PL_curstname));
4803                 sv_catpvs(svname, "::");
4804                 sv_catsv(svname, (SV *)name);
4805             }
4806
4807             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4808                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4809                 " in %" SVf,
4810                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4811                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4812                 SVfARG(svname));
4813         }
4814         if (*proto)
4815             op_free(*proto);
4816         *proto = new_proto;
4817     }
4818 }
4819
4820 static void
4821 S_cant_declare(pTHX_ OP *o)
4822 {
4823     if (o->op_type == OP_NULL
4824      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4825         o = cUNOPo->op_first;
4826     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4827                              o->op_type == OP_NULL
4828                                && o->op_flags & OPf_SPECIAL
4829                                  ? "do block"
4830                                  : OP_DESC(o),
4831                              PL_parser->in_my == KEY_our   ? "our"   :
4832                              PL_parser->in_my == KEY_state ? "state" :
4833                                                              "my"));
4834 }
4835
4836 STATIC OP *
4837 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4838 {
4839     I32 type;
4840     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4841
4842     PERL_ARGS_ASSERT_MY_KID;
4843
4844     if (!o || (PL_parser && PL_parser->error_count))
4845         return o;
4846
4847     type = o->op_type;
4848
4849     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4850         OP *kid;
4851         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4852             my_kid(kid, attrs, imopsp);
4853         return o;
4854     } else if (type == OP_UNDEF || type == OP_STUB) {
4855         return o;
4856     } else if (type == OP_RV2SV ||      /* "our" declaration */
4857                type == OP_RV2AV ||
4858                type == OP_RV2HV) {
4859         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4860             S_cant_declare(aTHX_ o);
4861         } else if (attrs) {
4862             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4863             assert(PL_parser);
4864             PL_parser->in_my = FALSE;
4865             PL_parser->in_my_stash = NULL;
4866             apply_attrs(GvSTASH(gv),
4867                         (type == OP_RV2SV ? GvSVn(gv) :
4868                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4869                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4870                         attrs);
4871         }
4872         o->op_private |= OPpOUR_INTRO;
4873         return o;
4874     }
4875     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4876         if (!FEATURE_MYREF_IS_ENABLED)
4877             Perl_croak(aTHX_ "The experimental declared_refs "
4878                              "feature is not enabled");
4879         Perl_ck_warner_d(aTHX_
4880              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4881             "Declaring references is experimental");
4882         /* Kid is a nulled OP_LIST, handled above.  */
4883         my_kid(cUNOPo->op_first, attrs, imopsp);
4884         return o;
4885     }
4886     else if (type != OP_PADSV &&
4887              type != OP_PADAV &&
4888              type != OP_PADHV &&
4889              type != OP_PUSHMARK)
4890     {
4891         S_cant_declare(aTHX_ o);
4892         return o;
4893     }
4894     else if (attrs && type != OP_PUSHMARK) {
4895         HV *stash;
4896
4897         assert(PL_parser);
4898         PL_parser->in_my = FALSE;
4899         PL_parser->in_my_stash = NULL;
4900
4901         /* check for C<my Dog $spot> when deciding package */
4902         stash = PAD_COMPNAME_TYPE(o->op_targ);
4903         if (!stash)
4904             stash = PL_curstash;
4905         apply_attrs_my(stash, o, attrs, imopsp);
4906     }
4907     o->op_flags |= OPf_MOD;
4908     o->op_private |= OPpLVAL_INTRO;
4909     if (stately)
4910         o->op_private |= OPpPAD_STATE;
4911     return o;
4912 }
4913
4914 OP *
4915 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4916 {
4917     OP *rops;
4918     int maybe_scalar = 0;
4919
4920     PERL_ARGS_ASSERT_MY_ATTRS;
4921
4922 /* [perl #17376]: this appears to be premature, and results in code such as
4923    C< our(%x); > executing in list mode rather than void mode */
4924 #if 0
4925     if (o->op_flags & OPf_PARENS)
4926         list(o);
4927     else
4928         maybe_scalar = 1;
4929 #else
4930     maybe_scalar = 1;
4931 #endif
4932     if (attrs)
4933         SAVEFREEOP(attrs);
4934     rops = NULL;
4935     o = my_kid(o, attrs, &rops);
4936     if (rops) {
4937         if (maybe_scalar && o->op_type == OP_PADSV) {
4938             o = scalar(op_append_list(OP_LIST, rops, o));
4939             o->op_private |= OPpLVAL_INTRO;
4940         }
4941         else {
4942             /* The listop in rops might have a pushmark at the beginning,
4943                which will mess up list assignment. */
4944             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4945             if (rops->op_type == OP_LIST &&
4946                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4947             {
4948                 OP * const pushmark = lrops->op_first;
4949                 /* excise pushmark */
4950                 op_sibling_splice(rops, NULL, 1, NULL);
4951                 op_free(pushmark);
4952             }
4953             o = op_append_list(OP_LIST, o, rops);
4954         }
4955     }
4956     PL_parser->in_my = FALSE;
4957     PL_parser->in_my_stash = NULL;
4958     return o;
4959 }
4960
4961 OP *
4962 Perl_sawparens(pTHX_ OP *o)
4963 {
4964     PERL_UNUSED_CONTEXT;
4965     if (o)
4966         o->op_flags |= OPf_PARENS;
4967     return o;
4968 }
4969
4970 OP *
4971 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4972 {
4973     OP *o;
4974     bool ismatchop = 0;
4975     const OPCODE ltype = left->op_type;
4976     const OPCODE rtype = right->op_type;
4977
4978     PERL_ARGS_ASSERT_BIND_MATCH;
4979
4980     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4981           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4982     {
4983       const char * const desc
4984           = PL_op_desc[(
4985                           rtype == OP_SUBST || rtype == OP_TRANS
4986                        || rtype == OP_TRANSR
4987                        )
4988                        ? (int)rtype : OP_MATCH];
4989       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4990       SV * const name =
4991         S_op_varname(aTHX_ left);
4992       if (name)
4993         Perl_warner(aTHX_ packWARN(WARN_MISC),
4994              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4995              desc, SVfARG(name), SVfARG(name));
4996       else {
4997         const char * const sample = (isary
4998              ? "@array" : "%hash");
4999         Perl_warner(aTHX_ packWARN(WARN_MISC),
5000              "Applying %s to %s will act on scalar(%s)",
5001              desc, sample, sample);
5002       }
5003     }
5004
5005     if (rtype == OP_CONST &&
5006         cSVOPx(right)->op_private & OPpCONST_BARE &&
5007         cSVOPx(right)->op_private & OPpCONST_STRICT)
5008     {
5009         no_bareword_allowed(right);
5010     }
5011
5012     /* !~ doesn't make sense with /r, so error on it for now */
5013     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5014         type == OP_NOT)
5015         /* diag_listed_as: Using !~ with %s doesn't make sense */
5016         yyerror("Using !~ with s///r doesn't make sense");
5017     if (rtype == OP_TRANSR && type == OP_NOT)
5018         /* diag_listed_as: Using !~ with %s doesn't make sense */
5019         yyerror("Using !~ with tr///r doesn't make sense");
5020
5021     ismatchop = (rtype == OP_MATCH ||
5022                  rtype == OP_SUBST ||
5023                  rtype == OP_TRANS || rtype == OP_TRANSR)
5024              && !(right->op_flags & OPf_SPECIAL);
5025     if (ismatchop && right->op_private & OPpTARGET_MY) {
5026         right->op_targ = 0;
5027         right->op_private &= ~OPpTARGET_MY;
5028     }
5029     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5030         if (left->op_type == OP_PADSV
5031          && !(left->op_private & OPpLVAL_INTRO))
5032         {
5033             right->op_targ = left->op_targ;
5034             op_free(left);
5035             o = right;
5036         }
5037         else {
5038             right->op_flags |= OPf_STACKED;
5039             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5040             ! (rtype == OP_TRANS &&
5041                right->op_private & OPpTRANS_IDENTICAL) &&
5042             ! (rtype == OP_SUBST &&
5043                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5044                 left = op_lvalue(left, rtype);
5045             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5046                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5047             else
5048                 o = op_prepend_elem(rtype, scalar(left), right);
5049         }
5050         if (type == OP_NOT)
5051             return newUNOP(OP_NOT, 0, scalar(o));
5052         return o;
5053     }
5054     else
5055         return bind_match(type, left,
5056                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5057 }
5058
5059 OP *
5060 Perl_invert(pTHX_ OP *o)
5061 {
5062     if (!o)
5063         return NULL;
5064     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5065 }
5066
5067 /*
5068 =for apidoc Amx|OP *|op_scope|OP *o
5069
5070 Wraps up an op tree with some additional ops so that at runtime a dynamic
5071 scope will be created.  The original ops run in the new dynamic scope,
5072 and then, provided that they exit normally, the scope will be unwound.
5073 The additional ops used to create and unwind the dynamic scope will
5074 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5075 instead if the ops are simple enough to not need the full dynamic scope
5076 structure.
5077
5078 =cut
5079 */
5080
5081 OP *
5082 Perl_op_scope(pTHX_ OP *o)
5083 {
5084     dVAR;
5085     if (o) {
5086         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5087             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5088             OpTYPE_set(o, OP_LEAVE);
5089         }
5090         else if (o->op_type == OP_LINESEQ) {
5091             OP *kid;
5092             OpTYPE_set(o, OP_SCOPE);
5093             kid = ((LISTOP*)o)->op_first;
5094             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5095                 op_null(kid);
5096
5097                 /* The following deals with things like 'do {1 for 1}' */
5098                 kid = OpSIBLING(kid);
5099                 if (kid &&
5100                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5101                     op_null(kid);
5102             }
5103         }
5104         else
5105             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5106     }
5107     return o;
5108 }
5109
5110 OP *
5111 Perl_op_unscope(pTHX_ OP *o)
5112 {
5113     if (o && o->op_type == OP_LINESEQ) {
5114         OP *kid = cLISTOPo->op_first;
5115         for(; kid; kid = OpSIBLING(kid))
5116             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5117                 op_null(kid);
5118     }
5119     return o;
5120 }
5121
5122 /*
5123 =for apidoc Am|int|block_start|int full
5124
5125 Handles compile-time scope entry.
5126 Arranges for hints to be restored on block
5127 exit and also handles pad sequence numbers to make lexical variables scope
5128 right.  Returns a savestack index for use with C<block_end>.
5129
5130 =cut
5131 */
5132
5133 int
5134 Perl_block_start(pTHX_ int full)
5135 {
5136     const int retval = PL_savestack_ix;
5137
5138     PL_compiling.cop_seq = PL_cop_seqmax;
5139     COP_SEQMAX_INC;
5140     pad_block_start(full);
5141     SAVEHINTS();
5142     PL_hints &= ~HINT_BLOCK_SCOPE;
5143     SAVECOMPILEWARNINGS();
5144     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5145     SAVEI32(PL_compiling.cop_seq);
5146     PL_compiling.cop_seq = 0;
5147
5148     CALL_BLOCK_HOOKS(bhk_start, full);
5149
5150     return retval;
5151 }
5152
5153 /*
5154 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5155
5156 Handles compile-time scope exit.  C<floor>
5157 is the savestack index returned by
5158 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5159 possibly modified.
5160
5161 =cut
5162 */
5163
5164 OP*
5165 Perl_block_end(pTHX_ I32 floor, OP *seq)
5166 {
5167     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5168     OP* retval = scalarseq(seq);
5169     OP *o;
5170
5171     /* XXX Is the null PL_parser check necessary here? */
5172     assert(PL_parser); /* Let’s find out under debugging builds.  */
5173     if (PL_parser && PL_parser->parsed_sub) {
5174         o = newSTATEOP(0, NULL, NULL);
5175         op_null(o);
5176         retval = op_append_elem(OP_LINESEQ, retval, o);
5177     }
5178
5179     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5180
5181     LEAVE_SCOPE(floor);
5182     if (needblockscope)
5183         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5184     o = pad_leavemy();
5185
5186     if (o) {
5187         /* pad_leavemy has created a sequence of introcv ops for all my
5188            subs declared in the block.  We have to replicate that list with
5189            clonecv ops, to deal with this situation:
5190
5191                sub {
5192                    my sub s1;
5193                    my sub s2;
5194                    sub s1 { state sub foo { \&s2 } }
5195                }->()
5196
5197            Originally, I was going to have introcv clone the CV and turn
5198            off the stale flag.  Since &s1 is declared before &s2, the
5199            introcv op for &s1 is executed (on sub entry) before the one for
5200            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5201            cloned, since it is a state sub) closes over &s2 and expects
5202            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5203            then &s2 is still marked stale.  Since &s1 is not active, and
5204            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5205            ble will not stay shared’ warning.  Because it is the same stub
5206            that will be used when the introcv op for &s2 is executed, clos-
5207            ing over it is safe.  Hence, we have to turn off the stale flag
5208            on all lexical subs in the block before we clone any of them.
5209            Hence, having introcv clone the sub cannot work.  So we create a
5210            list of ops like this:
5211
5212                lineseq
5213                   |
5214                   +-- introcv
5215                   |
5216                   +-- introcv
5217                   |
5218                   +-- introcv
5219                   |
5220                   .
5221                   .
5222                   .
5223                   |
5224                   +-- clonecv
5225                   |
5226                   +-- clonecv
5227                   |
5228                   +-- clonecv
5229                   |
5230                   .
5231                   .
5232                   .
5233          */
5234         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5235         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5236         for (;; kid = OpSIBLING(kid)) {
5237             OP *newkid = newOP(OP_CLONECV, 0);
5238             newkid->op_targ = kid->op_targ;
5239             o = op_append_elem(OP_LINESEQ, o, newkid);
5240             if (kid == last) break;
5241         }
5242         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5243     }
5244
5245     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5246
5247     return retval;
5248 }
5249
5250 /*
5251 =head1 Compile-time scope hooks
5252
5253 =for apidoc Aox||blockhook_register
5254
5255 Register a set of hooks to be called when the Perl lexical scope changes
5256 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5257
5258 =cut
5259 */
5260
5261 void
5262 Perl_blockhook_register(pTHX_ BHK *hk)
5263 {
5264     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5265
5266     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5267 }
5268
5269 void
5270 Perl_newPROG(pTHX_ OP *o)
5271 {
5272     OP *start;
5273
5274     PERL_ARGS_ASSERT_NEWPROG;
5275
5276     if (PL_in_eval) {
5277         PERL_CONTEXT *cx;
5278         I32 i;
5279         if (PL_eval_root)
5280                 return;
5281         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5282                                ((PL_in_eval & EVAL_KEEPERR)
5283                                 ? OPf_SPECIAL : 0), o);
5284
5285         cx = CX_CUR();
5286         assert(CxTYPE(cx) == CXt_EVAL);
5287
5288         if ((cx->blk_gimme & G_WANT) == G_VOID)
5289             scalarvoid(PL_eval_root);
5290         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5291             list(PL_eval_root);
5292         else
5293             scalar(PL_eval_root);
5294
5295         start = op_linklist(PL_eval_root);
5296         PL_eval_root->op_next = 0;
5297         i = PL_savestack_ix;
5298         SAVEFREEOP(o);
5299         ENTER;
5300         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5301         LEAVE;
5302         PL_savestack_ix = i;
5303     }
5304     else {
5305         if (o->op_type == OP_STUB) {
5306             /* This block is entered if nothing is compiled for the main
5307                program. This will be the case for an genuinely empty main
5308                program, or one which only has BEGIN blocks etc, so already
5309                run and freed.
5310
5311                Historically (5.000) the guard above was !o. However, commit
5312                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5313                c71fccf11fde0068, changed perly.y so that newPROG() is now
5314                called with the output of block_end(), which returns a new
5315                OP_STUB for the case of an empty optree. ByteLoader (and
5316                maybe other things) also take this path, because they set up
5317                PL_main_start and PL_main_root directly, without generating an
5318                optree.
5319
5320                If the parsing the main program aborts (due to parse errors,
5321                or due to BEGIN or similar calling exit), then newPROG()
5322                isn't even called, and hence this code path and its cleanups
5323                are skipped. This shouldn't make a make a difference:
5324                * a non-zero return from perl_parse is a failure, and
5325                  perl_destruct() should be called immediately.
5326                * however, if exit(0) is called during the parse, then
5327                  perl_parse() returns 0, and perl_run() is called. As
5328                  PL_main_start will be NULL, perl_run() will return
5329                  promptly, and the exit code will remain 0.
5330             */
5331
5332             PL_comppad_name = 0;
5333             PL_compcv = 0;
5334             S_op_destroy(aTHX_ o);
5335             return;
5336         }
5337         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5338         PL_curcop = &PL_compiling;
5339         start = LINKLIST(PL_main_root);
5340         PL_main_root->op_next = 0;
5341         S_process_optree(aTHX_ NULL, PL_main_root, start);
5342         cv_forget_slab(PL_compcv);
5343         PL_compcv = 0;
5344
5345         /* Register with debugger */
5346         if (PERLDB_INTER) {
5347             CV * const cv = get_cvs("DB::postponed", 0);
5348             if (cv) {
5349                 dSP;
5350                 PUSHMARK(SP);
5351                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5352                 PUTBACK;
5353                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5354             }
5355         }
5356     }
5357 }
5358
5359 OP *
5360 Perl_localize(pTHX_ OP *o, I32 lex)
5361 {
5362     PERL_ARGS_ASSERT_LOCALIZE;
5363
5364     if (o->op_flags & OPf_PARENS)
5365 /* [perl #17376]: this appears to be premature, and results in code such as
5366    C< our(%x); > executing in list mode rather than void mode */
5367 #if 0
5368         list(o);
5369 #else
5370         NOOP;
5371 #endif
5372     else {
5373         if ( PL_parser->bufptr > PL_parser->oldbufptr
5374             && PL_parser->bufptr[-1] == ','
5375             && ckWARN(WARN_PARENTHESIS))
5376         {
5377             char *s = PL_parser->bufptr;
5378             bool sigil = FALSE;
5379
5380             /* some heuristics to detect a potential error */
5381             while (*s && (strchr(", \t\n", *s)))
5382                 s++;
5383
5384             while (1) {
5385                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5386                        && *++s
5387                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5388                     s++;
5389                     sigil = TRUE;
5390                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5391                         s++;
5392                     while (*s && (strchr(", \t\n", *s)))
5393                         s++;
5394                 }
5395                 else
5396                     break;
5397             }
5398             if (sigil && (*s == ';' || *s == '=')) {
5399                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5400                                 "Parentheses missing around \"%s\" list",
5401                                 lex
5402                                     ? (PL_parser->in_my == KEY_our
5403                                         ? "our"
5404                                         : PL_parser->in_my == KEY_state
5405                                             ? "state"
5406                                             : "my")
5407                                     : "local");
5408             }
5409         }
5410     }
5411     if (lex)
5412         o = my(o);
5413     else
5414         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5415     PL_parser->in_my = FALSE;
5416     PL_parser->in_my_stash = NULL;
5417     return o;
5418 }
5419
5420 OP *
5421 Perl_jmaybe(pTHX_ OP *o)
5422 {
5423     PERL_ARGS_ASSERT_JMAYBE;
5424
5425     if (o->op_type == OP_LIST) {
5426         OP * const o2
5427             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5428         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5429     }
5430     return o;
5431 }
5432
5433 PERL_STATIC_INLINE OP *
5434 S_op_std_init(pTHX_ OP *o)
5435 {
5436     I32 type = o->op_type;
5437
5438     PERL_ARGS_ASSERT_OP_STD_INIT;
5439
5440     if (PL_opargs[type] & OA_RETSCALAR)
5441         scalar(o);
5442     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5443         o->op_targ = pad_alloc(type, SVs_PADTMP);
5444
5445     return o;
5446 }
5447
5448 PERL_STATIC_INLINE OP *
5449 S_op_integerize(pTHX_ OP *o)
5450 {
5451     I32 type = o->op_type;
5452
5453     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5454
5455     /* integerize op. */
5456     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5457     {
5458         dVAR;
5459         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5460     }
5461
5462     if (type == OP_NEGATE)
5463         /* XXX might want a ck_negate() for this */
5464         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5465
5466     return o;
5467 }
5468
5469 static OP *
5470 S_fold_constants(pTHX_ OP *const o)
5471 {
5472     dVAR;
5473     OP * volatile curop;
5474     OP *newop;
5475     volatile I32 type = o->op_type;
5476     bool is_stringify;
5477     SV * volatile sv = NULL;
5478     int ret = 0;
5479     OP *old_next;
5480     SV * const oldwarnhook = PL_warnhook;
5481     SV * const olddiehook  = PL_diehook;
5482     COP not_compiling;
5483     U8 oldwarn = PL_dowarn;
5484     I32 old_cxix;
5485     dJMPENV;
5486
5487     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5488
5489     if (!(PL_opargs[type] & OA_FOLDCONST))
5490         goto nope;
5491
5492     switch (type) {
5493     case OP_UCFIRST:
5494     case OP_LCFIRST:
5495     case OP_UC:
5496     case OP_LC:
5497     case OP_FC:
5498 #ifdef USE_LOCALE_CTYPE
5499         if (IN_LC_COMPILETIME(LC_CTYPE))
5500             goto nope;
5501 #endif
5502         break;
5503     case OP_SLT:
5504     case OP_SGT:
5505     case OP_SLE:
5506     case OP_SGE:
5507     case OP_SCMP:
5508 #ifdef USE_LOCALE_COLLATE
5509         if (IN_LC_COMPILETIME(LC_COLLATE))
5510             goto nope;
5511 #endif
5512         break;
5513     case OP_SPRINTF:
5514         /* XXX what about the numeric ops? */
5515 #ifdef USE_LOCALE_NUMERIC
5516         if (IN_LC_COMPILETIME(LC_NUMERIC))
5517             goto nope;
5518 #endif
5519         break;
5520     case OP_PACK:
5521         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5522           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5523             goto nope;
5524         {
5525             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5526             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5527             {
5528                 const char *s = SvPVX_const(sv);
5529                 while (s < SvEND(sv)) {
5530                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5531                     s++;
5532                 }
5533             }
5534         }
5535         break;
5536     case OP_REPEAT:
5537         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5538         break;
5539     case OP_SREFGEN:
5540         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5541          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5542             goto nope;
5543     }
5544
5545     if (PL_parser && PL_parser->error_count)
5546         goto nope;              /* Don't try to run w/ errors */
5547
5548     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5549         switch (curop->op_type) {
5550         case OP_CONST:
5551             if (   (curop->op_private & OPpCONST_BARE)
5552                 && (curop->op_private & OPpCONST_STRICT)) {
5553                 no_bareword_allowed(curop);
5554                 goto nope;
5555             }
5556             /* FALLTHROUGH */
5557         case OP_LIST:
5558         case OP_SCALAR:
5559         case OP_NULL:
5560         case OP_PUSHMARK:
5561             /* Foldable; move to next op in list */
5562             break;
5563
5564         default:
5565             /* No other op types are considered foldable */
5566             goto nope;
5567         }
5568     }
5569
5570     curop = LINKLIST(o);
5571     old_next = o->op_next;
5572     o->op_next = 0;
5573     PL_op = curop;
5574
5575     old_cxix = cxstack_ix;
5576     create_eval_scope(NULL, G_FAKINGEVAL);
5577
5578     /* Verify that we don't need to save it:  */
5579     assert(PL_curcop == &PL_compiling);
5580     StructCopy(&PL_compiling, &not_compiling, COP);
5581     PL_curcop = &not_compiling;
5582     /* The above ensures that we run with all the correct hints of the
5583        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5584     assert(IN_PERL_RUNTIME);
5585     PL_warnhook = PERL_WARNHOOK_FATAL;
5586     PL_diehook  = NULL;
5587     JMPENV_PUSH(ret);
5588
5589     /* Effective $^W=1.  */
5590     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5591         PL_dowarn |= G_WARN_ON;
5592
5593     switch (ret) {
5594     case 0:
5595         CALLRUNOPS(aTHX);
5596         sv = *(PL_stack_sp--);
5597         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5598             pad_swipe(o->op_targ,  FALSE);
5599         }
5600         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5601             SvREFCNT_inc_simple_void(sv);
5602             SvTEMP_off(sv);
5603         }
5604         else { assert(SvIMMORTAL(sv)); }
5605         break;
5606     case 3:
5607         /* Something tried to die.  Abandon constant folding.  */
5608         /* Pretend the error never happened.  */
5609         CLEAR_ERRSV();
5610         o->op_next = old_next;
5611         break;
5612     default:
5613         JMPENV_POP;
5614         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5615         PL_warnhook = oldwarnhook;
5616         PL_diehook  = olddiehook;
5617         /* XXX note that this croak may fail as we've already blown away
5618          * the stack - eg any nested evals */
5619         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5620     }
5621     JMPENV_POP;
5622     PL_dowarn   = oldwarn;
5623     PL_warnhook = oldwarnhook;
5624     PL_diehook  = olddiehook;
5625     PL_curcop = &PL_compiling;
5626
5627     /* if we croaked, depending on how we croaked the eval scope
5628      * may or may not have already been popped */
5629     if (cxstack_ix > old_cxix) {
5630         assert(cxstack_ix == old_cxix + 1);
5631         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5632         delete_eval_scope();
5633     }
5634     if (ret)
5635         goto nope;
5636
5637     /* OP_STRINGIFY and constant folding are used to implement qq.
5638        Here the constant folding is an implementation detail that we
5639        want to hide.  If the stringify op is itself already marked
5640        folded, however, then it is actually a folded join.  */
5641     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5642     op_free(o);
5643     assert(sv);
5644     if (is_stringify)
5645         SvPADTMP_off(sv);
5646     else if (!SvIMMORTAL(sv)) {
5647         SvPADTMP_on(sv);
5648         SvREADONLY_on(sv);
5649     }
5650     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5651     if (!is_stringify) newop->op_folded = 1;
5652     return newop;
5653
5654  nope:
5655     return o;
5656 }
5657
5658 static OP *
5659 S_gen_constant_list(pTHX_ OP *o)
5660 {
5661     dVAR;
5662     OP *curop, *old_next;
5663     SV * const oldwarnhook = PL_warnhook;
5664     SV * const olddiehook  = PL_diehook;
5665     COP *old_curcop;
5666     U8 oldwarn = PL_dowarn;
5667     SV **svp;
5668     AV *av;
5669     I32 old_cxix;
5670     COP not_compiling;
5671     int ret = 0;
5672     dJMPENV;
5673     bool op_was_null;
5674
5675     list(o);
5676     if (PL_parser && PL_parser->error_count)
5677         return o;               /* Don't attempt to run with errors */
5678
5679     curop = LINKLIST(o);
5680     old_next = o->op_next;
5681     o->op_next = 0;
5682     op_was_null = o->op_type == OP_NULL;
5683     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5684         o->op_type = OP_CUSTOM;
5685     CALL_PEEP(curop);
5686     if (op_was_null)
5687         o->op_type = OP_NULL;
5688     S_prune_chain_head(&curop);
5689     PL_op = curop;
5690
5691     old_cxix = cxstack_ix;
5692     create_eval_scope(NULL, G_FAKINGEVAL);
5693
5694     old_curcop = PL_curcop;
5695     StructCopy(old_curcop, &not_compiling, COP);
5696     PL_curcop = &not_compiling;
5697     /* The above ensures that we run with all the correct hints of the
5698        current COP, but that IN_PERL_RUNTIME is true. */
5699     assert(IN_PERL_RUNTIME);
5700     PL_warnhook = PERL_WARNHOOK_FATAL;
5701     PL_diehook  = NULL;
5702     JMPENV_PUSH(ret);
5703
5704     /* Effective $^W=1.  */
5705     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5706         PL_dowarn |= G_WARN_ON;
5707
5708     switch (ret) {
5709     case 0:
5710 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5711         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5712 #endif
5713         Perl_pp_pushmark(aTHX);
5714         CALLRUNOPS(aTHX);
5715         PL_op = curop;
5716         assert (!(curop->op_flags & OPf_SPECIAL));
5717         assert(curop->op_type == OP_RANGE);
5718         Perl_pp_anonlist(aTHX);
5719         break;
5720     case 3:
5721         CLEAR_ERRSV();
5722         o->op_next = old_next;
5723         break;
5724     default:
5725         JMPENV_POP;
5726         PL_warnhook = oldwarnhook;
5727         PL_diehook = olddiehook;
5728         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5729             ret);
5730     }
5731
5732     JMPENV_POP;
5733     PL_dowarn = oldwarn;
5734     PL_warnhook = oldwarnhook;
5735     PL_diehook = olddiehook;
5736     PL_curcop = old_curcop;
5737
5738     if (cxstack_ix > old_cxix) {
5739         assert(cxstack_ix == old_cxix + 1);
5740         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5741         delete_eval_scope();
5742     }
5743     if (ret)
5744         return o;
5745
5746     OpTYPE_set(o, OP_RV2AV);
5747     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5748     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5749     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5750     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5751
5752     /* replace subtree with an OP_CONST */
5753     curop = ((UNOP*)o)->op_first;
5754     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5755     op_free(curop);
5756
5757     if (AvFILLp(av) != -1)
5758         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5759         {
5760             SvPADTMP_on(*svp);
5761             SvREADONLY_on(*svp);
5762         }
5763     LINKLIST(o);
5764     return list(o);
5765 }
5766
5767 /*
5768 =head1 Optree Manipulation Functions
5769 */
5770
5771 /* List constructors */
5772
5773 /*
5774 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5775
5776 Append an item to the list of ops contained directly within a list-type
5777 op, returning the lengthened list.  C<first> is the list-type op,
5778 and C<last> is the op to append to the list.  C<optype> specifies the
5779 intended opcode for the list.  If C<first> is not already a list of the
5780 right type, it will be upgraded into one.  If either C<first> or C<last>
5781 is null, the other is returned unchanged.
5782
5783 =cut
5784 */
5785
5786 OP *
5787 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5788 {
5789     if (!first)
5790         return last;
5791
5792     if (!last)
5793         return first;
5794
5795     if (first->op_type != (unsigned)type
5796         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5797     {
5798         return newLISTOP(type, 0, first, last);
5799     }
5800
5801     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5802     first->op_flags |= OPf_KIDS;
5803     return first;
5804 }
5805
5806 /*
5807 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5808
5809 Concatenate the lists of ops contained directly within two list-type ops,
5810 returning the combined list.  C<first> and C<last> are the list-type ops
5811 to concatenate.  C<optype> specifies the intended opcode for the list.
5812 If either C<first> or C<last> is not already a list of the right type,
5813 it will be upgraded into one.  If either C<first> or C<last> is null,
5814 the other is returned unchanged.
5815
5816 =cut
5817 */
5818
5819 OP *
5820 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5821 {
5822     if (!first)
5823         return last;
5824
5825     if (!last)
5826         return first;
5827
5828     if (first->op_type != (unsigned)type)
5829         return op_prepend_elem(type, first, last);
5830
5831     if (last->op_type != (unsigned)type)
5832         return op_append_elem(type, first, last);
5833
5834     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5835     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5836     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5837     first->op_flags |= (last->op_flags & OPf_KIDS);
5838
5839     S_op_destroy(aTHX_ last);
5840
5841     return first;
5842 }
5843
5844 /*
5845 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5846
5847 Prepend an item to the list of ops contained directly within a list-type
5848 op, returning the lengthened list.  C<first> is the op to prepend to the
5849 list, and C<last> is the list-type op.  C<optype> specifies the intended
5850 opcode for the list.  If C<last> is not already a list of the right type,
5851 it will be upgraded into one.  If either C<first> or C<last> is null,
5852 the other is returned unchanged.
5853
5854 =cut
5855 */
5856
5857 OP *
5858 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5859 {
5860     if (!first)
5861         return last;
5862
5863     if (!last)
5864         return first;
5865
5866     if (last->op_type == (unsigned)type) {
5867         if (type == OP_LIST) {  /* already a PUSHMARK there */
5868             /* insert 'first' after pushmark */
5869             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5870             if (!(first->op_flags & OPf_PARENS))
5871                 last->op_flags &= ~OPf_PARENS;
5872         }
5873         else
5874             op_sibling_splice(last, NULL, 0, first);
5875         last->op_flags |= OPf_KIDS;
5876         return last;
5877     }
5878
5879     return newLISTOP(type, 0, first, last);
5880 }
5881
5882 /*
5883 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5884
5885 Converts C<o> into a list op if it is not one already, and then converts it
5886 into the specified C<type>, calling its check function, allocating a target if
5887 it needs one, and folding constants.
5888
5889 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5890 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5891 C<op_convert_list> to make it the right type.
5892
5893 =cut
5894 */
5895
5896 OP *
5897 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5898 {
5899     dVAR;
5900     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5901     if (!o || o->op_type != OP_LIST)
5902         o = force_list(o, 0);
5903     else
5904     {
5905         o->op_flags &= ~OPf_WANT;
5906         o->op_private &= ~OPpLVAL_INTRO;
5907     }
5908
5909     if (!(PL_opargs[type] & OA_MARK))
5910         op_null(cLISTOPo->op_first);
5911     else {
5912         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5913         if (kid2 && kid2->op_type == OP_COREARGS) {
5914             op_null(cLISTOPo->op_first);
5915             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5916         }
5917     }
5918
5919     if (type != OP_SPLIT)
5920         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5921          * ck_split() create a real PMOP and leave the op's type as listop
5922          * for now. Otherwise op_free() etc will crash.
5923          */
5924         OpTYPE_set(o, type);
5925
5926     o->op_flags |= flags;
5927     if (flags & OPf_FOLDED)
5928         o->op_folded = 1;
5929
5930     o = CHECKOP(type, o);
5931     if (o->op_type != (unsigned)type)
5932         return o;
5933
5934     return fold_constants(op_integerize(op_std_init(o)));
5935 }
5936
5937 /* Constructors */
5938
5939
5940 /*
5941 =head1 Optree construction
5942
5943 =for apidoc Am|OP *|newNULLLIST
5944
5945 Constructs, checks, and returns a new C<stub> op, which represents an
5946 empty list expression.
5947
5948 =cut
5949 */
5950
5951 OP *
5952 Perl_newNULLLIST(pTHX)
5953 {
5954     return newOP(OP_STUB, 0);
5955 }
5956
5957 /* promote o and any siblings to be a list if its not already; i.e.
5958  *
5959  *  o - A - B
5960  *
5961  * becomes
5962  *
5963  *  list
5964  *    |
5965  *  pushmark - o - A - B
5966  *
5967  * If nullit it true, the list op is nulled.
5968  */
5969
5970 static OP *
5971 S_force_list(pTHX_ OP *o, bool nullit)
5972 {
5973     if (!o || o->op_type != OP_LIST) {
5974         OP *rest = NULL;
5975         if (o) {
5976             /* manually detach any siblings then add them back later */
5977             rest = OpSIBLING(o);
5978             OpLASTSIB_set(o, NULL);
5979         }
5980         o = newLISTOP(OP_LIST, 0, o, NULL);
5981         if (rest)
5982             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5983     }
5984     if (nullit)
5985         op_null(o);
5986     return o;
5987 }
5988
5989 /*
5990 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5991
5992 Constructs, checks, and returns an op of any list type.  C<type> is
5993 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5994 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5995 supply up to two ops to be direct children of the list op; they are
5996 consumed by this function and become part of the constructed op tree.
5997
5998 For most list operators, the check function expects all the kid ops to be
5999 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6000 appropriate.  What you want to do in that case is create an op of type
6001 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6002 See L</op_convert_list> for more information.
6003
6004
6005 =cut
6006 */
6007
6008 OP *
6009 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6010 {
6011     dVAR;
6012     LISTOP *listop;
6013
6014     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6015         || type == OP_CUSTOM);
6016
6017     NewOp(1101, listop, 1, LISTOP);
6018
6019     OpTYPE_set(listop, type);
6020     if (first || last)
6021         flags |= OPf_KIDS;
6022     listop->op_flags = (U8)flags;
6023
6024     if (!last && first)
6025         last = first;
6026     else if (!first && last)
6027         first = last;
6028     else if (first)
6029         OpMORESIB_set(first, last);
6030     listop->op_first = first;
6031     listop->op_last = last;
6032     if (type == OP_LIST) {
6033         OP* const pushop = newOP(OP_PUSHMARK, 0);
6034         OpMORESIB_set(pushop, first);
6035         listop->op_first = pushop;
6036         listop->op_flags |= OPf_KIDS;
6037         if (!last)
6038             listop->op_last = pushop;
6039     }
6040     if (listop->op_last)
6041         OpLASTSIB_set(listop->op_last, (OP*)listop);
6042
6043     return CHECKOP(type, listop);
6044 }
6045
6046 /*
6047 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6048
6049 Constructs, checks, and returns an op of any base type (any type that
6050 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6051 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6052 of C<op_private>.
6053
6054 =cut
6055 */
6056
6057 OP *
6058 Perl_newOP(pTHX_ I32 type, I32 flags)
6059 {
6060     dVAR;
6061     OP *o;
6062
6063     if (type == -OP_ENTEREVAL) {
6064         type = OP_ENTEREVAL;
6065         flags |= OPpEVAL_BYTES<<8;
6066     }
6067
6068     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6069         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6070         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6071         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6072
6073     NewOp(1101, o, 1, OP);
6074     OpTYPE_set(o, type);
6075     o->op_flags = (U8)flags;
6076
6077     o->op_next = o;
6078     o->op_private = (U8)(0 | (flags >> 8));
6079     if (PL_opargs[type] & OA_RETSCALAR)
6080         scalar(o);
6081     if (PL_opargs[type] & OA_TARGET)
6082         o->op_targ = pad_alloc(type, SVs_PADTMP);
6083     return CHECKOP(type, o);
6084 }
6085
6086 /*
6087 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6088
6089 Constructs, checks, and returns an op of any unary type.  C<type> is
6090 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6091 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6092 bits, the eight bits of C<op_private>, except that the bit with value 1
6093 is automatically set.  C<first> supplies an optional op to be the direct
6094 child of the unary op; it is consumed by this function and become part
6095 of the constructed op tree.
6096
6097 =cut
6098 */
6099
6100 OP *
6101 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6102 {
6103     dVAR;
6104     UNOP *unop;
6105
6106     if (type == -OP_ENTEREVAL) {
6107         type = OP_ENTEREVAL;
6108         flags |= OPpEVAL_BYTES<<8;
6109     }
6110
6111     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6112         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6113         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6114         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6115         || type == OP_SASSIGN
6116         || type == OP_ENTERTRY
6117         || type == OP_CUSTOM
6118         || type == OP_NULL );
6119
6120     if (!first)
6121         first = newOP(OP_STUB, 0);
6122     if (PL_opargs[type] & OA_MARK)
6123         first = force_list(first, 1);
6124
6125     NewOp(1101, unop, 1, UNOP);
6126     OpTYPE_set(unop, type);
6127     unop->op_first = first;
6128     unop->op_flags = (U8)(flags | OPf_KIDS);
6129     unop->op_private = (U8)(1 | (flags >> 8));
6130
6131     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6132         OpLASTSIB_set(first, (OP*)unop);
6133
6134     unop = (UNOP*) CHECKOP(type, unop);
6135     if (unop->op_next)
6136         return (OP*)unop;
6137
6138     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6139 }
6140
6141 /*
6142 =for apidoc newUNOP_AUX
6143
6144 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6145 initialised to C<aux>
6146
6147 =cut
6148 */
6149
6150 OP *
6151 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6152 {
6153     dVAR;
6154     UNOP_AUX *unop;
6155
6156     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6157         || type == OP_CUSTOM);
6158
6159     NewOp(1101, unop, 1, UNOP_AUX);
6160     unop->op_type = (OPCODE)type;
6161     unop->op_ppaddr = PL_ppaddr[type];
6162     unop->op_first = first;
6163     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6164     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6165     unop->op_aux = aux;
6166
6167     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6168         OpLASTSIB_set(first, (OP*)unop);
6169
6170     unop = (UNOP_AUX*) CHECKOP(type, unop);
6171
6172     return op_std_init((OP *) unop);
6173 }
6174
6175 /*
6176 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6177
6178 Constructs, checks, and returns an op of method type with a method name
6179 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6180 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6181 and, shifted up eight bits, the eight bits of C<op_private>, except that
6182 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6183 op which evaluates method name; it is consumed by this function and
6184 become part of the constructed op tree.
6185 Supported optypes: C<OP_METHOD>.
6186
6187 =cut
6188 */
6189
6190 static OP*
6191 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6192     dVAR;
6193     METHOP *methop;
6194
6195     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6196         || type == OP_CUSTOM);
6197
6198     NewOp(1101, methop, 1, METHOP);
6199     if (dynamic_meth) {
6200         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6201         methop->op_flags = (U8)(flags | OPf_KIDS);
6202         methop->op_u.op_first = dynamic_meth;
6203         methop->op_private = (U8)(1 | (flags >> 8));
6204
6205         if (!OpHAS_SIBLING(dynamic_meth))
6206             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6207     }
6208     else {
6209         assert(const_meth);
6210         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6211         methop->op_u.op_meth_sv = const_meth;
6212         methop->op_private = (U8)(0 | (flags >> 8));
6213         methop->op_next = (OP*)methop;
6214     }
6215
6216 #ifdef USE_ITHREADS
6217     methop->op_rclass_targ = 0;
6218 #else
6219     methop->op_rclass_sv = NULL;
6220 #endif
6221
6222     OpTYPE_set(methop, type);
6223     return CHECKOP(type, methop);
6224 }
6225
6226 OP *
6227 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6228     PERL_ARGS_ASSERT_NEWMETHOP;
6229     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6230 }
6231
6232 /*
6233 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6234
6235 Constructs, checks, and returns an op of method type with a constant
6236 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6237 C<op_flags>, and, shifted up eight bits, the eight bits of
6238 C<op_private>.  C<const_meth> supplies a constant method name;
6239 it must be a shared COW string.
6240 Supported optypes: C<OP_METHOD_NAMED>.
6241
6242 =cut
6243 */
6244
6245 OP *
6246 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6247     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6248     return newMETHOP_internal(type, flags, NULL, const_meth);
6249 }
6250
6251 /*
6252 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6253
6254 Constructs, checks, and returns an op of any binary type.  C<type>
6255 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6256 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6257 the eight bits of C<op_private>, except that the bit with value 1 or
6258 2 is automatically set as required.  C<first> and C<last> supply up to
6259 two ops to be the direct children of the binary op; they are consumed
6260 by this function and become part of the constructed op tree.
6261
6262 =cut
6263 */
6264
6265 OP *
6266 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6267 {
6268     dVAR;
6269     BINOP *binop;
6270
6271     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6272         || type == OP_NULL || type == OP_CUSTOM);
6273
6274     NewOp(1101, binop, 1, BINOP);
6275
6276     if (!first)
6277         first = newOP(OP_NULL, 0);
6278
6279     OpTYPE_set(binop, type);
6280     binop->op_first = first;
6281     binop->op_flags = (U8)(flags | OPf_KIDS);
6282     if (!last) {
6283         last = first;
6284         binop->op_private = (U8)(1 | (flags >> 8));
6285     }
6286     else {
6287         binop->op_private = (U8)(2 | (flags >> 8));
6288         OpMORESIB_set(first, last);
6289     }
6290
6291     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6292         OpLASTSIB_set(last, (OP*)binop);
6293
6294     binop->op_last = OpSIBLING(binop->op_first);
6295     if (binop->op_last)
6296         OpLASTSIB_set(binop->op_last, (OP*)binop);
6297
6298     binop = (BINOP*)CHECKOP(type, binop);
6299     if (binop->op_next || binop->op_type != (OPCODE)type)
6300         return (OP*)binop;
6301
6302     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6303 }
6304
6305 /* Helper function for S_pmtrans(): comparison function to sort an array
6306  * of codepoint range pairs. Sorts by start point, or if equal, by end
6307  * point */
6308
6309 static int uvcompare(const void *a, const void *b)
6310     __attribute__nonnull__(1)
6311     __attribute__nonnull__(2)
6312     __attribute__pure__;
6313 static int uvcompare(const void *a, const void *b)
6314 {
6315     if (*((const UV *)a) < (*(const UV *)b))
6316         return -1;
6317     if (*((const UV *)a) > (*(const UV *)b))
6318         return 1;
6319     if (*((const UV *)a+1) < (*(const UV *)b+1))
6320         return -1;
6321     if (*((const UV *)a+1) > (*(const UV *)b+1))
6322         return 1;
6323     return 0;
6324 }
6325
6326 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6327  * containing the search and replacement strings, assemble into
6328  * a translation table attached as o->op_pv.
6329  * Free expr and repl.
6330  * It expects the toker to have already set the
6331  *   OPpTRANS_COMPLEMENT
6332  *   OPpTRANS_SQUASH
6333  *   OPpTRANS_DELETE
6334  * flags as appropriate; this function may add
6335  *   OPpTRANS_FROM_UTF
6336  *   OPpTRANS_TO_UTF
6337  *   OPpTRANS_IDENTICAL
6338  *   OPpTRANS_GROWS
6339  * flags
6340  */
6341
6342 static OP *
6343 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6344 {
6345     SV * const tstr = ((SVOP*)expr)->op_sv;
6346     SV * const rstr = ((SVOP*)repl)->op_sv;
6347     STRLEN tlen;
6348     STRLEN rlen;
6349     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6350     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6351     Size_t i, j;
6352     bool grows = FALSE;
6353     OPtrans_map *tbl;
6354     SSize_t struct_size; /* malloced size of table struct */
6355
6356     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6357     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6358     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6359     SV* swash;
6360
6361     PERL_ARGS_ASSERT_PMTRANS;
6362
6363     PL_hints |= HINT_BLOCK_SCOPE;
6364
6365     if (SvUTF8(tstr))
6366         o->op_private |= OPpTRANS_FROM_UTF;
6367
6368     if (SvUTF8(rstr))
6369         o->op_private |= OPpTRANS_TO_UTF;
6370
6371     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6372
6373         /* for utf8 translations, op_sv will be set to point to a swash
6374          * containing codepoint ranges. This is done by first assembling
6375          * a textual representation of the ranges in listsv then compiling
6376          * it using swash_init(). For more details of the textual format,
6377          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6378          */
6379
6380         SV* const listsv = newSVpvs("# comment\n");
6381         SV* transv = NULL;
6382         const U8* tend = t + tlen;
6383         const U8* rend = r + rlen;
6384         STRLEN ulen;
6385         UV tfirst = 1;
6386         UV tlast = 0;
6387         IV tdiff;
6388         STRLEN tcount = 0;
6389         UV rfirst = 1;
6390         UV rlast = 0;
6391         IV rdiff;
6392         STRLEN rcount = 0;
6393         IV diff;
6394         I32 none = 0;
6395         U32 max = 0;
6396         I32 bits;
6397         I32 havefinal = 0;
6398         U32 final = 0;
6399         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6400         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6401         U8* tsave = NULL;
6402         U8* rsave = NULL;
6403         const U32 flags = UTF8_ALLOW_DEFAULT;
6404
6405         if (!from_utf) {
6406             STRLEN len = tlen;
6407             t = tsave = bytes_to_utf8(t, &len);
6408             tend = t + len;
6409         }
6410         if (!to_utf && rlen) {
6411             STRLEN len = rlen;
6412             r = rsave = bytes_to_utf8(r, &len);
6413             rend = r + len;
6414         }
6415
6416 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6417  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6418  * odd.  */
6419
6420         if (complement) {
6421             /* utf8 and /c:
6422              * replace t/tlen/tend with a version that has the ranges
6423              * complemented
6424              */
6425             U8 tmpbuf[UTF8_MAXBYTES+1];
6426             UV *cp;
6427             UV nextmin = 0;
6428             Newx(cp, 2*tlen, UV);
6429             i = 0;
6430             transv = newSVpvs("");
6431
6432             /* convert search string into array of (start,end) range
6433              * codepoint pairs stored in cp[]. Most "ranges" will start
6434              * and end at the same char */
6435             while (t < tend) {
6436                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6437                 t += ulen;
6438                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6439                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6440                     t++;
6441                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6442                     t += ulen;
6443                 }
6444                 else {
6445                  cp[2*i+1] = cp[2*i];
6446                 }
6447                 i++;
6448             }
6449
6450             /* sort the ranges */
6451             qsort(cp, i, 2*sizeof(UV), uvcompare);
6452
6453             /* Create a utf8 string containing the complement of the
6454              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6455              * then transv will contain the equivalent of:
6456              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6457              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6458              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6459              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6460              * end cp.
6461              */
6462             for (j = 0; j < i; j++) {
6463                 UV  val = cp[2*j];
6464                 diff = val - nextmin;
6465                 if (diff > 0) {
6466                     t = uvchr_to_utf8(tmpbuf,nextmin);
6467                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6468                     if (diff > 1) {
6469                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6470                         t = uvchr_to_utf8(tmpbuf, val - 1);
6471                         sv_catpvn(transv, (char *)&range_mark, 1);
6472                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6473                     }
6474                 }
6475                 val = cp[2*j+1];
6476                 if (val >= nextmin)
6477                     nextmin = val + 1;
6478             }
6479
6480             t = uvchr_to_utf8(tmpbuf,nextmin);
6481             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6482             {
6483                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6484                 sv_catpvn(transv, (char *)&range_mark, 1);
6485             }
6486             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6487             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6488             t = (const U8*)SvPVX_const(transv);
6489             tlen = SvCUR(transv);
6490             tend = t + tlen;
6491             Safefree(cp);
6492         }
6493         else if (!rlen && !del) {
6494             r = t; rlen = tlen; rend = tend;
6495         }
6496
6497         if (!squash) {
6498                 if ((!rlen && !del) || t == r ||
6499                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6500                 {
6501                     o->op_private |= OPpTRANS_IDENTICAL;
6502                 }
6503         }
6504
6505         /* extract char ranges from t and r and append them to listsv */
6506
6507         while (t < tend || tfirst <= tlast) {
6508             /* see if we need more "t" chars */
6509             if (tfirst > tlast) {
6510                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6511                 t += ulen;
6512                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6513                     t++;
6514                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6515                     t += ulen;
6516                 }
6517                 else
6518                     tlast = tfirst;
6519             }
6520
6521             /* now see if we need more "r" chars */
6522             if (rfirst > rlast) {
6523                 if (r < rend) {
6524                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6525                     r += ulen;
6526                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6527                         r++;
6528                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6529                         r += ulen;
6530                     }
6531                     else
6532                         rlast = rfirst;
6533                 }
6534                 else {
6535                     if (!havefinal++)
6536                         final = rlast;
6537                     rfirst = rlast = 0xffffffff;
6538                 }
6539             }
6540
6541             /* now see which range will peter out first, if either. */
6542             tdiff = tlast - tfirst;
6543             rdiff = rlast - rfirst;
6544             tcount += tdiff + 1;
6545             rcount += rdiff + 1;
6546
6547             if (tdiff <= rdiff)
6548                 diff = tdiff;
6549             else
6550                 diff = rdiff;
6551
6552             if (rfirst == 0xffffffff) {
6553                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6554                 if (diff > 0)
6555                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6556                                    (long)tfirst, (long)tlast);
6557                 else
6558                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6559             }
6560             else {
6561                 if (diff > 0)
6562                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6563                                    (long)tfirst, (long)(tfirst + diff),
6564                                    (long)rfirst);
6565                 else
6566                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6567                                    (long)tfirst, (long)rfirst);
6568
6569                 if (rfirst + diff > max)
6570                     max = rfirst + diff;
6571                 if (!grows)
6572                     grows = (tfirst < rfirst &&
6573                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6574                 rfirst += diff + 1;
6575             }
6576             tfirst += diff + 1;
6577         }
6578
6579         /* compile listsv into a swash and attach to o */
6580
6581         none = ++max;
6582         if (del)
6583             ++max;
6584
6585         if (max > 0xffff)
6586             bits = 32;
6587         else if (max > 0xff)
6588             bits = 16;
6589         else
6590             bits = 8;
6591
6592         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6593 #ifdef USE_ITHREADS
6594         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6595         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6596         PAD_SETSV(cPADOPo->op_padix, swash);
6597         SvPADTMP_on(swash);
6598         SvREADONLY_on(swash);
6599 #else
6600         cSVOPo->op_sv = swash;
6601 #endif
6602         SvREFCNT_dec(listsv);
6603         SvREFCNT_dec(transv);
6604
6605         if (!del && havefinal && rlen)
6606             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6607                            newSVuv((UV)final), 0);
6608
6609         Safefree(tsave);
6610         Safefree(rsave);
6611
6612         tlen = tcount;
6613         rlen = rcount;
6614         if (r < rend)
6615             rlen++;
6616         else if (rlast == 0xffffffff)
6617             rlen = 0;
6618
6619         goto warnins;
6620     }
6621
6622     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6623      * table. Entries with the value -1 indicate chars not to be
6624      * translated, while -2 indicates a search char without a
6625      * corresponding replacement char under /d.
6626      *
6627      * Normally, the table has 256 slots. However, in the presence of
6628      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6629      * added, and if there are enough replacement chars to start pairing
6630      * with the \x{100},... search chars, then a larger (> 256) table
6631      * is allocated.
6632      *
6633      * In addition, regardless of whether under /c, an extra slot at the
6634      * end is used to store the final repeating char, or -3 under an empty
6635      * replacement list, or -2 under /d; which makes the runtime code
6636      * easier.
6637      *
6638      * The toker will have already expanded char ranges in t and r.
6639      */
6640
6641     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6642      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6643      * The OPtrans_map struct already contains one slot; hence the -1.
6644      */
6645     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6646     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6647     tbl->size = 256;
6648     cPVOPo->op_pv = (char*)tbl;
6649
6650     if (complement) {
6651         Size_t excess;
6652
6653         /* in this branch, j is a count of 'consumed' (i.e. paired off
6654          * with a search char) replacement chars (so j <= rlen always)
6655          */
6656         for (i = 0; i < tlen; i++)
6657             tbl->map[t[i]] = -1;
6658
6659         for (i = 0, j = 0; i < 256; i++) {
6660             if (!tbl->map[i]) {
6661                 if (j == rlen) {
6662                     if (del)
6663                         tbl->map[i] = -2;
6664                     else if (rlen)
6665                         tbl->map[i] = r[j-1];
6666                     else
6667                         tbl->map[i] = (short)i;
6668                 }
6669                 else {
6670                     tbl->map[i] = r[j++];
6671                 }
6672                 if (   tbl->map[i] >= 0
6673                     &&  UVCHR_IS_INVARIANT((UV)i)
6674                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6675                 )
6676                     grows = TRUE;
6677             }
6678         }
6679
6680         ASSUME(j <= rlen);
6681         excess = rlen - j;
6682
6683         if (excess) {
6684             /* More replacement chars than search chars:
6685              * store excess replacement chars at end of main table.
6686              */
6687
6688             struct_size += excess;
6689             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6690                         struct_size + excess * sizeof(short));
6691             tbl->size += excess;
6692             cPVOPo->op_pv = (char*)tbl;
6693
6694             for (i = 0; i < excess; i++)
6695                 tbl->map[i + 256] = r[j+i];
6696         }
6697         else {
6698             /* no more replacement chars than search chars */
6699             if (!rlen && !del && !squash)
6700                 o->op_private |= OPpTRANS_IDENTICAL;
6701         }
6702
6703         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6704     }
6705     else {
6706         if (!rlen && !del) {
6707             r = t; rlen = tlen;
6708             if (!squash)
6709                 o->op_private |= OPpTRANS_IDENTICAL;
6710         }
6711         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6712             o->op_private |= OPpTRANS_IDENTICAL;
6713         }
6714
6715         for (i = 0; i < 256; i++)
6716             tbl->map[i] = -1;
6717         for (i = 0, j = 0; i < tlen; i++,j++) {
6718             if (j >= rlen) {
6719                 if (del) {
6720                     if (tbl->map[t[i]] == -1)
6721                         tbl->map[t[i]] = -2;
6722                     continue;
6723                 }
6724                 --j;
6725             }
6726             if (tbl->map[t[i]] == -1) {
6727                 if (     UVCHR_IS_INVARIANT(t[i])
6728                     && ! UVCHR_IS_INVARIANT(r[j]))
6729                     grows = TRUE;
6730                 tbl->map[t[i]] = r[j];
6731             }
6732         }
6733         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6734     }
6735
6736     /* both non-utf8 and utf8 code paths end up here */
6737
6738   warnins:
6739     if(del && rlen == tlen) {
6740         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6741     } else if(rlen > tlen && !complement) {
6742         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6743     }
6744
6745     if (grows)
6746         o->op_private |= OPpTRANS_GROWS;
6747     op_free(expr);
6748     op_free(repl);
6749
6750     return o;
6751 }
6752
6753
6754 /*
6755 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6756
6757 Constructs, checks, and returns an op of any pattern matching type.
6758 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6759 and, shifted up eight bits, the eight bits of C<op_private>.
6760
6761 =cut
6762 */
6763
6764 OP *
6765 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6766 {
6767     dVAR;
6768     PMOP *pmop;
6769
6770     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6771         || type == OP_CUSTOM);
6772
6773     NewOp(1101, pmop, 1, PMOP);
6774     OpTYPE_set(pmop, type);
6775     pmop->op_flags = (U8)flags;
6776     pmop->op_private = (U8)(0 | (flags >> 8));
6777     if (PL_opargs[type] & OA_RETSCALAR)
6778         scalar((OP *)pmop);
6779
6780     if (PL_hints & HINT_RE_TAINT)
6781         pmop->op_pmflags |= PMf_RETAINT;
6782 #ifdef USE_LOCALE_CTYPE
6783     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6784         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6785     }
6786     else
6787 #endif
6788          if (IN_UNI_8_BIT) {
6789         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6790     }
6791     if (PL_hints & HINT_RE_FLAGS) {
6792         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6793          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6794         );
6795         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6796         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6797          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6798         );
6799         if (reflags && SvOK(reflags)) {
6800             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6801         }
6802     }
6803
6804
6805 #ifdef USE_ITHREADS
6806     assert(SvPOK(PL_regex_pad[0]));
6807     if (SvCUR(PL_regex_pad[0])) {
6808         /* Pop off the "packed" IV from the end.  */
6809         SV *const repointer_list = PL_regex_pad[0];
6810         const char *p = SvEND(repointer_list) - sizeof(IV);
6811         const IV offset = *((IV*)p);
6812
6813         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6814
6815         SvEND_set(repointer_list, p);
6816
6817         pmop->op_pmoffset = offset;
6818         /* This slot should be free, so assert this:  */
6819         assert(PL_regex_pad[offset] == &PL_sv_undef);
6820     } else {
6821         SV * const repointer = &PL_sv_undef;
6822         av_push(PL_regex_padav, repointer);
6823         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6824         PL_regex_pad = AvARRAY(PL_regex_padav);
6825     }
6826 #endif
6827
6828     return CHECKOP(type, pmop);
6829 }
6830
6831 static void
6832 S_set_haseval(pTHX)
6833 {
6834     PADOFFSET i = 1;
6835     PL_cv_has_eval = 1;
6836     /* Any pad names in scope are potentially lvalues.  */
6837     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6838         PADNAME *pn = PAD_COMPNAME_SV(i);
6839         if (!pn || !PadnameLEN(pn))
6840             continue;
6841         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6842             S_mark_padname_lvalue(aTHX_ pn);
6843     }
6844 }
6845
6846 /* Given some sort of match op o, and an expression expr containing a
6847  * pattern, either compile expr into a regex and attach it to o (if it's
6848  * constant), or convert expr into a runtime regcomp op sequence (if it's
6849  * not)
6850  *
6851  * Flags currently has 2 bits of meaning:
6852  * 1: isreg indicates that the pattern is part of a regex construct, eg
6853  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6854  * split "pattern", which aren't. In the former case, expr will be a list
6855  * if the pattern contains more than one term (eg /a$b/).
6856  * 2: The pattern is for a split.
6857  *
6858  * When the pattern has been compiled within a new anon CV (for
6859  * qr/(?{...})/ ), then floor indicates the savestack level just before
6860  * the new sub was created
6861  */
6862
6863 OP *
6864 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6865 {
6866     PMOP *pm;
6867     LOGOP *rcop;
6868     I32 repl_has_vars = 0;
6869     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6870     bool is_compiletime;
6871     bool has_code;
6872     bool isreg    = cBOOL(flags & 1);
6873     bool is_split = cBOOL(flags & 2);
6874
6875     PERL_ARGS_ASSERT_PMRUNTIME;
6876
6877     if (is_trans) {
6878         return pmtrans(o, expr, repl);
6879     }
6880
6881     /* find whether we have any runtime or code elements;
6882      * at the same time, temporarily set the op_next of each DO block;
6883      * then when we LINKLIST, this will cause the DO blocks to be excluded
6884      * from the op_next chain (and from having LINKLIST recursively
6885      * applied to them). We fix up the DOs specially later */
6886
6887     is_compiletime = 1;
6888     has_code = 0;
6889     if (expr->op_type == OP_LIST) {
6890         OP *o;
6891         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6892             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6893                 has_code = 1;
6894                 assert(!o->op_next);
6895                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6896                     assert(PL_parser && PL_parser->error_count);
6897                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6898                        the op we were expecting to see, to avoid crashing
6899                        elsewhere.  */
6900                     op_sibling_splice(expr, o, 0,
6901                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6902                 }
6903                 o->op_next = OpSIBLING(o);
6904             }
6905             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6906                 is_compiletime = 0;
6907         }
6908     }
6909     else if (expr->op_type != OP_CONST)
6910         is_compiletime = 0;
6911
6912     LINKLIST(expr);
6913
6914     /* fix up DO blocks; treat each one as a separate little sub;
6915      * also, mark any arrays as LIST/REF */
6916
6917     if (expr->op_type == OP_LIST) {
6918         OP *o;
6919         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6920
6921             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6922                 assert( !(o->op_flags  & OPf_WANT));
6923                 /* push the array rather than its contents. The regex
6924                  * engine will retrieve and join the elements later */
6925                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6926                 continue;
6927             }
6928
6929             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6930                 continue;
6931             o->op_next = NULL; /* undo temporary hack from above */
6932             scalar(o);
6933             LINKLIST(o);
6934             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6935                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6936                 /* skip ENTER */
6937                 assert(leaveop->op_first->op_type == OP_ENTER);
6938                 assert(OpHAS_SIBLING(leaveop->op_first));
6939                 o->op_next = OpSIBLING(leaveop->op_first);
6940                 /* skip leave */
6941                 assert(leaveop->op_flags & OPf_KIDS);
6942                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6943                 leaveop->op_next = NULL; /* stop on last op */
6944                 op_null((OP*)leaveop);
6945             }
6946             else {
6947                 /* skip SCOPE */
6948                 OP *scope = cLISTOPo->op_first;
6949                 assert(scope->op_type == OP_SCOPE);
6950                 assert(scope->op_flags & OPf_KIDS);
6951                 scope->op_next = NULL; /* stop on last op */
6952                 op_null(scope);
6953             }
6954
6955             /* XXX optimize_optree() must be called on o before
6956              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
6957              * currently cope with a peephole-optimised optree.
6958              * Calling optimize_optree() here ensures that condition
6959              * is met, but may mean optimize_optree() is applied
6960              * to the same optree later (where hopefully it won't do any
6961              * harm as it can't convert an op to multiconcat if it's
6962              * already been converted */
6963             optimize_optree(o);
6964
6965             /* have to peep the DOs individually as we've removed it from
6966              * the op_next chain */
6967             CALL_PEEP(o);
6968             S_prune_chain_head(&(o->op_next));
6969             if (is_compiletime)
6970                 /* runtime finalizes as part of finalizing whole tree */
6971                 finalize_optree(o);
6972         }
6973     }
6974     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6975         assert( !(expr->op_flags  & OPf_WANT));
6976         /* push the array rather than its contents. The regex
6977          * engine will retrieve and join the elements later */
6978         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6979     }
6980
6981     PL_hints |= HINT_BLOCK_SCOPE;
6982     pm = (PMOP*)o;
6983     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6984
6985     if (is_compiletime) {
6986         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6987         regexp_engine const *eng = current_re_engine();
6988
6989         if (is_split) {
6990             /* make engine handle split ' ' specially */
6991             pm->op_pmflags |= PMf_SPLIT;
6992             rx_flags |= RXf_SPLIT;
6993         }
6994
6995         /* Skip compiling if parser found an error for this pattern */
6996         if (pm->op_pmflags & PMf_HAS_ERROR) {
6997             return o;
6998         }
6999
7000         if (!has_code || !eng->op_comp) {
7001             /* compile-time simple constant pattern */
7002
7003             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7004                 /* whoops! we guessed that a qr// had a code block, but we
7005                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7006                  * that isn't required now. Note that we have to be pretty
7007                  * confident that nothing used that CV's pad while the
7008                  * regex was parsed, except maybe op targets for \Q etc.
7009                  * If there were any op targets, though, they should have
7010                  * been stolen by constant folding.
7011                  */
7012 #ifdef DEBUGGING
7013                 SSize_t i = 0;
7014                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7015                 while (++i <= AvFILLp(PL_comppad)) {
7016 #  ifdef USE_PAD_RESET
7017                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7018                      * folded constant with a fresh padtmp */
7019                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7020 #  else
7021                     assert(!PL_curpad[i]);
7022 #  endif
7023                 }
7024 #endif
7025                 /* But we know that one op is using this CV's slab. */
7026                 cv_forget_slab(PL_compcv);
7027                 LEAVE_SCOPE(floor);
7028                 pm->op_pmflags &= ~PMf_HAS_CV;
7029             }
7030
7031             PM_SETRE(pm,
7032                 eng->op_comp
7033                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7034                                         rx_flags, pm->op_pmflags)
7035                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7036                                         rx_flags, pm->op_pmflags)
7037             );
7038             op_free(expr);
7039         }
7040         else {
7041             /* compile-time pattern that includes literal code blocks */
7042             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7043                         rx_flags,
7044                         (pm->op_pmflags |
7045                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7046                     );
7047             PM_SETRE(pm, re);
7048             if (pm->op_pmflags & PMf_HAS_CV) {
7049                 CV *cv;
7050                 /* this QR op (and the anon sub we embed it in) is never
7051                  * actually executed. It's just a placeholder where we can
7052                  * squirrel away expr in op_code_list without the peephole
7053                  * optimiser etc processing it for a second time */
7054                 OP *qr = newPMOP(OP_QR, 0);
7055                 ((PMOP*)qr)->op_code_list = expr;
7056
7057                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7058                 SvREFCNT_inc_simple_void(PL_compcv);
7059                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7060                 ReANY(re)->qr_anoncv = cv;
7061
7062                 /* attach the anon CV to the pad so that
7063                  * pad_fixup_inner_anons() can find it */
7064                 (void)pad_add_anon(cv, o->op_type);
7065                 SvREFCNT_inc_simple_void(cv);
7066             }
7067             else {
7068                 pm->op_code_list = expr;
7069             }
7070         }
7071     }
7072     else {
7073         /* runtime pattern: build chain of regcomp etc ops */
7074         bool reglist;
7075         PADOFFSET cv_targ = 0;
7076
7077         reglist = isreg && expr->op_type == OP_LIST;
7078         if (reglist)
7079             op_null(expr);
7080
7081         if (has_code) {
7082             pm->op_code_list = expr;
7083             /* don't free op_code_list; its ops are embedded elsewhere too */
7084             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7085         }
7086
7087         if (is_split)
7088             /* make engine handle split ' ' specially */
7089             pm->op_pmflags |= PMf_SPLIT;
7090
7091         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7092          * to allow its op_next to be pointed past the regcomp and
7093          * preceding stacking ops;
7094          * OP_REGCRESET is there to reset taint before executing the
7095          * stacking ops */
7096         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7097             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7098
7099         if (pm->op_pmflags & PMf_HAS_CV) {
7100             /* we have a runtime qr with literal code. This means
7101              * that the qr// has been wrapped in a new CV, which
7102              * means that runtime consts, vars etc will have been compiled
7103              * against a new pad. So... we need to execute those ops
7104              * within the environment of the new CV. So wrap them in a call
7105              * to a new anon sub. i.e. for
7106              *
7107              *     qr/a$b(?{...})/,
7108              *
7109              * we build an anon sub that looks like
7110              *
7111              *     sub { "a", $b, '(?{...})' }
7112              *
7113              * and call it, passing the returned list to regcomp.
7114              * Or to put it another way, the list of ops that get executed
7115              * are:
7116              *
7117              *     normal              PMf_HAS_CV
7118              *     ------              -------------------
7119              *                         pushmark (for regcomp)
7120              *                         pushmark (for entersub)
7121              *                         anoncode
7122              *                         srefgen
7123              *                         entersub
7124              *     regcreset                  regcreset
7125              *     pushmark                   pushmark
7126              *     const("a")                 const("a")
7127              *     gvsv(b)                    gvsv(b)
7128              *     const("(?{...})")          const("(?{...})")
7129              *                                leavesub
7130              *     regcomp             regcomp
7131              */
7132
7133             SvREFCNT_inc_simple_void(PL_compcv);
7134             CvLVALUE_on(PL_compcv);
7135             /* these lines are just an unrolled newANONATTRSUB */
7136             expr = newSVOP(OP_ANONCODE, 0,
7137                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7138             cv_targ = expr->op_targ;
7139             expr = newUNOP(OP_REFGEN, 0, expr);
7140
7141             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7142         }
7143
7144         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7145         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7146                            | (reglist ? OPf_STACKED : 0);
7147         rcop->op_targ = cv_targ;
7148
7149         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7150         if (PL_hints & HINT_RE_EVAL)
7151             S_set_haseval(aTHX);
7152
7153         /* establish postfix order */
7154         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7155             LINKLIST(expr);
7156             rcop->op_next = expr;
7157             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7158         }
7159         else {
7160             rcop->op_next = LINKLIST(expr);
7161             expr->op_next = (OP*)rcop;
7162         }
7163
7164         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7165     }
7166
7167     if (repl) {
7168         OP *curop = repl;
7169         bool konst;
7170         /* If we are looking at s//.../e with a single statement, get past
7171            the implicit do{}. */
7172         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7173              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7174              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7175          {
7176             OP *sib;
7177             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7178             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7179              && !OpHAS_SIBLING(sib))
7180                 curop = sib;
7181         }
7182         if (curop->op_type == OP_CONST)
7183             konst = TRUE;
7184         else if (( (curop->op_type == OP_RV2SV ||
7185                     curop->op_type == OP_RV2AV ||
7186                     curop->op_type == OP_RV2HV ||
7187                     curop->op_type == OP_RV2GV)
7188                    && cUNOPx(curop)->op_first
7189                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7190                 || curop->op_type == OP_PADSV
7191                 || curop->op_type == OP_PADAV
7192                 || curop->op_type == OP_PADHV
7193                 || curop->op_type == OP_PADANY) {
7194             repl_has_vars = 1;
7195             konst = TRUE;
7196         }
7197         else konst = FALSE;
7198         if (konst
7199             && !(repl_has_vars
7200                  && (!PM_GETRE(pm)
7201                      || !RX_PRELEN(PM_GETRE(pm))
7202                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7203         {
7204             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7205             op_prepend_elem(o->op_type, scalar(repl), o);
7206         }
7207         else {
7208             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7209             rcop->op_private = 1;
7210
7211             /* establish postfix order */
7212             rcop->op_next = LINKLIST(repl);
7213             repl->op_next = (OP*)rcop;
7214
7215             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7216             assert(!(pm->op_pmflags & PMf_ONCE));
7217             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7218             rcop->op_next = 0;
7219         }
7220     }
7221
7222     return (OP*)pm;
7223 }
7224
7225 /*
7226 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7227
7228 Constructs, checks, and returns an op of any type that involves an
7229 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7230 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7231 takes ownership of one reference to it.
7232
7233 =cut
7234 */
7235
7236 OP *
7237 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7238 {
7239     dVAR;
7240     SVOP *svop;
7241
7242     PERL_ARGS_ASSERT_NEWSVOP;
7243
7244     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7245         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7246         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7247         || type == OP_CUSTOM);
7248
7249     NewOp(1101, svop, 1, SVOP);
7250     OpTYPE_set(svop, type);
7251     svop->op_sv = sv;
7252     svop->op_next = (OP*)svop;
7253     svop->op_flags = (U8)flags;
7254     svop->op_private = (U8)(0 | (flags >> 8));
7255     if (PL_opargs[type] & OA_RETSCALAR)
7256         scalar((OP*)svop);
7257     if (PL_opargs[type] & OA_TARGET)
7258         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7259     return CHECKOP(type, svop);
7260 }
7261
7262 /*
7263 =for apidoc Am|OP *|newDEFSVOP|
7264
7265 Constructs and returns an op to access C<$_>.
7266
7267 =cut
7268 */
7269
7270 OP *
7271 Perl_newDEFSVOP(pTHX)
7272 {
7273         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7274 }
7275
7276 #ifdef USE_ITHREADS
7277
7278 /*
7279 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7280
7281 Constructs, checks, and returns an op of any type that involves a
7282 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7283 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7284 is populated with C<sv>; this function takes ownership of one reference
7285 to it.
7286
7287 This function only exists if Perl has been compiled to use ithreads.
7288
7289 =cut
7290 */
7291
7292 OP *
7293 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7294 {
7295     dVAR;
7296     PADOP *padop;
7297
7298     PERL_ARGS_ASSERT_NEWPADOP;
7299
7300     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7301         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7302         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7303         || type == OP_CUSTOM);
7304
7305     NewOp(1101, padop, 1, PADOP);
7306     OpTYPE_set(padop, type);
7307     padop->op_padix =
7308         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7309     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7310     PAD_SETSV(padop->op_padix, sv);
7311     assert(sv);
7312     padop->op_next = (OP*)padop;
7313     padop->op_flags = (U8)flags;
7314     if (PL_opargs[type] & OA_RETSCALAR)
7315         scalar((OP*)padop);
7316     if (PL_opargs[type] & OA_TARGET)
7317         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7318     return CHECKOP(type, padop);
7319 }
7320
7321 #endif /* USE_ITHREADS */
7322
7323 /*
7324 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7325
7326 Constructs, checks, and returns an op of any type that involves an
7327 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7328 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7329 reference; calling this function does not transfer ownership of any
7330 reference to it.
7331
7332 =cut
7333 */
7334
7335 OP *
7336 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7337 {
7338     PERL_ARGS_ASSERT_NEWGVOP;
7339
7340 #ifdef USE_ITHREADS
7341     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7342 #else
7343     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7344 #endif
7345 }
7346
7347 /*
7348 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7349
7350 Constructs, checks, and returns an op of any type that involves an
7351 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7352 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7353 Depending on the op type, the memory referenced by C<pv> may be freed
7354 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7355 have been allocated using C<PerlMemShared_malloc>.
7356
7357 =cut
7358 */
7359
7360 OP *
7361 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7362 {
7363     dVAR;
7364     const bool utf8 = cBOOL(flags & SVf_UTF8);
7365     PVOP *pvop;
7366
7367     flags &= ~SVf_UTF8;
7368
7369     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7370         || type == OP_RUNCV || type == OP_CUSTOM
7371         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7372
7373     NewOp(1101, pvop, 1, PVOP);
7374     OpTYPE_set(pvop, type);
7375     pvop->op_pv = pv;
7376     pvop->op_next = (OP*)pvop;
7377     pvop->op_flags = (U8)flags;
7378     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7379     if (PL_opargs[type] & OA_RETSCALAR)
7380         scalar((OP*)pvop);
7381     if (PL_opargs[type] & OA_TARGET)
7382         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7383     return CHECKOP(type, pvop);
7384 }
7385
7386 void
7387 Perl_package(pTHX_ OP *o)
7388 {
7389     SV *const sv = cSVOPo->op_sv;
7390
7391     PERL_ARGS_ASSERT_PACKAGE;
7392
7393     SAVEGENERICSV(PL_curstash);
7394     save_item(PL_curstname);
7395
7396     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7397
7398     sv_setsv(PL_curstname, sv);
7399
7400     PL_hints |= HINT_BLOCK_SCOPE;
7401     PL_parser->copline = NOLINE;
7402
7403     op_free(o);
7404 }
7405
7406 void
7407 Perl_package_version( pTHX_ OP *v )
7408 {
7409     U32 savehints = PL_hints;
7410     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7411     PL_hints &= ~HINT_STRICT_VARS;
7412     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7413     PL_hints = savehints;
7414     op_free(v);
7415 }
7416
7417 void
7418 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7419 {
7420     OP *pack;
7421     OP *imop;
7422     OP *veop;
7423     SV *use_version = NULL;
7424
7425     PERL_ARGS_ASSERT_UTILIZE;
7426
7427     if (idop->op_type != OP_CONST)
7428         Perl_croak(aTHX_ "Module name must be constant");
7429
7430     veop = NULL;
7431
7432     if (version) {
7433         SV * const vesv = ((SVOP*)version)->op_sv;
7434
7435         if (!arg && !SvNIOKp(vesv)) {
7436             arg = version;
7437         }
7438         else {
7439             OP *pack;
7440             SV *meth;
7441
7442             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7443                 Perl_croak(aTHX_ "Version number must be a constant number");
7444
7445             /* Make copy of idop so we don't free it twice */
7446             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7447
7448             /* Fake up a method call to VERSION */
7449             meth = newSVpvs_share("VERSION");
7450             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7451                             op_append_elem(OP_LIST,
7452                                         op_prepend_elem(OP_LIST, pack, version),
7453                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7454         }
7455     }
7456
7457     /* Fake up an import/unimport */
7458     if (arg && arg->op_type == OP_STUB) {
7459         imop = arg;             /* no import on explicit () */
7460     }
7461     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7462         imop = NULL;            /* use 5.0; */
7463         if (aver)
7464             use_version = ((SVOP*)idop)->op_sv;
7465         else
7466             idop->op_private |= OPpCONST_NOVER;
7467     }
7468     else {
7469         SV *meth;
7470
7471         /* Make copy of idop so we don't free it twice */
7472         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7473
7474         /* Fake up a method call to import/unimport */
7475         meth = aver
7476             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7477         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7478                        op_append_elem(OP_LIST,
7479                                    op_prepend_elem(OP_LIST, pack, arg),
7480                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7481                        ));
7482     }
7483
7484     /* Fake up the BEGIN {}, which does its thing immediately. */
7485     newATTRSUB(floor,
7486         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7487         NULL,
7488         NULL,
7489         op_append_elem(OP_LINESEQ,
7490             op_append_elem(OP_LINESEQ,
7491                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7492                 newSTATEOP(0, NULL, veop)),
7493             newSTATEOP(0, NULL, imop) ));
7494
7495     if (use_version) {
7496         /* Enable the
7497          * feature bundle that corresponds to the required version. */
7498         use_version = sv_2mortal(new_version(use_version));
7499         S_enable_feature_bundle(aTHX_ use_version);
7500
7501         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7502         if (vcmp(use_version,
7503                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7504             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7505                 PL_hints |= HINT_STRICT_REFS;
7506             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7507                 PL_hints |= HINT_STRICT_SUBS;
7508             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7509                 PL_hints |= HINT_STRICT_VARS;
7510         }
7511         /* otherwise they are off */
7512         else {
7513             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7514                 PL_hints &= ~HINT_STRICT_REFS;
7515             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7516                 PL_hints &= ~HINT_STRICT_SUBS;
7517             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7518                 PL_hints &= ~HINT_STRICT_VARS;
7519         }
7520     }
7521
7522     /* The "did you use incorrect case?" warning used to be here.
7523      * The problem is that on case-insensitive filesystems one
7524      * might get false positives for "use" (and "require"):
7525      * "use Strict" or "require CARP" will work.  This causes
7526      * portability problems for the script: in case-strict
7527      * filesystems the script will stop working.
7528      *
7529      * The "incorrect case" warning checked whether "use Foo"
7530      * imported "Foo" to your namespace, but that is wrong, too:
7531      * there is no requirement nor promise in the language that
7532      * a Foo.pm should or would contain anything in package "Foo".
7533      *
7534      * There is very little Configure-wise that can be done, either:
7535      * the case-sensitivity of the build filesystem of Perl does not
7536      * help in guessing the case-sensitivity of the runtime environment.
7537      */
7538
7539     PL_hints |= HINT_BLOCK_SCOPE;
7540     PL_parser->copline = NOLINE;
7541     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7542 }
7543
7544 /*
7545 =head1 Embedding Functions
7546
7547 =for apidoc load_module
7548
7549 Loads the module whose name is pointed to by the string part of C<name>.
7550 Note that the actual module name, not its filename, should be given.
7551 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7552 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7553 trailing arguments can be used to specify arguments to the module's C<import()>
7554 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7555 on the flags. The flags argument is a bitwise-ORed collection of any of
7556 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7557 (or 0 for no flags).
7558
7559 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7560 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7561 the trailing optional arguments may be omitted entirely. Otherwise, if
7562 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7563 exactly one C<OP*>, containing the op tree that produces the relevant import
7564 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7565 will be used as import arguments; and the list must be terminated with C<(SV*)
7566 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7567 set, the trailing C<NULL> pointer is needed even if no import arguments are
7568 desired. The reference count for each specified C<SV*> argument is
7569 decremented. In addition, the C<name> argument is modified.
7570
7571 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7572 than C<use>.
7573
7574 =cut */
7575
7576 void
7577 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7578 {
7579     va_list args;
7580
7581     PERL_ARGS_ASSERT_LOAD_MODULE;
7582
7583     va_start(args, ver);
7584     vload_module(flags, name, ver, &args);
7585     va_end(args);
7586 }
7587
7588 #ifdef PERL_IMPLICIT_CONTEXT
7589 void
7590 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7591 {
7592     dTHX;
7593     va_list args;
7594     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7595     va_start(args, ver);
7596     vload_module(flags, name, ver, &args);
7597     va_end(args);
7598 }
7599 #endif
7600
7601 void
7602 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7603 {
7604     OP *veop, *imop;
7605     OP * const modname = newSVOP(OP_CONST, 0, name);
7606
7607     PERL_ARGS_ASSERT_VLOAD_MODULE;
7608
7609     modname->op_private |= OPpCONST_BARE;
7610     if (ver) {
7611         veop = newSVOP(OP_CONST, 0, ver);
7612     }
7613     else
7614         veop = NULL;
7615     if (flags & PERL_LOADMOD_NOIMPORT) {
7616         imop = sawparens(newNULLLIST());
7617     }
7618     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7619         imop = va_arg(*args, OP*);
7620     }
7621     else {
7622         SV *sv;
7623         imop = NULL;
7624         sv = va_arg(*args, SV*);
7625         while (sv) {
7626             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7627             sv = va_arg(*args, SV*);
7628         }
7629     }
7630
7631     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7632      * that it has a PL_parser to play with while doing that, and also
7633      * that it doesn't mess with any existing parser, by creating a tmp
7634      * new parser with lex_start(). This won't actually be used for much,
7635      * since pp_require() will create another parser for the real work.
7636      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7637
7638     ENTER;
7639     SAVEVPTR(PL_curcop);
7640     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7641     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7642             veop, modname, imop);
7643     LEAVE;
7644 }
7645
7646 PERL_STATIC_INLINE OP *
7647 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7648 {
7649     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7650                    newLISTOP(OP_LIST, 0, arg,
7651                              newUNOP(OP_RV2CV, 0,
7652                                      newGVOP(OP_GV, 0, gv))));
7653 }
7654
7655 OP *
7656 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7657 {
7658     OP *doop;
7659     GV *gv;
7660
7661     PERL_ARGS_ASSERT_DOFILE;
7662
7663     if (!force_builtin && (gv = gv_override("do", 2))) {
7664         doop = S_new_entersubop(aTHX_ gv, term);
7665     }
7666     else {
7667         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7668     }
7669     return doop;
7670 }
7671
7672 /*
7673 =head1 Optree construction
7674
7675 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7676
7677 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7678 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7679 be set automatically, and, shifted up eight bits, the eight bits of
7680 C<op_private>, except that the bit with value 1 or 2 is automatically
7681 set as required.  C<listval> and C<subscript> supply the parameters of
7682 the slice; they are consumed by this function and become part of the
7683 constructed op tree.
7684
7685 =cut
7686 */
7687
7688 OP *
7689 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7690 {
7691     return newBINOP(OP_LSLICE, flags,
7692             list(force_list(subscript, 1)),
7693             list(force_list(listval,   1)) );
7694 }
7695
7696 #define ASSIGN_LIST   1
7697 #define ASSIGN_REF    2
7698
7699 STATIC I32
7700 S_assignment_type(pTHX_ const OP *o)
7701 {
7702     unsigned type;
7703     U8 flags;
7704     U8 ret;
7705
7706     if (!o)
7707         return TRUE;
7708
7709     if (o->op_type == OP_SREFGEN)
7710     {
7711         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7712         type = kid->op_type;
7713         flags = o->op_flags | kid->op_flags;
7714         if (!(flags & OPf_PARENS)
7715           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7716               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7717             return ASSIGN_REF;
7718         ret = ASSIGN_REF;
7719     } else {
7720         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7721             o = cUNOPo->op_first;
7722         flags = o->op_flags;
7723         type = o->op_type;
7724         ret = 0;
7725     }
7726
7727     if (type == OP_COND_EXPR) {
7728         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7729         const I32 t = assignment_type(sib);
7730         const I32 f = assignment_type(OpSIBLING(sib));
7731
7732         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7733             return ASSIGN_LIST;
7734         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7735             yyerror("Assignment to both a list and a scalar");
7736         return FALSE;
7737     }
7738
7739     if (type == OP_LIST &&
7740         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7741         o->op_private & OPpLVAL_INTRO)
7742         return ret;
7743
7744     if (type == OP_LIST || flags & OPf_PARENS ||
7745         type == OP_RV2AV || type == OP_RV2HV ||
7746         type == OP_ASLICE || type == OP_HSLICE ||
7747         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7748         return TRUE;
7749
7750     if (type == OP_PADAV || type == OP_PADHV)
7751         return TRUE;
7752
7753     if (type == OP_RV2SV)
7754         return ret;
7755
7756     return ret;
7757 }
7758
7759 static OP *
7760 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7761 {
7762     const PADOFFSET target = padop->op_targ;
7763     OP *const other = newOP(OP_PADSV,
7764                             padop->op_flags
7765                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7766     OP *const first = newOP(OP_NULL, 0);
7767     OP *const nullop = newCONDOP(0, first, initop, other);
7768     /* XXX targlex disabled for now; see ticket #124160
7769         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7770      */
7771     OP *const condop = first->op_next;
7772
7773     OpTYPE_set(condop, OP_ONCE);
7774     other->op_targ = target;
7775     nullop->op_flags |= OPf_WANT_SCALAR;
7776
7777     /* Store the initializedness of state vars in a separate
7778        pad entry.  */
7779     condop->op_targ =
7780       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7781     /* hijacking PADSTALE for uninitialized state variables */
7782     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7783
7784     return nullop;
7785 }
7786
7787 /*
7788 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7789
7790 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7791 supply the parameters of the assignment; they are consumed by this
7792 function and become part of the constructed op tree.
7793
7794 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7795 a suitable conditional optree is constructed.  If C<optype> is the opcode
7796 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7797 performs the binary operation and assigns the result to the left argument.
7798 Either way, if C<optype> is non-zero then C<flags> has no effect.
7799
7800 If C<optype> is zero, then a plain scalar or list assignment is
7801 constructed.  Which type of assignment it is is automatically determined.
7802 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7803 will be set automatically, and, shifted up eight bits, the eight bits
7804 of C<op_private>, except that the bit with value 1 or 2 is automatically
7805 set as required.
7806
7807 =cut
7808 */
7809
7810 OP *
7811 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7812 {
7813     OP *o;
7814     I32 assign_type;
7815
7816     if (optype) {
7817         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7818             right = scalar(right);
7819             return newLOGOP(optype, 0,
7820                 op_lvalue(scalar(left), optype),
7821                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7822         }
7823         else {
7824             return newBINOP(optype, OPf_STACKED,
7825                 op_lvalue(scalar(left), optype), scalar(right));
7826         }
7827     }
7828
7829     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7830         OP *state_var_op = NULL;
7831         static const char no_list_state[] = "Initialization of state variables"
7832             " in list currently forbidden";
7833         OP *curop;
7834
7835         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7836             left->op_private &= ~ OPpSLICEWARNING;
7837
7838         PL_modcount = 0;
7839         left = op_lvalue(left, OP_AASSIGN);
7840         curop = list(force_list(left, 1));
7841         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7842         o->op_private = (U8)(0 | (flags >> 8));
7843
7844         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7845         {
7846             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7847             if (!(left->op_flags & OPf_PARENS) &&
7848                     lop->op_type == OP_PUSHMARK &&
7849                     (vop = OpSIBLING(lop)) &&
7850                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7851                     !(vop->op_flags & OPf_PARENS) &&
7852                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7853                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7854                     (eop = OpSIBLING(vop)) &&
7855                     eop->op_type == OP_ENTERSUB &&
7856                     !OpHAS_SIBLING(eop)) {
7857                 state_var_op = vop;
7858             } else {
7859                 while (lop) {
7860                     if ((lop->op_type == OP_PADSV ||
7861                          lop->op_type == OP_PADAV ||
7862                          lop->op_type == OP_PADHV ||
7863                          lop->op_type == OP_PADANY)
7864                       && (lop->op_private & OPpPAD_STATE)
7865                     )
7866                         yyerror(no_list_state);
7867                     lop = OpSIBLING(lop);
7868                 }
7869             }
7870         }
7871         else if (  (left->op_private & OPpLVAL_INTRO)
7872                 && (left->op_private & OPpPAD_STATE)
7873                 && (   left->op_type == OP_PADSV
7874                     || left->op_type == OP_PADAV
7875                     || left->op_type == OP_PADHV
7876                     || left->op_type == OP_PADANY)
7877         ) {
7878                 /* All single variable list context state assignments, hence
7879                    state ($a) = ...
7880                    (state $a) = ...
7881                    state @a = ...
7882                    state (@a) = ...
7883                    (state @a) = ...
7884                    state %a = ...
7885                    state (%a) = ...
7886                    (state %a) = ...
7887                 */
7888                 if (left->op_flags & OPf_PARENS)
7889                     yyerror(no_list_state);
7890                 else
7891                     state_var_op = left;
7892         }
7893
7894         /* optimise @a = split(...) into:
7895         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7896         * @a, my @a, local @a:  split(...)          (where @a is attached to
7897         *                                            the split op itself)
7898         */
7899
7900         if (   right
7901             && right->op_type == OP_SPLIT
7902             /* don't do twice, e.g. @b = (@a = split) */
7903             && !(right->op_private & OPpSPLIT_ASSIGN))
7904         {
7905             OP *gvop = NULL;
7906
7907             if (   (  left->op_type == OP_RV2AV
7908                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7909                 || left->op_type == OP_PADAV)
7910             {
7911                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7912                 OP *tmpop;
7913                 if (gvop) {
7914 #ifdef USE_ITHREADS
7915                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7916                         = cPADOPx(gvop)->op_padix;
7917                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7918 #else
7919                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7920                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7921                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7922 #endif
7923                     right->op_private |=
7924                         left->op_private & OPpOUR_INTRO;
7925                 }
7926                 else {
7927                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7928                     left->op_targ = 0;  /* steal it */
7929                     right->op_private |= OPpSPLIT_LEX;
7930                 }
7931                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7932
7933               detach_split:
7934                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7935                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7936                 assert(OpSIBLING(tmpop) == right);
7937                 assert(!OpHAS_SIBLING(right));
7938                 /* detach the split subtreee from the o tree,
7939                  * then free the residual o tree */
7940                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7941                 op_free(o);                     /* blow off assign */
7942                 right->op_private |= OPpSPLIT_ASSIGN;
7943                 right->op_flags &= ~OPf_WANT;
7944                         /* "I don't know and I don't care." */
7945                 return right;
7946             }
7947             else if (left->op_type == OP_RV2AV) {
7948                 /* @{expr} */
7949
7950                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7951                 assert(OpSIBLING(pushop) == left);
7952                 /* Detach the array ...  */
7953                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7954                 /* ... and attach it to the split.  */
7955                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7956                                   0, left);
7957                 right->op_flags |= OPf_STACKED;
7958                 /* Detach split and expunge aassign as above.  */
7959                 goto detach_split;
7960             }
7961             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7962                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
7963             {
7964                 /* convert split(...,0) to split(..., PL_modcount+1) */
7965                 SV ** const svp =
7966                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7967                 SV * const sv = *svp;
7968                 if (SvIOK(sv) && SvIVX(sv) == 0)
7969                 {
7970                   if (right->op_private & OPpSPLIT_IMPLIM) {
7971                     /* our own SV, created in ck_split */
7972                     SvREADONLY_off(sv);
7973                     sv_setiv(sv, PL_modcount+1);
7974                   }
7975                   else {
7976                     /* SV may belong to someone else */
7977                     SvREFCNT_dec(sv);
7978                     *svp = newSViv(PL_modcount+1);
7979                   }
7980                 }
7981             }
7982         }
7983
7984         if (state_var_op)
7985             o = S_newONCEOP(aTHX_ o, state_var_op);
7986         return o;
7987     }
7988     if (assign_type == ASSIGN_REF)
7989         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7990     if (!right)
7991         right = newOP(OP_UNDEF, 0);
7992     if (right->op_type == OP_READLINE) {
7993         right->op_flags |= OPf_STACKED;
7994         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7995                 scalar(right));
7996     }
7997     else {
7998         o = newBINOP(OP_SASSIGN, flags,
7999             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8000     }
8001     return o;
8002 }
8003
8004 /*
8005 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8006
8007 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8008 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8009 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8010 If C<label> is non-null, it supplies the name of a label to attach to
8011 the state op; this function takes ownership of the memory pointed at by
8012 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8013 for the state op.
8014
8015 If C<o> is null, the state op is returned.  Otherwise the state op is
8016 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8017 is consumed by this function and becomes part of the returned op tree.
8018
8019 =cut
8020 */
8021
8022 OP *
8023 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8024 {
8025     dVAR;
8026     const U32 seq = intro_my();
8027     const U32 utf8 = flags & SVf_UTF8;
8028     COP *cop;
8029
8030     PL_parser->parsed_sub = 0;
8031
8032     flags &= ~SVf_UTF8;
8033
8034     NewOp(1101, cop, 1, COP);
8035     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8036         OpTYPE_set(cop, OP_DBSTATE);
8037     }
8038     else {
8039         OpTYPE_set(cop, OP_NEXTSTATE);
8040     }
8041     cop->op_flags = (U8)flags;
8042     CopHINTS_set(cop, PL_hints);
8043 #ifdef VMS
8044     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8045 #endif
8046     cop->op_next = (OP*)cop;
8047
8048     cop->cop_seq = seq;
8049     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8050     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8051     if (label) {
8052         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8053
8054         PL_hints |= HINT_BLOCK_SCOPE;
8055         /* It seems that we need to defer freeing this pointer, as other parts
8056            of the grammar end up wanting to copy it after this op has been
8057            created. */
8058         SAVEFREEPV(label);
8059     }
8060
8061     if (PL_parser->preambling != NOLINE) {
8062         CopLINE_set(cop, PL_parser->preambling);
8063         PL_parser->copline = NOLINE;
8064     }
8065     else if (PL_parser->copline == NOLINE)
8066         CopLINE_set(cop, CopLINE(PL_curcop));
8067     else {
8068         CopLINE_set(cop, PL_parser->copline);
8069         PL_parser->copline = NOLINE;
8070     }
8071 #ifdef USE_ITHREADS
8072     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8073 #else
8074     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8075 #endif
8076     CopSTASH_set(cop, PL_curstash);
8077
8078     if (cop->op_type == OP_DBSTATE) {
8079         /* this line can have a breakpoint - store the cop in IV */
8080         AV *av = CopFILEAVx(PL_curcop);
8081         if (av) {
8082             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8083             if (svp && *svp != &PL_sv_undef ) {
8084                 (void)SvIOK_on(*svp);
8085                 SvIV_set(*svp, PTR2IV(cop));
8086             }
8087         }
8088     }
8089
8090     if (flags & OPf_SPECIAL)
8091         op_null((OP*)cop);
8092     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8093 }
8094
8095 /*
8096 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8097
8098 Constructs, checks, and returns a logical (flow control) op.  C<type>
8099 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8100 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8101 the eight bits of C<op_private>, except that the bit with value 1 is
8102 automatically set.  C<first> supplies the expression controlling the
8103 flow, and C<other> supplies the side (alternate) chain of ops; they are
8104 consumed by this function and become part of the constructed op tree.
8105
8106 =cut
8107 */
8108
8109 OP *
8110 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8111 {
8112     PERL_ARGS_ASSERT_NEWLOGOP;
8113
8114     return new_logop(type, flags, &first, &other);
8115 }
8116
8117 STATIC OP *
8118 S_search_const(pTHX_ OP *o)
8119 {
8120     PERL_ARGS_ASSERT_SEARCH_CONST;
8121
8122     switch (o->op_type) {
8123         case OP_CONST:
8124             return o;
8125         case OP_NULL:
8126             if (o->op_flags & OPf_KIDS)
8127                 return search_const(cUNOPo->op_first);
8128             break;
8129         case OP_LEAVE:
8130         case OP_SCOPE:
8131         case OP_LINESEQ:
8132         {
8133             OP *kid;
8134             if (!(o->op_flags & OPf_KIDS))
8135                 return NULL;
8136             kid = cLISTOPo->op_first;
8137             do {
8138                 switch (kid->op_type) {
8139                     case OP_ENTER:
8140                     case OP_NULL:
8141                     case OP_NEXTSTATE:
8142                         kid = OpSIBLING(kid);
8143                         break;
8144                     default:
8145                         if (kid != cLISTOPo->op_last)
8146                             return NULL;
8147                         goto last;
8148                 }
8149             } while (kid);
8150             if (!kid)
8151                 kid = cLISTOPo->op_last;
8152           last:
8153             return search_const(kid);
8154         }
8155     }
8156
8157     return NULL;
8158 }
8159
8160 STATIC OP *
8161 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8162 {
8163     dVAR;
8164     LOGOP *logop;
8165     OP *o;
8166     OP *first;
8167     OP *other;
8168     OP *cstop = NULL;
8169     int prepend_not = 0;
8170
8171     PERL_ARGS_ASSERT_NEW_LOGOP;
8172
8173     first = *firstp;
8174     other = *otherp;
8175
8176     /* [perl #59802]: Warn about things like "return $a or $b", which
8177        is parsed as "(return $a) or $b" rather than "return ($a or
8178        $b)".  NB: This also applies to xor, which is why we do it
8179        here.
8180      */
8181     switch (first->op_type) {
8182     case OP_NEXT:
8183     case OP_LAST:
8184     case OP_REDO:
8185         /* XXX: Perhaps we should emit a stronger warning for these.
8186            Even with the high-precedence operator they don't seem to do
8187            anything sensible.
8188
8189            But until we do, fall through here.
8190          */
8191     case OP_RETURN:
8192     case OP_EXIT:
8193     case OP_DIE:
8194     case OP_GOTO:
8195         /* XXX: Currently we allow people to "shoot themselves in the
8196            foot" by explicitly writing "(return $a) or $b".
8197
8198            Warn unless we are looking at the result from folding or if
8199            the programmer explicitly grouped the operators like this.
8200            The former can occur with e.g.
8201
8202                 use constant FEATURE => ( $] >= ... );
8203                 sub { not FEATURE and return or do_stuff(); }
8204          */
8205         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8206             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8207                            "Possible precedence issue with control flow operator");
8208         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8209            the "or $b" part)?
8210         */
8211         break;
8212     }
8213
8214     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8215         return newBINOP(type, flags, scalar(first), scalar(other));
8216
8217     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8218         || type == OP_CUSTOM);
8219
8220     scalarboolean(first);
8221
8222     /* search for a constant op that could let us fold the test */
8223     if ((cstop = search_const(first))) {
8224         if (cstop->op_private & OPpCONST_STRICT)
8225             no_bareword_allowed(cstop);
8226         else if ((cstop->op_private & OPpCONST_BARE))
8227                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8228         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8229             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8230             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8231             /* Elide the (constant) lhs, since it can't affect the outcome */
8232             *firstp = NULL;
8233             if (other->op_type == OP_CONST)
8234                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8235             op_free(first);
8236             if (other->op_type == OP_LEAVE)
8237                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8238             else if (other->op_type == OP_MATCH
8239                   || other->op_type == OP_SUBST
8240                   || other->op_type == OP_TRANSR
8241                   || other->op_type == OP_TRANS)
8242                 /* Mark the op as being unbindable with =~ */
8243                 other->op_flags |= OPf_SPECIAL;
8244
8245             other->op_folded = 1;
8246             return other;
8247         }
8248         else {
8249             /* Elide the rhs, since the outcome is entirely determined by
8250              * the (constant) lhs */
8251
8252             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8253             const OP *o2 = other;
8254             if ( ! (o2->op_type == OP_LIST
8255                     && (( o2 = cUNOPx(o2)->op_first))
8256                     && o2->op_type == OP_PUSHMARK
8257                     && (( o2 = OpSIBLING(o2))) )
8258             )
8259                 o2 = other;
8260             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8261                         || o2->op_type == OP_PADHV)
8262                 && o2->op_private & OPpLVAL_INTRO
8263                 && !(o2->op_private & OPpPAD_STATE))
8264             {
8265                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8266                                 "Deprecated use of my() in false conditional. "
8267                                 "This will be a fatal error in Perl 5.30");
8268             }
8269
8270             *otherp = NULL;
8271             if (cstop->op_type == OP_CONST)
8272                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8273             op_free(other);
8274             return first;
8275         }
8276     }
8277     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8278         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8279     {
8280         const OP * const k1 = ((UNOP*)first)->op_first;
8281         const OP * const k2 = OpSIBLING(k1);
8282         OPCODE warnop = 0;
8283         switch (first->op_type)
8284         {
8285         case OP_NULL:
8286             if (k2 && k2->op_type == OP_READLINE
8287                   && (k2->op_flags & OPf_STACKED)
8288                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8289             {
8290                 warnop = k2->op_type;
8291             }
8292             break;
8293
8294         case OP_SASSIGN:
8295             if (k1->op_type == OP_READDIR
8296                   || k1->op_type == OP_GLOB
8297                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8298                  || k1->op_type == OP_EACH
8299                  || k1->op_type == OP_AEACH)
8300             {
8301                 warnop = ((k1->op_type == OP_NULL)
8302                           ? (OPCODE)k1->op_targ : k1->op_type);
8303             }
8304             break;
8305         }
8306         if (warnop) {
8307             const line_t oldline = CopLINE(PL_curcop);
8308             /* This ensures that warnings are reported at the first line
8309                of the construction, not the last.  */
8310             CopLINE_set(PL_curcop, PL_parser->copline);
8311             Perl_warner(aTHX_ packWARN(WARN_MISC),
8312                  "Value of %s%s can be \"0\"; test with defined()",
8313                  PL_op_desc[warnop],
8314                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8315                   ? " construct" : "() operator"));
8316             CopLINE_set(PL_curcop, oldline);
8317         }
8318     }
8319
8320     /* optimize AND and OR ops that have NOTs as children */
8321     if (first->op_type == OP_NOT
8322         && (first->op_flags & OPf_KIDS)
8323         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8324             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8325         ) {
8326         if (type == OP_AND || type == OP_OR) {
8327             if (type == OP_AND)
8328                 type = OP_OR;
8329             else
8330                 type = OP_AND;
8331             op_null(first);
8332             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8333                 op_null(other);
8334                 prepend_not = 1; /* prepend a NOT op later */
8335             }
8336         }
8337     }
8338
8339     logop = alloc_LOGOP(type, first, LINKLIST(other));
8340     logop->op_flags |= (U8)flags;
8341     logop->op_private = (U8)(1 | (flags >> 8));
8342
8343     /* establish postfix order */
8344     logop->op_next = LINKLIST(first);
8345     first->op_next = (OP*)logop;
8346     assert(!OpHAS_SIBLING(first));
8347     op_sibling_splice((OP*)logop, first, 0, other);
8348
8349     CHECKOP(type,logop);
8350
8351     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8352                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8353                 (OP*)logop);
8354     other->op_next = o;
8355
8356     return o;
8357 }
8358
8359 /*
8360 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8361
8362 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8363 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8364 will be set automatically, and, shifted up eight bits, the eight bits of
8365 C<op_private>, except that the bit with value 1 is automatically set.
8366 C<first> supplies the expression selecting between the two branches,
8367 and C<trueop> and C<falseop> supply the branches; they are consumed by
8368 this function and become part of the constructed op tree.
8369
8370 =cut
8371 */
8372
8373 OP *
8374 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8375 {
8376     dVAR;
8377     LOGOP *logop;
8378     OP *start;
8379     OP *o;
8380     OP *cstop;
8381
8382     PERL_ARGS_ASSERT_NEWCONDOP;
8383
8384     if (!falseop)
8385         return newLOGOP(OP_AND, 0, first, trueop);
8386     if (!trueop)
8387         return newLOGOP(OP_OR, 0, first, falseop);
8388
8389     scalarboolean(first);
8390     if ((cstop = search_const(first))) {
8391         /* Left or right arm of the conditional?  */
8392         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8393         OP *live = left ? trueop : falseop;
8394         OP *const dead = left ? falseop : trueop;
8395         if (cstop->op_private & OPpCONST_BARE &&
8396             cstop->op_private & OPpCONST_STRICT) {
8397             no_bareword_allowed(cstop);
8398         }
8399         op_free(first);
8400         op_free(dead);
8401         if (live->op_type == OP_LEAVE)
8402             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8403         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8404               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8405             /* Mark the op as being unbindable with =~ */
8406             live->op_flags |= OPf_SPECIAL;
8407         live->op_folded = 1;
8408         return live;
8409     }
8410     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8411     logop->op_flags |= (U8)flags;
8412     logop->op_private = (U8)(1 | (flags >> 8));
8413     logop->op_next = LINKLIST(falseop);
8414
8415     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8416             logop);
8417
8418     /* establish postfix order */
8419     start = LINKLIST(first);
8420     first->op_next = (OP*)logop;
8421
8422     /* make first, trueop, falseop siblings */
8423     op_sibling_splice((OP*)logop, first,  0, trueop);
8424     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8425
8426     o = newUNOP(OP_NULL, 0, (OP*)logop);
8427
8428     trueop->op_next = falseop->op_next = o;
8429
8430     o->op_next = start;
8431     return o;
8432 }
8433
8434 /*
8435 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8436
8437 Constructs and returns a C<range> op, with subordinate C<flip> and
8438 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8439 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8440 for both the C<flip> and C<range> ops, except that the bit with value
8441 1 is automatically set.  C<left> and C<right> supply the expressions
8442 controlling the endpoints of the range; they are consumed by this function
8443 and become part of the constructed op tree.
8444
8445 =cut
8446 */
8447
8448 OP *
8449 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8450 {
8451     LOGOP *range;
8452     OP *flip;
8453     OP *flop;
8454     OP *leftstart;
8455     OP *o;
8456
8457     PERL_ARGS_ASSERT_NEWRANGE;
8458
8459     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8460     range->op_flags = OPf_KIDS;
8461     leftstart = LINKLIST(left);
8462     range->op_private = (U8)(1 | (flags >> 8));
8463
8464     /* make left and right siblings */
8465     op_sibling_splice((OP*)range, left, 0, right);
8466
8467     range->op_next = (OP*)range;
8468     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8469     flop = newUNOP(OP_FLOP, 0, flip);
8470     o = newUNOP(OP_NULL, 0, flop);
8471     LINKLIST(flop);
8472     range->op_next = leftstart;
8473
8474     left->op_next = flip;
8475     right->op_next = flop;
8476
8477     range->op_targ =
8478         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8479     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8480     flip->op_targ =
8481         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8482     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8483     SvPADTMP_on(PAD_SV(flip->op_targ));
8484
8485     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8486     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8487
8488     /* check barewords before they might be optimized aways */
8489     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8490         no_bareword_allowed(left);
8491     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8492         no_bareword_allowed(right);
8493
8494     flip->op_next = o;
8495     if (!flip->op_private || !flop->op_private)
8496         LINKLIST(o);            /* blow off optimizer unless constant */
8497
8498     return o;
8499 }
8500
8501 /*
8502 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8503
8504 Constructs, checks, and returns an op tree expressing a loop.  This is
8505 only a loop in the control flow through the op tree; it does not have
8506 the heavyweight loop structure that allows exiting the loop by C<last>
8507 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8508 top-level op, except that some bits will be set automatically as required.
8509 C<expr> supplies the expression controlling loop iteration, and C<block>
8510 supplies the body of the loop; they are consumed by this function and
8511 become part of the constructed op tree.  C<debuggable> is currently
8512 unused and should always be 1.
8513
8514 =cut
8515 */
8516
8517 OP *
8518 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8519 {
8520     OP* listop;
8521     OP* o;
8522     const bool once = block && block->op_flags & OPf_SPECIAL &&
8523                       block->op_type == OP_NULL;
8524
8525     PERL_UNUSED_ARG(debuggable);
8526
8527     if (expr) {
8528         if (once && (
8529               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8530            || (  expr->op_type == OP_NOT
8531               && cUNOPx(expr)->op_first->op_type == OP_CONST
8532               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8533               )
8534            ))
8535             /* Return the block now, so that S_new_logop does not try to
8536                fold it away. */
8537             return block;       /* do {} while 0 does once */
8538         if (expr->op_type == OP_READLINE
8539             || expr->op_type == OP_READDIR
8540             || expr->op_type == OP_GLOB
8541             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8542             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8543             expr = newUNOP(OP_DEFINED, 0,
8544                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8545         } else if (expr->op_flags & OPf_KIDS) {
8546             const OP * const k1 = ((UNOP*)expr)->op_first;
8547             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8548             switch (expr->op_type) {
8549               case OP_NULL:
8550                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8551                       && (k2->op_flags & OPf_STACKED)
8552                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8553                     expr = newUNOP(OP_DEFINED, 0, expr);
8554                 break;
8555
8556               case OP_SASSIGN:
8557                 if (k1 && (k1->op_type == OP_READDIR
8558                       || k1->op_type == OP_GLOB
8559                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8560                      || k1->op_type == OP_EACH
8561                      || k1->op_type == OP_AEACH))
8562                     expr = newUNOP(OP_DEFINED, 0, expr);
8563                 break;
8564             }
8565         }
8566     }
8567
8568     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8569      * op, in listop. This is wrong. [perl #27024] */
8570     if (!block)
8571         block = newOP(OP_NULL, 0);
8572     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8573     o = new_logop(OP_AND, 0, &expr, &listop);
8574
8575     if (once) {
8576         ASSUME(listop);
8577     }
8578
8579     if (listop)
8580         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8581
8582     if (once && o != listop)
8583     {
8584         assert(cUNOPo->op_first->op_type == OP_AND
8585             || cUNOPo->op_first->op_type == OP_OR);
8586         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8587     }
8588
8589     if (o == listop)
8590         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8591
8592     o->op_flags |= flags;
8593     o = op_scope(o);
8594     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8595     return o;
8596 }
8597
8598 /*
8599 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8600
8601 Constructs, checks, and returns an op tree expressing a C<while> loop.
8602 This is a heavyweight loop, with structure that allows exiting the loop
8603 by C<last> and suchlike.
8604
8605 C<loop> is an optional preconstructed C<enterloop> op to use in the
8606 loop; if it is null then a suitable op will be constructed automatically.
8607 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8608 main body of the loop, and C<cont> optionally supplies a C<continue> block
8609 that operates as a second half of the body.  All of these optree inputs
8610 are consumed by this function and become part of the constructed op tree.
8611
8612 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8613 op and, shifted up eight bits, the eight bits of C<op_private> for
8614 the C<leaveloop> op, except that (in both cases) some bits will be set
8615 automatically.  C<debuggable> is currently unused and should always be 1.
8616 C<has_my> can be supplied as true to force the
8617 loop body to be enclosed in its own scope.
8618
8619 =cut
8620 */
8621
8622 OP *
8623 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8624         OP *expr, OP *block, OP *cont, I32 has_my)
8625 {
8626     dVAR;
8627     OP *redo;
8628     OP *next = NULL;
8629     OP *listop;
8630     OP *o;
8631     U8 loopflags = 0;
8632
8633     PERL_UNUSED_ARG(debuggable);
8634
8635     if (expr) {
8636         if (expr->op_type == OP_READLINE
8637          || expr->op_type == OP_READDIR
8638          || expr->op_type == OP_GLOB
8639          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8640                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8641             expr = newUNOP(OP_DEFINED, 0,
8642                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8643         } else if (expr->op_flags & OPf_KIDS) {
8644             const OP * const k1 = ((UNOP*)expr)->op_first;
8645             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8646             switch (expr->op_type) {
8647               case OP_NULL:
8648                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8649                       && (k2->op_flags & OPf_STACKED)
8650                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8651                     expr = newUNOP(OP_DEFINED, 0, expr);
8652                 break;
8653
8654               case OP_SASSIGN:
8655                 if (k1 && (k1->op_type == OP_READDIR
8656                       || k1->op_type == OP_GLOB
8657                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8658                      || k1->op_type == OP_EACH
8659                      || k1->op_type == OP_AEACH))
8660                     expr = newUNOP(OP_DEFINED, 0, expr);
8661                 break;
8662             }
8663         }
8664     }
8665
8666     if (!block)
8667         block = newOP(OP_NULL, 0);
8668     else if (cont || has_my) {
8669         block = op_scope(block);
8670     }
8671
8672     if (cont) {
8673         next = LINKLIST(cont);
8674     }
8675     if (expr) {
8676         OP * const unstack = newOP(OP_UNSTACK, 0);
8677         if (!next)
8678             next = unstack;
8679         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8680     }
8681
8682     assert(block);
8683     listop = op_append_list(OP_LINESEQ, block, cont);
8684     assert(listop);
8685     redo = LINKLIST(listop);
8686
8687     if (expr) {
8688         scalar(listop);
8689         o = new_logop(OP_AND, 0, &expr, &listop);
8690         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8691             op_free((OP*)loop);
8692             return expr;                /* listop already freed by new_logop */
8693         }
8694         if (listop)
8695             ((LISTOP*)listop)->op_last->op_next =
8696                 (o == listop ? redo : LINKLIST(o));
8697     }
8698     else
8699         o = listop;
8700
8701     if (!loop) {
8702         NewOp(1101,loop,1,LOOP);
8703         OpTYPE_set(loop, OP_ENTERLOOP);
8704         loop->op_private = 0;
8705         loop->op_next = (OP*)loop;
8706     }
8707
8708     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8709
8710     loop->op_redoop = redo;
8711     loop->op_lastop = o;
8712     o->op_private |= loopflags;
8713
8714     if (next)
8715         loop->op_nextop = next;
8716     else
8717         loop->op_nextop = o;
8718
8719     o->op_flags |= flags;
8720     o->op_private |= (flags >> 8);
8721     return o;
8722 }
8723
8724 /*
8725 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8726
8727 Constructs, checks, and returns an op tree expressing a C<foreach>
8728 loop (iteration through a list of values).  This is a heavyweight loop,
8729 with structure that allows exiting the loop by C<last> and suchlike.
8730
8731 C<sv> optionally supplies the variable that will be aliased to each
8732 item in turn; if null, it defaults to C<$_>.
8733 C<expr> supplies the list of values to iterate over.  C<block> supplies
8734 the main body of the loop, and C<cont> optionally supplies a C<continue>
8735 block that operates as a second half of the body.  All of these optree
8736 inputs are consumed by this function and become part of the constructed
8737 op tree.
8738
8739 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8740 op and, shifted up eight bits, the eight bits of C<op_private> for
8741 the C<leaveloop> op, except that (in both cases) some bits will be set
8742 automatically.
8743
8744 =cut
8745 */
8746
8747 OP *
8748 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8749 {
8750     dVAR;
8751     LOOP *loop;
8752     OP *wop;
8753     PADOFFSET padoff = 0;
8754     I32 iterflags = 0;
8755     I32 iterpflags = 0;
8756
8757     PERL_ARGS_ASSERT_NEWFOROP;
8758
8759     if (sv) {
8760         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8761             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8762             OpTYPE_set(sv, OP_RV2GV);
8763
8764             /* The op_type check is needed to prevent a possible segfault
8765              * if the loop variable is undeclared and 'strict vars' is in
8766              * effect. This is illegal but is nonetheless parsed, so we
8767              * may reach this point with an OP_CONST where we're expecting
8768              * an OP_GV.
8769              */
8770             if (cUNOPx(sv)->op_first->op_type == OP_GV
8771              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8772                 iterpflags |= OPpITER_DEF;
8773         }
8774         else if (sv->op_type == OP_PADSV) { /* private variable */
8775             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8776             padoff = sv->op_targ;
8777             sv->op_targ = 0;
8778             op_free(sv);
8779             sv = NULL;
8780             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8781         }
8782         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8783             NOOP;
8784         else
8785             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8786         if (padoff) {
8787             PADNAME * const pn = PAD_COMPNAME(padoff);
8788             const char * const name = PadnamePV(pn);
8789
8790             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8791                 iterpflags |= OPpITER_DEF;
8792         }
8793     }
8794     else {
8795         sv = newGVOP(OP_GV, 0, PL_defgv);
8796         iterpflags |= OPpITER_DEF;
8797     }
8798
8799     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8800         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8801         iterflags |= OPf_STACKED;
8802     }
8803     else if (expr->op_type == OP_NULL &&
8804              (expr->op_flags & OPf_KIDS) &&
8805              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8806     {
8807         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8808          * set the STACKED flag to indicate that these values are to be
8809          * treated as min/max values by 'pp_enteriter'.
8810          */
8811         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8812         LOGOP* const range = (LOGOP*) flip->op_first;
8813         OP* const left  = range->op_first;
8814         OP* const right = OpSIBLING(left);
8815         LISTOP* listop;
8816
8817         range->op_flags &= ~OPf_KIDS;
8818         /* detach range's children */
8819         op_sibling_splice((OP*)range, NULL, -1, NULL);
8820
8821         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8822         listop->op_first->op_next = range->op_next;
8823         left->op_next = range->op_other;
8824         right->op_next = (OP*)listop;
8825         listop->op_next = listop->op_first;
8826
8827         op_free(expr);
8828         expr = (OP*)(listop);
8829         op_null(expr);
8830         iterflags |= OPf_STACKED;
8831     }
8832     else {
8833         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8834     }
8835
8836     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8837                                   op_append_elem(OP_LIST, list(expr),
8838                                                  scalar(sv)));
8839     assert(!loop->op_next);
8840     /* for my  $x () sets OPpLVAL_INTRO;
8841      * for our $x () sets OPpOUR_INTRO */
8842     loop->op_private = (U8)iterpflags;
8843     if (loop->op_slabbed
8844      && DIFF(loop, OpSLOT(loop)->opslot_next)
8845          < SIZE_TO_PSIZE(sizeof(LOOP)))
8846     {
8847         LOOP *tmp;
8848         NewOp(1234,tmp,1,LOOP);
8849         Copy(loop,tmp,1,LISTOP);
8850 #ifdef PERL_OP_PARENT
8851         assert(loop->op_last->op_sibparent == (OP*)loop);
8852         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8853 #endif
8854         S_op_destroy(aTHX_ (OP*)loop);
8855         loop = tmp;
8856     }
8857     else if (!loop->op_slabbed)
8858     {
8859         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8860 #ifdef PERL_OP_PARENT
8861         OpLASTSIB_set(loop->op_last, (OP*)loop);
8862 #endif
8863     }
8864     loop->op_targ = padoff;
8865     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8866     return wop;
8867 }
8868
8869 /*
8870 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8871
8872 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8873 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8874 determining the target of the op; it is consumed by this function and
8875 becomes part of the constructed op tree.
8876
8877 =cut
8878 */
8879
8880 OP*
8881 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8882 {
8883     OP *o = NULL;
8884
8885     PERL_ARGS_ASSERT_NEWLOOPEX;
8886
8887     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8888         || type == OP_CUSTOM);
8889
8890     if (type != OP_GOTO) {
8891         /* "last()" means "last" */
8892         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8893             o = newOP(type, OPf_SPECIAL);
8894         }
8895     }
8896     else {
8897         /* Check whether it's going to be a goto &function */
8898         if (label->op_type == OP_ENTERSUB
8899                 && !(label->op_flags & OPf_STACKED))
8900             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8901     }
8902
8903     /* Check for a constant argument */
8904     if (label->op_type == OP_CONST) {
8905             SV * const sv = ((SVOP *)label)->op_sv;
8906             STRLEN l;
8907             const char *s = SvPV_const(sv,l);
8908             if (l == strlen(s)) {
8909                 o = newPVOP(type,
8910                             SvUTF8(((SVOP*)label)->op_sv),
8911                             savesharedpv(
8912                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8913             }
8914     }
8915
8916     /* If we have already created an op, we do not need the label. */
8917     if (o)
8918                 op_free(label);
8919     else o = newUNOP(type, OPf_STACKED, label);
8920
8921     PL_hints |= HINT_BLOCK_SCOPE;
8922     return o;
8923 }
8924
8925 /* if the condition is a literal array or hash
8926    (or @{ ... } etc), make a reference to it.
8927  */
8928 STATIC OP *
8929 S_ref_array_or_hash(pTHX_ OP *cond)
8930 {
8931     if (cond
8932     && (cond->op_type == OP_RV2AV
8933     ||  cond->op_type == OP_PADAV
8934     ||  cond->op_type == OP_RV2HV
8935     ||  cond->op_type == OP_PADHV))
8936
8937         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8938
8939     else if(cond
8940     && (cond->op_type == OP_ASLICE
8941     ||  cond->op_type == OP_KVASLICE
8942     ||  cond->op_type == OP_HSLICE
8943     ||  cond->op_type == OP_KVHSLICE)) {
8944
8945         /* anonlist now needs a list from this op, was previously used in
8946          * scalar context */
8947         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8948         cond->op_flags |= OPf_WANT_LIST;
8949
8950         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8951     }
8952
8953     else
8954         return cond;
8955 }
8956
8957 /* These construct the optree fragments representing given()
8958    and when() blocks.
8959
8960    entergiven and enterwhen are LOGOPs; the op_other pointer
8961    points up to the associated leave op. We need this so we
8962    can put it in the context and make break/continue work.
8963    (Also, of course, pp_enterwhen will jump straight to
8964    op_other if the match fails.)
8965  */
8966
8967 STATIC OP *
8968 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8969                    I32 enter_opcode, I32 leave_opcode,
8970                    PADOFFSET entertarg)
8971 {
8972     dVAR;
8973     LOGOP *enterop;
8974     OP *o;
8975
8976     PERL_ARGS_ASSERT_NEWGIVWHENOP;
8977     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8978
8979     enterop = alloc_LOGOP(enter_opcode, block, NULL);
8980     enterop->op_targ = 0;
8981     enterop->op_private = 0;
8982
8983     o = newUNOP(leave_opcode, 0, (OP *) enterop);
8984
8985     if (cond) {
8986         /* prepend cond if we have one */
8987         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8988
8989         o->op_next = LINKLIST(cond);
8990         cond->op_next = (OP *) enterop;
8991     }
8992     else {
8993         /* This is a default {} block */
8994         enterop->op_flags |= OPf_SPECIAL;
8995         o      ->op_flags |= OPf_SPECIAL;
8996
8997         o->op_next = (OP *) enterop;
8998     }
8999
9000     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9001                                        entergiven and enterwhen both
9002                                        use ck_null() */
9003
9004     enterop->op_next = LINKLIST(block);
9005     block->op_next = enterop->op_other = o;
9006
9007     return o;
9008 }
9009
9010 /* Does this look like a boolean operation? For these purposes
9011    a boolean operation is:
9012      - a subroutine call [*]
9013      - a logical connective
9014      - a comparison operator
9015      - a filetest operator, with the exception of -s -M -A -C
9016      - defined(), exists() or eof()
9017      - /$re/ or $foo =~ /$re/
9018
9019    [*] possibly surprising
9020  */
9021 STATIC bool
9022 S_looks_like_bool(pTHX_ const OP *o)
9023 {
9024     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9025
9026     switch(o->op_type) {
9027         case OP_OR:
9028         case OP_DOR:
9029             return looks_like_bool(cLOGOPo->op_first);
9030
9031         case OP_AND:
9032         {
9033             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9034             ASSUME(sibl);
9035             return (
9036                 looks_like_bool(cLOGOPo->op_first)
9037              && looks_like_bool(sibl));
9038         }
9039
9040         case OP_NULL:
9041         case OP_SCALAR:
9042             return (
9043                 o->op_flags & OPf_KIDS
9044             && looks_like_bool(cUNOPo->op_first));
9045
9046         case OP_ENTERSUB:
9047
9048         case OP_NOT:    case OP_XOR:
9049
9050         case OP_EQ:     case OP_NE:     case OP_LT:
9051         case OP_GT:     case OP_LE:     case OP_GE:
9052
9053         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9054         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9055
9056         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9057         case OP_SGT:    case OP_SLE:    case OP_SGE:
9058
9059         case OP_SMARTMATCH:
9060
9061         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9062         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9063         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9064         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9065         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9066         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9067         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9068         case OP_FTTEXT:   case OP_FTBINARY:
9069
9070         case OP_DEFINED: case OP_EXISTS:
9071         case OP_MATCH:   case OP_EOF:
9072
9073         case OP_FLOP:
9074
9075             return TRUE;
9076
9077         case OP_CONST:
9078             /* Detect comparisons that have been optimized away */
9079             if (cSVOPo->op_sv == &PL_sv_yes
9080             ||  cSVOPo->op_sv == &PL_sv_no)
9081
9082                 return TRUE;
9083             else
9084                 return FALSE;
9085
9086         /* FALLTHROUGH */
9087         default:
9088             return FALSE;
9089     }
9090 }
9091
9092 /*
9093 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9094
9095 Constructs, checks, and returns an op tree expressing a C<given> block.
9096 C<cond> supplies the expression to whose value C<$_> will be locally
9097 aliased, and C<block> supplies the body of the C<given> construct; they
9098 are consumed by this function and become part of the constructed op tree.
9099 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9100
9101 =cut
9102 */
9103
9104 OP *
9105 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9106 {
9107     PERL_ARGS_ASSERT_NEWGIVENOP;
9108     PERL_UNUSED_ARG(defsv_off);
9109
9110     assert(!defsv_off);
9111     return newGIVWHENOP(
9112         ref_array_or_hash(cond),
9113         block,
9114         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9115         0);
9116 }
9117
9118 /*
9119 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9120
9121 Constructs, checks, and returns an op tree expressing a C<when> block.
9122 C<cond> supplies the test expression, and C<block> supplies the block
9123 that will be executed if the test evaluates to true; they are consumed
9124 by this function and become part of the constructed op tree.  C<cond>
9125 will be interpreted DWIMically, often as a comparison against C<$_>,
9126 and may be null to generate a C<default> block.
9127
9128 =cut
9129 */
9130
9131 OP *
9132 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9133 {
9134     const bool cond_llb = (!cond || looks_like_bool(cond));
9135     OP *cond_op;
9136
9137     PERL_ARGS_ASSERT_NEWWHENOP;
9138
9139     if (cond_llb)
9140         cond_op = cond;
9141     else {
9142         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9143                 newDEFSVOP(),
9144                 scalar(ref_array_or_hash(cond)));
9145     }
9146
9147     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9148 }
9149
9150 /* must not conflict with SVf_UTF8 */
9151 #define CV_CKPROTO_CURSTASH     0x1
9152
9153 void
9154 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9155                     const STRLEN len, const U32 flags)
9156 {
9157     SV *name = NULL, *msg;
9158     const char * cvp = SvROK(cv)
9159                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9160                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9161                            : ""
9162                         : CvPROTO(cv);
9163     STRLEN clen = CvPROTOLEN(cv), plen = len;
9164
9165     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9166
9167     if (p == NULL && cvp == NULL)
9168         return;
9169
9170     if (!ckWARN_d(WARN_PROTOTYPE))
9171         return;
9172
9173     if (p && cvp) {
9174         p = S_strip_spaces(aTHX_ p, &plen);
9175         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9176         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9177             if (plen == clen && memEQ(cvp, p, plen))
9178                 return;
9179         } else {
9180             if (flags & SVf_UTF8) {
9181                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9182                     return;
9183             }
9184             else {
9185                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9186                     return;
9187             }
9188         }
9189     }
9190
9191     msg = sv_newmortal();
9192
9193     if (gv)
9194     {
9195         if (isGV(gv))
9196             gv_efullname3(name = sv_newmortal(), gv, NULL);
9197         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9198             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9199         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9200             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9201             sv_catpvs(name, "::");
9202             if (SvROK(gv)) {
9203                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9204                 assert (CvNAMED(SvRV_const(gv)));
9205                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9206             }
9207             else sv_catsv(name, (SV *)gv);
9208         }
9209         else name = (SV *)gv;
9210     }
9211     sv_setpvs(msg, "Prototype mismatch:");
9212     if (name)
9213         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9214     if (cvp)
9215         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9216             UTF8fARG(SvUTF8(cv),clen,cvp)
9217         );
9218     else
9219         sv_catpvs(msg, ": none");
9220     sv_catpvs(msg, " vs ");
9221     if (p)
9222         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9223     else
9224         sv_catpvs(msg, "none");
9225     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9226 }
9227
9228 static void const_sv_xsub(pTHX_ CV* cv);
9229 static void const_av_xsub(pTHX_ CV* cv);
9230
9231 /*
9232
9233 =head1 Optree Manipulation Functions
9234
9235 =for apidoc cv_const_sv
9236
9237 If C<cv> is a constant sub eligible for inlining, returns the constant
9238 value returned by the sub.  Otherwise, returns C<NULL>.
9239
9240 Constant subs can be created with C<newCONSTSUB> or as described in
9241 L<perlsub/"Constant Functions">.
9242
9243 =cut
9244 */
9245 SV *
9246 Perl_cv_const_sv(const CV *const cv)
9247 {
9248     SV *sv;
9249     if (!cv)
9250         return NULL;
9251     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9252         return NULL;
9253     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9254     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9255     return sv;
9256 }
9257
9258 SV *
9259 Perl_cv_const_sv_or_av(const CV * const cv)
9260 {
9261     if (!cv)
9262         return NULL;
9263     if (SvROK(cv)) return SvRV((SV *)cv);
9264     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9265     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9266 }
9267
9268 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9269  * Can be called in 2 ways:
9270  *
9271  * !allow_lex
9272  *      look for a single OP_CONST with attached value: return the value
9273  *
9274  * allow_lex && !CvCONST(cv);
9275  *
9276  *      examine the clone prototype, and if contains only a single
9277  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9278  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9279  *      a candidate for "constizing" at clone time, and return NULL.
9280  */
9281
9282 static SV *
9283 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9284 {
9285     SV *sv = NULL;
9286     bool padsv = FALSE;
9287
9288     assert(o);
9289     assert(cv);
9290
9291     for (; o; o = o->op_next) {
9292         const OPCODE type = o->op_type;
9293
9294         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9295              || type == OP_NULL
9296              || type == OP_PUSHMARK)
9297                 continue;
9298         if (type == OP_DBSTATE)
9299                 continue;
9300         if (type == OP_LEAVESUB)
9301             break;
9302         if (sv)
9303             return NULL;
9304         if (type == OP_CONST && cSVOPo->op_sv)
9305             sv = cSVOPo->op_sv;
9306         else if (type == OP_UNDEF && !o->op_private) {
9307             sv = newSV(0);
9308             SAVEFREESV(sv);
9309         }
9310         else if (allow_lex && type == OP_PADSV) {
9311                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9312                 {
9313                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9314                     padsv = TRUE;
9315                 }
9316                 else
9317                     return NULL;
9318         }
9319         else {
9320             return NULL;
9321         }
9322     }
9323     if (padsv) {
9324         CvCONST_on(cv);
9325         return NULL;
9326     }
9327     return sv;
9328 }
9329
9330 static void
9331 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9332                         PADNAME * const name, SV ** const const_svp)
9333 {
9334     assert (cv);
9335     assert (o || name);
9336     assert (const_svp);
9337     if (!block) {
9338         if (CvFLAGS(PL_compcv)) {
9339             /* might have had built-in attrs applied */
9340             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9341             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9342              && ckWARN(WARN_MISC))
9343             {
9344                 /* protect against fatal warnings leaking compcv */
9345                 SAVEFREESV(PL_compcv);
9346                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9347                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9348             }
9349             CvFLAGS(cv) |=
9350                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9351                   & ~(CVf_LVALUE * pureperl));
9352         }
9353         return;
9354     }
9355
9356     /* redundant check for speed: */
9357     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9358         const line_t oldline = CopLINE(PL_curcop);
9359         SV *namesv = o
9360             ? cSVOPo->op_sv
9361             : sv_2mortal(newSVpvn_utf8(
9362                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9363               ));
9364         if (PL_parser && PL_parser->copline != NOLINE)
9365             /* This ensures that warnings are reported at the first
9366                line of a redefinition, not the last.  */
9367             CopLINE_set(PL_curcop, PL_parser->copline);
9368         /* protect against fatal warnings leaking compcv */
9369         SAVEFREESV(PL_compcv);
9370         report_redefined_cv(namesv, cv, const_svp);
9371         SvREFCNT_inc_simple_void_NN(PL_compcv);
9372         CopLINE_set(PL_curcop, oldline);
9373     }
9374     SAVEFREESV(cv);
9375     return;
9376 }
9377
9378 CV *
9379 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9380 {
9381     CV **spot;
9382     SV **svspot;
9383     const char *ps;
9384     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9385     U32 ps_utf8 = 0;
9386     CV *cv = NULL;
9387     CV *compcv = PL_compcv;
9388     SV *const_sv;
9389     PADNAME *name;
9390     PADOFFSET pax = o->op_targ;
9391     CV *outcv = CvOUTSIDE(PL_compcv);
9392     CV *clonee = NULL;
9393     HEK *hek = NULL;
9394     bool reusable = FALSE;
9395     OP *start = NULL;
9396 #ifdef PERL_DEBUG_READONLY_OPS
9397     OPSLAB *slab = NULL;
9398 #endif
9399
9400     PERL_ARGS_ASSERT_NEWMYSUB;
9401
9402     PL_hints |= HINT_BLOCK_SCOPE;
9403
9404     /* Find the pad slot for storing the new sub.
9405        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9406        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9407        ing sub.  And then we need to dig deeper if this is a lexical from
9408        outside, as in:
9409            my sub foo; sub { sub foo { } }
9410      */
9411   redo:
9412     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9413     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9414         pax = PARENT_PAD_INDEX(name);
9415         outcv = CvOUTSIDE(outcv);
9416         assert(outcv);
9417         goto redo;
9418     }
9419     svspot =
9420         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9421                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9422     spot = (CV **)svspot;
9423
9424     if (!(PL_parser && PL_parser->error_count))
9425         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9426
9427     if (proto) {
9428         assert(proto->op_type == OP_CONST);
9429         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9430         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9431     }
9432     else
9433         ps = NULL;
9434
9435     if (proto)
9436         SAVEFREEOP(proto);
9437     if (attrs)
9438         SAVEFREEOP(attrs);
9439
9440     if (PL_parser && PL_parser->error_count) {
9441         op_free(block);
9442         SvREFCNT_dec(PL_compcv);
9443         PL_compcv = 0;
9444         goto done;
9445     }
9446
9447     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9448         cv = *spot;
9449         svspot = (SV **)(spot = &clonee);
9450     }
9451     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9452         cv = *spot;
9453     else {
9454         assert (SvTYPE(*spot) == SVt_PVCV);
9455         if (CvNAMED(*spot))
9456             hek = CvNAME_HEK(*spot);
9457         else {
9458             dVAR;
9459             U32 hash;
9460             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9461             CvNAME_HEK_set(*spot, hek =
9462                 share_hek(
9463                     PadnamePV(name)+1,
9464                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9465                     hash
9466                 )
9467             );
9468             CvLEXICAL_on(*spot);
9469         }
9470         cv = PadnamePROTOCV(name);
9471         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9472     }
9473
9474     if (block) {
9475         /* This makes sub {}; work as expected.  */
9476         if (block->op_type == OP_STUB) {
9477             const line_t l = PL_parser->copline;
9478             op_free(block);
9479             block = newSTATEOP(0, NULL, 0);
9480             PL_parser->copline = l;
9481         }
9482         block = CvLVALUE(compcv)
9483              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9484                    ? newUNOP(OP_LEAVESUBLV, 0,
9485                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9486                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9487         start = LINKLIST(block);
9488         block->op_next = 0;
9489         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9490             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9491         else
9492             const_sv = NULL;
9493     }
9494     else
9495         const_sv = NULL;
9496
9497     if (cv) {
9498         const bool exists = CvROOT(cv) || CvXSUB(cv);
9499
9500         /* if the subroutine doesn't exist and wasn't pre-declared
9501          * with a prototype, assume it will be AUTOLOADed,
9502          * skipping the prototype check
9503          */
9504         if (exists || SvPOK(cv))
9505             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9506                                  ps_utf8);
9507         /* already defined? */
9508         if (exists) {
9509             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9510             if (block)
9511                 cv = NULL;
9512             else {
9513                 if (attrs)
9514                     goto attrs;
9515                 /* just a "sub foo;" when &foo is already defined */
9516                 SAVEFREESV(compcv);
9517                 goto done;
9518             }
9519         }
9520         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9521             cv = NULL;
9522             reusable = TRUE;
9523         }
9524     }
9525
9526     if (const_sv) {
9527         SvREFCNT_inc_simple_void_NN(const_sv);
9528         SvFLAGS(const_sv) |= SVs_PADTMP;
9529         if (cv) {
9530             assert(!CvROOT(cv) && !CvCONST(cv));
9531             cv_forget_slab(cv);
9532         }
9533         else {
9534             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9535             CvFILE_set_from_cop(cv, PL_curcop);
9536             CvSTASH_set(cv, PL_curstash);
9537             *spot = cv;
9538         }
9539         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9540         CvXSUBANY(cv).any_ptr = const_sv;
9541         CvXSUB(cv) = const_sv_xsub;
9542         CvCONST_on(cv);
9543         CvISXSUB_on(cv);
9544         PoisonPADLIST(cv);
9545         CvFLAGS(cv) |= CvMETHOD(compcv);
9546         op_free(block);
9547         SvREFCNT_dec(compcv);
9548         PL_compcv = NULL;
9549         goto setname;
9550     }
9551
9552     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9553        determine whether this sub definition is in the same scope as its
9554        declaration.  If this sub definition is inside an inner named pack-
9555        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9556        the package sub.  So check PadnameOUTER(name) too.
9557      */
9558     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9559         assert(!CvWEAKOUTSIDE(compcv));
9560         SvREFCNT_dec(CvOUTSIDE(compcv));
9561         CvWEAKOUTSIDE_on(compcv);
9562     }
9563     /* XXX else do we have a circular reference? */
9564
9565     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9566         /* transfer PL_compcv to cv */
9567         if (block) {
9568             cv_flags_t preserved_flags =
9569                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9570             PADLIST *const temp_padl = CvPADLIST(cv);
9571             CV *const temp_cv = CvOUTSIDE(cv);
9572             const cv_flags_t other_flags =
9573                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9574             OP * const cvstart = CvSTART(cv);
9575
9576             SvPOK_off(cv);
9577             CvFLAGS(cv) =
9578                 CvFLAGS(compcv) | preserved_flags;
9579             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9580             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9581             CvPADLIST_set(cv, CvPADLIST(compcv));
9582             CvOUTSIDE(compcv) = temp_cv;
9583             CvPADLIST_set(compcv, temp_padl);
9584             CvSTART(cv) = CvSTART(compcv);
9585             CvSTART(compcv) = cvstart;
9586             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9587             CvFLAGS(compcv) |= other_flags;
9588
9589             if (CvFILE(cv) && CvDYNFILE(cv)) {
9590                 Safefree(CvFILE(cv));
9591             }
9592
9593             /* inner references to compcv must be fixed up ... */
9594             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9595             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9596                 ++PL_sub_generation;
9597         }
9598         else {
9599             /* Might have had built-in attributes applied -- propagate them. */
9600             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9601         }
9602         /* ... before we throw it away */
9603         SvREFCNT_dec(compcv);
9604         PL_compcv = compcv = cv;
9605     }
9606     else {
9607         cv = compcv;
9608         *spot = cv;
9609     }
9610
9611   setname:
9612     CvLEXICAL_on(cv);
9613     if (!CvNAME_HEK(cv)) {
9614         if (hek) (void)share_hek_hek(hek);
9615         else {
9616             dVAR;
9617             U32 hash;
9618             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9619             hek = share_hek(PadnamePV(name)+1,
9620                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9621                       hash);
9622         }
9623         CvNAME_HEK_set(cv, hek);
9624     }
9625
9626     if (const_sv)
9627         goto clone;
9628
9629     CvFILE_set_from_cop(cv, PL_curcop);
9630     CvSTASH_set(cv, PL_curstash);
9631
9632     if (ps) {
9633         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9634         if (ps_utf8)
9635             SvUTF8_on(MUTABLE_SV(cv));
9636     }
9637
9638     if (block) {
9639         /* If we assign an optree to a PVCV, then we've defined a
9640          * subroutine that the debugger could be able to set a breakpoint
9641          * in, so signal to pp_entereval that it should not throw away any
9642          * saved lines at scope exit.  */
9643
9644         PL_breakable_sub_gen++;
9645         CvROOT(cv) = block;
9646         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9647            itself has a refcount. */
9648         CvSLABBED_off(cv);
9649         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9650 #ifdef PERL_DEBUG_READONLY_OPS
9651         slab = (OPSLAB *)CvSTART(cv);
9652 #endif
9653         S_process_optree(aTHX_ cv, block, start);
9654     }
9655
9656   attrs:
9657     if (attrs) {
9658         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9659         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9660     }
9661
9662     if (block) {
9663         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9664             SV * const tmpstr = sv_newmortal();
9665             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9666                                                   GV_ADDMULTI, SVt_PVHV);
9667             HV *hv;
9668             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9669                                           CopFILE(PL_curcop),
9670                                           (long)PL_subline,
9671                                           (long)CopLINE(PL_curcop));
9672             if (HvNAME_HEK(PL_curstash)) {
9673                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9674                 sv_catpvs(tmpstr, "::");
9675             }
9676             else
9677                 sv_setpvs(tmpstr, "__ANON__::");
9678
9679             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9680                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9681             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9682                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9683             hv = GvHVn(db_postponed);
9684             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9685                 CV * const pcv = GvCV(db_postponed);
9686                 if (pcv) {
9687                     dSP;
9688                     PUSHMARK(SP);
9689                     XPUSHs(tmpstr);
9690                     PUTBACK;
9691                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9692                 }
9693             }
9694         }
9695     }
9696
9697   clone:
9698     if (clonee) {
9699         assert(CvDEPTH(outcv));
9700         spot = (CV **)
9701             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9702         if (reusable)
9703             cv_clone_into(clonee, *spot);
9704         else *spot = cv_clone(clonee);
9705         SvREFCNT_dec_NN(clonee);
9706         cv = *spot;
9707     }
9708
9709     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9710         PADOFFSET depth = CvDEPTH(outcv);
9711         while (--depth) {
9712             SV *oldcv;
9713             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9714             oldcv = *svspot;
9715             *svspot = SvREFCNT_inc_simple_NN(cv);
9716             SvREFCNT_dec(oldcv);
9717         }
9718     }
9719
9720   done:
9721     if (PL_parser)
9722         PL_parser->copline = NOLINE;
9723     LEAVE_SCOPE(floor);
9724 #ifdef PERL_DEBUG_READONLY_OPS
9725     if (slab)
9726         Slab_to_ro(slab);
9727 #endif
9728     op_free(o);
9729     return cv;
9730 }
9731
9732 /*
9733 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9734
9735 Construct a Perl subroutine, also performing some surrounding jobs.
9736
9737 This function is expected to be called in a Perl compilation context,
9738 and some aspects of the subroutine are taken from global variables
9739 associated with compilation.  In particular, C<PL_compcv> represents
9740 the subroutine that is currently being compiled.  It must be non-null
9741 when this function is called, and some aspects of the subroutine being
9742 constructed are taken from it.  The constructed subroutine may actually
9743 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9744
9745 If C<block> is null then the subroutine will have no body, and for the
9746 time being it will be an error to call it.  This represents a forward
9747 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9748 non-null then it provides the Perl code of the subroutine body, which
9749 will be executed when the subroutine is called.  This body includes
9750 any argument unwrapping code resulting from a subroutine signature or
9751 similar.  The pad use of the code must correspond to the pad attached
9752 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9753 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9754 by this function and will become part of the constructed subroutine.
9755
9756 C<proto> specifies the subroutine's prototype, unless one is supplied
9757 as an attribute (see below).  If C<proto> is null, then the subroutine
9758 will not have a prototype.  If C<proto> is non-null, it must point to a
9759 C<const> op whose value is a string, and the subroutine will have that
9760 string as its prototype.  If a prototype is supplied as an attribute, the
9761 attribute takes precedence over C<proto>, but in that case C<proto> should
9762 preferably be null.  In any case, C<proto> is consumed by this function.
9763
9764 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9765 attributes take effect by built-in means, being applied to C<PL_compcv>
9766 immediately when seen.  Other attributes are collected up and attached
9767 to the subroutine by this route.  C<attrs> may be null to supply no
9768 attributes, or point to a C<const> op for a single attribute, or point
9769 to a C<list> op whose children apart from the C<pushmark> are C<const>
9770 ops for one or more attributes.  Each C<const> op must be a string,
9771 giving the attribute name optionally followed by parenthesised arguments,
9772 in the manner in which attributes appear in Perl source.  The attributes
9773 will be applied to the sub by this function.  C<attrs> is consumed by
9774 this function.
9775
9776 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9777 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9778 must point to a C<const> op, which will be consumed by this function,
9779 and its string value supplies a name for the subroutine.  The name may
9780 be qualified or unqualified, and if it is unqualified then a default
9781 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9782 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9783 by which the subroutine will be named.
9784
9785 If there is already a subroutine of the specified name, then the new
9786 sub will either replace the existing one in the glob or be merged with
9787 the existing one.  A warning may be generated about redefinition.
9788
9789 If the subroutine has one of a few special names, such as C<BEGIN> or
9790 C<END>, then it will be claimed by the appropriate queue for automatic
9791 running of phase-related subroutines.  In this case the relevant glob will
9792 be left not containing any subroutine, even if it did contain one before.
9793 In the case of C<BEGIN>, the subroutine will be executed and the reference
9794 to it disposed of before this function returns.
9795
9796 The function returns a pointer to the constructed subroutine.  If the sub
9797 is anonymous then ownership of one counted reference to the subroutine
9798 is transferred to the caller.  If the sub is named then the caller does
9799 not get ownership of a reference.  In most such cases, where the sub
9800 has a non-phase name, the sub will be alive at the point it is returned
9801 by virtue of being contained in the glob that names it.  A phase-named
9802 subroutine will usually be alive by virtue of the reference owned by the
9803 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9804 been executed, will quite likely have been destroyed already by the
9805 time this function returns, making it erroneous for the caller to make
9806 any use of the returned pointer.  It is the caller's responsibility to
9807 ensure that it knows which of these situations applies.
9808
9809 =cut
9810 */
9811
9812 /* _x = extended */
9813 CV *
9814 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9815                             OP *block, bool o_is_gv)
9816 {
9817     GV *gv;
9818     const char *ps;
9819     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9820     U32 ps_utf8 = 0;
9821     CV *cv = NULL;     /* the previous CV with this name, if any */
9822     SV *const_sv;
9823     const bool ec = PL_parser && PL_parser->error_count;
9824     /* If the subroutine has no body, no attributes, and no builtin attributes
9825        then it's just a sub declaration, and we may be able to get away with
9826        storing with a placeholder scalar in the symbol table, rather than a
9827        full CV.  If anything is present then it will take a full CV to
9828        store it.  */
9829     const I32 gv_fetch_flags
9830         = ec ? GV_NOADD_NOINIT :
9831         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9832         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9833     STRLEN namlen = 0;
9834     const char * const name =
9835          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9836     bool has_name;
9837     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9838     bool evanescent = FALSE;
9839     OP *start = NULL;
9840 #ifdef PERL_DEBUG_READONLY_OPS
9841     OPSLAB *slab = NULL;
9842 #endif
9843
9844     if (o_is_gv) {
9845         gv = (GV*)o;
9846         o = NULL;
9847         has_name = TRUE;
9848     } else if (name) {
9849         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9850            hek and CvSTASH pointer together can imply the GV.  If the name
9851            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9852            CvSTASH, so forego the optimisation if we find any.
9853            Also, we may be called from load_module at run time, so
9854            PL_curstash (which sets CvSTASH) may not point to the stash the
9855            sub is stored in.  */
9856         /* XXX This optimization is currently disabled for packages other
9857                than main, since there was too much CPAN breakage.  */
9858         const I32 flags =
9859            ec ? GV_NOADD_NOINIT
9860               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9861                || PL_curstash != PL_defstash
9862                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9863                     ? gv_fetch_flags
9864                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9865         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9866         has_name = TRUE;
9867     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9868         SV * const sv = sv_newmortal();
9869         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9870                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9871                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9872         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9873         has_name = TRUE;
9874     } else if (PL_curstash) {
9875         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9876         has_name = FALSE;
9877     } else {
9878         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9879         has_name = FALSE;
9880     }
9881
9882     if (!ec) {
9883         if (isGV(gv)) {
9884             move_proto_attr(&proto, &attrs, gv, 0);
9885         } else {
9886             assert(cSVOPo);
9887             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9888         }
9889     }
9890
9891     if (proto) {
9892         assert(proto->op_type == OP_CONST);
9893         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9894         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9895     }
9896     else
9897         ps = NULL;
9898
9899     if (o)
9900         SAVEFREEOP(o);
9901     if (proto)
9902         SAVEFREEOP(proto);
9903     if (attrs)
9904         SAVEFREEOP(attrs);
9905
9906     if (ec) {
9907         op_free(block);
9908
9909         if (name)
9910             SvREFCNT_dec(PL_compcv);
9911         else
9912             cv = PL_compcv;
9913
9914         PL_compcv = 0;
9915         if (name && block) {
9916             const char *s = (char *) my_memrchr(name, ':', namlen);
9917             s = s ? s+1 : name;
9918             if (strEQ(s, "BEGIN")) {
9919                 if (PL_in_eval & EVAL_KEEPERR)
9920                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9921                 else {
9922                     SV * const errsv = ERRSV;
9923                     /* force display of errors found but not reported */
9924                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9925                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9926                 }
9927             }
9928         }
9929         goto done;
9930     }
9931
9932     if (!block && SvTYPE(gv) != SVt_PVGV) {
9933         /* If we are not defining a new sub and the existing one is not a
9934            full GV + CV... */
9935         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9936             /* We are applying attributes to an existing sub, so we need it
9937                upgraded if it is a constant.  */
9938             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9939                 gv_init_pvn(gv, PL_curstash, name, namlen,
9940                             SVf_UTF8 * name_is_utf8);
9941         }
9942         else {                  /* Maybe prototype now, and had at maximum
9943                                    a prototype or const/sub ref before.  */
9944             if (SvTYPE(gv) > SVt_NULL) {
9945                 cv_ckproto_len_flags((const CV *)gv,
9946                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9947                                     ps_len, ps_utf8);
9948             }
9949
9950             if (!SvROK(gv)) {
9951                 if (ps) {
9952                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9953                     if (ps_utf8)
9954                         SvUTF8_on(MUTABLE_SV(gv));
9955                 }
9956                 else
9957                     sv_setiv(MUTABLE_SV(gv), -1);
9958             }
9959
9960             SvREFCNT_dec(PL_compcv);
9961             cv = PL_compcv = NULL;
9962             goto done;
9963         }
9964     }
9965
9966     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9967         ? NULL
9968         : isGV(gv)
9969             ? GvCV(gv)
9970             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9971                 ? (CV *)SvRV(gv)
9972                 : NULL;
9973
9974     if (block) {
9975         assert(PL_parser);
9976         /* This makes sub {}; work as expected.  */
9977         if (block->op_type == OP_STUB) {
9978             const line_t l = PL_parser->copline;
9979             op_free(block);
9980             block = newSTATEOP(0, NULL, 0);
9981             PL_parser->copline = l;
9982         }
9983         block = CvLVALUE(PL_compcv)
9984              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9985                     && (!isGV(gv) || !GvASSUMECV(gv)))
9986                    ? newUNOP(OP_LEAVESUBLV, 0,
9987                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9988                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9989         start = LINKLIST(block);
9990         block->op_next = 0;
9991         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9992             const_sv =
9993                 S_op_const_sv(aTHX_ start, PL_compcv,
9994                                         cBOOL(CvCLONE(PL_compcv)));
9995         else
9996             const_sv = NULL;
9997     }
9998     else
9999         const_sv = NULL;
10000
10001     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10002         cv_ckproto_len_flags((const CV *)gv,
10003                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10004                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10005         if (SvROK(gv)) {
10006             /* All the other code for sub redefinition warnings expects the
10007                clobbered sub to be a CV.  Instead of making all those code
10008                paths more complex, just inline the RV version here.  */
10009             const line_t oldline = CopLINE(PL_curcop);
10010             assert(IN_PERL_COMPILETIME);
10011             if (PL_parser && PL_parser->copline != NOLINE)
10012                 /* This ensures that warnings are reported at the first
10013                    line of a redefinition, not the last.  */
10014                 CopLINE_set(PL_curcop, PL_parser->copline);
10015             /* protect against fatal warnings leaking compcv */
10016             SAVEFREESV(PL_compcv);
10017
10018             if (ckWARN(WARN_REDEFINE)
10019              || (  ckWARN_d(WARN_REDEFINE)
10020                 && (  !const_sv || SvRV(gv) == const_sv
10021                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10022                 assert(cSVOPo);
10023                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10024                           "Constant subroutine %" SVf " redefined",
10025                           SVfARG(cSVOPo->op_sv));
10026             }
10027
10028             SvREFCNT_inc_simple_void_NN(PL_compcv);
10029             CopLINE_set(PL_curcop, oldline);
10030             SvREFCNT_dec(SvRV(gv));
10031         }
10032     }
10033
10034     if (cv) {
10035         const bool exists = CvROOT(cv) || CvXSUB(cv);
10036
10037         /* if the subroutine doesn't exist and wasn't pre-declared
10038          * with a prototype, assume it will be AUTOLOADed,
10039          * skipping the prototype check
10040          */
10041         if (exists || SvPOK(cv))
10042             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10043         /* already defined (or promised)? */
10044         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10045             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10046             if (block)
10047                 cv = NULL;
10048             else {
10049                 if (attrs)
10050                     goto attrs;
10051                 /* just a "sub foo;" when &foo is already defined */
10052                 SAVEFREESV(PL_compcv);
10053                 goto done;
10054             }
10055         }
10056     }
10057
10058     if (const_sv) {
10059         SvREFCNT_inc_simple_void_NN(const_sv);
10060         SvFLAGS(const_sv) |= SVs_PADTMP;
10061         if (cv) {
10062             assert(!CvROOT(cv) && !CvCONST(cv));
10063             cv_forget_slab(cv);
10064             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10065             CvXSUBANY(cv).any_ptr = const_sv;
10066             CvXSUB(cv) = const_sv_xsub;
10067             CvCONST_on(cv);
10068             CvISXSUB_on(cv);
10069             PoisonPADLIST(cv);
10070             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10071         }
10072         else {
10073             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10074                 if (name && isGV(gv))
10075                     GvCV_set(gv, NULL);
10076                 cv = newCONSTSUB_flags(
10077                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10078                     const_sv
10079                 );
10080                 assert(cv);
10081                 assert(SvREFCNT((SV*)cv) != 0);
10082                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10083             }
10084             else {
10085                 if (!SvROK(gv)) {
10086                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10087                     prepare_SV_for_RV((SV *)gv);
10088                     SvOK_off((SV *)gv);
10089                     SvROK_on(gv);
10090                 }
10091                 SvRV_set(gv, const_sv);
10092             }
10093         }
10094         op_free(block);
10095         SvREFCNT_dec(PL_compcv);
10096         PL_compcv = NULL;
10097         goto done;
10098     }
10099
10100     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10101     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10102         cv = NULL;
10103
10104     if (cv) {                           /* must reuse cv if autoloaded */
10105         /* transfer PL_compcv to cv */
10106         if (block) {
10107             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10108             PADLIST *const temp_av = CvPADLIST(cv);
10109             CV *const temp_cv = CvOUTSIDE(cv);
10110             const cv_flags_t other_flags =
10111                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10112             OP * const cvstart = CvSTART(cv);
10113
10114             if (isGV(gv)) {
10115                 CvGV_set(cv,gv);
10116                 assert(!CvCVGV_RC(cv));
10117                 assert(CvGV(cv) == gv);
10118             }
10119             else {
10120                 dVAR;
10121                 U32 hash;
10122                 PERL_HASH(hash, name, namlen);
10123                 CvNAME_HEK_set(cv,
10124                                share_hek(name,
10125                                          name_is_utf8
10126                                             ? -(SSize_t)namlen
10127                                             :  (SSize_t)namlen,
10128                                          hash));
10129             }
10130
10131             SvPOK_off(cv);
10132             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10133                                              | CvNAMED(cv);
10134             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10135             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10136             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10137             CvOUTSIDE(PL_compcv) = temp_cv;
10138             CvPADLIST_set(PL_compcv, temp_av);
10139             CvSTART(cv) = CvSTART(PL_compcv);
10140             CvSTART(PL_compcv) = cvstart;
10141             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10142             CvFLAGS(PL_compcv) |= other_flags;
10143
10144             if (CvFILE(cv) && CvDYNFILE(cv)) {
10145                 Safefree(CvFILE(cv));
10146             }
10147             CvFILE_set_from_cop(cv, PL_curcop);
10148             CvSTASH_set(cv, PL_curstash);
10149
10150             /* inner references to PL_compcv must be fixed up ... */
10151             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10152             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10153                 ++PL_sub_generation;
10154         }
10155         else {
10156             /* Might have had built-in attributes applied -- propagate them. */
10157             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10158         }
10159         /* ... before we throw it away */
10160         SvREFCNT_dec(PL_compcv);
10161         PL_compcv = cv;
10162     }
10163     else {
10164         cv = PL_compcv;
10165         if (name && isGV(gv)) {
10166             GvCV_set(gv, cv);
10167             GvCVGEN(gv) = 0;
10168             if (HvENAME_HEK(GvSTASH(gv)))
10169                 /* sub Foo::bar { (shift)+1 } */
10170                 gv_method_changed(gv);
10171         }
10172         else if (name) {
10173             if (!SvROK(gv)) {
10174                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10175                 prepare_SV_for_RV((SV *)gv);
10176                 SvOK_off((SV *)gv);
10177                 SvROK_on(gv);
10178             }
10179             SvRV_set(gv, (SV *)cv);
10180             if (HvENAME_HEK(PL_curstash))
10181                 mro_method_changed_in(PL_curstash);
10182         }
10183     }
10184     assert(cv);
10185     assert(SvREFCNT((SV*)cv) != 0);
10186
10187     if (!CvHASGV(cv)) {
10188         if (isGV(gv))
10189             CvGV_set(cv, gv);
10190         else {
10191             dVAR;
10192             U32 hash;
10193             PERL_HASH(hash, name, namlen);
10194             CvNAME_HEK_set(cv, share_hek(name,
10195                                          name_is_utf8
10196                                             ? -(SSize_t)namlen
10197                                             :  (SSize_t)namlen,
10198                                          hash));
10199         }
10200         CvFILE_set_from_cop(cv, PL_curcop);
10201         CvSTASH_set(cv, PL_curstash);
10202     }
10203
10204     if (ps) {
10205         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10206         if ( ps_utf8 )
10207             SvUTF8_on(MUTABLE_SV(cv));
10208     }
10209
10210     if (block) {
10211         /* If we assign an optree to a PVCV, then we've defined a
10212          * subroutine that the debugger could be able to set a breakpoint
10213          * in, so signal to pp_entereval that it should not throw away any
10214          * saved lines at scope exit.  */
10215
10216         PL_breakable_sub_gen++;
10217         CvROOT(cv) = block;
10218         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10219            itself has a refcount. */
10220         CvSLABBED_off(cv);
10221         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10222 #ifdef PERL_DEBUG_READONLY_OPS
10223         slab = (OPSLAB *)CvSTART(cv);
10224 #endif
10225         S_process_optree(aTHX_ cv, block, start);
10226     }
10227
10228   attrs:
10229     if (attrs) {
10230         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10231         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10232                         ? GvSTASH(CvGV(cv))
10233                         : PL_curstash;
10234         if (!name)
10235             SAVEFREESV(cv);
10236         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10237         if (!name)
10238             SvREFCNT_inc_simple_void_NN(cv);
10239     }
10240
10241     if (block && has_name) {
10242         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10243             SV * const tmpstr = cv_name(cv,NULL,0);
10244             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10245                                                   GV_ADDMULTI, SVt_PVHV);
10246             HV *hv;
10247             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10248                                           CopFILE(PL_curcop),
10249                                           (long)PL_subline,
10250                                           (long)CopLINE(PL_curcop));
10251             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10252                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10253             hv = GvHVn(db_postponed);
10254             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10255                 CV * const pcv = GvCV(db_postponed);
10256                 if (pcv) {
10257                     dSP;
10258                     PUSHMARK(SP);
10259                     XPUSHs(tmpstr);
10260                     PUTBACK;
10261                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10262                 }
10263             }
10264         }
10265
10266         if (name) {
10267             if (PL_parser && PL_parser->error_count)
10268                 clear_special_blocks(name, gv, cv);
10269             else
10270                 evanescent =
10271                     process_special_blocks(floor, name, gv, cv);
10272         }
10273     }
10274     assert(cv);
10275
10276   done:
10277     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10278     if (PL_parser)
10279         PL_parser->copline = NOLINE;
10280     LEAVE_SCOPE(floor);
10281
10282     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10283     if (!evanescent) {
10284 #ifdef PERL_DEBUG_READONLY_OPS
10285     if (slab)
10286         Slab_to_ro(slab);
10287 #endif
10288     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10289         pad_add_weakref(cv);
10290     }
10291     return cv;
10292 }
10293
10294 STATIC void
10295 S_clear_special_blocks(pTHX_ const char *const fullname,
10296                        GV *const gv, CV *const cv) {
10297     const char *colon;
10298     const char *name;
10299
10300     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10301
10302     colon = strrchr(fullname,':');
10303     name = colon ? colon + 1 : fullname;
10304
10305     if ((*name == 'B' && strEQ(name, "BEGIN"))
10306         || (*name == 'E' && strEQ(name, "END"))
10307         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10308         || (*name == 'C' && strEQ(name, "CHECK"))
10309         || (*name == 'I' && strEQ(name, "INIT"))) {
10310         if (!isGV(gv)) {
10311             (void)CvGV(cv);
10312             assert(isGV(gv));
10313         }
10314         GvCV_set(gv, NULL);
10315         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10316     }
10317 }
10318
10319 /* Returns true if the sub has been freed.  */
10320 STATIC bool
10321 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10322                          GV *const gv,
10323                          CV *const cv)
10324 {
10325     const char *const colon = strrchr(fullname,':');
10326     const char *const name = colon ? colon + 1 : fullname;
10327
10328     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10329
10330     if (*name == 'B') {
10331         if (strEQ(name, "BEGIN")) {
10332             const I32 oldscope = PL_scopestack_ix;
10333             dSP;
10334             (void)CvGV(cv);
10335             if (floor) LEAVE_SCOPE(floor);
10336             ENTER;
10337             PUSHSTACKi(PERLSI_REQUIRE);
10338             SAVECOPFILE(&PL_compiling);
10339             SAVECOPLINE(&PL_compiling);
10340             SAVEVPTR(PL_curcop);
10341
10342             DEBUG_x( dump_sub(gv) );
10343             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10344             GvCV_set(gv,0);             /* cv has been hijacked */
10345             call_list(oldscope, PL_beginav);
10346
10347             POPSTACK;
10348             LEAVE;
10349             return !PL_savebegin;
10350         }
10351         else
10352             return FALSE;
10353     } else {
10354         if (*name == 'E') {
10355             if strEQ(name, "END") {
10356                 DEBUG_x( dump_sub(gv) );
10357                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10358             } else
10359                 return FALSE;
10360         } else if (*name == 'U') {
10361             if (strEQ(name, "UNITCHECK")) {
10362                 /* It's never too late to run a unitcheck block */
10363                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10364             }
10365             else
10366                 return FALSE;
10367         } else if (*name == 'C') {
10368             if (strEQ(name, "CHECK")) {
10369                 if (PL_main_start)
10370                     /* diag_listed_as: Too late to run %s block */
10371                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10372                                    "Too late to run CHECK block");
10373                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10374             }
10375             else
10376                 return FALSE;
10377         } else if (*name == 'I') {
10378             if (strEQ(name, "INIT")) {
10379                 if (PL_main_start)
10380                     /* diag_listed_as: Too late to run %s block */
10381                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10382                                    "Too late to run INIT block");
10383                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10384             }
10385             else
10386                 return FALSE;
10387         } else
10388             return FALSE;
10389         DEBUG_x( dump_sub(gv) );
10390         (void)CvGV(cv);
10391         GvCV_set(gv,0);         /* cv has been hijacked */
10392         return FALSE;
10393     }
10394 }
10395
10396 /*
10397 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10398
10399 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10400 rather than of counted length, and no flags are set.  (This means that
10401 C<name> is always interpreted as Latin-1.)
10402
10403 =cut
10404 */
10405
10406 CV *
10407 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10408 {
10409     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10410 }
10411
10412 /*
10413 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10414
10415 Construct a constant subroutine, also performing some surrounding
10416 jobs.  A scalar constant-valued subroutine is eligible for inlining
10417 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10418 123 }>>.  Other kinds of constant subroutine have other treatment.
10419
10420 The subroutine will have an empty prototype and will ignore any arguments
10421 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10422 is null, the subroutine will yield an empty list.  If C<sv> points to a
10423 scalar, the subroutine will always yield that scalar.  If C<sv> points
10424 to an array, the subroutine will always yield a list of the elements of
10425 that array in list context, or the number of elements in the array in
10426 scalar context.  This function takes ownership of one counted reference
10427 to the scalar or array, and will arrange for the object to live as long
10428 as the subroutine does.  If C<sv> points to a scalar then the inlining
10429 assumes that the value of the scalar will never change, so the caller
10430 must ensure that the scalar is not subsequently written to.  If C<sv>
10431 points to an array then no such assumption is made, so it is ostensibly
10432 safe to mutate the array or its elements, but whether this is really
10433 supported has not been determined.
10434
10435 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10436 Other aspects of the subroutine will be left in their default state.
10437 The caller is free to mutate the subroutine beyond its initial state
10438 after this function has returned.
10439
10440 If C<name> is null then the subroutine will be anonymous, with its
10441 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10442 subroutine will be named accordingly, referenced by the appropriate glob.
10443 C<name> is a string of length C<len> bytes giving a sigilless symbol
10444 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10445 otherwise.  The name may be either qualified or unqualified.  If the
10446 name is unqualified then it defaults to being in the stash specified by
10447 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10448 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10449 semantics.
10450
10451 C<flags> should not have bits set other than C<SVf_UTF8>.
10452
10453 If there is already a subroutine of the specified name, then the new sub
10454 will replace the existing one in the glob.  A warning may be generated
10455 about the redefinition.
10456
10457 If the subroutine has one of a few special names, such as C<BEGIN> or
10458 C<END>, then it will be claimed by the appropriate queue for automatic
10459 running of phase-related subroutines.  In this case the relevant glob will
10460 be left not containing any subroutine, even if it did contain one before.
10461 Execution of the subroutine will likely be a no-op, unless C<sv> was
10462 a tied array or the caller modified the subroutine in some interesting
10463 way before it was executed.  In the case of C<BEGIN>, the treatment is
10464 buggy: the sub will be executed when only half built, and may be deleted
10465 prematurely, possibly causing a crash.
10466
10467 The function returns a pointer to the constructed subroutine.  If the sub
10468 is anonymous then ownership of one counted reference to the subroutine
10469 is transferred to the caller.  If the sub is named then the caller does
10470 not get ownership of a reference.  In most such cases, where the sub
10471 has a non-phase name, the sub will be alive at the point it is returned
10472 by virtue of being contained in the glob that names it.  A phase-named
10473 subroutine will usually be alive by virtue of the reference owned by
10474 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10475 destroyed already by the time this function returns, but currently bugs
10476 occur in that case before the caller gets control.  It is the caller's
10477 responsibility to ensure that it knows which of these situations applies.
10478
10479 =cut
10480 */
10481
10482 CV *
10483 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10484                              U32 flags, SV *sv)
10485 {
10486     CV* cv;
10487     const char *const file = CopFILE(PL_curcop);
10488
10489     ENTER;
10490
10491     if (IN_PERL_RUNTIME) {
10492         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10493          * an op shared between threads. Use a non-shared COP for our
10494          * dirty work */
10495          SAVEVPTR(PL_curcop);
10496          SAVECOMPILEWARNINGS();
10497          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10498          PL_curcop = &PL_compiling;
10499     }
10500     SAVECOPLINE(PL_curcop);
10501     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10502
10503     SAVEHINTS();
10504     PL_hints &= ~HINT_BLOCK_SCOPE;
10505
10506     if (stash) {
10507         SAVEGENERICSV(PL_curstash);
10508         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10509     }
10510
10511     /* Protect sv against leakage caused by fatal warnings. */
10512     if (sv) SAVEFREESV(sv);
10513
10514     /* file becomes the CvFILE. For an XS, it's usually static storage,
10515        and so doesn't get free()d.  (It's expected to be from the C pre-
10516        processor __FILE__ directive). But we need a dynamically allocated one,
10517        and we need it to get freed.  */
10518     cv = newXS_len_flags(name, len,
10519                          sv && SvTYPE(sv) == SVt_PVAV
10520                              ? const_av_xsub
10521                              : const_sv_xsub,
10522                          file ? file : "", "",
10523                          &sv, XS_DYNAMIC_FILENAME | flags);
10524     assert(cv);
10525     assert(SvREFCNT((SV*)cv) != 0);
10526     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10527     CvCONST_on(cv);
10528
10529     LEAVE;
10530
10531     return cv;
10532 }
10533
10534 /*
10535 =for apidoc U||newXS
10536
10537 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10538 static storage, as it is used directly as CvFILE(), without a copy being made.
10539
10540 =cut
10541 */
10542
10543 CV *
10544 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10545 {
10546     PERL_ARGS_ASSERT_NEWXS;
10547     return newXS_len_flags(
10548         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10549     );
10550 }
10551
10552 CV *
10553 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10554                  const char *const filename, const char *const proto,
10555                  U32 flags)
10556 {
10557     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10558     return newXS_len_flags(
10559        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10560     );
10561 }
10562
10563 CV *
10564 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10565 {
10566     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10567     return newXS_len_flags(
10568         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10569     );
10570 }
10571
10572 /*
10573 =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
10574
10575 Construct an XS subroutine, also performing some surrounding jobs.
10576
10577 The subroutine will have the entry point C<subaddr>.  It will have
10578 the prototype specified by the nul-terminated string C<proto>, or
10579 no prototype if C<proto> is null.  The prototype string is copied;
10580 the caller can mutate the supplied string afterwards.  If C<filename>
10581 is non-null, it must be a nul-terminated filename, and the subroutine
10582 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10583 point directly to the supplied string, which must be static.  If C<flags>
10584 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10585 be taken instead.
10586
10587 Other aspects of the subroutine will be left in their default state.
10588 If anything else needs to be done to the subroutine for it to function
10589 correctly, it is the caller's responsibility to do that after this
10590 function has constructed it.  However, beware of the subroutine
10591 potentially being destroyed before this function returns, as described
10592 below.
10593
10594 If C<name> is null then the subroutine will be anonymous, with its
10595 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10596 subroutine will be named accordingly, referenced by the appropriate glob.
10597 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10598 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10599 The name may be either qualified or unqualified, with the stash defaulting
10600 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10601 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10602 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10603 the stash if necessary, with C<GV_ADDMULTI> semantics.
10604
10605 If there is already a subroutine of the specified name, then the new sub
10606 will replace the existing one in the glob.  A warning may be generated
10607 about the redefinition.  If the old subroutine was C<CvCONST> then the
10608 decision about whether to warn is influenced by an expectation about
10609 whether the new subroutine will become a constant of similar value.
10610 That expectation is determined by C<const_svp>.  (Note that the call to
10611 this function doesn't make the new subroutine C<CvCONST> in any case;
10612 that is left to the caller.)  If C<const_svp> is null then it indicates
10613 that the new subroutine will not become a constant.  If C<const_svp>
10614 is non-null then it indicates that the new subroutine will become a
10615 constant, and it points to an C<SV*> that provides the constant value
10616 that the subroutine will have.
10617
10618 If the subroutine has one of a few special names, such as C<BEGIN> or
10619 C<END>, then it will be claimed by the appropriate queue for automatic
10620 running of phase-related subroutines.  In this case the relevant glob will
10621 be left not containing any subroutine, even if it did contain one before.
10622 In the case of C<BEGIN>, the subroutine will be executed and the reference
10623 to it disposed of before this function returns, and also before its
10624 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10625 constructed by this function to be ready for execution then the caller
10626 must prevent this happening by giving the subroutine a different name.
10627
10628 The function returns a pointer to the constructed subroutine.  If the sub
10629 is anonymous then ownership of one counted reference to the subroutine
10630 is transferred to the caller.  If the sub is named then the caller does
10631 not get ownership of a reference.  In most such cases, where the sub
10632 has a non-phase name, the sub will be alive at the point it is returned
10633 by virtue of being contained in the glob that names it.  A phase-named
10634 subroutine will usually be alive by virtue of the reference owned by the
10635 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10636 been executed, will quite likely have been destroyed already by the
10637 time this function returns, making it erroneous for the caller to make
10638 any use of the returned pointer.  It is the caller's responsibility to
10639 ensure that it knows which of these situations applies.
10640
10641 =cut
10642 */
10643
10644 CV *
10645 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10646                            XSUBADDR_t subaddr, const char *const filename,
10647                            const char *const proto, SV **const_svp,
10648                            U32 flags)
10649 {
10650     CV *cv;
10651     bool interleave = FALSE;
10652     bool evanescent = FALSE;
10653
10654     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10655
10656     {
10657         GV * const gv = gv_fetchpvn(
10658                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10659                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10660                                 sizeof("__ANON__::__ANON__") - 1,
10661                             GV_ADDMULTI | flags, SVt_PVCV);
10662
10663         if ((cv = (name ? GvCV(gv) : NULL))) {
10664             if (GvCVGEN(gv)) {
10665                 /* just a cached method */
10666                 SvREFCNT_dec(cv);
10667                 cv = NULL;
10668             }
10669             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10670                 /* already defined (or promised) */
10671                 /* Redundant check that allows us to avoid creating an SV
10672                    most of the time: */
10673                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10674                     report_redefined_cv(newSVpvn_flags(
10675                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10676                                         ),
10677                                         cv, const_svp);
10678                 }
10679                 interleave = TRUE;
10680                 ENTER;
10681                 SAVEFREESV(cv);
10682                 cv = NULL;
10683             }
10684         }
10685
10686         if (cv)                         /* must reuse cv if autoloaded */
10687             cv_undef(cv);
10688         else {
10689             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10690             if (name) {
10691                 GvCV_set(gv,cv);
10692                 GvCVGEN(gv) = 0;
10693                 if (HvENAME_HEK(GvSTASH(gv)))
10694                     gv_method_changed(gv); /* newXS */
10695             }
10696         }
10697         assert(cv);
10698         assert(SvREFCNT((SV*)cv) != 0);
10699
10700         CvGV_set(cv, gv);
10701         if(filename) {
10702             /* XSUBs can't be perl lang/perl5db.pl debugged
10703             if (PERLDB_LINE_OR_SAVESRC)
10704                 (void)gv_fetchfile(filename); */
10705             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10706             if (flags & XS_DYNAMIC_FILENAME) {
10707                 CvDYNFILE_on(cv);
10708                 CvFILE(cv) = savepv(filename);
10709             } else {
10710             /* NOTE: not copied, as it is expected to be an external constant string */
10711                 CvFILE(cv) = (char *)filename;
10712             }
10713         } else {
10714             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10715             CvFILE(cv) = (char*)PL_xsubfilename;
10716         }
10717         CvISXSUB_on(cv);
10718         CvXSUB(cv) = subaddr;
10719 #ifndef PERL_IMPLICIT_CONTEXT
10720         CvHSCXT(cv) = &PL_stack_sp;
10721 #else
10722         PoisonPADLIST(cv);
10723 #endif
10724
10725         if (name)
10726             evanescent = process_special_blocks(0, name, gv, cv);
10727         else
10728             CvANON_on(cv);
10729     } /* <- not a conditional branch */
10730
10731     assert(cv);
10732     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10733
10734     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10735     if (interleave) LEAVE;
10736     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10737     return cv;
10738 }
10739
10740 CV *
10741 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10742 {
10743     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10744     GV *cvgv;
10745     PERL_ARGS_ASSERT_NEWSTUB;
10746     assert(!GvCVu(gv));
10747     GvCV_set(gv, cv);
10748     GvCVGEN(gv) = 0;
10749     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10750         gv_method_changed(gv);
10751     if (SvFAKE(gv)) {
10752         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10753         SvFAKE_off(cvgv);
10754     }
10755     else cvgv = gv;
10756     CvGV_set(cv, cvgv);
10757     CvFILE_set_from_cop(cv, PL_curcop);
10758     CvSTASH_set(cv, PL_curstash);
10759     GvMULTI_on(gv);
10760     return cv;
10761 }
10762
10763 void
10764 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10765 {
10766     CV *cv;
10767     GV *gv;
10768     OP *root;
10769     OP *start;
10770
10771     if (PL_parser && PL_parser->error_count) {
10772         op_free(block);
10773         goto finish;
10774     }
10775
10776     gv = o
10777         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10778         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10779
10780     GvMULTI_on(gv);
10781     if ((cv = GvFORM(gv))) {
10782         if (ckWARN(WARN_REDEFINE)) {
10783             const line_t oldline = CopLINE(PL_curcop);
10784             if (PL_parser && PL_parser->copline != NOLINE)
10785                 CopLINE_set(PL_curcop, PL_parser->copline);
10786             if (o) {
10787                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10788                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10789             } else {
10790                 /* diag_listed_as: Format %s redefined */
10791                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10792                             "Format STDOUT redefined");
10793             }
10794             CopLINE_set(PL_curcop, oldline);
10795         }
10796         SvREFCNT_dec(cv);
10797     }
10798     cv = PL_compcv;
10799     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10800     CvGV_set(cv, gv);
10801     CvFILE_set_from_cop(cv, PL_curcop);
10802
10803
10804     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10805     CvROOT(cv) = root;
10806     start = LINKLIST(root);
10807     root->op_next = 0;
10808     S_process_optree(aTHX_ cv, root, start);
10809     cv_forget_slab(cv);
10810
10811   finish:
10812     op_free(o);
10813     if (PL_parser)
10814         PL_parser->copline = NOLINE;
10815     LEAVE_SCOPE(floor);
10816     PL_compiling.cop_seq = 0;
10817 }
10818
10819 OP *
10820 Perl_newANONLIST(pTHX_ OP *o)
10821 {
10822     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10823 }
10824
10825 OP *
10826 Perl_newANONHASH(pTHX_ OP *o)
10827 {
10828     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10829 }
10830
10831 OP *
10832 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10833 {
10834     return newANONATTRSUB(floor, proto, NULL, block);
10835 }
10836
10837 OP *
10838 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10839 {
10840     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10841     OP * anoncode =
10842         newSVOP(OP_ANONCODE, 0,
10843                 cv);
10844     if (CvANONCONST(cv))
10845         anoncode = newUNOP(OP_ANONCONST, 0,
10846                            op_convert_list(OP_ENTERSUB,
10847                                            OPf_STACKED|OPf_WANT_SCALAR,
10848                                            anoncode));
10849     return newUNOP(OP_REFGEN, 0, anoncode);
10850 }
10851
10852 OP *
10853 Perl_oopsAV(pTHX_ OP *o)
10854 {
10855     dVAR;
10856
10857     PERL_ARGS_ASSERT_OOPSAV;
10858
10859     switch (o->op_type) {
10860     case OP_PADSV:
10861     case OP_PADHV:
10862         OpTYPE_set(o, OP_PADAV);
10863         return ref(o, OP_RV2AV);
10864
10865     case OP_RV2SV:
10866     case OP_RV2HV:
10867         OpTYPE_set(o, OP_RV2AV);
10868         ref(o, OP_RV2AV);
10869         break;
10870
10871     default:
10872         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10873         break;
10874     }
10875     return o;
10876 }
10877
10878 OP *
10879 Perl_oopsHV(pTHX_ OP *o)
10880 {
10881     dVAR;
10882
10883     PERL_ARGS_ASSERT_OOPSHV;
10884
10885     switch (o->op_type) {
10886     case OP_PADSV:
10887     case OP_PADAV:
10888         OpTYPE_set(o, OP_PADHV);
10889         return ref(o, OP_RV2HV);
10890
10891     case OP_RV2SV:
10892     case OP_RV2AV:
10893         OpTYPE_set(o, OP_RV2HV);
10894         /* rv2hv steals the bottom bit for its own uses */
10895         o->op_private &= ~OPpARG1_MASK;
10896         ref(o, OP_RV2HV);
10897         break;
10898
10899     default:
10900         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10901         break;
10902     }
10903     return o;
10904 }
10905
10906 OP *
10907 Perl_newAVREF(pTHX_ OP *o)
10908 {
10909     dVAR;
10910
10911     PERL_ARGS_ASSERT_NEWAVREF;
10912
10913     if (o->op_type == OP_PADANY) {
10914         OpTYPE_set(o, OP_PADAV);
10915         return o;
10916     }
10917     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10918         Perl_croak(aTHX_ "Can't use an array as a reference");
10919     }
10920     return newUNOP(OP_RV2AV, 0, scalar(o));
10921 }
10922
10923 OP *
10924 Perl_newGVREF(pTHX_ I32 type, OP *o)
10925 {
10926     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10927         return newUNOP(OP_NULL, 0, o);
10928     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10929 }
10930
10931 OP *
10932 Perl_newHVREF(pTHX_ OP *o)
10933 {
10934     dVAR;
10935
10936     PERL_ARGS_ASSERT_NEWHVREF;
10937
10938     if (o->op_type == OP_PADANY) {
10939         OpTYPE_set(o, OP_PADHV);
10940         return o;
10941     }
10942     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10943         Perl_croak(aTHX_ "Can't use a hash as a reference");
10944     }
10945     return newUNOP(OP_RV2HV, 0, scalar(o));
10946 }
10947
10948 OP *
10949 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10950 {
10951     if (o->op_type == OP_PADANY) {
10952         dVAR;
10953         OpTYPE_set(o, OP_PADCV);
10954     }
10955     return newUNOP(OP_RV2CV, flags, scalar(o));
10956 }
10957
10958 OP *
10959 Perl_newSVREF(pTHX_ OP *o)
10960 {
10961     dVAR;
10962
10963     PERL_ARGS_ASSERT_NEWSVREF;
10964
10965     if (o->op_type == OP_PADANY) {
10966         OpTYPE_set(o, OP_PADSV);
10967         scalar(o);
10968         return o;
10969     }
10970     return newUNOP(OP_RV2SV, 0, scalar(o));
10971 }
10972
10973 /* Check routines. See the comments at the top of this file for details
10974  * on when these are called */
10975
10976 OP *
10977 Perl_ck_anoncode(pTHX_ OP *o)
10978 {
10979     PERL_ARGS_ASSERT_CK_ANONCODE;
10980
10981     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10982     cSVOPo->op_sv = NULL;
10983     return o;
10984 }
10985
10986 static void
10987 S_io_hints(pTHX_ OP *o)
10988 {
10989 #if O_BINARY != 0 || O_TEXT != 0
10990     HV * const table =
10991         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10992     if (table) {
10993         SV **svp = hv_fetchs(table, "open_IN", FALSE);
10994         if (svp && *svp) {
10995             STRLEN len = 0;
10996             const char *d = SvPV_const(*svp, len);
10997             const I32 mode = mode_from_discipline(d, len);
10998             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10999 #  if O_BINARY != 0
11000             if (mode & O_BINARY)
11001                 o->op_private |= OPpOPEN_IN_RAW;
11002 #  endif
11003 #  if O_TEXT != 0
11004             if (mode & O_TEXT)
11005                 o->op_private |= OPpOPEN_IN_CRLF;
11006 #  endif
11007         }
11008
11009         svp = hv_fetchs(table, "open_OUT", FALSE);
11010         if (svp && *svp) {
11011             STRLEN len = 0;
11012             const char *d = SvPV_const(*svp, len);
11013             const I32 mode = mode_from_discipline(d, len);
11014             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11015 #  if O_BINARY != 0
11016             if (mode & O_BINARY)
11017                 o->op_private |= OPpOPEN_OUT_RAW;
11018 #  endif
11019 #  if O_TEXT != 0
11020             if (mode & O_TEXT)
11021                 o->op_private |= OPpOPEN_OUT_CRLF;
11022 #  endif
11023         }
11024     }
11025 #else
11026     PERL_UNUSED_CONTEXT;
11027     PERL_UNUSED_ARG(o);
11028 #endif
11029 }
11030
11031 OP *
11032 Perl_ck_backtick(pTHX_ OP *o)
11033 {
11034     GV *gv;
11035     OP *newop = NULL;
11036     OP *sibl;
11037     PERL_ARGS_ASSERT_CK_BACKTICK;
11038     o = ck_fun(o);
11039     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11040     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11041      && (gv = gv_override("readpipe",8)))
11042     {
11043         /* detach rest of siblings from o and its first child */
11044         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11045         newop = S_new_entersubop(aTHX_ gv, sibl);
11046     }
11047     else if (!(o->op_flags & OPf_KIDS))
11048         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11049     if (newop) {
11050         op_free(o);
11051         return newop;
11052     }
11053     S_io_hints(aTHX_ o);
11054     return o;
11055 }
11056
11057 OP *
11058 Perl_ck_bitop(pTHX_ OP *o)
11059 {
11060     PERL_ARGS_ASSERT_CK_BITOP;
11061
11062     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11063
11064     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11065             && OP_IS_INFIX_BIT(o->op_type))
11066     {
11067         const OP * const left = cBINOPo->op_first;
11068         const OP * const right = OpSIBLING(left);
11069         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11070                 (left->op_flags & OPf_PARENS) == 0) ||
11071             (OP_IS_NUMCOMPARE(right->op_type) &&
11072                 (right->op_flags & OPf_PARENS) == 0))
11073             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11074                           "Possible precedence problem on bitwise %s operator",
11075                            o->op_type ==  OP_BIT_OR
11076                          ||o->op_type == OP_NBIT_OR  ? "|"
11077                         :  o->op_type ==  OP_BIT_AND
11078                          ||o->op_type == OP_NBIT_AND ? "&"
11079                         :  o->op_type ==  OP_BIT_XOR
11080                          ||o->op_type == OP_NBIT_XOR ? "^"
11081                         :  o->op_type == OP_SBIT_OR  ? "|."
11082                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11083                            );
11084     }
11085     return o;
11086 }
11087
11088 PERL_STATIC_INLINE bool
11089 is_dollar_bracket(pTHX_ const OP * const o)
11090 {
11091     const OP *kid;
11092     PERL_UNUSED_CONTEXT;
11093     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11094         && (kid = cUNOPx(o)->op_first)
11095         && kid->op_type == OP_GV
11096         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11097 }
11098
11099 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11100
11101 OP *
11102 Perl_ck_cmp(pTHX_ OP *o)
11103 {
11104     bool is_eq;
11105     bool neg;
11106     bool reverse;
11107     bool iv0;
11108     OP *indexop, *constop, *start;
11109     SV *sv;
11110     IV iv;
11111
11112     PERL_ARGS_ASSERT_CK_CMP;
11113
11114     is_eq = (   o->op_type == OP_EQ
11115              || o->op_type == OP_NE
11116              || o->op_type == OP_I_EQ
11117              || o->op_type == OP_I_NE);
11118
11119     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11120         const OP *kid = cUNOPo->op_first;
11121         if (kid &&
11122             (
11123                 (   is_dollar_bracket(aTHX_ kid)
11124                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11125                 )
11126              || (   kid->op_type == OP_CONST
11127                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11128                 )
11129            )
11130         )
11131             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11132                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11133     }
11134
11135     /* convert (index(...) == -1) and variations into
11136      *   (r)index/BOOL(,NEG)
11137      */
11138
11139     reverse = FALSE;
11140
11141     indexop = cUNOPo->op_first;
11142     constop = OpSIBLING(indexop);
11143     start = NULL;
11144     if (indexop->op_type == OP_CONST) {
11145         constop = indexop;
11146         indexop = OpSIBLING(constop);
11147         start = constop;
11148         reverse = TRUE;
11149     }
11150
11151     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11152         return o;
11153
11154     /* ($lex = index(....)) == -1 */
11155     if (indexop->op_private & OPpTARGET_MY)
11156         return o;
11157
11158     if (constop->op_type != OP_CONST)
11159         return o;
11160
11161     sv = cSVOPx_sv(constop);
11162     if (!(sv && SvIOK_notUV(sv)))
11163         return o;
11164
11165     iv = SvIVX(sv);
11166     if (iv != -1 && iv != 0)
11167         return o;
11168     iv0 = (iv == 0);
11169
11170     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11171         if (!(iv0 ^ reverse))
11172             return o;
11173         neg = iv0;
11174     }
11175     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11176         if (iv0 ^ reverse)
11177             return o;
11178         neg = !iv0;
11179     }
11180     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11181         if (!(iv0 ^ reverse))
11182             return o;
11183         neg = !iv0;
11184     }
11185     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11186         if (iv0 ^ reverse)
11187             return o;
11188         neg = iv0;
11189     }
11190     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11191         if (iv0)
11192             return o;
11193         neg = TRUE;
11194     }
11195     else {
11196         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11197         if (iv0)
11198             return o;
11199         neg = FALSE;
11200     }
11201
11202     indexop->op_flags &= ~OPf_PARENS;
11203     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11204     indexop->op_private |= OPpTRUEBOOL;
11205     if (neg)
11206         indexop->op_private |= OPpINDEX_BOOLNEG;
11207     /* cut out the index op and free the eq,const ops */
11208     (void)op_sibling_splice(o, start, 1, NULL);
11209     op_free(o);
11210
11211     return indexop;
11212 }
11213
11214
11215 OP *
11216 Perl_ck_concat(pTHX_ OP *o)
11217 {
11218     const OP * const kid = cUNOPo->op_first;
11219
11220     PERL_ARGS_ASSERT_CK_CONCAT;
11221     PERL_UNUSED_CONTEXT;
11222
11223     /* reuse the padtmp returned by the concat child */
11224     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11225             !(kUNOP->op_first->op_flags & OPf_MOD))
11226     {
11227         o->op_flags |= OPf_STACKED;
11228         o->op_private |= OPpCONCAT_NESTED;
11229     }
11230     return o;
11231 }
11232
11233 OP *
11234 Perl_ck_spair(pTHX_ OP *o)
11235 {
11236     dVAR;
11237
11238     PERL_ARGS_ASSERT_CK_SPAIR;
11239
11240     if (o->op_flags & OPf_KIDS) {
11241         OP* newop;
11242         OP* kid;
11243         OP* kidkid;
11244         const OPCODE type = o->op_type;
11245         o = modkids(ck_fun(o), type);
11246         kid    = cUNOPo->op_first;
11247         kidkid = kUNOP->op_first;
11248         newop = OpSIBLING(kidkid);
11249         if (newop) {
11250             const OPCODE type = newop->op_type;
11251             if (OpHAS_SIBLING(newop))
11252                 return o;
11253             if (o->op_type == OP_REFGEN
11254              && (  type == OP_RV2CV
11255                 || (  !(newop->op_flags & OPf_PARENS)
11256                    && (  type == OP_RV2AV || type == OP_PADAV
11257                       || type == OP_RV2HV || type == OP_PADHV))))
11258                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11259             else if (OP_GIMME(newop,0) != G_SCALAR)
11260                 return o;
11261         }
11262         /* excise first sibling */
11263         op_sibling_splice(kid, NULL, 1, NULL);
11264         op_free(kidkid);
11265     }
11266     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11267      * and OP_CHOMP into OP_SCHOMP */
11268     o->op_ppaddr = PL_ppaddr[++o->op_type];
11269     return ck_fun(o);
11270 }
11271
11272 OP *
11273 Perl_ck_delete(pTHX_ OP *o)
11274 {
11275     PERL_ARGS_ASSERT_CK_DELETE;
11276
11277     o = ck_fun(o);
11278     o->op_private = 0;
11279     if (o->op_flags & OPf_KIDS) {
11280         OP * const kid = cUNOPo->op_first;
11281         switch (kid->op_type) {
11282         case OP_ASLICE:
11283             o->op_flags |= OPf_SPECIAL;
11284             /* FALLTHROUGH */
11285         case OP_HSLICE:
11286             o->op_private |= OPpSLICE;
11287             break;
11288         case OP_AELEM:
11289             o->op_flags |= OPf_SPECIAL;
11290             /* FALLTHROUGH */
11291         case OP_HELEM:
11292             break;
11293         case OP_KVASLICE:
11294             o->op_flags |= OPf_SPECIAL;
11295             /* FALLTHROUGH */
11296         case OP_KVHSLICE:
11297             o->op_private |= OPpKVSLICE;
11298             break;
11299         default:
11300             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11301                              "element or slice");
11302         }
11303         if (kid->op_private & OPpLVAL_INTRO)
11304             o->op_private |= OPpLVAL_INTRO;
11305         op_null(kid);
11306     }
11307     return o;
11308 }
11309
11310 OP *
11311 Perl_ck_eof(pTHX_ OP *o)
11312 {
11313     PERL_ARGS_ASSERT_CK_EOF;
11314
11315     if (o->op_flags & OPf_KIDS) {
11316         OP *kid;
11317         if (cLISTOPo->op_first->op_type == OP_STUB) {
11318             OP * const newop
11319                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11320             op_free(o);
11321             o = newop;
11322         }
11323         o = ck_fun(o);
11324         kid = cLISTOPo->op_first;
11325         if (kid->op_type == OP_RV2GV)
11326             kid->op_private |= OPpALLOW_FAKE;
11327     }
11328     return o;
11329 }
11330
11331
11332 OP *
11333 Perl_ck_eval(pTHX_ OP *o)
11334 {
11335     dVAR;
11336
11337     PERL_ARGS_ASSERT_CK_EVAL;
11338
11339     PL_hints |= HINT_BLOCK_SCOPE;
11340     if (o->op_flags & OPf_KIDS) {
11341         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11342         assert(kid);
11343
11344         if (o->op_type == OP_ENTERTRY) {
11345             LOGOP *enter;
11346
11347             /* cut whole sibling chain free from o */
11348             op_sibling_splice(o, NULL, -1, NULL);
11349             op_free(o);
11350
11351             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11352
11353             /* establish postfix order */
11354             enter->op_next = (OP*)enter;
11355
11356             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11357             OpTYPE_set(o, OP_LEAVETRY);
11358             enter->op_other = o;
11359             return o;
11360         }
11361         else {
11362             scalar((OP*)kid);
11363             S_set_haseval(aTHX);
11364         }
11365     }
11366     else {
11367         const U8 priv = o->op_private;
11368         op_free(o);
11369         /* the newUNOP will recursively call ck_eval(), which will handle
11370          * all the stuff at the end of this function, like adding
11371          * OP_HINTSEVAL
11372          */
11373         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11374     }
11375     o->op_targ = (PADOFFSET)PL_hints;
11376     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11377     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11378      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11379         /* Store a copy of %^H that pp_entereval can pick up. */
11380         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11381                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11382         /* append hhop to only child  */
11383         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11384
11385         o->op_private |= OPpEVAL_HAS_HH;
11386     }
11387     if (!(o->op_private & OPpEVAL_BYTES)
11388          && FEATURE_UNIEVAL_IS_ENABLED)
11389             o->op_private |= OPpEVAL_UNICODE;
11390     return o;
11391 }
11392
11393 OP *
11394 Perl_ck_exec(pTHX_ OP *o)
11395 {
11396     PERL_ARGS_ASSERT_CK_EXEC;
11397
11398     if (o->op_flags & OPf_STACKED) {
11399         OP *kid;
11400         o = ck_fun(o);
11401         kid = OpSIBLING(cUNOPo->op_first);
11402         if (kid->op_type == OP_RV2GV)
11403             op_null(kid);
11404     }
11405     else
11406         o = listkids(o);
11407     return o;
11408 }
11409
11410 OP *
11411 Perl_ck_exists(pTHX_ OP *o)
11412 {
11413     PERL_ARGS_ASSERT_CK_EXISTS;
11414
11415     o = ck_fun(o);
11416     if (o->op_flags & OPf_KIDS) {
11417         OP * const kid = cUNOPo->op_first;
11418         if (kid->op_type == OP_ENTERSUB) {
11419             (void) ref(kid, o->op_type);
11420             if (kid->op_type != OP_RV2CV
11421                         && !(PL_parser && PL_parser->error_count))
11422                 Perl_croak(aTHX_
11423                           "exists argument is not a subroutine name");
11424             o->op_private |= OPpEXISTS_SUB;
11425         }
11426         else if (kid->op_type == OP_AELEM)
11427             o->op_flags |= OPf_SPECIAL;
11428         else if (kid->op_type != OP_HELEM)
11429             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11430                              "element or a subroutine");
11431         op_null(kid);
11432     }
11433     return o;
11434 }
11435
11436 OP *
11437 Perl_ck_rvconst(pTHX_ OP *o)
11438 {
11439     dVAR;
11440     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11441
11442     PERL_ARGS_ASSERT_CK_RVCONST;
11443
11444     if (o->op_type == OP_RV2HV)
11445         /* rv2hv steals the bottom bit for its own uses */
11446         o->op_private &= ~OPpARG1_MASK;
11447
11448     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11449
11450     if (kid->op_type == OP_CONST) {
11451         int iscv;
11452         GV *gv;
11453         SV * const kidsv = kid->op_sv;
11454
11455         /* Is it a constant from cv_const_sv()? */
11456         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11457             return o;
11458         }
11459         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11460         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11461             const char *badthing;
11462             switch (o->op_type) {
11463             case OP_RV2SV:
11464                 badthing = "a SCALAR";
11465                 break;
11466             case OP_RV2AV:
11467                 badthing = "an ARRAY";
11468                 break;
11469             case OP_RV2HV:
11470                 badthing = "a HASH";
11471                 break;
11472             default:
11473                 badthing = NULL;
11474                 break;
11475             }
11476             if (badthing)
11477                 Perl_croak(aTHX_
11478                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11479                            SVfARG(kidsv), badthing);
11480         }
11481         /*
11482          * This is a little tricky.  We only want to add the symbol if we
11483          * didn't add it in the lexer.  Otherwise we get duplicate strict
11484          * warnings.  But if we didn't add it in the lexer, we must at
11485          * least pretend like we wanted to add it even if it existed before,
11486          * or we get possible typo warnings.  OPpCONST_ENTERED says
11487          * whether the lexer already added THIS instance of this symbol.
11488          */
11489         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11490         gv = gv_fetchsv(kidsv,
11491                 o->op_type == OP_RV2CV
11492                         && o->op_private & OPpMAY_RETURN_CONSTANT
11493                     ? GV_NOEXPAND
11494                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11495                 iscv
11496                     ? SVt_PVCV
11497                     : o->op_type == OP_RV2SV
11498                         ? SVt_PV
11499                         : o->op_type == OP_RV2AV
11500                             ? SVt_PVAV
11501                             : o->op_type == OP_RV2HV
11502                                 ? SVt_PVHV
11503                                 : SVt_PVGV);
11504         if (gv) {
11505             if (!isGV(gv)) {
11506                 assert(iscv);
11507                 assert(SvROK(gv));
11508                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11509                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11510                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11511             }
11512             OpTYPE_set(kid, OP_GV);
11513             SvREFCNT_dec(kid->op_sv);
11514 #ifdef USE_ITHREADS
11515             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11516             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11517             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11518             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11519             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11520 #else
11521             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11522 #endif
11523             kid->op_private = 0;
11524             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11525             SvFAKE_off(gv);
11526         }
11527     }
11528     return o;
11529 }
11530
11531 OP *
11532 Perl_ck_ftst(pTHX_ OP *o)
11533 {
11534     dVAR;
11535     const I32 type = o->op_type;
11536
11537     PERL_ARGS_ASSERT_CK_FTST;
11538
11539     if (o->op_flags & OPf_REF) {
11540         NOOP;
11541     }
11542     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11543         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11544         const OPCODE kidtype = kid->op_type;
11545
11546         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11547          && !kid->op_folded) {
11548             OP * const newop = newGVOP(type, OPf_REF,
11549                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11550             op_free(o);
11551             return newop;
11552         }
11553
11554         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11555             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11556             if (name) {
11557                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11558                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11559                             array_passed_to_stat, name);
11560             }
11561             else {
11562                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11563                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11564             }
11565        }
11566         scalar((OP *) kid);
11567         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11568             o->op_private |= OPpFT_ACCESS;
11569         if (type != OP_STAT && type != OP_LSTAT
11570             && PL_check[kidtype] == Perl_ck_ftst
11571             && kidtype != OP_STAT && kidtype != OP_LSTAT
11572         ) {
11573             o->op_private |= OPpFT_STACKED;
11574             kid->op_private |= OPpFT_STACKING;
11575             if (kidtype == OP_FTTTY && (
11576                    !(kid->op_private & OPpFT_STACKED)
11577                 || kid->op_private & OPpFT_AFTER_t
11578                ))
11579                 o->op_private |= OPpFT_AFTER_t;
11580         }
11581     }
11582     else {
11583         op_free(o);
11584         if (type == OP_FTTTY)
11585             o = newGVOP(type, OPf_REF, PL_stdingv);
11586         else
11587             o = newUNOP(type, 0, newDEFSVOP());
11588     }
11589     return o;
11590 }
11591
11592 OP *
11593 Perl_ck_fun(pTHX_ OP *o)
11594 {
11595     const int type = o->op_type;
11596     I32 oa = PL_opargs[type] >> OASHIFT;
11597
11598     PERL_ARGS_ASSERT_CK_FUN;
11599
11600     if (o->op_flags & OPf_STACKED) {
11601         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11602             oa &= ~OA_OPTIONAL;
11603         else
11604             return no_fh_allowed(o);
11605     }
11606
11607     if (o->op_flags & OPf_KIDS) {
11608         OP *prev_kid = NULL;
11609         OP *kid = cLISTOPo->op_first;
11610         I32 numargs = 0;
11611         bool seen_optional = FALSE;
11612
11613         if (kid->op_type == OP_PUSHMARK ||
11614             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11615         {
11616             prev_kid = kid;
11617             kid = OpSIBLING(kid);
11618         }
11619         if (kid && kid->op_type == OP_COREARGS) {
11620             bool optional = FALSE;
11621             while (oa) {
11622                 numargs++;
11623                 if (oa & OA_OPTIONAL) optional = TRUE;
11624                 oa = oa >> 4;
11625             }
11626             if (optional) o->op_private |= numargs;
11627             return o;
11628         }
11629
11630         while (oa) {
11631             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11632                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11633                     kid = newDEFSVOP();
11634                     /* append kid to chain */
11635                     op_sibling_splice(o, prev_kid, 0, kid);
11636                 }
11637                 seen_optional = TRUE;
11638             }
11639             if (!kid) break;
11640
11641             numargs++;
11642             switch (oa & 7) {
11643             case OA_SCALAR:
11644                 /* list seen where single (scalar) arg expected? */
11645                 if (numargs == 1 && !(oa >> 4)
11646                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11647                 {
11648                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11649                 }
11650                 if (type != OP_DELETE) scalar(kid);
11651                 break;
11652             case OA_LIST:
11653                 if (oa < 16) {
11654                     kid = 0;
11655                     continue;
11656                 }
11657                 else
11658                     list(kid);
11659                 break;
11660             case OA_AVREF:
11661                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11662                     && !OpHAS_SIBLING(kid))
11663                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11664                                    "Useless use of %s with no values",
11665                                    PL_op_desc[type]);
11666
11667                 if (kid->op_type == OP_CONST
11668                       && (  !SvROK(cSVOPx_sv(kid))
11669                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11670                         )
11671                     bad_type_pv(numargs, "array", o, kid);
11672                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11673                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11674                                          PL_op_desc[type]), 0);
11675                 }
11676                 else {
11677                     op_lvalue(kid, type);
11678                 }
11679                 break;
11680             case OA_HVREF:
11681                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11682                     bad_type_pv(numargs, "hash", o, kid);
11683                 op_lvalue(kid, type);
11684                 break;
11685             case OA_CVREF:
11686                 {
11687                     /* replace kid with newop in chain */
11688                     OP * const newop =
11689                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11690                     newop->op_next = newop;
11691                     kid = newop;
11692                 }
11693                 break;
11694             case OA_FILEREF:
11695                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11696                     if (kid->op_type == OP_CONST &&
11697                         (kid->op_private & OPpCONST_BARE))
11698                     {
11699                         OP * const newop = newGVOP(OP_GV, 0,
11700                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11701                         /* replace kid with newop in chain */
11702                         op_sibling_splice(o, prev_kid, 1, newop);
11703                         op_free(kid);
11704                         kid = newop;
11705                     }
11706                     else if (kid->op_type == OP_READLINE) {
11707                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11708                         bad_type_pv(numargs, "HANDLE", o, kid);
11709                     }
11710                     else {
11711                         I32 flags = OPf_SPECIAL;
11712                         I32 priv = 0;
11713                         PADOFFSET targ = 0;
11714
11715                         /* is this op a FH constructor? */
11716                         if (is_handle_constructor(o,numargs)) {
11717                             const char *name = NULL;
11718                             STRLEN len = 0;
11719                             U32 name_utf8 = 0;
11720                             bool want_dollar = TRUE;
11721
11722                             flags = 0;
11723                             /* Set a flag to tell rv2gv to vivify
11724                              * need to "prove" flag does not mean something
11725                              * else already - NI-S 1999/05/07
11726                              */
11727                             priv = OPpDEREF;
11728                             if (kid->op_type == OP_PADSV) {
11729                                 PADNAME * const pn
11730                                     = PAD_COMPNAME_SV(kid->op_targ);
11731                                 name = PadnamePV (pn);
11732                                 len  = PadnameLEN(pn);
11733                                 name_utf8 = PadnameUTF8(pn);
11734                             }
11735                             else if (kid->op_type == OP_RV2SV
11736                                      && kUNOP->op_first->op_type == OP_GV)
11737                             {
11738                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11739                                 name = GvNAME(gv);
11740                                 len = GvNAMELEN(gv);
11741                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11742                             }
11743                             else if (kid->op_type == OP_AELEM
11744                                      || kid->op_type == OP_HELEM)
11745                             {
11746                                  OP *firstop;
11747                                  OP *op = ((BINOP*)kid)->op_first;
11748                                  name = NULL;
11749                                  if (op) {
11750                                       SV *tmpstr = NULL;
11751                                       const char * const a =
11752                                            kid->op_type == OP_AELEM ?
11753                                            "[]" : "{}";
11754                                       if (((op->op_type == OP_RV2AV) ||
11755                                            (op->op_type == OP_RV2HV)) &&
11756                                           (firstop = ((UNOP*)op)->op_first) &&
11757                                           (firstop->op_type == OP_GV)) {
11758                                            /* packagevar $a[] or $h{} */
11759                                            GV * const gv = cGVOPx_gv(firstop);
11760                                            if (gv)
11761                                                 tmpstr =
11762                                                      Perl_newSVpvf(aTHX_
11763                                                                    "%s%c...%c",
11764                                                                    GvNAME(gv),
11765                                                                    a[0], a[1]);
11766                                       }
11767                                       else if (op->op_type == OP_PADAV
11768                                                || op->op_type == OP_PADHV) {
11769                                            /* lexicalvar $a[] or $h{} */
11770                                            const char * const padname =
11771                                                 PAD_COMPNAME_PV(op->op_targ);
11772                                            if (padname)
11773                                                 tmpstr =
11774                                                      Perl_newSVpvf(aTHX_
11775                                                                    "%s%c...%c",
11776                                                                    padname + 1,
11777                                                                    a[0], a[1]);
11778                                       }
11779                                       if (tmpstr) {
11780                                            name = SvPV_const(tmpstr, len);
11781                                            name_utf8 = SvUTF8(tmpstr);
11782                                            sv_2mortal(tmpstr);
11783                                       }
11784                                  }
11785                                  if (!name) {
11786                                       name = "__ANONIO__";
11787                                       len = 10;
11788                                       want_dollar = FALSE;
11789                                  }
11790                                  op_lvalue(kid, type);
11791                             }
11792                             if (name) {
11793                                 SV *namesv;
11794                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11795                                 namesv = PAD_SVl(targ);
11796                                 if (want_dollar && *name != '$')
11797                                     sv_setpvs(namesv, "$");
11798                                 else
11799                                     SvPVCLEAR(namesv);
11800                                 sv_catpvn(namesv, name, len);
11801                                 if ( name_utf8 ) SvUTF8_on(namesv);
11802                             }
11803                         }
11804                         scalar(kid);
11805                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11806                                     OP_RV2GV, flags);
11807                         kid->op_targ = targ;
11808                         kid->op_private |= priv;
11809                     }
11810                 }
11811                 scalar(kid);
11812                 break;
11813             case OA_SCALARREF:
11814                 if ((type == OP_UNDEF || type == OP_POS)
11815                     && numargs == 1 && !(oa >> 4)
11816                     && kid->op_type == OP_LIST)
11817                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11818                 op_lvalue(scalar(kid), type);
11819                 break;
11820             }
11821             oa >>= 4;
11822             prev_kid = kid;
11823             kid = OpSIBLING(kid);
11824         }
11825         /* FIXME - should the numargs or-ing move after the too many
11826          * arguments check? */
11827         o->op_private |= numargs;
11828         if (kid)
11829             return too_many_arguments_pv(o,OP_DESC(o), 0);
11830         listkids(o);
11831     }
11832     else if (PL_opargs[type] & OA_DEFGV) {
11833         /* Ordering of these two is important to keep f_map.t passing.  */
11834         op_free(o);
11835         return newUNOP(type, 0, newDEFSVOP());
11836     }
11837
11838     if (oa) {
11839         while (oa & OA_OPTIONAL)
11840             oa >>= 4;
11841         if (oa && oa != OA_LIST)
11842             return too_few_arguments_pv(o,OP_DESC(o), 0);
11843     }
11844     return o;
11845 }
11846
11847 OP *
11848 Perl_ck_glob(pTHX_ OP *o)
11849 {
11850     GV *gv;
11851
11852     PERL_ARGS_ASSERT_CK_GLOB;
11853
11854     o = ck_fun(o);
11855     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11856         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11857
11858     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11859     {
11860         /* convert
11861          *     glob
11862          *       \ null - const(wildcard)
11863          * into
11864          *     null
11865          *       \ enter
11866          *            \ list
11867          *                 \ mark - glob - rv2cv
11868          *                             |        \ gv(CORE::GLOBAL::glob)
11869          *                             |
11870          *                              \ null - const(wildcard)
11871          */
11872         o->op_flags |= OPf_SPECIAL;
11873         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11874         o = S_new_entersubop(aTHX_ gv, o);
11875         o = newUNOP(OP_NULL, 0, o);
11876         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11877         return o;
11878     }
11879     else o->op_flags &= ~OPf_SPECIAL;
11880 #if !defined(PERL_EXTERNAL_GLOB)
11881     if (!PL_globhook) {
11882         ENTER;
11883         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11884                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11885         LEAVE;
11886     }
11887 #endif /* !PERL_EXTERNAL_GLOB */
11888     gv = (GV *)newSV(0);
11889     gv_init(gv, 0, "", 0, 0);
11890     gv_IOadd(gv);
11891     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11892     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11893     scalarkids(o);
11894     return o;
11895 }
11896
11897 OP *
11898 Perl_ck_grep(pTHX_ OP *o)
11899 {
11900     LOGOP *gwop;
11901     OP *kid;
11902     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11903
11904     PERL_ARGS_ASSERT_CK_GREP;
11905
11906     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11907
11908     if (o->op_flags & OPf_STACKED) {
11909         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11910         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11911             return no_fh_allowed(o);
11912         o->op_flags &= ~OPf_STACKED;
11913     }
11914     kid = OpSIBLING(cLISTOPo->op_first);
11915     if (type == OP_MAPWHILE)
11916         list(kid);
11917     else
11918         scalar(kid);
11919     o = ck_fun(o);
11920     if (PL_parser && PL_parser->error_count)
11921         return o;
11922     kid = OpSIBLING(cLISTOPo->op_first);
11923     if (kid->op_type != OP_NULL)
11924         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11925     kid = kUNOP->op_first;
11926
11927     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11928     kid->op_next = (OP*)gwop;
11929     o->op_private = gwop->op_private = 0;
11930     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11931
11932     kid = OpSIBLING(cLISTOPo->op_first);
11933     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11934         op_lvalue(kid, OP_GREPSTART);
11935
11936     return (OP*)gwop;
11937 }
11938
11939 OP *
11940 Perl_ck_index(pTHX_ OP *o)
11941 {
11942     PERL_ARGS_ASSERT_CK_INDEX;
11943
11944     if (o->op_flags & OPf_KIDS) {
11945         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11946         if (kid)
11947             kid = OpSIBLING(kid);                       /* get past "big" */
11948         if (kid && kid->op_type == OP_CONST) {
11949             const bool save_taint = TAINT_get;
11950             SV *sv = kSVOP->op_sv;
11951             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11952                 && SvOK(sv) && !SvROK(sv))
11953             {
11954                 sv = newSV(0);
11955                 sv_copypv(sv, kSVOP->op_sv);
11956                 SvREFCNT_dec_NN(kSVOP->op_sv);
11957                 kSVOP->op_sv = sv;
11958             }
11959             if (SvOK(sv)) fbm_compile(sv, 0);
11960             TAINT_set(save_taint);
11961 #ifdef NO_TAINT_SUPPORT
11962             PERL_UNUSED_VAR(save_taint);
11963 #endif
11964         }
11965     }
11966     return ck_fun(o);
11967 }
11968
11969 OP *
11970 Perl_ck_lfun(pTHX_ OP *o)
11971 {
11972     const OPCODE type = o->op_type;
11973
11974     PERL_ARGS_ASSERT_CK_LFUN;
11975
11976     return modkids(ck_fun(o), type);
11977 }
11978
11979 OP *
11980 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
11981 {
11982     PERL_ARGS_ASSERT_CK_DEFINED;
11983
11984     if ((o->op_flags & OPf_KIDS)) {
11985         switch (cUNOPo->op_first->op_type) {
11986         case OP_RV2AV:
11987         case OP_PADAV:
11988             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11989                              " (Maybe you should just omit the defined()?)");
11990             NOT_REACHED; /* NOTREACHED */
11991             break;
11992         case OP_RV2HV:
11993         case OP_PADHV:
11994             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11995                              " (Maybe you should just omit the defined()?)");
11996             NOT_REACHED; /* NOTREACHED */
11997             break;
11998         default:
11999             /* no warning */
12000             break;
12001         }
12002     }
12003     return ck_rfun(o);
12004 }
12005
12006 OP *
12007 Perl_ck_readline(pTHX_ OP *o)
12008 {
12009     PERL_ARGS_ASSERT_CK_READLINE;
12010
12011     if (o->op_flags & OPf_KIDS) {
12012          OP *kid = cLISTOPo->op_first;
12013          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12014     }
12015     else {
12016         OP * const newop
12017             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12018         op_free(o);
12019         return newop;
12020     }
12021     return o;
12022 }
12023
12024 OP *
12025 Perl_ck_rfun(pTHX_ OP *o)
12026 {
12027     const OPCODE type = o->op_type;
12028
12029     PERL_ARGS_ASSERT_CK_RFUN;
12030
12031     return refkids(ck_fun(o), type);
12032 }
12033
12034 OP *
12035 Perl_ck_listiob(pTHX_ OP *o)
12036 {
12037     OP *kid;
12038
12039     PERL_ARGS_ASSERT_CK_LISTIOB;
12040
12041     kid = cLISTOPo->op_first;
12042     if (!kid) {
12043         o = force_list(o, 1);
12044         kid = cLISTOPo->op_first;
12045     }
12046     if (kid->op_type == OP_PUSHMARK)
12047         kid = OpSIBLING(kid);
12048     if (kid && o->op_flags & OPf_STACKED)
12049         kid = OpSIBLING(kid);
12050     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12051         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12052          && !kid->op_folded) {
12053             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12054             scalar(kid);
12055             /* replace old const op with new OP_RV2GV parent */
12056             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12057                                         OP_RV2GV, OPf_REF);
12058             kid = OpSIBLING(kid);
12059         }
12060     }
12061
12062     if (!kid)
12063         op_append_elem(o->op_type, o, newDEFSVOP());
12064
12065     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12066     return listkids(o);
12067 }
12068
12069 OP *
12070 Perl_ck_smartmatch(pTHX_ OP *o)
12071 {
12072     dVAR;
12073     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12074     if (0 == (o->op_flags & OPf_SPECIAL)) {
12075         OP *first  = cBINOPo->op_first;
12076         OP *second = OpSIBLING(first);
12077
12078         /* Implicitly take a reference to an array or hash */
12079
12080         /* remove the original two siblings, then add back the
12081          * (possibly different) first and second sibs.
12082          */
12083         op_sibling_splice(o, NULL, 1, NULL);
12084         op_sibling_splice(o, NULL, 1, NULL);
12085         first  = ref_array_or_hash(first);
12086         second = ref_array_or_hash(second);
12087         op_sibling_splice(o, NULL, 0, second);
12088         op_sibling_splice(o, NULL, 0, first);
12089
12090         /* Implicitly take a reference to a regular expression */
12091         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12092             OpTYPE_set(first, OP_QR);
12093         }
12094         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12095             OpTYPE_set(second, OP_QR);
12096         }
12097     }
12098
12099     return o;
12100 }
12101
12102
12103 static OP *
12104 S_maybe_targlex(pTHX_ OP *o)
12105 {
12106     OP * const kid = cLISTOPo->op_first;
12107     /* has a disposable target? */
12108     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12109         && !(kid->op_flags & OPf_STACKED)
12110         /* Cannot steal the second time! */
12111         && !(kid->op_private & OPpTARGET_MY)
12112         )
12113     {
12114         OP * const kkid = OpSIBLING(kid);
12115
12116         /* Can just relocate the target. */
12117         if (kkid && kkid->op_type == OP_PADSV
12118             && (!(kkid->op_private & OPpLVAL_INTRO)
12119                || kkid->op_private & OPpPAD_STATE))
12120         {
12121             kid->op_targ = kkid->op_targ;
12122             kkid->op_targ = 0;
12123             /* Now we do not need PADSV and SASSIGN.
12124              * Detach kid and free the rest. */
12125             op_sibling_splice(o, NULL, 1, NULL);
12126             op_free(o);
12127             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12128             return kid;
12129         }
12130     }
12131     return o;
12132 }
12133
12134 OP *
12135 Perl_ck_sassign(pTHX_ OP *o)
12136 {
12137     dVAR;
12138     OP * const kid = cBINOPo->op_first;
12139
12140     PERL_ARGS_ASSERT_CK_SASSIGN;
12141
12142     if (OpHAS_SIBLING(kid)) {
12143         OP *kkid = OpSIBLING(kid);
12144         /* For state variable assignment with attributes, kkid is a list op
12145            whose op_last is a padsv. */
12146         if ((kkid->op_type == OP_PADSV ||
12147              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12148               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12149              )
12150             )
12151                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12152                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12153             return S_newONCEOP(aTHX_ o, kkid);
12154         }
12155     }
12156     return S_maybe_targlex(aTHX_ o);
12157 }
12158
12159
12160 OP *
12161 Perl_ck_match(pTHX_ OP *o)
12162 {
12163     PERL_UNUSED_CONTEXT;
12164     PERL_ARGS_ASSERT_CK_MATCH;
12165
12166     return o;
12167 }
12168
12169 OP *
12170 Perl_ck_method(pTHX_ OP *o)
12171 {
12172     SV *sv, *methsv, *rclass;
12173     const char* method;
12174     char* compatptr;
12175     int utf8;
12176     STRLEN len, nsplit = 0, i;
12177     OP* new_op;
12178     OP * const kid = cUNOPo->op_first;
12179
12180     PERL_ARGS_ASSERT_CK_METHOD;
12181     if (kid->op_type != OP_CONST) return o;
12182
12183     sv = kSVOP->op_sv;
12184
12185     /* replace ' with :: */
12186     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12187                                         SvEND(sv) - SvPVX(sv) )))
12188     {
12189         *compatptr = ':';
12190         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12191     }
12192
12193     method = SvPVX_const(sv);
12194     len = SvCUR(sv);
12195     utf8 = SvUTF8(sv) ? -1 : 1;
12196
12197     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12198         nsplit = i+1;
12199         break;
12200     }
12201
12202     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12203
12204     if (!nsplit) { /* $proto->method() */
12205         op_free(o);
12206         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12207     }
12208
12209     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12210         op_free(o);
12211         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12212     }
12213
12214     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12215     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12216         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12217         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12218     } else {
12219         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12220         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12221     }
12222 #ifdef USE_ITHREADS
12223     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12224 #else
12225     cMETHOPx(new_op)->op_rclass_sv = rclass;
12226 #endif
12227     op_free(o);
12228     return new_op;
12229 }
12230
12231 OP *
12232 Perl_ck_null(pTHX_ OP *o)
12233 {
12234     PERL_ARGS_ASSERT_CK_NULL;
12235     PERL_UNUSED_CONTEXT;
12236     return o;
12237 }
12238
12239 OP *
12240 Perl_ck_open(pTHX_ OP *o)
12241 {
12242     PERL_ARGS_ASSERT_CK_OPEN;
12243
12244     S_io_hints(aTHX_ o);
12245     {
12246          /* In case of three-arg dup open remove strictness
12247           * from the last arg if it is a bareword. */
12248          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12249          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12250          OP *oa;
12251          const char *mode;
12252
12253          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12254              (last->op_private & OPpCONST_BARE) &&
12255              (last->op_private & OPpCONST_STRICT) &&
12256              (oa = OpSIBLING(first)) &&         /* The fh. */
12257              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12258              (oa->op_type == OP_CONST) &&
12259              SvPOK(((SVOP*)oa)->op_sv) &&
12260              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12261              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12262              (last == OpSIBLING(oa)))                   /* The bareword. */
12263               last->op_private &= ~OPpCONST_STRICT;
12264     }
12265     return ck_fun(o);
12266 }
12267
12268 OP *
12269 Perl_ck_prototype(pTHX_ OP *o)
12270 {
12271     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12272     if (!(o->op_flags & OPf_KIDS)) {
12273         op_free(o);
12274         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12275     }
12276     return o;
12277 }
12278
12279 OP *
12280 Perl_ck_refassign(pTHX_ OP *o)
12281 {
12282     OP * const right = cLISTOPo->op_first;
12283     OP * const left = OpSIBLING(right);
12284     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12285     bool stacked = 0;
12286
12287     PERL_ARGS_ASSERT_CK_REFASSIGN;
12288     assert (left);
12289     assert (left->op_type == OP_SREFGEN);
12290
12291     o->op_private = 0;
12292     /* we use OPpPAD_STATE in refassign to mean either of those things,
12293      * and the code assumes the two flags occupy the same bit position
12294      * in the various ops below */
12295     assert(OPpPAD_STATE == OPpOUR_INTRO);
12296
12297     switch (varop->op_type) {
12298     case OP_PADAV:
12299         o->op_private |= OPpLVREF_AV;
12300         goto settarg;
12301     case OP_PADHV:
12302         o->op_private |= OPpLVREF_HV;
12303         /* FALLTHROUGH */
12304     case OP_PADSV:
12305       settarg:
12306         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12307         o->op_targ = varop->op_targ;
12308         varop->op_targ = 0;
12309         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12310         break;
12311
12312     case OP_RV2AV:
12313         o->op_private |= OPpLVREF_AV;
12314         goto checkgv;
12315         NOT_REACHED; /* NOTREACHED */
12316     case OP_RV2HV:
12317         o->op_private |= OPpLVREF_HV;
12318         /* FALLTHROUGH */
12319     case OP_RV2SV:
12320       checkgv:
12321         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12322         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12323       detach_and_stack:
12324         /* Point varop to its GV kid, detached.  */
12325         varop = op_sibling_splice(varop, NULL, -1, NULL);
12326         stacked = TRUE;
12327         break;
12328     case OP_RV2CV: {
12329         OP * const kidparent =
12330             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12331         OP * const kid = cUNOPx(kidparent)->op_first;
12332         o->op_private |= OPpLVREF_CV;
12333         if (kid->op_type == OP_GV) {
12334             varop = kidparent;
12335             goto detach_and_stack;
12336         }
12337         if (kid->op_type != OP_PADCV)   goto bad;
12338         o->op_targ = kid->op_targ;
12339         kid->op_targ = 0;
12340         break;
12341     }
12342     case OP_AELEM:
12343     case OP_HELEM:
12344         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12345         o->op_private |= OPpLVREF_ELEM;
12346         op_null(varop);
12347         stacked = TRUE;
12348         /* Detach varop.  */
12349         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12350         break;
12351     default:
12352       bad:
12353         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12354         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12355                                 "assignment",
12356                                  OP_DESC(varop)));
12357         return o;
12358     }
12359     if (!FEATURE_REFALIASING_IS_ENABLED)
12360         Perl_croak(aTHX_
12361                   "Experimental aliasing via reference not enabled");
12362     Perl_ck_warner_d(aTHX_
12363                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12364                     "Aliasing via reference is experimental");
12365     if (stacked) {
12366         o->op_flags |= OPf_STACKED;
12367         op_sibling_splice(o, right, 1, varop);
12368     }
12369     else {
12370         o->op_flags &=~ OPf_STACKED;
12371         op_sibling_splice(o, right, 1, NULL);
12372     }
12373     op_free(left);
12374     return o;
12375 }
12376
12377 OP *
12378 Perl_ck_repeat(pTHX_ OP *o)
12379 {
12380     PERL_ARGS_ASSERT_CK_REPEAT;
12381
12382     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12383         OP* kids;
12384         o->op_private |= OPpREPEAT_DOLIST;
12385         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12386         kids = force_list(kids, 1); /* promote it to a list */
12387         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12388     }
12389     else
12390         scalar(o);
12391     return o;
12392 }
12393
12394 OP *
12395 Perl_ck_require(pTHX_ OP *o)
12396 {
12397     GV* gv;
12398
12399     PERL_ARGS_ASSERT_CK_REQUIRE;
12400
12401     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12402         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12403         U32 hash;
12404         char *s;
12405         STRLEN len;
12406         if (kid->op_type == OP_CONST) {
12407           SV * const sv = kid->op_sv;
12408           U32 const was_readonly = SvREADONLY(sv);
12409           if (kid->op_private & OPpCONST_BARE) {
12410             dVAR;
12411             const char *end;
12412             HEK *hek;
12413
12414             if (was_readonly) {
12415                     SvREADONLY_off(sv);
12416             }
12417             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12418
12419             s = SvPVX(sv);
12420             len = SvCUR(sv);
12421             end = s + len;
12422             /* treat ::foo::bar as foo::bar */
12423             if (len >= 2 && s[0] == ':' && s[1] == ':')
12424                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12425             if (s == end)
12426                 DIE(aTHX_ "Bareword in require maps to empty filename");
12427
12428             for (; s < end; s++) {
12429                 if (*s == ':' && s[1] == ':') {
12430                     *s = '/';
12431                     Move(s+2, s+1, end - s - 1, char);
12432                     --end;
12433                 }
12434             }
12435             SvEND_set(sv, end);
12436             sv_catpvs(sv, ".pm");
12437             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12438             hek = share_hek(SvPVX(sv),
12439                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12440                             hash);
12441             sv_sethek(sv, hek);
12442             unshare_hek(hek);
12443             SvFLAGS(sv) |= was_readonly;
12444           }
12445           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12446                 && !SvVOK(sv)) {
12447             s = SvPV(sv, len);
12448             if (SvREFCNT(sv) > 1) {
12449                 kid->op_sv = newSVpvn_share(
12450                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12451                 SvREFCNT_dec_NN(sv);
12452             }
12453             else {
12454                 dVAR;
12455                 HEK *hek;
12456                 if (was_readonly) SvREADONLY_off(sv);
12457                 PERL_HASH(hash, s, len);
12458                 hek = share_hek(s,
12459                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12460                                 hash);
12461                 sv_sethek(sv, hek);
12462                 unshare_hek(hek);
12463                 SvFLAGS(sv) |= was_readonly;
12464             }
12465           }
12466         }
12467     }
12468
12469     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12470         /* handle override, if any */
12471      && (gv = gv_override("require", 7))) {
12472         OP *kid, *newop;
12473         if (o->op_flags & OPf_KIDS) {
12474             kid = cUNOPo->op_first;
12475             op_sibling_splice(o, NULL, -1, NULL);
12476         }
12477         else {
12478             kid = newDEFSVOP();
12479         }
12480         op_free(o);
12481         newop = S_new_entersubop(aTHX_ gv, kid);
12482         return newop;
12483     }
12484
12485     return ck_fun(o);
12486 }
12487
12488 OP *
12489 Perl_ck_return(pTHX_ OP *o)
12490 {
12491     OP *kid;
12492
12493     PERL_ARGS_ASSERT_CK_RETURN;
12494
12495     kid = OpSIBLING(cLISTOPo->op_first);
12496     if (PL_compcv && CvLVALUE(PL_compcv)) {
12497         for (; kid; kid = OpSIBLING(kid))
12498             op_lvalue(kid, OP_LEAVESUBLV);
12499     }
12500
12501     return o;
12502 }
12503
12504 OP *
12505 Perl_ck_select(pTHX_ OP *o)
12506 {
12507     dVAR;
12508     OP* kid;
12509
12510     PERL_ARGS_ASSERT_CK_SELECT;
12511
12512     if (o->op_flags & OPf_KIDS) {
12513         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12514         if (kid && OpHAS_SIBLING(kid)) {
12515             OpTYPE_set(o, OP_SSELECT);
12516             o = ck_fun(o);
12517             return fold_constants(op_integerize(op_std_init(o)));
12518         }
12519     }
12520     o = ck_fun(o);
12521     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12522     if (kid && kid->op_type == OP_RV2GV)
12523         kid->op_private &= ~HINT_STRICT_REFS;
12524     return o;
12525 }
12526
12527 OP *
12528 Perl_ck_shift(pTHX_ OP *o)
12529 {
12530     const I32 type = o->op_type;
12531
12532     PERL_ARGS_ASSERT_CK_SHIFT;
12533
12534     if (!(o->op_flags & OPf_KIDS)) {
12535         OP *argop;
12536
12537         if (!CvUNIQUE(PL_compcv)) {
12538             o->op_flags |= OPf_SPECIAL;
12539             return o;
12540         }
12541
12542         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12543         op_free(o);
12544         return newUNOP(type, 0, scalar(argop));
12545     }
12546     return scalar(ck_fun(o));
12547 }
12548
12549 OP *
12550 Perl_ck_sort(pTHX_ OP *o)
12551 {
12552     OP *firstkid;
12553     OP *kid;
12554     HV * const hinthv =
12555         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12556     U8 stacked;
12557
12558     PERL_ARGS_ASSERT_CK_SORT;
12559
12560     if (hinthv) {
12561             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12562             if (svp) {
12563                 const I32 sorthints = (I32)SvIV(*svp);
12564                 if ((sorthints & HINT_SORT_STABLE) != 0)
12565                     o->op_private |= OPpSORT_STABLE;
12566                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12567                     o->op_private |= OPpSORT_UNSTABLE;
12568             }
12569     }
12570
12571     if (o->op_flags & OPf_STACKED)
12572         simplify_sort(o);
12573     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12574
12575     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12576         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12577
12578         /* if the first arg is a code block, process it and mark sort as
12579          * OPf_SPECIAL */
12580         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12581             LINKLIST(kid);
12582             if (kid->op_type == OP_LEAVE)
12583                     op_null(kid);                       /* wipe out leave */
12584             /* Prevent execution from escaping out of the sort block. */
12585             kid->op_next = 0;
12586
12587             /* provide scalar context for comparison function/block */
12588             kid = scalar(firstkid);
12589             kid->op_next = kid;
12590             o->op_flags |= OPf_SPECIAL;
12591         }
12592         else if (kid->op_type == OP_CONST
12593               && kid->op_private & OPpCONST_BARE) {
12594             char tmpbuf[256];
12595             STRLEN len;
12596             PADOFFSET off;
12597             const char * const name = SvPV(kSVOP_sv, len);
12598             *tmpbuf = '&';
12599             assert (len < 256);
12600             Copy(name, tmpbuf+1, len, char);
12601             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12602             if (off != NOT_IN_PAD) {
12603                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12604                     SV * const fq =
12605                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12606                     sv_catpvs(fq, "::");
12607                     sv_catsv(fq, kSVOP_sv);
12608                     SvREFCNT_dec_NN(kSVOP_sv);
12609                     kSVOP->op_sv = fq;
12610                 }
12611                 else {
12612                     OP * const padop = newOP(OP_PADCV, 0);
12613                     padop->op_targ = off;
12614                     /* replace the const op with the pad op */
12615                     op_sibling_splice(firstkid, NULL, 1, padop);
12616                     op_free(kid);
12617                 }
12618             }
12619         }
12620
12621         firstkid = OpSIBLING(firstkid);
12622     }
12623
12624     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12625         /* provide list context for arguments */
12626         list(kid);
12627         if (stacked)
12628             op_lvalue(kid, OP_GREPSTART);
12629     }
12630
12631     return o;
12632 }
12633
12634 /* for sort { X } ..., where X is one of
12635  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12636  * elide the second child of the sort (the one containing X),
12637  * and set these flags as appropriate
12638         OPpSORT_NUMERIC;
12639         OPpSORT_INTEGER;
12640         OPpSORT_DESCEND;
12641  * Also, check and warn on lexical $a, $b.
12642  */
12643
12644 STATIC void
12645 S_simplify_sort(pTHX_ OP *o)
12646 {
12647     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12648     OP *k;
12649     int descending;
12650     GV *gv;
12651     const char *gvname;
12652     bool have_scopeop;
12653
12654     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12655
12656     kid = kUNOP->op_first;                              /* get past null */
12657     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12658      && kid->op_type != OP_LEAVE)
12659         return;
12660     kid = kLISTOP->op_last;                             /* get past scope */
12661     switch(kid->op_type) {
12662         case OP_NCMP:
12663         case OP_I_NCMP:
12664         case OP_SCMP:
12665             if (!have_scopeop) goto padkids;
12666             break;
12667         default:
12668             return;
12669     }
12670     k = kid;                                            /* remember this node*/
12671     if (kBINOP->op_first->op_type != OP_RV2SV
12672      || kBINOP->op_last ->op_type != OP_RV2SV)
12673     {
12674         /*
12675            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12676            then used in a comparison.  This catches most, but not
12677            all cases.  For instance, it catches
12678                sort { my($a); $a <=> $b }
12679            but not
12680                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12681            (although why you'd do that is anyone's guess).
12682         */
12683
12684        padkids:
12685         if (!ckWARN(WARN_SYNTAX)) return;
12686         kid = kBINOP->op_first;
12687         do {
12688             if (kid->op_type == OP_PADSV) {
12689                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12690                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12691                  && (  PadnamePV(name)[1] == 'a'
12692                     || PadnamePV(name)[1] == 'b'  ))
12693                     /* diag_listed_as: "my %s" used in sort comparison */
12694                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12695                                      "\"%s %s\" used in sort comparison",
12696                                       PadnameIsSTATE(name)
12697                                         ? "state"
12698                                         : "my",
12699                                       PadnamePV(name));
12700             }
12701         } while ((kid = OpSIBLING(kid)));
12702         return;
12703     }
12704     kid = kBINOP->op_first;                             /* get past cmp */
12705     if (kUNOP->op_first->op_type != OP_GV)
12706         return;
12707     kid = kUNOP->op_first;                              /* get past rv2sv */
12708     gv = kGVOP_gv;
12709     if (GvSTASH(gv) != PL_curstash)
12710         return;
12711     gvname = GvNAME(gv);
12712     if (*gvname == 'a' && gvname[1] == '\0')
12713         descending = 0;
12714     else if (*gvname == 'b' && gvname[1] == '\0')
12715         descending = 1;
12716     else
12717         return;
12718
12719     kid = k;                                            /* back to cmp */
12720     /* already checked above that it is rv2sv */
12721     kid = kBINOP->op_last;                              /* down to 2nd arg */
12722     if (kUNOP->op_first->op_type != OP_GV)
12723         return;
12724     kid = kUNOP->op_first;                              /* get past rv2sv */
12725     gv = kGVOP_gv;
12726     if (GvSTASH(gv) != PL_curstash)
12727         return;
12728     gvname = GvNAME(gv);
12729     if ( descending
12730          ? !(*gvname == 'a' && gvname[1] == '\0')
12731          : !(*gvname == 'b' && gvname[1] == '\0'))
12732         return;
12733     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12734     if (descending)
12735         o->op_private |= OPpSORT_DESCEND;
12736     if (k->op_type == OP_NCMP)
12737         o->op_private |= OPpSORT_NUMERIC;
12738     if (k->op_type == OP_I_NCMP)
12739         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12740     kid = OpSIBLING(cLISTOPo->op_first);
12741     /* cut out and delete old block (second sibling) */
12742     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12743     op_free(kid);
12744 }
12745
12746 OP *
12747 Perl_ck_split(pTHX_ OP *o)
12748 {
12749     dVAR;
12750     OP *kid;
12751     OP *sibs;
12752
12753     PERL_ARGS_ASSERT_CK_SPLIT;
12754
12755     assert(o->op_type == OP_LIST);
12756
12757     if (o->op_flags & OPf_STACKED)
12758         return no_fh_allowed(o);
12759
12760     kid = cLISTOPo->op_first;
12761     /* delete leading NULL node, then add a CONST if no other nodes */
12762     assert(kid->op_type == OP_NULL);
12763     op_sibling_splice(o, NULL, 1,
12764         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12765     op_free(kid);
12766     kid = cLISTOPo->op_first;
12767
12768     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12769         /* remove match expression, and replace with new optree with
12770          * a match op at its head */
12771         op_sibling_splice(o, NULL, 1, NULL);
12772         /* pmruntime will handle split " " behavior with flag==2 */
12773         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12774         op_sibling_splice(o, NULL, 0, kid);
12775     }
12776
12777     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12778
12779     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12780       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12781                      "Use of /g modifier is meaningless in split");
12782     }
12783
12784     /* eliminate the split op, and move the match op (plus any children)
12785      * into its place, then convert the match op into a split op. i.e.
12786      *
12787      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12788      *    |                        |                     |
12789      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12790      *    |                        |                     |
12791      *    R                        X - Y                 X - Y
12792      *    |
12793      *    X - Y
12794      *
12795      * (R, if it exists, will be a regcomp op)
12796      */
12797
12798     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12799     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12800     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12801     OpTYPE_set(kid, OP_SPLIT);
12802     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12803     kid->op_private = o->op_private;
12804     op_free(o);
12805     o = kid;
12806     kid = sibs; /* kid is now the string arg of the split */
12807
12808     if (!kid) {
12809         kid = newDEFSVOP();
12810         op_append_elem(OP_SPLIT, o, kid);
12811     }
12812     scalar(kid);
12813
12814     kid = OpSIBLING(kid);
12815     if (!kid) {
12816         kid = newSVOP(OP_CONST, 0, newSViv(0));
12817         op_append_elem(OP_SPLIT, o, kid);
12818         o->op_private |= OPpSPLIT_IMPLIM;
12819     }
12820     scalar(kid);
12821
12822     if (OpHAS_SIBLING(kid))
12823         return too_many_arguments_pv(o,OP_DESC(o), 0);
12824
12825     return o;
12826 }
12827
12828 OP *
12829 Perl_ck_stringify(pTHX_ OP *o)
12830 {
12831     OP * const kid = OpSIBLING(cUNOPo->op_first);
12832     PERL_ARGS_ASSERT_CK_STRINGIFY;
12833     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12834          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12835          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12836         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12837     {
12838         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12839         op_free(o);
12840         return kid;
12841     }
12842     return ck_fun(o);
12843 }
12844
12845 OP *
12846 Perl_ck_join(pTHX_ OP *o)
12847 {
12848     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12849
12850     PERL_ARGS_ASSERT_CK_JOIN;
12851
12852     if (kid && kid->op_type == OP_MATCH) {
12853         if (ckWARN(WARN_SYNTAX)) {
12854             const REGEXP *re = PM_GETRE(kPMOP);
12855             const SV *msg = re
12856                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12857                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12858                     : newSVpvs_flags( "STRING", SVs_TEMP );
12859             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12860                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12861                         SVfARG(msg), SVfARG(msg));
12862         }
12863     }
12864     if (kid
12865      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12866         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12867         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12868            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12869     {
12870         const OP * const bairn = OpSIBLING(kid); /* the list */
12871         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12872          && OP_GIMME(bairn,0) == G_SCALAR)
12873         {
12874             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12875                                      op_sibling_splice(o, kid, 1, NULL));
12876             op_free(o);
12877             return ret;
12878         }
12879     }
12880
12881     return ck_fun(o);
12882 }
12883
12884 /*
12885 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12886
12887 Examines an op, which is expected to identify a subroutine at runtime,
12888 and attempts to determine at compile time which subroutine it identifies.
12889 This is normally used during Perl compilation to determine whether
12890 a prototype can be applied to a function call.  C<cvop> is the op
12891 being considered, normally an C<rv2cv> op.  A pointer to the identified
12892 subroutine is returned, if it could be determined statically, and a null
12893 pointer is returned if it was not possible to determine statically.
12894
12895 Currently, the subroutine can be identified statically if the RV that the
12896 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12897 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12898 suitable if the constant value must be an RV pointing to a CV.  Details of
12899 this process may change in future versions of Perl.  If the C<rv2cv> op
12900 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12901 the subroutine statically: this flag is used to suppress compile-time
12902 magic on a subroutine call, forcing it to use default runtime behaviour.
12903
12904 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12905 of a GV reference is modified.  If a GV was examined and its CV slot was
12906 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12907 If the op is not optimised away, and the CV slot is later populated with
12908 a subroutine having a prototype, that flag eventually triggers the warning
12909 "called too early to check prototype".
12910
12911 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12912 of returning a pointer to the subroutine it returns a pointer to the
12913 GV giving the most appropriate name for the subroutine in this context.
12914 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12915 (C<CvANON>) subroutine that is referenced through a GV it will be the
12916 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12917 A null pointer is returned as usual if there is no statically-determinable
12918 subroutine.
12919
12920 =cut
12921 */
12922
12923 /* shared by toke.c:yylex */
12924 CV *
12925 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12926 {
12927     PADNAME *name = PAD_COMPNAME(off);
12928     CV *compcv = PL_compcv;
12929     while (PadnameOUTER(name)) {
12930         assert(PARENT_PAD_INDEX(name));
12931         compcv = CvOUTSIDE(compcv);
12932         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12933                 [off = PARENT_PAD_INDEX(name)];
12934     }
12935     assert(!PadnameIsOUR(name));
12936     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12937         return PadnamePROTOCV(name);
12938     }
12939     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12940 }
12941
12942 CV *
12943 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12944 {
12945     OP *rvop;
12946     CV *cv;
12947     GV *gv;
12948     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12949     if (flags & ~RV2CVOPCV_FLAG_MASK)
12950         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12951     if (cvop->op_type != OP_RV2CV)
12952         return NULL;
12953     if (cvop->op_private & OPpENTERSUB_AMPER)
12954         return NULL;
12955     if (!(cvop->op_flags & OPf_KIDS))
12956         return NULL;
12957     rvop = cUNOPx(cvop)->op_first;
12958     switch (rvop->op_type) {
12959         case OP_GV: {
12960             gv = cGVOPx_gv(rvop);
12961             if (!isGV(gv)) {
12962                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12963                     cv = MUTABLE_CV(SvRV(gv));
12964                     gv = NULL;
12965                     break;
12966                 }
12967                 if (flags & RV2CVOPCV_RETURN_STUB)
12968                     return (CV *)gv;
12969                 else return NULL;
12970             }
12971             cv = GvCVu(gv);
12972             if (!cv) {
12973                 if (flags & RV2CVOPCV_MARK_EARLY)
12974                     rvop->op_private |= OPpEARLY_CV;
12975                 return NULL;
12976             }
12977         } break;
12978         case OP_CONST: {
12979             SV *rv = cSVOPx_sv(rvop);
12980             if (!SvROK(rv))
12981                 return NULL;
12982             cv = (CV*)SvRV(rv);
12983             gv = NULL;
12984         } break;
12985         case OP_PADCV: {
12986             cv = find_lexical_cv(rvop->op_targ);
12987             gv = NULL;
12988         } break;
12989         default: {
12990             return NULL;
12991         } NOT_REACHED; /* NOTREACHED */
12992     }
12993     if (SvTYPE((SV*)cv) != SVt_PVCV)
12994         return NULL;
12995     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12996         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12997             gv = CvGV(cv);
12998         return (CV*)gv;
12999     }
13000     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13001         if (CvLEXICAL(cv) || CvNAMED(cv))
13002             return NULL;
13003         if (!CvANON(cv) || !gv)
13004             gv = CvGV(cv);
13005         return (CV*)gv;
13006
13007     } else {
13008         return cv;
13009     }
13010 }
13011
13012 /*
13013 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13014
13015 Performs the default fixup of the arguments part of an C<entersub>
13016 op tree.  This consists of applying list context to each of the
13017 argument ops.  This is the standard treatment used on a call marked
13018 with C<&>, or a method call, or a call through a subroutine reference,
13019 or any other call where the callee can't be identified at compile time,
13020 or a call where the callee has no prototype.
13021
13022 =cut
13023 */
13024
13025 OP *
13026 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13027 {
13028     OP *aop;
13029
13030     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13031
13032     aop = cUNOPx(entersubop)->op_first;
13033     if (!OpHAS_SIBLING(aop))
13034         aop = cUNOPx(aop)->op_first;
13035     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13036         /* skip the extra attributes->import() call implicitly added in
13037          * something like foo(my $x : bar)
13038          */
13039         if (   aop->op_type == OP_ENTERSUB
13040             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13041         )
13042             continue;
13043         list(aop);
13044         op_lvalue(aop, OP_ENTERSUB);
13045     }
13046     return entersubop;
13047 }
13048
13049 /*
13050 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13051
13052 Performs the fixup of the arguments part of an C<entersub> op tree
13053 based on a subroutine prototype.  This makes various modifications to
13054 the argument ops, from applying context up to inserting C<refgen> ops,
13055 and checking the number and syntactic types of arguments, as directed by
13056 the prototype.  This is the standard treatment used on a subroutine call,
13057 not marked with C<&>, where the callee can be identified at compile time
13058 and has a prototype.
13059
13060 C<protosv> supplies the subroutine prototype to be applied to the call.
13061 It may be a normal defined scalar, of which the string value will be used.
13062 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13063 that has been cast to C<SV*>) which has a prototype.  The prototype
13064 supplied, in whichever form, does not need to match the actual callee
13065 referenced by the op tree.
13066
13067 If the argument ops disagree with the prototype, for example by having
13068 an unacceptable number of arguments, a valid op tree is returned anyway.
13069 The error is reflected in the parser state, normally resulting in a single
13070 exception at the top level of parsing which covers all the compilation
13071 errors that occurred.  In the error message, the callee is referred to
13072 by the name defined by the C<namegv> parameter.
13073
13074 =cut
13075 */
13076
13077 OP *
13078 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13079 {
13080     STRLEN proto_len;
13081     const char *proto, *proto_end;
13082     OP *aop, *prev, *cvop, *parent;
13083     int optional = 0;
13084     I32 arg = 0;
13085     I32 contextclass = 0;
13086     const char *e = NULL;
13087     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13088     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13089         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13090                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13091     if (SvTYPE(protosv) == SVt_PVCV)
13092          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13093     else proto = SvPV(protosv, proto_len);
13094     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13095     proto_end = proto + proto_len;
13096     parent = entersubop;
13097     aop = cUNOPx(entersubop)->op_first;
13098     if (!OpHAS_SIBLING(aop)) {
13099         parent = aop;
13100         aop = cUNOPx(aop)->op_first;
13101     }
13102     prev = aop;
13103     aop = OpSIBLING(aop);
13104     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13105     while (aop != cvop) {
13106         OP* o3 = aop;
13107
13108         if (proto >= proto_end)
13109         {
13110             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13111             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13112                                         SVfARG(namesv)), SvUTF8(namesv));
13113             return entersubop;
13114         }
13115
13116         switch (*proto) {
13117             case ';':
13118                 optional = 1;
13119                 proto++;
13120                 continue;
13121             case '_':
13122                 /* _ must be at the end */
13123                 if (proto[1] && !strchr(";@%", proto[1]))
13124                     goto oops;
13125                 /* FALLTHROUGH */
13126             case '$':
13127                 proto++;
13128                 arg++;
13129                 scalar(aop);
13130                 break;
13131             case '%':
13132             case '@':
13133                 list(aop);
13134                 arg++;
13135                 break;
13136             case '&':
13137                 proto++;
13138                 arg++;
13139                 if (    o3->op_type != OP_UNDEF
13140                     && (o3->op_type != OP_SREFGEN
13141                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13142                                 != OP_ANONCODE
13143                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13144                                 != OP_RV2CV)))
13145                     bad_type_gv(arg, namegv, o3,
13146                             arg == 1 ? "block or sub {}" : "sub {}");
13147                 break;
13148             case '*':
13149                 /* '*' allows any scalar type, including bareword */
13150                 proto++;
13151                 arg++;
13152                 if (o3->op_type == OP_RV2GV)
13153                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13154                 else if (o3->op_type == OP_CONST)
13155                     o3->op_private &= ~OPpCONST_STRICT;
13156                 scalar(aop);
13157                 break;
13158             case '+':
13159                 proto++;
13160                 arg++;
13161                 if (o3->op_type == OP_RV2AV ||
13162                     o3->op_type == OP_PADAV ||
13163                     o3->op_type == OP_RV2HV ||
13164                     o3->op_type == OP_PADHV
13165                 ) {
13166                     goto wrapref;
13167                 }
13168                 scalar(aop);
13169                 break;
13170             case '[': case ']':
13171                 goto oops;
13172
13173             case '\\':
13174                 proto++;
13175                 arg++;
13176             again:
13177                 switch (*proto++) {
13178                     case '[':
13179                         if (contextclass++ == 0) {
13180                             e = (char *) memchr(proto, ']', proto_end - proto);
13181                             if (!e || e == proto)
13182                                 goto oops;
13183                         }
13184                         else
13185                             goto oops;
13186                         goto again;
13187
13188                     case ']':
13189                         if (contextclass) {
13190                             const char *p = proto;
13191                             const char *const end = proto;
13192                             contextclass = 0;
13193                             while (*--p != '[')
13194                                 /* \[$] accepts any scalar lvalue */
13195                                 if (*p == '$'
13196                                  && Perl_op_lvalue_flags(aTHX_
13197                                      scalar(o3),
13198                                      OP_READ, /* not entersub */
13199                                      OP_LVALUE_NO_CROAK
13200                                     )) goto wrapref;
13201                             bad_type_gv(arg, namegv, o3,
13202                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13203                         } else
13204                             goto oops;
13205                         break;
13206                     case '*':
13207                         if (o3->op_type == OP_RV2GV)
13208                             goto wrapref;
13209                         if (!contextclass)
13210                             bad_type_gv(arg, namegv, o3, "symbol");
13211                         break;
13212                     case '&':
13213                         if (o3->op_type == OP_ENTERSUB
13214                          && !(o3->op_flags & OPf_STACKED))
13215                             goto wrapref;
13216                         if (!contextclass)
13217                             bad_type_gv(arg, namegv, o3, "subroutine");
13218                         break;
13219                     case '$':
13220                         if (o3->op_type == OP_RV2SV ||
13221                                 o3->op_type == OP_PADSV ||
13222                                 o3->op_type == OP_HELEM ||
13223                                 o3->op_type == OP_AELEM)
13224                             goto wrapref;
13225                         if (!contextclass) {
13226                             /* \$ accepts any scalar lvalue */
13227                             if (Perl_op_lvalue_flags(aTHX_
13228                                     scalar(o3),
13229                                     OP_READ,  /* not entersub */
13230                                     OP_LVALUE_NO_CROAK
13231                                )) goto wrapref;
13232                             bad_type_gv(arg, namegv, o3, "scalar");
13233                         }
13234                         break;
13235                     case '@':
13236                         if (o3->op_type == OP_RV2AV ||
13237                                 o3->op_type == OP_PADAV)
13238                         {
13239                             o3->op_flags &=~ OPf_PARENS;
13240                             goto wrapref;
13241                         }
13242                         if (!contextclass)
13243                             bad_type_gv(arg, namegv, o3, "array");
13244                         break;
13245                     case '%':
13246                         if (o3->op_type == OP_RV2HV ||
13247                                 o3->op_type == OP_PADHV)
13248                         {
13249                             o3->op_flags &=~ OPf_PARENS;
13250                             goto wrapref;
13251                         }
13252                         if (!contextclass)
13253                             bad_type_gv(arg, namegv, o3, "hash");
13254                         break;
13255                     wrapref:
13256                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13257                                                 OP_REFGEN, 0);
13258                         if (contextclass && e) {
13259                             proto = e + 1;
13260                             contextclass = 0;
13261                         }
13262                         break;
13263                     default: goto oops;
13264                 }
13265                 if (contextclass)
13266                     goto again;
13267                 break;
13268             case ' ':
13269                 proto++;
13270                 continue;
13271             default:
13272             oops: {
13273                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13274                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13275                                   SVfARG(protosv));
13276             }
13277         }
13278
13279         op_lvalue(aop, OP_ENTERSUB);
13280         prev = aop;
13281         aop = OpSIBLING(aop);
13282     }
13283     if (aop == cvop && *proto == '_') {
13284         /* generate an access to $_ */
13285         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13286     }
13287     if (!optional && proto_end > proto &&
13288         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13289     {
13290         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13291         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13292                                     SVfARG(namesv)), SvUTF8(namesv));
13293     }
13294     return entersubop;
13295 }
13296
13297 /*
13298 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13299
13300 Performs the fixup of the arguments part of an C<entersub> op tree either
13301 based on a subroutine prototype or using default list-context processing.
13302 This is the standard treatment used on a subroutine call, not marked
13303 with C<&>, where the callee can be identified at compile time.
13304
13305 C<protosv> supplies the subroutine prototype to be applied to the call,
13306 or indicates that there is no prototype.  It may be a normal scalar,
13307 in which case if it is defined then the string value will be used
13308 as a prototype, and if it is undefined then there is no prototype.
13309 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13310 that has been cast to C<SV*>), of which the prototype will be used if it
13311 has one.  The prototype (or lack thereof) supplied, in whichever form,
13312 does not need to match the actual callee referenced by the op tree.
13313
13314 If the argument ops disagree with the prototype, for example by having
13315 an unacceptable number of arguments, a valid op tree is returned anyway.
13316 The error is reflected in the parser state, normally resulting in a single
13317 exception at the top level of parsing which covers all the compilation
13318 errors that occurred.  In the error message, the callee is referred to
13319 by the name defined by the C<namegv> parameter.
13320
13321 =cut
13322 */
13323
13324 OP *
13325 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13326         GV *namegv, SV *protosv)
13327 {
13328     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13329     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13330         return ck_entersub_args_proto(entersubop, namegv, protosv);
13331     else
13332         return ck_entersub_args_list(entersubop);
13333 }
13334
13335 OP *
13336 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13337 {
13338     IV cvflags = SvIVX(protosv);
13339     int opnum = cvflags & 0xffff;
13340     OP *aop = cUNOPx(entersubop)->op_first;
13341
13342     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13343
13344     if (!opnum) {
13345         OP *cvop;
13346         if (!OpHAS_SIBLING(aop))
13347             aop = cUNOPx(aop)->op_first;
13348         aop = OpSIBLING(aop);
13349         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13350         if (aop != cvop) {
13351             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13352             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13353                 SVfARG(namesv)), SvUTF8(namesv));
13354         }
13355
13356         op_free(entersubop);
13357         switch(cvflags >> 16) {
13358         case 'F': return newSVOP(OP_CONST, 0,
13359                                         newSVpv(CopFILE(PL_curcop),0));
13360         case 'L': return newSVOP(
13361                            OP_CONST, 0,
13362                            Perl_newSVpvf(aTHX_
13363                              "%" IVdf, (IV)CopLINE(PL_curcop)
13364                            )
13365                          );
13366         case 'P': return newSVOP(OP_CONST, 0,
13367                                    (PL_curstash
13368                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13369                                      : &PL_sv_undef
13370                                    )
13371                                 );
13372         }
13373         NOT_REACHED; /* NOTREACHED */
13374     }
13375     else {
13376         OP *prev, *cvop, *first, *parent;
13377         U32 flags = 0;
13378
13379         parent = entersubop;
13380         if (!OpHAS_SIBLING(aop)) {
13381             parent = aop;
13382             aop = cUNOPx(aop)->op_first;
13383         }
13384
13385         first = prev = aop;
13386         aop = OpSIBLING(aop);
13387         /* find last sibling */
13388         for (cvop = aop;
13389              OpHAS_SIBLING(cvop);
13390              prev = cvop, cvop = OpSIBLING(cvop))
13391             ;
13392         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13393             /* Usually, OPf_SPECIAL on an op with no args means that it had
13394              * parens, but these have their own meaning for that flag: */
13395             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13396             && opnum != OP_DELETE && opnum != OP_EXISTS)
13397                 flags |= OPf_SPECIAL;
13398         /* excise cvop from end of sibling chain */
13399         op_sibling_splice(parent, prev, 1, NULL);
13400         op_free(cvop);
13401         if (aop == cvop) aop = NULL;
13402
13403         /* detach remaining siblings from the first sibling, then
13404          * dispose of original optree */
13405
13406         if (aop)
13407             op_sibling_splice(parent, first, -1, NULL);
13408         op_free(entersubop);
13409
13410         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13411             flags |= OPpEVAL_BYTES <<8;
13412
13413         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13414         case OA_UNOP:
13415         case OA_BASEOP_OR_UNOP:
13416         case OA_FILESTATOP:
13417             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13418         case OA_BASEOP:
13419             if (aop) {
13420                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13421                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13422                     SVfARG(namesv)), SvUTF8(namesv));
13423                 op_free(aop);
13424             }
13425             return opnum == OP_RUNCV
13426                 ? newPVOP(OP_RUNCV,0,NULL)
13427                 : newOP(opnum,0);
13428         default:
13429             return op_convert_list(opnum,0,aop);
13430         }
13431     }
13432     NOT_REACHED; /* NOTREACHED */
13433     return entersubop;
13434 }
13435
13436 /*
13437 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13438
13439 Retrieves the function that will be used to fix up a call to C<cv>.
13440 Specifically, the function is applied to an C<entersub> op tree for a
13441 subroutine call, not marked with C<&>, where the callee can be identified
13442 at compile time as C<cv>.
13443
13444 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13445 for it is returned in C<*ckobj_p>, and control flags are returned in
13446 C<*ckflags_p>.  The function is intended to be called in this manner:
13447
13448  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13449
13450 In this call, C<entersubop> is a pointer to the C<entersub> op,
13451 which may be replaced by the check function, and C<namegv> supplies
13452 the name that should be used by the check function to refer
13453 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13454 It is permitted to apply the check function in non-standard situations,
13455 such as to a call to a different subroutine or to a method call.
13456
13457 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13458 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13459 instead, anything that can be used as the first argument to L</cv_name>.
13460 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13461 check function requires C<namegv> to be a genuine GV.
13462
13463 By default, the check function is
13464 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13465 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13466 flag is clear.  This implements standard prototype processing.  It can
13467 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13468
13469 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13470 indicates that the caller only knows about the genuine GV version of
13471 C<namegv>, and accordingly the corresponding bit will always be set in
13472 C<*ckflags_p>, regardless of the check function's recorded requirements.
13473 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13474 indicates the caller knows about the possibility of passing something
13475 other than a GV as C<namegv>, and accordingly the corresponding bit may
13476 be either set or clear in C<*ckflags_p>, indicating the check function's
13477 recorded requirements.
13478
13479 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13480 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13481 (for which see above).  All other bits should be clear.
13482
13483 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13484
13485 The original form of L</cv_get_call_checker_flags>, which does not return
13486 checker flags.  When using a checker function returned by this function,
13487 it is only safe to call it with a genuine GV as its C<namegv> argument.
13488
13489 =cut
13490 */
13491
13492 void
13493 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13494         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13495 {
13496     MAGIC *callmg;
13497     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13498     PERL_UNUSED_CONTEXT;
13499     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13500     if (callmg) {
13501         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13502         *ckobj_p = callmg->mg_obj;
13503         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13504     } else {
13505         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13506         *ckobj_p = (SV*)cv;
13507         *ckflags_p = gflags & MGf_REQUIRE_GV;
13508     }
13509 }
13510
13511 void
13512 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13513 {
13514     U32 ckflags;
13515     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13516     PERL_UNUSED_CONTEXT;
13517     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13518         &ckflags);
13519 }
13520
13521 /*
13522 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13523
13524 Sets the function that will be used to fix up a call to C<cv>.
13525 Specifically, the function is applied to an C<entersub> op tree for a
13526 subroutine call, not marked with C<&>, where the callee can be identified
13527 at compile time as C<cv>.
13528
13529 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13530 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13531 The function should be defined like this:
13532
13533     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13534
13535 It is intended to be called in this manner:
13536
13537     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13538
13539 In this call, C<entersubop> is a pointer to the C<entersub> op,
13540 which may be replaced by the check function, and C<namegv> supplies
13541 the name that should be used by the check function to refer
13542 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13543 It is permitted to apply the check function in non-standard situations,
13544 such as to a call to a different subroutine or to a method call.
13545
13546 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13547 CV or other SV instead.  Whatever is passed can be used as the first
13548 argument to L</cv_name>.  You can force perl to pass a GV by including
13549 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13550
13551 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13552 bit currently has a defined meaning (for which see above).  All other
13553 bits should be clear.
13554
13555 The current setting for a particular CV can be retrieved by
13556 L</cv_get_call_checker_flags>.
13557
13558 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13559
13560 The original form of L</cv_set_call_checker_flags>, which passes it the
13561 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13562 of that flag setting is that the check function is guaranteed to get a
13563 genuine GV as its C<namegv> argument.
13564
13565 =cut
13566 */
13567
13568 void
13569 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13570 {
13571     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13572     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13573 }
13574
13575 void
13576 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13577                                      SV *ckobj, U32 ckflags)
13578 {
13579     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13580     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13581         if (SvMAGICAL((SV*)cv))
13582             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13583     } else {
13584         MAGIC *callmg;
13585         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13586         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13587         assert(callmg);
13588         if (callmg->mg_flags & MGf_REFCOUNTED) {
13589             SvREFCNT_dec(callmg->mg_obj);
13590             callmg->mg_flags &= ~MGf_REFCOUNTED;
13591         }
13592         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13593         callmg->mg_obj = ckobj;
13594         if (ckobj != (SV*)cv) {
13595             SvREFCNT_inc_simple_void_NN(ckobj);
13596             callmg->mg_flags |= MGf_REFCOUNTED;
13597         }
13598         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13599                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13600     }
13601 }
13602
13603 static void
13604 S_entersub_alloc_targ(pTHX_ OP * const o)
13605 {
13606     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13607     o->op_private |= OPpENTERSUB_HASTARG;
13608 }
13609
13610 OP *
13611 Perl_ck_subr(pTHX_ OP *o)
13612 {
13613     OP *aop, *cvop;
13614     CV *cv;
13615     GV *namegv;
13616     SV **const_class = NULL;
13617
13618     PERL_ARGS_ASSERT_CK_SUBR;
13619
13620     aop = cUNOPx(o)->op_first;
13621     if (!OpHAS_SIBLING(aop))
13622         aop = cUNOPx(aop)->op_first;
13623     aop = OpSIBLING(aop);
13624     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13625     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13626     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13627
13628     o->op_private &= ~1;
13629     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13630     if (PERLDB_SUB && PL_curstash != PL_debstash)
13631         o->op_private |= OPpENTERSUB_DB;
13632     switch (cvop->op_type) {
13633         case OP_RV2CV:
13634             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13635             op_null(cvop);
13636             break;
13637         case OP_METHOD:
13638         case OP_METHOD_NAMED:
13639         case OP_METHOD_SUPER:
13640         case OP_METHOD_REDIR:
13641         case OP_METHOD_REDIR_SUPER:
13642             o->op_flags |= OPf_REF;
13643             if (aop->op_type == OP_CONST) {
13644                 aop->op_private &= ~OPpCONST_STRICT;
13645                 const_class = &cSVOPx(aop)->op_sv;
13646             }
13647             else if (aop->op_type == OP_LIST) {
13648                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13649                 if (sib && sib->op_type == OP_CONST) {
13650                     sib->op_private &= ~OPpCONST_STRICT;
13651                     const_class = &cSVOPx(sib)->op_sv;
13652                 }
13653             }
13654             /* make class name a shared cow string to speedup method calls */
13655             /* constant string might be replaced with object, f.e. bigint */
13656             if (const_class && SvPOK(*const_class)) {
13657                 STRLEN len;
13658                 const char* str = SvPV(*const_class, len);
13659                 if (len) {
13660                     SV* const shared = newSVpvn_share(
13661                         str, SvUTF8(*const_class)
13662                                     ? -(SSize_t)len : (SSize_t)len,
13663                         0
13664                     );
13665                     if (SvREADONLY(*const_class))
13666                         SvREADONLY_on(shared);
13667                     SvREFCNT_dec(*const_class);
13668                     *const_class = shared;
13669                 }
13670             }
13671             break;
13672     }
13673
13674     if (!cv) {
13675         S_entersub_alloc_targ(aTHX_ o);
13676         return ck_entersub_args_list(o);
13677     } else {
13678         Perl_call_checker ckfun;
13679         SV *ckobj;
13680         U32 ckflags;
13681         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13682         if (CvISXSUB(cv) || !CvROOT(cv))
13683             S_entersub_alloc_targ(aTHX_ o);
13684         if (!namegv) {
13685             /* The original call checker API guarantees that a GV will be
13686                be provided with the right name.  So, if the old API was
13687                used (or the REQUIRE_GV flag was passed), we have to reify
13688                the CV’s GV, unless this is an anonymous sub.  This is not
13689                ideal for lexical subs, as its stringification will include
13690                the package.  But it is the best we can do.  */
13691             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13692                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13693                     namegv = CvGV(cv);
13694             }
13695             else namegv = MUTABLE_GV(cv);
13696             /* After a syntax error in a lexical sub, the cv that
13697                rv2cv_op_cv returns may be a nameless stub. */
13698             if (!namegv) return ck_entersub_args_list(o);
13699
13700         }
13701         return ckfun(aTHX_ o, namegv, ckobj);
13702     }
13703 }
13704
13705 OP *
13706 Perl_ck_svconst(pTHX_ OP *o)
13707 {
13708     SV * const sv = cSVOPo->op_sv;
13709     PERL_ARGS_ASSERT_CK_SVCONST;
13710     PERL_UNUSED_CONTEXT;
13711 #ifdef PERL_COPY_ON_WRITE
13712     /* Since the read-only flag may be used to protect a string buffer, we
13713        cannot do copy-on-write with existing read-only scalars that are not
13714        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13715        that constant, mark the constant as COWable here, if it is not
13716        already read-only. */
13717     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13718         SvIsCOW_on(sv);
13719         CowREFCNT(sv) = 0;
13720 # ifdef PERL_DEBUG_READONLY_COW
13721         sv_buf_to_ro(sv);
13722 # endif
13723     }
13724 #endif
13725     SvREADONLY_on(sv);
13726     return o;
13727 }
13728
13729 OP *
13730 Perl_ck_trunc(pTHX_ OP *o)
13731 {
13732     PERL_ARGS_ASSERT_CK_TRUNC;
13733
13734     if (o->op_flags & OPf_KIDS) {
13735         SVOP *kid = (SVOP*)cUNOPo->op_first;
13736
13737         if (kid->op_type == OP_NULL)
13738             kid = (SVOP*)OpSIBLING(kid);
13739         if (kid && kid->op_type == OP_CONST &&
13740             (kid->op_private & OPpCONST_BARE) &&
13741             !kid->op_folded)
13742         {
13743             o->op_flags |= OPf_SPECIAL;
13744             kid->op_private &= ~OPpCONST_STRICT;
13745         }
13746     }
13747     return ck_fun(o);
13748 }
13749
13750 OP *
13751 Perl_ck_substr(pTHX_ OP *o)
13752 {
13753     PERL_ARGS_ASSERT_CK_SUBSTR;
13754
13755     o = ck_fun(o);
13756     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13757         OP *kid = cLISTOPo->op_first;
13758
13759         if (kid->op_type == OP_NULL)
13760             kid = OpSIBLING(kid);
13761         if (kid)
13762             /* Historically, substr(delete $foo{bar},...) has been allowed
13763                with 4-arg substr.  Keep it working by applying entersub
13764                lvalue context.  */
13765             op_lvalue(kid, OP_ENTERSUB);
13766
13767     }
13768     return o;
13769 }
13770
13771 OP *
13772 Perl_ck_tell(pTHX_ OP *o)
13773 {
13774     PERL_ARGS_ASSERT_CK_TELL;
13775     o = ck_fun(o);
13776     if (o->op_flags & OPf_KIDS) {
13777      OP *kid = cLISTOPo->op_first;
13778      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13779      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13780     }
13781     return o;
13782 }
13783
13784 OP *
13785 Perl_ck_each(pTHX_ OP *o)
13786 {
13787     dVAR;
13788     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13789     const unsigned orig_type  = o->op_type;
13790
13791     PERL_ARGS_ASSERT_CK_EACH;
13792
13793     if (kid) {
13794         switch (kid->op_type) {
13795             case OP_PADHV:
13796             case OP_RV2HV:
13797                 break;
13798             case OP_PADAV:
13799             case OP_RV2AV:
13800                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13801                             : orig_type == OP_KEYS ? OP_AKEYS
13802                             :                        OP_AVALUES);
13803                 break;
13804             case OP_CONST:
13805                 if (kid->op_private == OPpCONST_BARE
13806                  || !SvROK(cSVOPx_sv(kid))
13807                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13808                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13809                    )
13810                     goto bad;
13811                 /* FALLTHROUGH */
13812             default:
13813                 qerror(Perl_mess(aTHX_
13814                     "Experimental %s on scalar is now forbidden",
13815                      PL_op_desc[orig_type]));
13816                bad:
13817                 bad_type_pv(1, "hash or array", o, kid);
13818                 return o;
13819         }
13820     }
13821     return ck_fun(o);
13822 }
13823
13824 OP *
13825 Perl_ck_length(pTHX_ OP *o)
13826 {
13827     PERL_ARGS_ASSERT_CK_LENGTH;
13828
13829     o = ck_fun(o);
13830
13831     if (ckWARN(WARN_SYNTAX)) {
13832         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13833
13834         if (kid) {
13835             SV *name = NULL;
13836             const bool hash = kid->op_type == OP_PADHV
13837                            || kid->op_type == OP_RV2HV;
13838             switch (kid->op_type) {
13839                 case OP_PADHV:
13840                 case OP_PADAV:
13841                 case OP_RV2HV:
13842                 case OP_RV2AV:
13843                     name = S_op_varname(aTHX_ kid);
13844                     break;
13845                 default:
13846                     return o;
13847             }
13848             if (name)
13849                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13850                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13851                     ")\"?)",
13852                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13853                 );
13854             else if (hash)
13855      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13856                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13857                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13858             else
13859      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13860                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13861                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13862         }
13863     }
13864
13865     return o;
13866 }
13867
13868
13869
13870 /*
13871    ---------------------------------------------------------
13872
13873    Common vars in list assignment
13874
13875    There now follows some enums and static functions for detecting
13876    common variables in list assignments. Here is a little essay I wrote
13877    for myself when trying to get my head around this. DAPM.
13878
13879    ----
13880
13881    First some random observations:
13882
13883    * If a lexical var is an alias of something else, e.g.
13884        for my $x ($lex, $pkg, $a[0]) {...}
13885      then the act of aliasing will increase the reference count of the SV
13886
13887    * If a package var is an alias of something else, it may still have a
13888      reference count of 1, depending on how the alias was created, e.g.
13889      in *a = *b, $a may have a refcount of 1 since the GP is shared
13890      with a single GvSV pointer to the SV. So If it's an alias of another
13891      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13892      a lexical var or an array element, then it will have RC > 1.
13893
13894    * There are many ways to create a package alias; ultimately, XS code
13895      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13896      run-time tracing mechanisms are unlikely to be able to catch all cases.
13897
13898    * When the LHS is all my declarations, the same vars can't appear directly
13899      on the RHS, but they can indirectly via closures, aliasing and lvalue
13900      subs. But those techniques all involve an increase in the lexical
13901      scalar's ref count.
13902
13903    * When the LHS is all lexical vars (but not necessarily my declarations),
13904      it is possible for the same lexicals to appear directly on the RHS, and
13905      without an increased ref count, since the stack isn't refcounted.
13906      This case can be detected at compile time by scanning for common lex
13907      vars with PL_generation.
13908
13909    * lvalue subs defeat common var detection, but they do at least
13910      return vars with a temporary ref count increment. Also, you can't
13911      tell at compile time whether a sub call is lvalue.
13912
13913
13914    So...
13915
13916    A: There are a few circumstances where there definitely can't be any
13917      commonality:
13918
13919        LHS empty:  () = (...);
13920        RHS empty:  (....) = ();
13921        RHS contains only constants or other 'can't possibly be shared'
13922            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13923            i.e. they only contain ops not marked as dangerous, whose children
13924            are also not dangerous;
13925        LHS ditto;
13926        LHS contains a single scalar element: e.g. ($x) = (....); because
13927            after $x has been modified, it won't be used again on the RHS;
13928        RHS contains a single element with no aggregate on LHS: e.g.
13929            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13930            won't be used again.
13931
13932    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13933      we can ignore):
13934
13935        my ($a, $b, @c) = ...;
13936
13937        Due to closure and goto tricks, these vars may already have content.
13938        For the same reason, an element on the RHS may be a lexical or package
13939        alias of one of the vars on the left, or share common elements, for
13940        example:
13941
13942            my ($x,$y) = f(); # $x and $y on both sides
13943            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13944
13945        and
13946
13947            my $ra = f();
13948            my @a = @$ra;  # elements of @a on both sides
13949            sub f { @a = 1..4; \@a }
13950
13951
13952        First, just consider scalar vars on LHS:
13953
13954            RHS is safe only if (A), or in addition,
13955                * contains only lexical *scalar* vars, where neither side's
13956                  lexicals have been flagged as aliases
13957
13958            If RHS is not safe, then it's always legal to check LHS vars for
13959            RC==1, since the only RHS aliases will always be associated
13960            with an RC bump.
13961
13962            Note that in particular, RHS is not safe if:
13963
13964                * it contains package scalar vars; e.g.:
13965
13966                    f();
13967                    my ($x, $y) = (2, $x_alias);
13968                    sub f { $x = 1; *x_alias = \$x; }
13969
13970                * It contains other general elements, such as flattened or
13971                * spliced or single array or hash elements, e.g.
13972
13973                    f();
13974                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13975
13976                    sub f {
13977                        ($x, $y) = (1,2);
13978                        use feature 'refaliasing';
13979                        \($a[0], $a[1]) = \($y,$x);
13980                    }
13981
13982                  It doesn't matter if the array/hash is lexical or package.
13983
13984                * it contains a function call that happens to be an lvalue
13985                  sub which returns one or more of the above, e.g.
13986
13987                    f();
13988                    my ($x,$y) = f();
13989
13990                    sub f : lvalue {
13991                        ($x, $y) = (1,2);
13992                        *x1 = \$x;
13993                        $y, $x1;
13994                    }
13995
13996                    (so a sub call on the RHS should be treated the same
13997                    as having a package var on the RHS).
13998
13999                * any other "dangerous" thing, such an op or built-in that
14000                  returns one of the above, e.g. pp_preinc
14001
14002
14003            If RHS is not safe, what we can do however is at compile time flag
14004            that the LHS are all my declarations, and at run time check whether
14005            all the LHS have RC == 1, and if so skip the full scan.
14006
14007        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14008
14009            Here the issue is whether there can be elements of @a on the RHS
14010            which will get prematurely freed when @a is cleared prior to
14011            assignment. This is only a problem if the aliasing mechanism
14012            is one which doesn't increase the refcount - only if RC == 1
14013            will the RHS element be prematurely freed.
14014
14015            Because the array/hash is being INTROed, it or its elements
14016            can't directly appear on the RHS:
14017
14018                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14019
14020            but can indirectly, e.g.:
14021
14022                my $r = f();
14023                my (@a) = @$r;
14024                sub f { @a = 1..3; \@a }
14025
14026            So if the RHS isn't safe as defined by (A), we must always
14027            mortalise and bump the ref count of any remaining RHS elements
14028            when assigning to a non-empty LHS aggregate.
14029
14030            Lexical scalars on the RHS aren't safe if they've been involved in
14031            aliasing, e.g.
14032
14033                use feature 'refaliasing';
14034
14035                f();
14036                \(my $lex) = \$pkg;
14037                my @a = ($lex,3); # equivalent to ($a[0],3)
14038
14039                sub f {
14040                    @a = (1,2);
14041                    \$pkg = \$a[0];
14042                }
14043
14044            Similarly with lexical arrays and hashes on the RHS:
14045
14046                f();
14047                my @b;
14048                my @a = (@b);
14049
14050                sub f {
14051                    @a = (1,2);
14052                    \$b[0] = \$a[1];
14053                    \$b[1] = \$a[0];
14054                }
14055
14056
14057
14058    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14059        my $a; ($a, my $b) = (....);
14060
14061        The difference between (B) and (C) is that it is now physically
14062        possible for the LHS vars to appear on the RHS too, where they
14063        are not reference counted; but in this case, the compile-time
14064        PL_generation sweep will detect such common vars.
14065
14066        So the rules for (C) differ from (B) in that if common vars are
14067        detected, the runtime "test RC==1" optimisation can no longer be used,
14068        and a full mark and sweep is required
14069
14070    D: As (C), but in addition the LHS may contain package vars.
14071
14072        Since package vars can be aliased without a corresponding refcount
14073        increase, all bets are off. It's only safe if (A). E.g.
14074
14075            my ($x, $y) = (1,2);
14076
14077            for $x_alias ($x) {
14078                ($x_alias, $y) = (3, $x); # whoops
14079            }
14080
14081        Ditto for LHS aggregate package vars.
14082
14083    E: Any other dangerous ops on LHS, e.g.
14084            (f(), $a[0], @$r) = (...);
14085
14086        this is similar to (E) in that all bets are off. In addition, it's
14087        impossible to determine at compile time whether the LHS
14088        contains a scalar or an aggregate, e.g.
14089
14090            sub f : lvalue { @a }
14091            (f()) = 1..3;
14092
14093 * ---------------------------------------------------------
14094 */
14095
14096
14097 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14098  * that at least one of the things flagged was seen.
14099  */
14100
14101 enum {
14102     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14103     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14104     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14105     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14106     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14107     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14108     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14109     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14110                                          that's flagged OA_DANGEROUS */
14111     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14112                                         not in any of the categories above */
14113     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14114 };
14115
14116
14117
14118 /* helper function for S_aassign_scan().
14119  * check a PAD-related op for commonality and/or set its generation number.
14120  * Returns a boolean indicating whether its shared */
14121
14122 static bool
14123 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14124 {
14125     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14126         /* lexical used in aliasing */
14127         return TRUE;
14128
14129     if (rhs)
14130         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14131     else
14132         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14133
14134     return FALSE;
14135 }
14136
14137
14138 /*
14139   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14140   It scans the left or right hand subtree of the aassign op, and returns a
14141   set of flags indicating what sorts of things it found there.
14142   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14143   set PL_generation on lexical vars; if the latter, we see if
14144   PL_generation matches.
14145   'top' indicates whether we're recursing or at the top level.
14146   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14147   This fn will increment it by the number seen. It's not intended to
14148   be an accurate count (especially as many ops can push a variable
14149   number of SVs onto the stack); rather it's used as to test whether there
14150   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14151 */
14152
14153 static int
14154 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14155 {
14156     int flags = 0;
14157     bool kid_top = FALSE;
14158
14159     /* first, look for a solitary @_ on the RHS */
14160     if (   rhs
14161         && top
14162         && (o->op_flags & OPf_KIDS)
14163         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14164     ) {
14165         OP *kid = cUNOPo->op_first;
14166         if (   (   kid->op_type == OP_PUSHMARK
14167                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14168             && ((kid = OpSIBLING(kid)))
14169             && !OpHAS_SIBLING(kid)
14170             && kid->op_type == OP_RV2AV
14171             && !(kid->op_flags & OPf_REF)
14172             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14173             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14174             && ((kid = cUNOPx(kid)->op_first))
14175             && kid->op_type == OP_GV
14176             && cGVOPx_gv(kid) == PL_defgv
14177         )
14178             flags |= AAS_DEFAV;
14179     }
14180
14181     switch (o->op_type) {
14182     case OP_GVSV:
14183         (*scalars_p)++;
14184         return AAS_PKG_SCALAR;
14185
14186     case OP_PADAV:
14187     case OP_PADHV:
14188         (*scalars_p) += 2;
14189         /* if !top, could be e.g. @a[0,1] */
14190         if (top && (o->op_flags & OPf_REF))
14191             return (o->op_private & OPpLVAL_INTRO)
14192                 ? AAS_MY_AGG : AAS_LEX_AGG;
14193         return AAS_DANGEROUS;
14194
14195     case OP_PADSV:
14196         {
14197             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14198                         ?  AAS_LEX_SCALAR_COMM : 0;
14199             (*scalars_p)++;
14200             return (o->op_private & OPpLVAL_INTRO)
14201                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14202         }
14203
14204     case OP_RV2AV:
14205     case OP_RV2HV:
14206         (*scalars_p) += 2;
14207         if (cUNOPx(o)->op_first->op_type != OP_GV)
14208             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14209         /* @pkg, %pkg */
14210         /* if !top, could be e.g. @a[0,1] */
14211         if (top && (o->op_flags & OPf_REF))
14212             return AAS_PKG_AGG;
14213         return AAS_DANGEROUS;
14214
14215     case OP_RV2SV:
14216         (*scalars_p)++;
14217         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14218             (*scalars_p) += 2;
14219             return AAS_DANGEROUS; /* ${expr} */
14220         }
14221         return AAS_PKG_SCALAR; /* $pkg */
14222
14223     case OP_SPLIT:
14224         if (o->op_private & OPpSPLIT_ASSIGN) {
14225             /* the assign in @a = split() has been optimised away
14226              * and the @a attached directly to the split op
14227              * Treat the array as appearing on the RHS, i.e.
14228              *    ... = (@a = split)
14229              * is treated like
14230              *    ... = @a;
14231              */
14232
14233             if (o->op_flags & OPf_STACKED)
14234                 /* @{expr} = split() - the array expression is tacked
14235                  * on as an extra child to split - process kid */
14236                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14237                                         top, scalars_p);
14238
14239             /* ... else array is directly attached to split op */
14240             (*scalars_p) += 2;
14241             if (PL_op->op_private & OPpSPLIT_LEX)
14242                 return (o->op_private & OPpLVAL_INTRO)
14243                     ? AAS_MY_AGG : AAS_LEX_AGG;
14244             else
14245                 return AAS_PKG_AGG;
14246         }
14247         (*scalars_p)++;
14248         /* other args of split can't be returned */
14249         return AAS_SAFE_SCALAR;
14250
14251     case OP_UNDEF:
14252         /* undef counts as a scalar on the RHS:
14253          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14254          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14255          */
14256         if (rhs)
14257             (*scalars_p)++;
14258         flags = AAS_SAFE_SCALAR;
14259         break;
14260
14261     case OP_PUSHMARK:
14262     case OP_STUB:
14263         /* these are all no-ops; they don't push a potentially common SV
14264          * onto the stack, so they are neither AAS_DANGEROUS nor
14265          * AAS_SAFE_SCALAR */
14266         return 0;
14267
14268     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14269         break;
14270
14271     case OP_NULL:
14272     case OP_LIST:
14273         /* these do nothing but may have children; but their children
14274          * should also be treated as top-level */
14275         kid_top = top;
14276         break;
14277
14278     default:
14279         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14280             (*scalars_p) += 2;
14281             flags = AAS_DANGEROUS;
14282             break;
14283         }
14284
14285         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14286             && (o->op_private & OPpTARGET_MY))
14287         {
14288             (*scalars_p)++;
14289             return S_aassign_padcheck(aTHX_ o, rhs)
14290                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14291         }
14292
14293         /* if its an unrecognised, non-dangerous op, assume that it
14294          * it the cause of at least one safe scalar */
14295         (*scalars_p)++;
14296         flags = AAS_SAFE_SCALAR;
14297         break;
14298     }
14299
14300     /* XXX this assumes that all other ops are "transparent" - i.e. that
14301      * they can return some of their children. While this true for e.g.
14302      * sort and grep, it's not true for e.g. map. We really need a
14303      * 'transparent' flag added to regen/opcodes
14304      */
14305     if (o->op_flags & OPf_KIDS) {
14306         OP *kid;
14307         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14308             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14309     }
14310     return flags;
14311 }
14312
14313
14314 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14315    and modify the optree to make them work inplace */
14316
14317 STATIC void
14318 S_inplace_aassign(pTHX_ OP *o) {
14319
14320     OP *modop, *modop_pushmark;
14321     OP *oright;
14322     OP *oleft, *oleft_pushmark;
14323
14324     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14325
14326     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14327
14328     assert(cUNOPo->op_first->op_type == OP_NULL);
14329     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14330     assert(modop_pushmark->op_type == OP_PUSHMARK);
14331     modop = OpSIBLING(modop_pushmark);
14332
14333     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14334         return;
14335
14336     /* no other operation except sort/reverse */
14337     if (OpHAS_SIBLING(modop))
14338         return;
14339
14340     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14341     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14342
14343     if (modop->op_flags & OPf_STACKED) {
14344         /* skip sort subroutine/block */
14345         assert(oright->op_type == OP_NULL);
14346         oright = OpSIBLING(oright);
14347     }
14348
14349     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14350     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14351     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14352     oleft = OpSIBLING(oleft_pushmark);
14353
14354     /* Check the lhs is an array */
14355     if (!oleft ||
14356         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14357         || OpHAS_SIBLING(oleft)
14358         || (oleft->op_private & OPpLVAL_INTRO)
14359     )
14360         return;
14361
14362     /* Only one thing on the rhs */
14363     if (OpHAS_SIBLING(oright))
14364         return;
14365
14366     /* check the array is the same on both sides */
14367     if (oleft->op_type == OP_RV2AV) {
14368         if (oright->op_type != OP_RV2AV
14369             || !cUNOPx(oright)->op_first
14370             || cUNOPx(oright)->op_first->op_type != OP_GV
14371             || cUNOPx(oleft )->op_first->op_type != OP_GV
14372             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14373                cGVOPx_gv(cUNOPx(oright)->op_first)
14374         )
14375             return;
14376     }
14377     else if (oright->op_type != OP_PADAV
14378         || oright->op_targ != oleft->op_targ
14379     )
14380         return;
14381
14382     /* This actually is an inplace assignment */
14383
14384     modop->op_private |= OPpSORT_INPLACE;
14385
14386     /* transfer MODishness etc from LHS arg to RHS arg */
14387     oright->op_flags = oleft->op_flags;
14388
14389     /* remove the aassign op and the lhs */
14390     op_null(o);
14391     op_null(oleft_pushmark);
14392     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14393         op_null(cUNOPx(oleft)->op_first);
14394     op_null(oleft);
14395 }
14396
14397
14398
14399 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14400  * that potentially represent a series of one or more aggregate derefs
14401  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14402  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14403  * additional ops left in too).
14404  *
14405  * The caller will have already verified that the first few ops in the
14406  * chain following 'start' indicate a multideref candidate, and will have
14407  * set 'orig_o' to the point further on in the chain where the first index
14408  * expression (if any) begins.  'orig_action' specifies what type of
14409  * beginning has already been determined by the ops between start..orig_o
14410  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14411  *
14412  * 'hints' contains any hints flags that need adding (currently just
14413  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14414  */
14415
14416 STATIC void
14417 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14418 {
14419     dVAR;
14420     int pass;
14421     UNOP_AUX_item *arg_buf = NULL;
14422     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14423     int index_skip         = -1;    /* don't output index arg on this action */
14424
14425     /* similar to regex compiling, do two passes; the first pass
14426      * determines whether the op chain is convertible and calculates the
14427      * buffer size; the second pass populates the buffer and makes any
14428      * changes necessary to ops (such as moving consts to the pad on
14429      * threaded builds).
14430      *
14431      * NB: for things like Coverity, note that both passes take the same
14432      * path through the logic tree (except for 'if (pass)' bits), since
14433      * both passes are following the same op_next chain; and in
14434      * particular, if it would return early on the second pass, it would
14435      * already have returned early on the first pass.
14436      */
14437     for (pass = 0; pass < 2; pass++) {
14438         OP *o                = orig_o;
14439         UV action            = orig_action;
14440         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14441         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14442         int action_count     = 0;     /* number of actions seen so far */
14443         int action_ix        = 0;     /* action_count % (actions per IV) */
14444         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14445         bool is_last         = FALSE; /* no more derefs to follow */
14446         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14447         UNOP_AUX_item *arg     = arg_buf;
14448         UNOP_AUX_item *action_ptr = arg_buf;
14449
14450         if (pass)
14451             action_ptr->uv = 0;
14452         arg++;
14453
14454         switch (action) {
14455         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14456         case MDEREF_HV_gvhv_helem:
14457             next_is_hash = TRUE;
14458             /* FALLTHROUGH */
14459         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14460         case MDEREF_AV_gvav_aelem:
14461             if (pass) {
14462 #ifdef USE_ITHREADS
14463                 arg->pad_offset = cPADOPx(start)->op_padix;
14464                 /* stop it being swiped when nulled */
14465                 cPADOPx(start)->op_padix = 0;
14466 #else
14467                 arg->sv = cSVOPx(start)->op_sv;
14468                 cSVOPx(start)->op_sv = NULL;
14469 #endif
14470             }
14471             arg++;
14472             break;
14473
14474         case MDEREF_HV_padhv_helem:
14475         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14476             next_is_hash = TRUE;
14477             /* FALLTHROUGH */
14478         case MDEREF_AV_padav_aelem:
14479         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14480             if (pass) {
14481                 arg->pad_offset = start->op_targ;
14482                 /* we skip setting op_targ = 0 for now, since the intact
14483                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14484                 reset_start_targ = TRUE;
14485             }
14486             arg++;
14487             break;
14488
14489         case MDEREF_HV_pop_rv2hv_helem:
14490             next_is_hash = TRUE;
14491             /* FALLTHROUGH */
14492         case MDEREF_AV_pop_rv2av_aelem:
14493             break;
14494
14495         default:
14496             NOT_REACHED; /* NOTREACHED */
14497             return;
14498         }
14499
14500         while (!is_last) {
14501             /* look for another (rv2av/hv; get index;
14502              * aelem/helem/exists/delele) sequence */
14503
14504             OP *kid;
14505             bool is_deref;
14506             bool ok;
14507             UV index_type = MDEREF_INDEX_none;
14508
14509             if (action_count) {
14510                 /* if this is not the first lookup, consume the rv2av/hv  */
14511
14512                 /* for N levels of aggregate lookup, we normally expect
14513                  * that the first N-1 [ah]elem ops will be flagged as
14514                  * /DEREF (so they autovivifiy if necessary), and the last
14515                  * lookup op not to be.
14516                  * For other things (like @{$h{k1}{k2}}) extra scope or
14517                  * leave ops can appear, so abandon the effort in that
14518                  * case */
14519                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14520                     return;
14521
14522                 /* rv2av or rv2hv sKR/1 */
14523
14524                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14525                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14526                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14527                     return;
14528
14529                 /* at this point, we wouldn't expect any of these
14530                  * possible private flags:
14531                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14532                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14533                  */
14534                 ASSUME(!(o->op_private &
14535                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14536
14537                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14538
14539                 /* make sure the type of the previous /DEREF matches the
14540                  * type of the next lookup */
14541                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14542                 top_op = o;
14543
14544                 action = next_is_hash
14545                             ? MDEREF_HV_vivify_rv2hv_helem
14546                             : MDEREF_AV_vivify_rv2av_aelem;
14547                 o = o->op_next;
14548             }
14549
14550             /* if this is the second pass, and we're at the depth where
14551              * previously we encountered a non-simple index expression,
14552              * stop processing the index at this point */
14553             if (action_count != index_skip) {
14554
14555                 /* look for one or more simple ops that return an array
14556                  * index or hash key */
14557
14558                 switch (o->op_type) {
14559                 case OP_PADSV:
14560                     /* it may be a lexical var index */
14561                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14562                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14563                     ASSUME(!(o->op_private &
14564                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14565
14566                     if (   OP_GIMME(o,0) == G_SCALAR
14567                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14568                         && o->op_private == 0)
14569                     {
14570                         if (pass)
14571                             arg->pad_offset = o->op_targ;
14572                         arg++;
14573                         index_type = MDEREF_INDEX_padsv;
14574                         o = o->op_next;
14575                     }
14576                     break;
14577
14578                 case OP_CONST:
14579                     if (next_is_hash) {
14580                         /* it's a constant hash index */
14581                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14582                             /* "use constant foo => FOO; $h{+foo}" for
14583                              * some weird FOO, can leave you with constants
14584                              * that aren't simple strings. It's not worth
14585                              * the extra hassle for those edge cases */
14586                             break;
14587
14588                         if (pass) {
14589                             UNOP *rop = NULL;
14590                             OP * helem_op = o->op_next;
14591
14592                             ASSUME(   helem_op->op_type == OP_HELEM
14593                                    || helem_op->op_type == OP_NULL);
14594                             if (helem_op->op_type == OP_HELEM) {
14595                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14596                                 if (   helem_op->op_private & OPpLVAL_INTRO
14597                                     || rop->op_type != OP_RV2HV
14598                                 )
14599                                     rop = NULL;
14600                             }
14601                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14602
14603 #ifdef USE_ITHREADS
14604                             /* Relocate sv to the pad for thread safety */
14605                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14606                             arg->pad_offset = o->op_targ;
14607                             o->op_targ = 0;
14608 #else
14609                             arg->sv = cSVOPx_sv(o);
14610 #endif
14611                         }
14612                     }
14613                     else {
14614                         /* it's a constant array index */
14615                         IV iv;
14616                         SV *ix_sv = cSVOPo->op_sv;
14617                         if (!SvIOK(ix_sv))
14618                             break;
14619                         iv = SvIV(ix_sv);
14620
14621                         if (   action_count == 0
14622                             && iv >= -128
14623                             && iv <= 127
14624                             && (   action == MDEREF_AV_padav_aelem
14625                                 || action == MDEREF_AV_gvav_aelem)
14626                         )
14627                             maybe_aelemfast = TRUE;
14628
14629                         if (pass) {
14630                             arg->iv = iv;
14631                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14632                         }
14633                     }
14634                     if (pass)
14635                         /* we've taken ownership of the SV */
14636                         cSVOPo->op_sv = NULL;
14637                     arg++;
14638                     index_type = MDEREF_INDEX_const;
14639                     o = o->op_next;
14640                     break;
14641
14642                 case OP_GV:
14643                     /* it may be a package var index */
14644
14645                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14646                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14647                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14648                         || o->op_private != 0
14649                     )
14650                         break;
14651
14652                     kid = o->op_next;
14653                     if (kid->op_type != OP_RV2SV)
14654                         break;
14655
14656                     ASSUME(!(kid->op_flags &
14657                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14658                              |OPf_SPECIAL|OPf_PARENS)));
14659                     ASSUME(!(kid->op_private &
14660                                     ~(OPpARG1_MASK
14661                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14662                                      |OPpDEREF|OPpLVAL_INTRO)));
14663                     if(   (kid->op_flags &~ OPf_PARENS)
14664                             != (OPf_WANT_SCALAR|OPf_KIDS)
14665                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14666                     )
14667                         break;
14668
14669                     if (pass) {
14670 #ifdef USE_ITHREADS
14671                         arg->pad_offset = cPADOPx(o)->op_padix;
14672                         /* stop it being swiped when nulled */
14673                         cPADOPx(o)->op_padix = 0;
14674 #else
14675                         arg->sv = cSVOPx(o)->op_sv;
14676                         cSVOPo->op_sv = NULL;
14677 #endif
14678                     }
14679                     arg++;
14680                     index_type = MDEREF_INDEX_gvsv;
14681                     o = kid->op_next;
14682                     break;
14683
14684                 } /* switch */
14685             } /* action_count != index_skip */
14686
14687             action |= index_type;
14688
14689
14690             /* at this point we have either:
14691              *   * detected what looks like a simple index expression,
14692              *     and expect the next op to be an [ah]elem, or
14693              *     an nulled  [ah]elem followed by a delete or exists;
14694              *  * found a more complex expression, so something other
14695              *    than the above follows.
14696              */
14697
14698             /* possibly an optimised away [ah]elem (where op_next is
14699              * exists or delete) */
14700             if (o->op_type == OP_NULL)
14701                 o = o->op_next;
14702
14703             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14704              * OP_EXISTS or OP_DELETE */
14705
14706             /* if something like arybase (a.k.a $[ ) is in scope,
14707              * abandon optimisation attempt */
14708             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14709                && PL_check[o->op_type] != Perl_ck_null)
14710                 return;
14711             /* similarly for customised exists and delete */
14712             if (  (o->op_type == OP_EXISTS)
14713                && PL_check[o->op_type] != Perl_ck_exists)
14714                 return;
14715             if (  (o->op_type == OP_DELETE)
14716                && PL_check[o->op_type] != Perl_ck_delete)
14717                 return;
14718
14719             if (   o->op_type != OP_AELEM
14720                 || (o->op_private &
14721                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14722                 )
14723                 maybe_aelemfast = FALSE;
14724
14725             /* look for aelem/helem/exists/delete. If it's not the last elem
14726              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14727              * flags; if it's the last, then it mustn't have
14728              * OPpDEREF_AV/HV, but may have lots of other flags, like
14729              * OPpLVAL_INTRO etc
14730              */
14731
14732             if (   index_type == MDEREF_INDEX_none
14733                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14734                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14735             )
14736                 ok = FALSE;
14737             else {
14738                 /* we have aelem/helem/exists/delete with valid simple index */
14739
14740                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14741                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14742                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14743
14744                 /* This doesn't make much sense but is legal:
14745                  *    @{ local $x[0][0] } = 1
14746                  * Since scope exit will undo the autovivification,
14747                  * don't bother in the first place. The OP_LEAVE
14748                  * assertion is in case there are other cases of both
14749                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14750                  * exit that would undo the local - in which case this
14751                  * block of code would need rethinking.
14752                  */
14753                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14754 #ifdef DEBUGGING
14755                     OP *n = o->op_next;
14756                     while (n && (  n->op_type == OP_NULL
14757                                 || n->op_type == OP_LIST))
14758                         n = n->op_next;
14759                     assert(n && n->op_type == OP_LEAVE);
14760 #endif
14761                     o->op_private &= ~OPpDEREF;
14762                     is_deref = FALSE;
14763                 }
14764
14765                 if (is_deref) {
14766                     ASSUME(!(o->op_flags &
14767                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14768                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14769
14770                     ok =    (o->op_flags &~ OPf_PARENS)
14771                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14772                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14773                 }
14774                 else if (o->op_type == OP_EXISTS) {
14775                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14776                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14777                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14778                     ok =  !(o->op_private & ~OPpARG1_MASK);
14779                 }
14780                 else if (o->op_type == OP_DELETE) {
14781                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14782                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14783                     ASSUME(!(o->op_private &
14784                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14785                     /* don't handle slices or 'local delete'; the latter
14786                      * is fairly rare, and has a complex runtime */
14787                     ok =  !(o->op_private & ~OPpARG1_MASK);
14788                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14789                         /* skip handling run-tome error */
14790                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14791                 }
14792                 else {
14793                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14794                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14795                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14796                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14797                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14798                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14799                 }
14800             }
14801
14802             if (ok) {
14803                 if (!first_elem_op)
14804                     first_elem_op = o;
14805                 top_op = o;
14806                 if (is_deref) {
14807                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14808                     o = o->op_next;
14809                 }
14810                 else {
14811                     is_last = TRUE;
14812                     action |= MDEREF_FLAG_last;
14813                 }
14814             }
14815             else {
14816                 /* at this point we have something that started
14817                  * promisingly enough (with rv2av or whatever), but failed
14818                  * to find a simple index followed by an
14819                  * aelem/helem/exists/delete. If this is the first action,
14820                  * give up; but if we've already seen at least one
14821                  * aelem/helem, then keep them and add a new action with
14822                  * MDEREF_INDEX_none, which causes it to do the vivify
14823                  * from the end of the previous lookup, and do the deref,
14824                  * but stop at that point. So $a[0][expr] will do one
14825                  * av_fetch, vivify and deref, then continue executing at
14826                  * expr */
14827                 if (!action_count)
14828                     return;
14829                 is_last = TRUE;
14830                 index_skip = action_count;
14831                 action |= MDEREF_FLAG_last;
14832                 if (index_type != MDEREF_INDEX_none)
14833                     arg--;
14834             }
14835
14836             if (pass)
14837                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14838             action_ix++;
14839             action_count++;
14840             /* if there's no space for the next action, create a new slot
14841              * for it *before* we start adding args for that action */
14842             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14843                 action_ptr = arg;
14844                 if (pass)
14845                     arg->uv = 0;
14846                 arg++;
14847                 action_ix = 0;
14848             }
14849         } /* while !is_last */
14850
14851         /* success! */
14852
14853         if (pass) {
14854             OP *mderef;
14855             OP *p, *q;
14856
14857             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14858             if (index_skip == -1) {
14859                 mderef->op_flags = o->op_flags
14860                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14861                 if (o->op_type == OP_EXISTS)
14862                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14863                 else if (o->op_type == OP_DELETE)
14864                     mderef->op_private = OPpMULTIDEREF_DELETE;
14865                 else
14866                     mderef->op_private = o->op_private
14867                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14868             }
14869             /* accumulate strictness from every level (although I don't think
14870              * they can actually vary) */
14871             mderef->op_private |= hints;
14872
14873             /* integrate the new multideref op into the optree and the
14874              * op_next chain.
14875              *
14876              * In general an op like aelem or helem has two child
14877              * sub-trees: the aggregate expression (a_expr) and the
14878              * index expression (i_expr):
14879              *
14880              *     aelem
14881              *       |
14882              *     a_expr - i_expr
14883              *
14884              * The a_expr returns an AV or HV, while the i-expr returns an
14885              * index. In general a multideref replaces most or all of a
14886              * multi-level tree, e.g.
14887              *
14888              *     exists
14889              *       |
14890              *     ex-aelem
14891              *       |
14892              *     rv2av  - i_expr1
14893              *       |
14894              *     helem
14895              *       |
14896              *     rv2hv  - i_expr2
14897              *       |
14898              *     aelem
14899              *       |
14900              *     a_expr - i_expr3
14901              *
14902              * With multideref, all the i_exprs will be simple vars or
14903              * constants, except that i_expr1 may be arbitrary in the case
14904              * of MDEREF_INDEX_none.
14905              *
14906              * The bottom-most a_expr will be either:
14907              *   1) a simple var (so padXv or gv+rv2Xv);
14908              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14909              *      so a simple var with an extra rv2Xv;
14910              *   3) or an arbitrary expression.
14911              *
14912              * 'start', the first op in the execution chain, will point to
14913              *   1),2): the padXv or gv op;
14914              *   3):    the rv2Xv which forms the last op in the a_expr
14915              *          execution chain, and the top-most op in the a_expr
14916              *          subtree.
14917              *
14918              * For all cases, the 'start' node is no longer required,
14919              * but we can't free it since one or more external nodes
14920              * may point to it. E.g. consider
14921              *     $h{foo} = $a ? $b : $c
14922              * Here, both the op_next and op_other branches of the
14923              * cond_expr point to the gv[*h] of the hash expression, so
14924              * we can't free the 'start' op.
14925              *
14926              * For expr->[...], we need to save the subtree containing the
14927              * expression; for the other cases, we just need to save the
14928              * start node.
14929              * So in all cases, we null the start op and keep it around by
14930              * making it the child of the multideref op; for the expr->
14931              * case, the expr will be a subtree of the start node.
14932              *
14933              * So in the simple 1,2 case the  optree above changes to
14934              *
14935              *     ex-exists
14936              *       |
14937              *     multideref
14938              *       |
14939              *     ex-gv (or ex-padxv)
14940              *
14941              *  with the op_next chain being
14942              *
14943              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14944              *
14945              *  In the 3 case, we have
14946              *
14947              *     ex-exists
14948              *       |
14949              *     multideref
14950              *       |
14951              *     ex-rv2xv
14952              *       |
14953              *    rest-of-a_expr
14954              *      subtree
14955              *
14956              *  and
14957              *
14958              *  -> rest-of-a_expr subtree ->
14959              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
14960              *
14961              *
14962              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14963              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14964              * multideref attached as the child, e.g.
14965              *
14966              *     exists
14967              *       |
14968              *     ex-aelem
14969              *       |
14970              *     ex-rv2av  - i_expr1
14971              *       |
14972              *     multideref
14973              *       |
14974              *     ex-whatever
14975              *
14976              */
14977
14978             /* if we free this op, don't free the pad entry */
14979             if (reset_start_targ)
14980                 start->op_targ = 0;
14981
14982
14983             /* Cut the bit we need to save out of the tree and attach to
14984              * the multideref op, then free the rest of the tree */
14985
14986             /* find parent of node to be detached (for use by splice) */
14987             p = first_elem_op;
14988             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
14989                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14990             {
14991                 /* there is an arbitrary expression preceding us, e.g.
14992                  * expr->[..]? so we need to save the 'expr' subtree */
14993                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14994                     p = cUNOPx(p)->op_first;
14995                 ASSUME(   start->op_type == OP_RV2AV
14996                        || start->op_type == OP_RV2HV);
14997             }
14998             else {
14999                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15000                  * above for exists/delete. */
15001                 while (   (p->op_flags & OPf_KIDS)
15002                        && cUNOPx(p)->op_first != start
15003                 )
15004                     p = cUNOPx(p)->op_first;
15005             }
15006             ASSUME(cUNOPx(p)->op_first == start);
15007
15008             /* detach from main tree, and re-attach under the multideref */
15009             op_sibling_splice(mderef, NULL, 0,
15010                     op_sibling_splice(p, NULL, 1, NULL));
15011             op_null(start);
15012
15013             start->op_next = mderef;
15014
15015             mderef->op_next = index_skip == -1 ? o->op_next : o;
15016
15017             /* excise and free the original tree, and replace with
15018              * the multideref op */
15019             p = op_sibling_splice(top_op, NULL, -1, mderef);
15020             while (p) {
15021                 q = OpSIBLING(p);
15022                 op_free(p);
15023                 p = q;
15024             }
15025             op_null(top_op);
15026         }
15027         else {
15028             Size_t size = arg - arg_buf;
15029
15030             if (maybe_aelemfast && action_count == 1)
15031                 return;
15032
15033             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15034                                 sizeof(UNOP_AUX_item) * (size + 1));
15035             /* for dumping etc: store the length in a hidden first slot;
15036              * we set the op_aux pointer to the second slot */
15037             arg_buf->uv = size;
15038             arg_buf++;
15039         }
15040     } /* for (pass = ...) */
15041 }
15042
15043 /* See if the ops following o are such that o will always be executed in
15044  * boolean context: that is, the SV which o pushes onto the stack will
15045  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15046  * If so, set a suitable private flag on o. Normally this will be
15047  * bool_flag; but see below why maybe_flag is needed too.
15048  *
15049  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15050  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15051  * already be taken, so you'll have to give that op two different flags.
15052  *
15053  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15054  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15055  * those underlying ops) short-circuit, which means that rather than
15056  * necessarily returning a truth value, they may return the LH argument,
15057  * which may not be boolean. For example in $x = (keys %h || -1), keys
15058  * should return a key count rather than a boolean, even though its
15059  * sort-of being used in boolean context.
15060  *
15061  * So we only consider such logical ops to provide boolean context to
15062  * their LH argument if they themselves are in void or boolean context.
15063  * However, sometimes the context isn't known until run-time. In this
15064  * case the op is marked with the maybe_flag flag it.
15065  *
15066  * Consider the following.
15067  *
15068  *     sub f { ....;  if (%h) { .... } }
15069  *
15070  * This is actually compiled as
15071  *
15072  *     sub f { ....;  %h && do { .... } }
15073  *
15074  * Here we won't know until runtime whether the final statement (and hence
15075  * the &&) is in void context and so is safe to return a boolean value.
15076  * So mark o with maybe_flag rather than the bool_flag.
15077  * Note that there is cost associated with determining context at runtime
15078  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15079  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15080  * boolean costs savings are marginal.
15081  *
15082  * However, we can do slightly better with && (compared to || and //):
15083  * this op only returns its LH argument when that argument is false. In
15084  * this case, as long as the op promises to return a false value which is
15085  * valid in both boolean and scalar contexts, we can mark an op consumed
15086  * by && with bool_flag rather than maybe_flag.
15087  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15088  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15089  * op which promises to handle this case is indicated by setting safe_and
15090  * to true.
15091  */
15092
15093 static void
15094 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15095 {
15096     OP *lop;
15097     U8 flag = 0;
15098
15099     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15100
15101     /* OPpTARGET_MY and boolean context probably don't mix well.
15102      * If someone finds a valid use case, maybe add an extra flag to this
15103      * function which indicates its safe to do so for this op? */
15104     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15105              && (o->op_private & OPpTARGET_MY)));
15106
15107     lop = o->op_next;
15108
15109     while (lop) {
15110         switch (lop->op_type) {
15111         case OP_NULL:
15112         case OP_SCALAR:
15113             break;
15114
15115         /* these two consume the stack argument in the scalar case,
15116          * and treat it as a boolean in the non linenumber case */
15117         case OP_FLIP:
15118         case OP_FLOP:
15119             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15120                 || (lop->op_private & OPpFLIP_LINENUM))
15121             {
15122                 lop = NULL;
15123                 break;
15124             }
15125             /* FALLTHROUGH */
15126         /* these never leave the original value on the stack */
15127         case OP_NOT:
15128         case OP_XOR:
15129         case OP_COND_EXPR:
15130         case OP_GREPWHILE:
15131             flag = bool_flag;
15132             lop = NULL;
15133             break;
15134
15135         /* OR DOR and AND evaluate their arg as a boolean, but then may
15136          * leave the original scalar value on the stack when following the
15137          * op_next route. If not in void context, we need to ensure
15138          * that whatever follows consumes the arg only in boolean context
15139          * too.
15140          */
15141         case OP_AND:
15142             if (safe_and) {
15143                 flag = bool_flag;
15144                 lop = NULL;
15145                 break;
15146             }
15147             /* FALLTHROUGH */
15148         case OP_OR:
15149         case OP_DOR:
15150             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15151                 flag = bool_flag;
15152                 lop = NULL;
15153             }
15154             else if (!(lop->op_flags & OPf_WANT)) {
15155                 /* unknown context - decide at runtime */
15156                 flag = maybe_flag;
15157                 lop = NULL;
15158             }
15159             break;
15160
15161         default:
15162             lop = NULL;
15163             break;
15164         }
15165
15166         if (lop)
15167             lop = lop->op_next;
15168     }
15169
15170     o->op_private |= flag;
15171 }
15172
15173
15174
15175 /* mechanism for deferring recursion in rpeep() */
15176
15177 #define MAX_DEFERRED 4
15178
15179 #define DEFER(o) \
15180   STMT_START { \
15181     if (defer_ix == (MAX_DEFERRED-1)) { \
15182         OP **defer = defer_queue[defer_base]; \
15183         CALL_RPEEP(*defer); \
15184         S_prune_chain_head(defer); \
15185         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15186         defer_ix--; \
15187     } \
15188     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15189   } STMT_END
15190
15191 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15192 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15193
15194
15195 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15196  * See the comments at the top of this file for more details about when
15197  * peep() is called */
15198
15199 void
15200 Perl_rpeep(pTHX_ OP *o)
15201 {
15202     dVAR;
15203     OP* oldop = NULL;
15204     OP* oldoldop = NULL;
15205     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15206     int defer_base = 0;
15207     int defer_ix = -1;
15208
15209     if (!o || o->op_opt)
15210         return;
15211
15212     assert(o->op_type != OP_FREED);
15213
15214     ENTER;
15215     SAVEOP();
15216     SAVEVPTR(PL_curcop);
15217     for (;; o = o->op_next) {
15218         if (o && o->op_opt)
15219             o = NULL;
15220         if (!o) {
15221             while (defer_ix >= 0) {
15222                 OP **defer =
15223                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15224                 CALL_RPEEP(*defer);
15225                 S_prune_chain_head(defer);
15226             }
15227             break;
15228         }
15229
15230       redo:
15231
15232         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15233         assert(!oldoldop || oldoldop->op_next == oldop);
15234         assert(!oldop    || oldop->op_next    == o);
15235
15236         /* By default, this op has now been optimised. A couple of cases below
15237            clear this again.  */
15238         o->op_opt = 1;
15239         PL_op = o;
15240
15241         /* look for a series of 1 or more aggregate derefs, e.g.
15242          *   $a[1]{foo}[$i]{$k}
15243          * and replace with a single OP_MULTIDEREF op.
15244          * Each index must be either a const, or a simple variable,
15245          *
15246          * First, look for likely combinations of starting ops,
15247          * corresponding to (global and lexical variants of)
15248          *     $a[...]   $h{...}
15249          *     $r->[...] $r->{...}
15250          *     (preceding expression)->[...]
15251          *     (preceding expression)->{...}
15252          * and if so, call maybe_multideref() to do a full inspection
15253          * of the op chain and if appropriate, replace with an
15254          * OP_MULTIDEREF
15255          */
15256         {
15257             UV action;
15258             OP *o2 = o;
15259             U8 hints = 0;
15260
15261             switch (o2->op_type) {
15262             case OP_GV:
15263                 /* $pkg[..]   :   gv[*pkg]
15264                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15265
15266                 /* Fail if there are new op flag combinations that we're
15267                  * not aware of, rather than:
15268                  *  * silently failing to optimise, or
15269                  *  * silently optimising the flag away.
15270                  * If this ASSUME starts failing, examine what new flag
15271                  * has been added to the op, and decide whether the
15272                  * optimisation should still occur with that flag, then
15273                  * update the code accordingly. This applies to all the
15274                  * other ASSUMEs in the block of code too.
15275                  */
15276                 ASSUME(!(o2->op_flags &
15277                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15278                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15279
15280                 o2 = o2->op_next;
15281
15282                 if (o2->op_type == OP_RV2AV) {
15283                     action = MDEREF_AV_gvav_aelem;
15284                     goto do_deref;
15285                 }
15286
15287                 if (o2->op_type == OP_RV2HV) {
15288                     action = MDEREF_HV_gvhv_helem;
15289                     goto do_deref;
15290                 }
15291
15292                 if (o2->op_type != OP_RV2SV)
15293                     break;
15294
15295                 /* at this point we've seen gv,rv2sv, so the only valid
15296                  * construct left is $pkg->[] or $pkg->{} */
15297
15298                 ASSUME(!(o2->op_flags & OPf_STACKED));
15299                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15300                             != (OPf_WANT_SCALAR|OPf_MOD))
15301                     break;
15302
15303                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15304                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15305                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15306                     break;
15307                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15308                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15309                     break;
15310
15311                 o2 = o2->op_next;
15312                 if (o2->op_type == OP_RV2AV) {
15313                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15314                     goto do_deref;
15315                 }
15316                 if (o2->op_type == OP_RV2HV) {
15317                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15318                     goto do_deref;
15319                 }
15320                 break;
15321
15322             case OP_PADSV:
15323                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15324
15325                 ASSUME(!(o2->op_flags &
15326                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15327                 if ((o2->op_flags &
15328                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15329                      != (OPf_WANT_SCALAR|OPf_MOD))
15330                     break;
15331
15332                 ASSUME(!(o2->op_private &
15333                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15334                 /* skip if state or intro, or not a deref */
15335                 if (      o2->op_private != OPpDEREF_AV
15336                        && o2->op_private != OPpDEREF_HV)
15337                     break;
15338
15339                 o2 = o2->op_next;
15340                 if (o2->op_type == OP_RV2AV) {
15341                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15342                     goto do_deref;
15343                 }
15344                 if (o2->op_type == OP_RV2HV) {
15345                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15346                     goto do_deref;
15347                 }
15348                 break;
15349
15350             case OP_PADAV:
15351             case OP_PADHV:
15352                 /*    $lex[..]:  padav[@lex:1,2] sR *
15353                  * or $lex{..}:  padhv[%lex:1,2] sR */
15354                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15355                                             OPf_REF|OPf_SPECIAL)));
15356                 if ((o2->op_flags &
15357                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15358                      != (OPf_WANT_SCALAR|OPf_REF))
15359                     break;
15360                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15361                     break;
15362                 /* OPf_PARENS isn't currently used in this case;
15363                  * if that changes, let us know! */
15364                 ASSUME(!(o2->op_flags & OPf_PARENS));
15365
15366                 /* at this point, we wouldn't expect any of the remaining
15367                  * possible private flags:
15368                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15369                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15370                  *
15371                  * OPpSLICEWARNING shouldn't affect runtime
15372                  */
15373                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15374
15375                 action = o2->op_type == OP_PADAV
15376                             ? MDEREF_AV_padav_aelem
15377                             : MDEREF_HV_padhv_helem;
15378                 o2 = o2->op_next;
15379                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15380                 break;
15381
15382
15383             case OP_RV2AV:
15384             case OP_RV2HV:
15385                 action = o2->op_type == OP_RV2AV
15386                             ? MDEREF_AV_pop_rv2av_aelem
15387                             : MDEREF_HV_pop_rv2hv_helem;
15388                 /* FALLTHROUGH */
15389             do_deref:
15390                 /* (expr)->[...]:  rv2av sKR/1;
15391                  * (expr)->{...}:  rv2hv sKR/1; */
15392
15393                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15394
15395                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15396                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15397                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15398                     break;
15399
15400                 /* at this point, we wouldn't expect any of these
15401                  * possible private flags:
15402                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15403                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15404                  */
15405                 ASSUME(!(o2->op_private &
15406                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15407                      |OPpOUR_INTRO)));
15408                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15409
15410                 o2 = o2->op_next;
15411
15412                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15413                 break;
15414
15415             default:
15416                 break;
15417             }
15418         }
15419
15420
15421         switch (o->op_type) {
15422         case OP_DBSTATE:
15423             PL_curcop = ((COP*)o);              /* for warnings */
15424             break;
15425         case OP_NEXTSTATE:
15426             PL_curcop = ((COP*)o);              /* for warnings */
15427
15428             /* Optimise a "return ..." at the end of a sub to just be "...".
15429              * This saves 2 ops. Before:
15430              * 1  <;> nextstate(main 1 -e:1) v ->2
15431              * 4  <@> return K ->5
15432              * 2    <0> pushmark s ->3
15433              * -    <1> ex-rv2sv sK/1 ->4
15434              * 3      <#> gvsv[*cat] s ->4
15435              *
15436              * After:
15437              * -  <@> return K ->-
15438              * -    <0> pushmark s ->2
15439              * -    <1> ex-rv2sv sK/1 ->-
15440              * 2      <$> gvsv(*cat) s ->3
15441              */
15442             {
15443                 OP *next = o->op_next;
15444                 OP *sibling = OpSIBLING(o);
15445                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15446                     && OP_TYPE_IS(sibling, OP_RETURN)
15447                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15448                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15449                        ||OP_TYPE_IS(sibling->op_next->op_next,
15450                                     OP_LEAVESUBLV))
15451                     && cUNOPx(sibling)->op_first == next
15452                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15453                     && next->op_next
15454                 ) {
15455                     /* Look through the PUSHMARK's siblings for one that
15456                      * points to the RETURN */
15457                     OP *top = OpSIBLING(next);
15458                     while (top && top->op_next) {
15459                         if (top->op_next == sibling) {
15460                             top->op_next = sibling->op_next;
15461                             o->op_next = next->op_next;
15462                             break;
15463                         }
15464                         top = OpSIBLING(top);
15465                     }
15466                 }
15467             }
15468
15469             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15470              *
15471              * This latter form is then suitable for conversion into padrange
15472              * later on. Convert:
15473              *
15474              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15475              *
15476              * into:
15477              *
15478              *   nextstate1 ->     listop     -> nextstate3
15479              *                 /            \
15480              *         pushmark -> padop1 -> padop2
15481              */
15482             if (o->op_next && (
15483                     o->op_next->op_type == OP_PADSV
15484                  || o->op_next->op_type == OP_PADAV
15485                  || o->op_next->op_type == OP_PADHV
15486                 )
15487                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15488                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15489                 && o->op_next->op_next->op_next && (
15490                     o->op_next->op_next->op_next->op_type == OP_PADSV
15491                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15492                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15493                 )
15494                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15495                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15496                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15497                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15498             ) {
15499                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15500
15501                 pad1 =    o->op_next;
15502                 ns2  = pad1->op_next;
15503                 pad2 =  ns2->op_next;
15504                 ns3  = pad2->op_next;
15505
15506                 /* we assume here that the op_next chain is the same as
15507                  * the op_sibling chain */
15508                 assert(OpSIBLING(o)    == pad1);
15509                 assert(OpSIBLING(pad1) == ns2);
15510                 assert(OpSIBLING(ns2)  == pad2);
15511                 assert(OpSIBLING(pad2) == ns3);
15512
15513                 /* excise and delete ns2 */
15514                 op_sibling_splice(NULL, pad1, 1, NULL);
15515                 op_free(ns2);
15516
15517                 /* excise pad1 and pad2 */
15518                 op_sibling_splice(NULL, o, 2, NULL);
15519
15520                 /* create new listop, with children consisting of:
15521                  * a new pushmark, pad1, pad2. */
15522                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15523                 newop->op_flags |= OPf_PARENS;
15524                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15525
15526                 /* insert newop between o and ns3 */
15527                 op_sibling_splice(NULL, o, 0, newop);
15528
15529                 /*fixup op_next chain */
15530                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15531                 o    ->op_next = newpm;
15532                 newpm->op_next = pad1;
15533                 pad1 ->op_next = pad2;
15534                 pad2 ->op_next = newop; /* listop */
15535                 newop->op_next = ns3;
15536
15537                 /* Ensure pushmark has this flag if padops do */
15538                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15539                     newpm->op_flags |= OPf_MOD;
15540                 }
15541
15542                 break;
15543             }
15544
15545             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15546                to carry two labels. For now, take the easier option, and skip
15547                this optimisation if the first NEXTSTATE has a label.  */
15548             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15549                 OP *nextop = o->op_next;
15550                 while (nextop && nextop->op_type == OP_NULL)
15551                     nextop = nextop->op_next;
15552
15553                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15554                     op_null(o);
15555                     if (oldop)
15556                         oldop->op_next = nextop;
15557                     o = nextop;
15558                     /* Skip (old)oldop assignment since the current oldop's
15559                        op_next already points to the next op.  */
15560                     goto redo;
15561                 }
15562             }
15563             break;
15564
15565         case OP_CONCAT:
15566             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15567                 if (o->op_next->op_private & OPpTARGET_MY) {
15568                     if (o->op_flags & OPf_STACKED) /* chained concats */
15569                         break; /* ignore_optimization */
15570                     else {
15571                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15572                         o->op_targ = o->op_next->op_targ;
15573                         o->op_next->op_targ = 0;
15574                         o->op_private |= OPpTARGET_MY;
15575                     }
15576                 }
15577                 op_null(o->op_next);
15578             }
15579             break;
15580         case OP_STUB:
15581             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15582                 break; /* Scalar stub must produce undef.  List stub is noop */
15583             }
15584             goto nothin;
15585         case OP_NULL:
15586             if (o->op_targ == OP_NEXTSTATE
15587                 || o->op_targ == OP_DBSTATE)
15588             {
15589                 PL_curcop = ((COP*)o);
15590             }
15591             /* XXX: We avoid setting op_seq here to prevent later calls
15592                to rpeep() from mistakenly concluding that optimisation
15593                has already occurred. This doesn't fix the real problem,
15594                though (See 20010220.007 (#5874)). AMS 20010719 */
15595             /* op_seq functionality is now replaced by op_opt */
15596             o->op_opt = 0;
15597             /* FALLTHROUGH */
15598         case OP_SCALAR:
15599         case OP_LINESEQ:
15600         case OP_SCOPE:
15601         nothin:
15602             if (oldop) {
15603                 oldop->op_next = o->op_next;
15604                 o->op_opt = 0;
15605                 continue;
15606             }
15607             break;
15608
15609         case OP_PUSHMARK:
15610
15611             /* Given
15612                  5 repeat/DOLIST
15613                  3   ex-list
15614                  1     pushmark
15615                  2     scalar or const
15616                  4   const[0]
15617                convert repeat into a stub with no kids.
15618              */
15619             if (o->op_next->op_type == OP_CONST
15620              || (  o->op_next->op_type == OP_PADSV
15621                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15622              || (  o->op_next->op_type == OP_GV
15623                 && o->op_next->op_next->op_type == OP_RV2SV
15624                 && !(o->op_next->op_next->op_private
15625                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15626             {
15627                 const OP *kid = o->op_next->op_next;
15628                 if (o->op_next->op_type == OP_GV)
15629                    kid = kid->op_next;
15630                 /* kid is now the ex-list.  */
15631                 if (kid->op_type == OP_NULL
15632                  && (kid = kid->op_next)->op_type == OP_CONST
15633                     /* kid is now the repeat count.  */
15634                  && kid->op_next->op_type == OP_REPEAT
15635                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15636                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15637                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15638                  && oldop)
15639                 {
15640                     o = kid->op_next; /* repeat */
15641                     oldop->op_next = o;
15642                     op_free(cBINOPo->op_first);
15643                     op_free(cBINOPo->op_last );
15644                     o->op_flags &=~ OPf_KIDS;
15645                     /* stub is a baseop; repeat is a binop */
15646                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15647                     OpTYPE_set(o, OP_STUB);
15648                     o->op_private = 0;
15649                     break;
15650                 }
15651             }
15652
15653             /* Convert a series of PAD ops for my vars plus support into a
15654              * single padrange op. Basically
15655              *
15656              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15657              *
15658              * becomes, depending on circumstances, one of
15659              *
15660              *    padrange  ----------------------------------> (list) -> rest
15661              *    padrange  --------------------------------------------> rest
15662              *
15663              * where all the pad indexes are sequential and of the same type
15664              * (INTRO or not).
15665              * We convert the pushmark into a padrange op, then skip
15666              * any other pad ops, and possibly some trailing ops.
15667              * Note that we don't null() the skipped ops, to make it
15668              * easier for Deparse to undo this optimisation (and none of
15669              * the skipped ops are holding any resourses). It also makes
15670              * it easier for find_uninit_var(), as it can just ignore
15671              * padrange, and examine the original pad ops.
15672              */
15673         {
15674             OP *p;
15675             OP *followop = NULL; /* the op that will follow the padrange op */
15676             U8 count = 0;
15677             U8 intro = 0;
15678             PADOFFSET base = 0; /* init only to stop compiler whining */
15679             bool gvoid = 0;     /* init only to stop compiler whining */
15680             bool defav = 0;  /* seen (...) = @_ */
15681             bool reuse = 0;  /* reuse an existing padrange op */
15682
15683             /* look for a pushmark -> gv[_] -> rv2av */
15684
15685             {
15686                 OP *rv2av, *q;
15687                 p = o->op_next;
15688                 if (   p->op_type == OP_GV
15689                     && cGVOPx_gv(p) == PL_defgv
15690                     && (rv2av = p->op_next)
15691                     && rv2av->op_type == OP_RV2AV
15692                     && !(rv2av->op_flags & OPf_REF)
15693                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15694                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15695                 ) {
15696                     q = rv2av->op_next;
15697                     if (q->op_type == OP_NULL)
15698                         q = q->op_next;
15699                     if (q->op_type == OP_PUSHMARK) {
15700                         defav = 1;
15701                         p = q;
15702                     }
15703                 }
15704             }
15705             if (!defav) {
15706                 p = o;
15707             }
15708
15709             /* scan for PAD ops */
15710
15711             for (p = p->op_next; p; p = p->op_next) {
15712                 if (p->op_type == OP_NULL)
15713                     continue;
15714
15715                 if ((     p->op_type != OP_PADSV
15716                        && p->op_type != OP_PADAV
15717                        && p->op_type != OP_PADHV
15718                     )
15719                       /* any private flag other than INTRO? e.g. STATE */
15720                    || (p->op_private & ~OPpLVAL_INTRO)
15721                 )
15722                     break;
15723
15724                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15725                  * instead */
15726                 if (   p->op_type == OP_PADAV
15727                     && p->op_next
15728                     && p->op_next->op_type == OP_CONST
15729                     && p->op_next->op_next
15730                     && p->op_next->op_next->op_type == OP_AELEM
15731                 )
15732                     break;
15733
15734                 /* for 1st padop, note what type it is and the range
15735                  * start; for the others, check that it's the same type
15736                  * and that the targs are contiguous */
15737                 if (count == 0) {
15738                     intro = (p->op_private & OPpLVAL_INTRO);
15739                     base = p->op_targ;
15740                     gvoid = OP_GIMME(p,0) == G_VOID;
15741                 }
15742                 else {
15743                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15744                         break;
15745                     /* Note that you'd normally  expect targs to be
15746                      * contiguous in my($a,$b,$c), but that's not the case
15747                      * when external modules start doing things, e.g.
15748                      * Function::Parameters */
15749                     if (p->op_targ != base + count)
15750                         break;
15751                     assert(p->op_targ == base + count);
15752                     /* Either all the padops or none of the padops should
15753                        be in void context.  Since we only do the optimisa-
15754                        tion for av/hv when the aggregate itself is pushed
15755                        on to the stack (one item), there is no need to dis-
15756                        tinguish list from scalar context.  */
15757                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15758                         break;
15759                 }
15760
15761                 /* for AV, HV, only when we're not flattening */
15762                 if (   p->op_type != OP_PADSV
15763                     && !gvoid
15764                     && !(p->op_flags & OPf_REF)
15765                 )
15766                     break;
15767
15768                 if (count >= OPpPADRANGE_COUNTMASK)
15769                     break;
15770
15771                 /* there's a biggest base we can fit into a
15772                  * SAVEt_CLEARPADRANGE in pp_padrange.
15773                  * (The sizeof() stuff will be constant-folded, and is
15774                  * intended to avoid getting "comparison is always false"
15775                  * compiler warnings. See the comments above
15776                  * MEM_WRAP_CHECK for more explanation on why we do this
15777                  * in a weird way to avoid compiler warnings.)
15778                  */
15779                 if (   intro
15780                     && (8*sizeof(base) >
15781                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15782                         ? (Size_t)base
15783                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15784                         ) >
15785                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15786                 )
15787                     break;
15788
15789                 /* Success! We've got another valid pad op to optimise away */
15790                 count++;
15791                 followop = p->op_next;
15792             }
15793
15794             if (count < 1 || (count == 1 && !defav))
15795                 break;
15796
15797             /* pp_padrange in specifically compile-time void context
15798              * skips pushing a mark and lexicals; in all other contexts
15799              * (including unknown till runtime) it pushes a mark and the
15800              * lexicals. We must be very careful then, that the ops we
15801              * optimise away would have exactly the same effect as the
15802              * padrange.
15803              * In particular in void context, we can only optimise to
15804              * a padrange if we see the complete sequence
15805              *     pushmark, pad*v, ...., list
15806              * which has the net effect of leaving the markstack as it
15807              * was.  Not pushing onto the stack (whereas padsv does touch
15808              * the stack) makes no difference in void context.
15809              */
15810             assert(followop);
15811             if (gvoid) {
15812                 if (followop->op_type == OP_LIST
15813                         && OP_GIMME(followop,0) == G_VOID
15814                    )
15815                 {
15816                     followop = followop->op_next; /* skip OP_LIST */
15817
15818                     /* consolidate two successive my(...);'s */
15819
15820                     if (   oldoldop
15821                         && oldoldop->op_type == OP_PADRANGE
15822                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15823                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15824                         && !(oldoldop->op_flags & OPf_SPECIAL)
15825                     ) {
15826                         U8 old_count;
15827                         assert(oldoldop->op_next == oldop);
15828                         assert(   oldop->op_type == OP_NEXTSTATE
15829                                || oldop->op_type == OP_DBSTATE);
15830                         assert(oldop->op_next == o);
15831
15832                         old_count
15833                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15834
15835                        /* Do not assume pad offsets for $c and $d are con-
15836                           tiguous in
15837                             my ($a,$b,$c);
15838                             my ($d,$e,$f);
15839                         */
15840                         if (  oldoldop->op_targ + old_count == base
15841                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15842                             base = oldoldop->op_targ;
15843                             count += old_count;
15844                             reuse = 1;
15845                         }
15846                     }
15847
15848                     /* if there's any immediately following singleton
15849                      * my var's; then swallow them and the associated
15850                      * nextstates; i.e.
15851                      *    my ($a,$b); my $c; my $d;
15852                      * is treated as
15853                      *    my ($a,$b,$c,$d);
15854                      */
15855
15856                     while (    ((p = followop->op_next))
15857                             && (  p->op_type == OP_PADSV
15858                                || p->op_type == OP_PADAV
15859                                || p->op_type == OP_PADHV)
15860                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15861                             && (p->op_private & OPpLVAL_INTRO) == intro
15862                             && !(p->op_private & ~OPpLVAL_INTRO)
15863                             && p->op_next
15864                             && (   p->op_next->op_type == OP_NEXTSTATE
15865                                 || p->op_next->op_type == OP_DBSTATE)
15866                             && count < OPpPADRANGE_COUNTMASK
15867                             && base + count == p->op_targ
15868                     ) {
15869                         count++;
15870                         followop = p->op_next;
15871                     }
15872                 }
15873                 else
15874                     break;
15875             }
15876
15877             if (reuse) {
15878                 assert(oldoldop->op_type == OP_PADRANGE);
15879                 oldoldop->op_next = followop;
15880                 oldoldop->op_private = (intro | count);
15881                 o = oldoldop;
15882                 oldop = NULL;
15883                 oldoldop = NULL;
15884             }
15885             else {
15886                 /* Convert the pushmark into a padrange.
15887                  * To make Deparse easier, we guarantee that a padrange was
15888                  * *always* formerly a pushmark */
15889                 assert(o->op_type == OP_PUSHMARK);
15890                 o->op_next = followop;
15891                 OpTYPE_set(o, OP_PADRANGE);
15892                 o->op_targ = base;
15893                 /* bit 7: INTRO; bit 6..0: count */
15894                 o->op_private = (intro | count);
15895                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15896                               | gvoid * OPf_WANT_VOID
15897                               | (defav ? OPf_SPECIAL : 0));
15898             }
15899             break;
15900         }
15901
15902         case OP_RV2AV:
15903             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15904                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15905             break;
15906
15907         case OP_RV2HV:
15908         case OP_PADHV:
15909             /*'keys %h' in void or scalar context: skip the OP_KEYS
15910              * and perform the functionality directly in the RV2HV/PADHV
15911              * op
15912              */
15913             if (o->op_flags & OPf_REF) {
15914                 OP *k = o->op_next;
15915                 U8 want = (k->op_flags & OPf_WANT);
15916                 if (   k
15917                     && k->op_type == OP_KEYS
15918                     && (   want == OPf_WANT_VOID
15919                         || want == OPf_WANT_SCALAR)
15920                     && !(k->op_private & OPpMAYBE_LVSUB)
15921                     && !(k->op_flags & OPf_MOD)
15922                 ) {
15923                     o->op_next     = k->op_next;
15924                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15925                     o->op_flags   |= want;
15926                     o->op_private |= (o->op_type == OP_PADHV ?
15927                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15928                     /* for keys(%lex), hold onto the OP_KEYS's targ
15929                      * since padhv doesn't have its own targ to return
15930                      * an int with */
15931                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15932                         op_null(k);
15933                 }
15934             }
15935
15936             /* see if %h is used in boolean context */
15937             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15938                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15939
15940
15941             if (o->op_type != OP_PADHV)
15942                 break;
15943             /* FALLTHROUGH */
15944         case OP_PADAV:
15945             if (   o->op_type == OP_PADAV
15946                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15947             )
15948                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15949             /* FALLTHROUGH */
15950         case OP_PADSV:
15951             /* Skip over state($x) in void context.  */
15952             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15953              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15954             {
15955                 oldop->op_next = o->op_next;
15956                 goto redo_nextstate;
15957             }
15958             if (o->op_type != OP_PADAV)
15959                 break;
15960             /* FALLTHROUGH */
15961         case OP_GV:
15962             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15963                 OP* const pop = (o->op_type == OP_PADAV) ?
15964                             o->op_next : o->op_next->op_next;
15965                 IV i;
15966                 if (pop && pop->op_type == OP_CONST &&
15967                     ((PL_op = pop->op_next)) &&
15968                     pop->op_next->op_type == OP_AELEM &&
15969                     !(pop->op_next->op_private &
15970                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15971                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15972                 {
15973                     GV *gv;
15974                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15975                         no_bareword_allowed(pop);
15976                     if (o->op_type == OP_GV)
15977                         op_null(o->op_next);
15978                     op_null(pop->op_next);
15979                     op_null(pop);
15980                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15981                     o->op_next = pop->op_next->op_next;
15982                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15983                     o->op_private = (U8)i;
15984                     if (o->op_type == OP_GV) {
15985                         gv = cGVOPo_gv;
15986                         GvAVn(gv);
15987                         o->op_type = OP_AELEMFAST;
15988                     }
15989                     else
15990                         o->op_type = OP_AELEMFAST_LEX;
15991                 }
15992                 if (o->op_type != OP_GV)
15993                     break;
15994             }
15995
15996             /* Remove $foo from the op_next chain in void context.  */
15997             if (oldop
15998              && (  o->op_next->op_type == OP_RV2SV
15999                 || o->op_next->op_type == OP_RV2AV
16000                 || o->op_next->op_type == OP_RV2HV  )
16001              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16002              && !(o->op_next->op_private & OPpLVAL_INTRO))
16003             {
16004                 oldop->op_next = o->op_next->op_next;
16005                 /* Reprocess the previous op if it is a nextstate, to
16006                    allow double-nextstate optimisation.  */
16007               redo_nextstate:
16008                 if (oldop->op_type == OP_NEXTSTATE) {
16009                     oldop->op_opt = 0;
16010                     o = oldop;
16011                     oldop = oldoldop;
16012                     oldoldop = NULL;
16013                     goto redo;
16014                 }
16015                 o = oldop->op_next;
16016                 goto redo;
16017             }
16018             else if (o->op_next->op_type == OP_RV2SV) {
16019                 if (!(o->op_next->op_private & OPpDEREF)) {
16020                     op_null(o->op_next);
16021                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16022                                                                | OPpOUR_INTRO);
16023                     o->op_next = o->op_next->op_next;
16024                     OpTYPE_set(o, OP_GVSV);
16025                 }
16026             }
16027             else if (o->op_next->op_type == OP_READLINE
16028                     && o->op_next->op_next->op_type == OP_CONCAT
16029                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16030             {
16031                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16032                 OpTYPE_set(o, OP_RCATLINE);
16033                 o->op_flags |= OPf_STACKED;
16034                 op_null(o->op_next->op_next);
16035                 op_null(o->op_next);
16036             }
16037
16038             break;
16039
16040         case OP_NOT:
16041             break;
16042
16043         case OP_AND:
16044         case OP_OR:
16045         case OP_DOR:
16046             while (cLOGOP->op_other->op_type == OP_NULL)
16047                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16048             while (o->op_next && (   o->op_type == o->op_next->op_type
16049                                   || o->op_next->op_type == OP_NULL))
16050                 o->op_next = o->op_next->op_next;
16051
16052             /* If we're an OR and our next is an AND in void context, we'll
16053                follow its op_other on short circuit, same for reverse.
16054                We can't do this with OP_DOR since if it's true, its return
16055                value is the underlying value which must be evaluated
16056                by the next op. */
16057             if (o->op_next &&
16058                 (
16059                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16060                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16061                 )
16062                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16063             ) {
16064                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16065             }
16066             DEFER(cLOGOP->op_other);
16067             o->op_opt = 1;
16068             break;
16069
16070         case OP_GREPWHILE:
16071             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16072                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16073             /* FALLTHROUGH */
16074         case OP_COND_EXPR:
16075         case OP_MAPWHILE:
16076         case OP_ANDASSIGN:
16077         case OP_ORASSIGN:
16078         case OP_DORASSIGN:
16079         case OP_RANGE:
16080         case OP_ONCE:
16081         case OP_ARGDEFELEM:
16082             while (cLOGOP->op_other->op_type == OP_NULL)
16083                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16084             DEFER(cLOGOP->op_other);
16085             break;
16086
16087         case OP_ENTERLOOP:
16088         case OP_ENTERITER:
16089             while (cLOOP->op_redoop->op_type == OP_NULL)
16090                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16091             while (cLOOP->op_nextop->op_type == OP_NULL)
16092                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16093             while (cLOOP->op_lastop->op_type == OP_NULL)
16094                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16095             /* a while(1) loop doesn't have an op_next that escapes the
16096              * loop, so we have to explicitly follow the op_lastop to
16097              * process the rest of the code */
16098             DEFER(cLOOP->op_lastop);
16099             break;
16100
16101         case OP_ENTERTRY:
16102             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16103             DEFER(cLOGOPo->op_other);
16104             break;
16105
16106         case OP_SUBST:
16107             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16108                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16109             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16110             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16111                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16112                 cPMOP->op_pmstashstartu.op_pmreplstart
16113                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16114             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16115             break;
16116
16117         case OP_SORT: {
16118             OP *oright;
16119
16120             if (o->op_flags & OPf_SPECIAL) {
16121                 /* first arg is a code block */
16122                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16123                 OP * kid          = cUNOPx(nullop)->op_first;
16124
16125                 assert(nullop->op_type == OP_NULL);
16126                 assert(kid->op_type == OP_SCOPE
16127                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16128                 /* since OP_SORT doesn't have a handy op_other-style
16129                  * field that can point directly to the start of the code
16130                  * block, store it in the otherwise-unused op_next field
16131                  * of the top-level OP_NULL. This will be quicker at
16132                  * run-time, and it will also allow us to remove leading
16133                  * OP_NULLs by just messing with op_nexts without
16134                  * altering the basic op_first/op_sibling layout. */
16135                 kid = kLISTOP->op_first;
16136                 assert(
16137                       (kid->op_type == OP_NULL
16138                       && (  kid->op_targ == OP_NEXTSTATE
16139                          || kid->op_targ == OP_DBSTATE  ))
16140                     || kid->op_type == OP_STUB
16141                     || kid->op_type == OP_ENTER
16142                     || (PL_parser && PL_parser->error_count));
16143                 nullop->op_next = kid->op_next;
16144                 DEFER(nullop->op_next);
16145             }
16146
16147             /* check that RHS of sort is a single plain array */
16148             oright = cUNOPo->op_first;
16149             if (!oright || oright->op_type != OP_PUSHMARK)
16150                 break;
16151
16152             if (o->op_private & OPpSORT_INPLACE)
16153                 break;
16154
16155             /* reverse sort ... can be optimised.  */
16156             if (!OpHAS_SIBLING(cUNOPo)) {
16157                 /* Nothing follows us on the list. */
16158                 OP * const reverse = o->op_next;
16159
16160                 if (reverse->op_type == OP_REVERSE &&
16161                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16162                     OP * const pushmark = cUNOPx(reverse)->op_first;
16163                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16164                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16165                         /* reverse -> pushmark -> sort */
16166                         o->op_private |= OPpSORT_REVERSE;
16167                         op_null(reverse);
16168                         pushmark->op_next = oright->op_next;
16169                         op_null(oright);
16170                     }
16171                 }
16172             }
16173
16174             break;
16175         }
16176
16177         case OP_REVERSE: {
16178             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16179             OP *gvop = NULL;
16180             LISTOP *enter, *exlist;
16181
16182             if (o->op_private & OPpSORT_INPLACE)
16183                 break;
16184
16185             enter = (LISTOP *) o->op_next;
16186             if (!enter)
16187                 break;
16188             if (enter->op_type == OP_NULL) {
16189                 enter = (LISTOP *) enter->op_next;
16190                 if (!enter)
16191                     break;
16192             }
16193             /* for $a (...) will have OP_GV then OP_RV2GV here.
16194                for (...) just has an OP_GV.  */
16195             if (enter->op_type == OP_GV) {
16196                 gvop = (OP *) enter;
16197                 enter = (LISTOP *) enter->op_next;
16198                 if (!enter)
16199                     break;
16200                 if (enter->op_type == OP_RV2GV) {
16201                   enter = (LISTOP *) enter->op_next;
16202                   if (!enter)
16203                     break;
16204                 }
16205             }
16206
16207             if (enter->op_type != OP_ENTERITER)
16208                 break;
16209
16210             iter = enter->op_next;
16211             if (!iter || iter->op_type != OP_ITER)
16212                 break;
16213
16214             expushmark = enter->op_first;
16215             if (!expushmark || expushmark->op_type != OP_NULL
16216                 || expushmark->op_targ != OP_PUSHMARK)
16217                 break;
16218
16219             exlist = (LISTOP *) OpSIBLING(expushmark);
16220             if (!exlist || exlist->op_type != OP_NULL
16221                 || exlist->op_targ != OP_LIST)
16222                 break;
16223
16224             if (exlist->op_last != o) {
16225                 /* Mmm. Was expecting to point back to this op.  */
16226                 break;
16227             }
16228             theirmark = exlist->op_first;
16229             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16230                 break;
16231
16232             if (OpSIBLING(theirmark) != o) {
16233                 /* There's something between the mark and the reverse, eg
16234                    for (1, reverse (...))
16235                    so no go.  */
16236                 break;
16237             }
16238
16239             ourmark = ((LISTOP *)o)->op_first;
16240             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16241                 break;
16242
16243             ourlast = ((LISTOP *)o)->op_last;
16244             if (!ourlast || ourlast->op_next != o)
16245                 break;
16246
16247             rv2av = OpSIBLING(ourmark);
16248             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16249                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16250                 /* We're just reversing a single array.  */
16251                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16252                 enter->op_flags |= OPf_STACKED;
16253             }
16254
16255             /* We don't have control over who points to theirmark, so sacrifice
16256                ours.  */
16257             theirmark->op_next = ourmark->op_next;
16258             theirmark->op_flags = ourmark->op_flags;
16259             ourlast->op_next = gvop ? gvop : (OP *) enter;
16260             op_null(ourmark);
16261             op_null(o);
16262             enter->op_private |= OPpITER_REVERSED;
16263             iter->op_private |= OPpITER_REVERSED;
16264
16265             oldoldop = NULL;
16266             oldop    = ourlast;
16267             o        = oldop->op_next;
16268             goto redo;
16269             NOT_REACHED; /* NOTREACHED */
16270             break;
16271         }
16272
16273         case OP_QR:
16274         case OP_MATCH:
16275             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16276                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16277             }
16278             break;
16279
16280         case OP_RUNCV:
16281             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16282              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16283             {
16284                 SV *sv;
16285                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16286                 else {
16287                     sv = newRV((SV *)PL_compcv);
16288                     sv_rvweaken(sv);
16289                     SvREADONLY_on(sv);
16290                 }
16291                 OpTYPE_set(o, OP_CONST);
16292                 o->op_flags |= OPf_SPECIAL;
16293                 cSVOPo->op_sv = sv;
16294             }
16295             break;
16296
16297         case OP_SASSIGN:
16298             if (OP_GIMME(o,0) == G_VOID
16299              || (  o->op_next->op_type == OP_LINESEQ
16300                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16301                    || (  o->op_next->op_next->op_type == OP_RETURN
16302                       && !CvLVALUE(PL_compcv)))))
16303             {
16304                 OP *right = cBINOP->op_first;
16305                 if (right) {
16306                     /*   sassign
16307                     *      RIGHT
16308                     *      substr
16309                     *         pushmark
16310                     *         arg1
16311                     *         arg2
16312                     *         ...
16313                     * becomes
16314                     *
16315                     *  ex-sassign
16316                     *     substr
16317                     *        pushmark
16318                     *        RIGHT
16319                     *        arg1
16320                     *        arg2
16321                     *        ...
16322                     */
16323                     OP *left = OpSIBLING(right);
16324                     if (left->op_type == OP_SUBSTR
16325                          && (left->op_private & 7) < 4) {
16326                         op_null(o);
16327                         /* cut out right */
16328                         op_sibling_splice(o, NULL, 1, NULL);
16329                         /* and insert it as second child of OP_SUBSTR */
16330                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16331                                     right);
16332                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16333                         left->op_flags =
16334                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16335                     }
16336                 }
16337             }
16338             break;
16339
16340         case OP_AASSIGN: {
16341             int l, r, lr, lscalars, rscalars;
16342
16343             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16344                Note that we do this now rather than in newASSIGNOP(),
16345                since only by now are aliased lexicals flagged as such
16346
16347                See the essay "Common vars in list assignment" above for
16348                the full details of the rationale behind all the conditions
16349                below.
16350
16351                PL_generation sorcery:
16352                To detect whether there are common vars, the global var
16353                PL_generation is incremented for each assign op we scan.
16354                Then we run through all the lexical variables on the LHS,
16355                of the assignment, setting a spare slot in each of them to
16356                PL_generation.  Then we scan the RHS, and if any lexicals
16357                already have that value, we know we've got commonality.
16358                Also, if the generation number is already set to
16359                PERL_INT_MAX, then the variable is involved in aliasing, so
16360                we also have potential commonality in that case.
16361              */
16362
16363             PL_generation++;
16364             /* scan LHS */
16365             lscalars = 0;
16366             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16367             /* scan RHS */
16368             rscalars = 0;
16369             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16370             lr = (l|r);
16371
16372
16373             /* After looking for things which are *always* safe, this main
16374              * if/else chain selects primarily based on the type of the
16375              * LHS, gradually working its way down from the more dangerous
16376              * to the more restrictive and thus safer cases */
16377
16378             if (   !l                      /* () = ....; */
16379                 || !r                      /* .... = (); */
16380                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16381                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16382                 || (lscalars < 2)          /* ($x, undef) = ... */
16383             ) {
16384                 NOOP; /* always safe */
16385             }
16386             else if (l & AAS_DANGEROUS) {
16387                 /* always dangerous */
16388                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16389                 o->op_private |= OPpASSIGN_COMMON_AGG;
16390             }
16391             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16392                 /* package vars are always dangerous - too many
16393                  * aliasing possibilities */
16394                 if (l & AAS_PKG_SCALAR)
16395                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16396                 if (l & AAS_PKG_AGG)
16397                     o->op_private |= OPpASSIGN_COMMON_AGG;
16398             }
16399             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16400                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16401             {
16402                 /* LHS contains only lexicals and safe ops */
16403
16404                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16405                     o->op_private |= OPpASSIGN_COMMON_AGG;
16406
16407                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16408                     if (lr & AAS_LEX_SCALAR_COMM)
16409                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16410                     else if (   !(l & AAS_LEX_SCALAR)
16411                              && (r & AAS_DEFAV))
16412                     {
16413                         /* falsely mark
16414                          *    my (...) = @_
16415                          * as scalar-safe for performance reasons.
16416                          * (it will still have been marked _AGG if necessary */
16417                         NOOP;
16418                     }
16419                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16420                         /* if there are only lexicals on the LHS and no
16421                          * common ones on the RHS, then we assume that the
16422                          * only way those lexicals could also get
16423                          * on the RHS is via some sort of dereffing or
16424                          * closure, e.g.
16425                          *    $r = \$lex;
16426                          *    ($lex, $x) = (1, $$r)
16427                          * and in this case we assume the var must have
16428                          *  a bumped ref count. So if its ref count is 1,
16429                          *  it must only be on the LHS.
16430                          */
16431                         o->op_private |= OPpASSIGN_COMMON_RC1;
16432                 }
16433             }
16434
16435             /* ... = ($x)
16436              * may have to handle aggregate on LHS, but we can't
16437              * have common scalars. */
16438             if (rscalars < 2)
16439                 o->op_private &=
16440                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16441
16442             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16443                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16444             break;
16445         }
16446
16447         case OP_REF:
16448             /* see if ref() is used in boolean context */
16449             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16450                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16451             break;
16452
16453         case OP_LENGTH:
16454             /* see if the op is used in known boolean context,
16455              * but not if OA_TARGLEX optimisation is enabled */
16456             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16457                 && !(o->op_private & OPpTARGET_MY)
16458             )
16459                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16460             break;
16461
16462         case OP_POS:
16463             /* see if the op is used in known boolean context */
16464             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16465                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16466             break;
16467
16468         case OP_CUSTOM: {
16469             Perl_cpeep_t cpeep =
16470                 XopENTRYCUSTOM(o, xop_peep);
16471             if (cpeep)
16472                 cpeep(aTHX_ o, oldop);
16473             break;
16474         }
16475
16476         }
16477         /* did we just null the current op? If so, re-process it to handle
16478          * eliding "empty" ops from the chain */
16479         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16480             o->op_opt = 0;
16481             o = oldop;
16482         }
16483         else {
16484             oldoldop = oldop;
16485             oldop = o;
16486         }
16487     }
16488     LEAVE;
16489 }
16490
16491 void
16492 Perl_peep(pTHX_ OP *o)
16493 {
16494     CALL_RPEEP(o);
16495 }
16496
16497 /*
16498 =head1 Custom Operators
16499
16500 =for apidoc Ao||custom_op_xop
16501 Return the XOP structure for a given custom op.  This macro should be
16502 considered internal to C<OP_NAME> and the other access macros: use them instead.
16503 This macro does call a function.  Prior
16504 to 5.19.6, this was implemented as a
16505 function.
16506
16507 =cut
16508 */
16509
16510 XOPRETANY
16511 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16512 {
16513     SV *keysv;
16514     HE *he = NULL;
16515     XOP *xop;
16516
16517     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16518
16519     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16520     assert(o->op_type == OP_CUSTOM);
16521
16522     /* This is wrong. It assumes a function pointer can be cast to IV,
16523      * which isn't guaranteed, but this is what the old custom OP code
16524      * did. In principle it should be safer to Copy the bytes of the
16525      * pointer into a PV: since the new interface is hidden behind
16526      * functions, this can be changed later if necessary.  */
16527     /* Change custom_op_xop if this ever happens */
16528     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16529
16530     if (PL_custom_ops)
16531         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16532
16533     /* assume noone will have just registered a desc */
16534     if (!he && PL_custom_op_names &&
16535         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16536     ) {
16537         const char *pv;
16538         STRLEN l;
16539
16540         /* XXX does all this need to be shared mem? */
16541         Newxz(xop, 1, XOP);
16542         pv = SvPV(HeVAL(he), l);
16543         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16544         if (PL_custom_op_descs &&
16545             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16546         ) {
16547             pv = SvPV(HeVAL(he), l);
16548             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16549         }
16550         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16551     }
16552     else {
16553         if (!he)
16554             xop = (XOP *)&xop_null;
16555         else
16556             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16557     }
16558     {
16559         XOPRETANY any;
16560         if(field == XOPe_xop_ptr) {
16561             any.xop_ptr = xop;
16562         } else {
16563             const U32 flags = XopFLAGS(xop);
16564             if(flags & field) {
16565                 switch(field) {
16566                 case XOPe_xop_name:
16567                     any.xop_name = xop->xop_name;
16568                     break;
16569                 case XOPe_xop_desc:
16570                     any.xop_desc = xop->xop_desc;
16571                     break;
16572                 case XOPe_xop_class:
16573                     any.xop_class = xop->xop_class;
16574                     break;
16575                 case XOPe_xop_peep:
16576                     any.xop_peep = xop->xop_peep;
16577                     break;
16578                 default:
16579                     NOT_REACHED; /* NOTREACHED */
16580                     break;
16581                 }
16582             } else {
16583                 switch(field) {
16584                 case XOPe_xop_name:
16585                     any.xop_name = XOPd_xop_name;
16586                     break;
16587                 case XOPe_xop_desc:
16588                     any.xop_desc = XOPd_xop_desc;
16589                     break;
16590                 case XOPe_xop_class:
16591                     any.xop_class = XOPd_xop_class;
16592                     break;
16593                 case XOPe_xop_peep:
16594                     any.xop_peep = XOPd_xop_peep;
16595                     break;
16596                 default:
16597                     NOT_REACHED; /* NOTREACHED */
16598                     break;
16599                 }
16600             }
16601         }
16602         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16603          * op.c: In function 'Perl_custom_op_get_field':
16604          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16605          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16606          * expands to assert(0), which expands to ((0) ? (void)0 :
16607          * __assert(...)), and gcc doesn't know that __assert can never return. */
16608         return any;
16609     }
16610 }
16611
16612 /*
16613 =for apidoc Ao||custom_op_register
16614 Register a custom op.  See L<perlguts/"Custom Operators">.
16615
16616 =cut
16617 */
16618
16619 void
16620 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16621 {
16622     SV *keysv;
16623
16624     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16625
16626     /* see the comment in custom_op_xop */
16627     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16628
16629     if (!PL_custom_ops)
16630         PL_custom_ops = newHV();
16631
16632     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16633         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16634 }
16635
16636 /*
16637
16638 =for apidoc core_prototype
16639
16640 This function assigns the prototype of the named core function to C<sv>, or
16641 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16642 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16643 by C<keyword()>.  It must not be equal to 0.
16644
16645 =cut
16646 */
16647
16648 SV *
16649 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16650                           int * const opnum)
16651 {
16652     int i = 0, n = 0, seen_question = 0, defgv = 0;
16653     I32 oa;
16654 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16655     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16656     bool nullret = FALSE;
16657
16658     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16659
16660     assert (code);
16661
16662     if (!sv) sv = sv_newmortal();
16663
16664 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16665
16666     switch (code < 0 ? -code : code) {
16667     case KEY_and   : case KEY_chop: case KEY_chomp:
16668     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16669     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16670     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16671     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16672     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16673     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16674     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16675     case KEY_x     : case KEY_xor    :
16676         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16677     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16678     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16679     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16680     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16681     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16682     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16683         retsetpvs("", 0);
16684     case KEY_evalbytes:
16685         name = "entereval"; break;
16686     case KEY_readpipe:
16687         name = "backtick";
16688     }
16689
16690 #undef retsetpvs
16691
16692   findopnum:
16693     while (i < MAXO) {  /* The slow way. */
16694         if (strEQ(name, PL_op_name[i])
16695             || strEQ(name, PL_op_desc[i]))
16696         {
16697             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16698             goto found;
16699         }
16700         i++;
16701     }
16702     return NULL;
16703   found:
16704     defgv = PL_opargs[i] & OA_DEFGV;
16705     oa = PL_opargs[i] >> OASHIFT;
16706     while (oa) {
16707         if (oa & OA_OPTIONAL && !seen_question && (
16708               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16709         )) {
16710             seen_question = 1;
16711             str[n++] = ';';
16712         }
16713         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16714             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16715             /* But globs are already references (kinda) */
16716             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16717         ) {
16718             str[n++] = '\\';
16719         }
16720         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16721          && !scalar_mod_type(NULL, i)) {
16722             str[n++] = '[';
16723             str[n++] = '$';
16724             str[n++] = '@';
16725             str[n++] = '%';
16726             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16727             str[n++] = '*';
16728             str[n++] = ']';
16729         }
16730         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16731         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16732             str[n-1] = '_'; defgv = 0;
16733         }
16734         oa = oa >> 4;
16735     }
16736     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16737     str[n++] = '\0';
16738     sv_setpvn(sv, str, n - 1);
16739     if (opnum) *opnum = i;
16740     return sv;
16741 }
16742
16743 OP *
16744 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16745                       const int opnum)
16746 {
16747     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16748     OP *o;
16749
16750     PERL_ARGS_ASSERT_CORESUB_OP;
16751
16752     switch(opnum) {
16753     case 0:
16754         return op_append_elem(OP_LINESEQ,
16755                        argop,
16756                        newSLICEOP(0,
16757                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16758                                   newOP(OP_CALLER,0)
16759                        )
16760                );
16761     case OP_EACH:
16762     case OP_KEYS:
16763     case OP_VALUES:
16764         o = newUNOP(OP_AVHVSWITCH,0,argop);
16765         o->op_private = opnum-OP_EACH;
16766         return o;
16767     case OP_SELECT: /* which represents OP_SSELECT as well */
16768         if (code)
16769             return newCONDOP(
16770                          0,
16771                          newBINOP(OP_GT, 0,
16772                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16773                                   newSVOP(OP_CONST, 0, newSVuv(1))
16774                                  ),
16775                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16776                                     OP_SSELECT),
16777                          coresub_op(coreargssv, 0, OP_SELECT)
16778                    );
16779         /* FALLTHROUGH */
16780     default:
16781         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16782         case OA_BASEOP:
16783             return op_append_elem(
16784                         OP_LINESEQ, argop,
16785                         newOP(opnum,
16786                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16787                                 ? OPpOFFBYONE << 8 : 0)
16788                    );
16789         case OA_BASEOP_OR_UNOP:
16790             if (opnum == OP_ENTEREVAL) {
16791                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16792                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16793             }
16794             else o = newUNOP(opnum,0,argop);
16795             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16796             else {
16797           onearg:
16798               if (is_handle_constructor(o, 1))
16799                 argop->op_private |= OPpCOREARGS_DEREF1;
16800               if (scalar_mod_type(NULL, opnum))
16801                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16802             }
16803             return o;
16804         default:
16805             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16806             if (is_handle_constructor(o, 2))
16807                 argop->op_private |= OPpCOREARGS_DEREF2;
16808             if (opnum == OP_SUBSTR) {
16809                 o->op_private |= OPpMAYBE_LVSUB;
16810                 return o;
16811             }
16812             else goto onearg;
16813         }
16814     }
16815 }
16816
16817 void
16818 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16819                                SV * const *new_const_svp)
16820 {
16821     const char *hvname;
16822     bool is_const = !!CvCONST(old_cv);
16823     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16824
16825     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16826
16827     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16828         return;
16829         /* They are 2 constant subroutines generated from
16830            the same constant. This probably means that
16831            they are really the "same" proxy subroutine
16832            instantiated in 2 places. Most likely this is
16833            when a constant is exported twice.  Don't warn.
16834         */
16835     if (
16836         (ckWARN(WARN_REDEFINE)
16837          && !(
16838                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16839              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16840              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16841                  strEQ(hvname, "autouse"))
16842              )
16843         )
16844      || (is_const
16845          && ckWARN_d(WARN_REDEFINE)
16846          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16847         )
16848     )
16849         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16850                           is_const
16851                             ? "Constant subroutine %" SVf " redefined"
16852                             : "Subroutine %" SVf " redefined",
16853                           SVfARG(name));
16854 }
16855
16856 /*
16857 =head1 Hook manipulation
16858
16859 These functions provide convenient and thread-safe means of manipulating
16860 hook variables.
16861
16862 =cut
16863 */
16864
16865 /*
16866 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16867
16868 Puts a C function into the chain of check functions for a specified op
16869 type.  This is the preferred way to manipulate the L</PL_check> array.
16870 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16871 is a pointer to the C function that is to be added to that opcode's
16872 check chain, and C<old_checker_p> points to the storage location where a
16873 pointer to the next function in the chain will be stored.  The value of
16874 C<new_checker> is written into the L</PL_check> array, while the value
16875 previously stored there is written to C<*old_checker_p>.
16876
16877 L</PL_check> is global to an entire process, and a module wishing to
16878 hook op checking may find itself invoked more than once per process,
16879 typically in different threads.  To handle that situation, this function
16880 is idempotent.  The location C<*old_checker_p> must initially (once
16881 per process) contain a null pointer.  A C variable of static duration
16882 (declared at file scope, typically also marked C<static> to give
16883 it internal linkage) will be implicitly initialised appropriately,
16884 if it does not have an explicit initialiser.  This function will only
16885 actually modify the check chain if it finds C<*old_checker_p> to be null.
16886 This function is also thread safe on the small scale.  It uses appropriate
16887 locking to avoid race conditions in accessing L</PL_check>.
16888
16889 When this function is called, the function referenced by C<new_checker>
16890 must be ready to be called, except for C<*old_checker_p> being unfilled.
16891 In a threading situation, C<new_checker> may be called immediately,
16892 even before this function has returned.  C<*old_checker_p> will always
16893 be appropriately set before C<new_checker> is called.  If C<new_checker>
16894 decides not to do anything special with an op that it is given (which
16895 is the usual case for most uses of op check hooking), it must chain the
16896 check function referenced by C<*old_checker_p>.
16897
16898 Taken all together, XS code to hook an op checker should typically look
16899 something like this:
16900
16901     static Perl_check_t nxck_frob;
16902     static OP *myck_frob(pTHX_ OP *op) {
16903         ...
16904         op = nxck_frob(aTHX_ op);
16905         ...
16906         return op;
16907     }
16908     BOOT:
16909         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16910
16911 If you want to influence compilation of calls to a specific subroutine,
16912 then use L</cv_set_call_checker_flags> rather than hooking checking of
16913 all C<entersub> ops.
16914
16915 =cut
16916 */
16917
16918 void
16919 Perl_wrap_op_checker(pTHX_ Optype opcode,
16920     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16921 {
16922     dVAR;
16923
16924     PERL_UNUSED_CONTEXT;
16925     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16926     if (*old_checker_p) return;
16927     OP_CHECK_MUTEX_LOCK;
16928     if (!*old_checker_p) {
16929         *old_checker_p = PL_check[opcode];
16930         PL_check[opcode] = new_checker;
16931     }
16932     OP_CHECK_MUTEX_UNLOCK;
16933 }
16934
16935 #include "XSUB.h"
16936
16937 /* Efficient sub that returns a constant scalar value. */
16938 static void
16939 const_sv_xsub(pTHX_ CV* cv)
16940 {
16941     dXSARGS;
16942     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16943     PERL_UNUSED_ARG(items);
16944     if (!sv) {
16945         XSRETURN(0);
16946     }
16947     EXTEND(sp, 1);
16948     ST(0) = sv;
16949     XSRETURN(1);
16950 }
16951
16952 static void
16953 const_av_xsub(pTHX_ CV* cv)
16954 {
16955     dXSARGS;
16956     AV * const av = MUTABLE_AV(XSANY.any_ptr);
16957     SP -= items;
16958     assert(av);
16959 #ifndef DEBUGGING
16960     if (!av) {
16961         XSRETURN(0);
16962     }
16963 #endif
16964     if (SvRMAGICAL(av))
16965         Perl_croak(aTHX_ "Magical list constants are not supported");
16966     if (GIMME_V != G_ARRAY) {
16967         EXTEND(SP, 1);
16968         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16969         XSRETURN(1);
16970     }
16971     EXTEND(SP, AvFILLp(av)+1);
16972     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16973     XSRETURN(AvFILLp(av)+1);
16974 }
16975
16976
16977 /*
16978  * ex: set ts=8 sts=4 sw=4 et:
16979  */