op.c

   1 #line 2 "op.c"
   2 /*    op.c
   3  *
   4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   6  *
   7  *    You may distribute under the terms of either the GNU General Public
   8  *    License or the Artistic License, as specified in the README file.
   9  *
  10  */
  11
  12 /*
  13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
  15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
  16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  17  *  either way, as the saying is, if you follow me.'       --the Gaffer
  18  *
  19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains the functions that create, manipulate and optimize
  23  * the OP structures that hold a compiled perl program.
  24  *
  25  * Note that during the build of miniperl, a temporary copy of this file
  26  * is made, called opmini.c.
  27  *
  28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
  29  *  * structural OP pointers to its children and siblings (op_sibling,
  30  *    op_first etc) that define the tree structure;
  31  *  * execution order OP pointers (op_next, plus sometimes op_other,
  32  *    op_lastop  etc) that define the execution sequence plus variants;
  33  *  * a pointer to the C "pp" function that would execute the op;
  34  *  * any data specific to that op.
  35  * For example, an OP_CONST op points to the pp_const() function and to an
  36  * SV containing the constant value. When pp_const() is executed, its job
  37  * is to push that SV onto the stack.
  38  *
  39  * OPs are mainly created by the newFOO() functions, which are mainly
  40  * called from the parser (in perly.y) as the code is parsed. For example
  41  * the Perl code $a + $b * $c would cause the equivalent of the following
  42  * to be called (oversimplifying a bit):
  43  *
  44  *  newBINOP(OP_ADD, flags,
  45  *      newSVREF($a),
  46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  47  *  )
  48  *
  49  * As the parser reduces low-level rules, it creates little op subtrees;
  50  * as higher-level rules are resolved, these subtrees get joined together
  51  * as branches on a bigger subtree, until eventually a top-level rule like
  52  * a subroutine definition is reduced, at which point there is one large
  53  * parse tree left.
  54  *
  55  * The execution order pointers (op_next) are generated as the subtrees
  56  * are joined together. Consider this sub-expression: A*B + C/D: at the
  57  * point when it's just been parsed, the op tree looks like:
  58  *
  59  *   [+]
  60  *    |
  61  *   [*]------[/]
  62  *    |        |
  63  *    A---B    C---D
  64  *
  65  * with the intended execution order being:
  66  *
  67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
  68  *
  69  * At this point all the nodes' op_next pointers will have been set,
  70  * except that:
  71  *    * we don't know what the [NEXT] node will be yet;
  72  *    * we don't know what the [PREV] node will be yet, but when it gets
  73  *      created and needs its op_next set, it needs to be set to point to
  74  *      A, which is non-obvious.
  75  * To handle both those cases, we temporarily set the top node's
  76  * op_next to point to the first node to be executed in this subtree (A in
  77  * this case). This means that initially a subtree's op_next chain,
  78  * starting from the top node, will visit each node in execution sequence
  79  * then point back at the top node.
  80  * When we embed this subtree in a larger tree, its top op_next is used
  81  * to get the start node, then is set to point to its new neighbour.
  82  * For example the two separate [*],A,B and [/],C,D subtrees would
  83  * initially have had:
  84  *   [*] => A;  A => B;  B => [*]
  85  * and
  86  *   [/] => C;  C => D;  D => [/]
  87  * When these two subtrees were joined together to make the [+] subtree,
  88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
  89  * set to point to [/]'s op_next, i.e. C.
  90  *
  91  * This op_next linking is done by the LINKLIST() macro and its underlying
  92  * op_linklist() function. Given a top-level op, if its op_next is
  93  * non-null, it's already been linked, so leave it. Otherwise link it with
  94  * its children as described above, possibly recursively if any of the
  95  * children have a null op_next.
  96  *
  97  * In summary: given a subtree, its top-level node's op_next will either
  98  * be:
  99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
 100  *   fake: points to the start op for this subtree;
 101  *   real: once the subtree has been embedded into a larger tree
 102  */
 103
 104 /*
 105
 106 Here's an older description from Larry.
 107
 108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
 109
 110     A bottom-up pass
 111     A top-down pass
 112     An execution-order pass
 113
 114 The bottom-up pass is represented by all the "newOP" routines and
 115 the ck_ routines.  The bottom-upness is actually driven by yacc.
 116 So at the point that a ck_ routine fires, we have no idea what the
 117 context is, either upward in the syntax tree, or either forward or
 118 backward in the execution order.  (The bottom-up parser builds that
 119 part of the execution order it knows about, but if you follow the "next"
 120 links around, you'll find it's actually a closed loop through the
 121 top level node.)
 122
 123 Whenever the bottom-up parser gets to a node that supplies context to
 124 its components, it invokes that portion of the top-down pass that applies
 125 to that part of the subtree (and marks the top node as processed, so
 126 if a node further up supplies context, it doesn't have to take the
 127 plunge again).  As a particular subcase of this, as the new node is
 128 built, it takes all the closed execution loops of its subcomponents
 129 and links them into a new closed loop for the higher level node.  But
 130 it's still not the real execution order.
 131
 132 The actual execution order is not known till we get a grammar reduction
 133 to a top-level unit like a subroutine or file that will be called by
 134 "name" rather than via a "next" pointer.  At that point, we can call
 135 into peep() to do that code's portion of the 3rd pass.  It has to be
 136 recursive, but it's recursive on basic blocks, not on tree nodes.
 137 */
 138
 139 /* To implement user lexical pragmas, there needs to be a way at run time to
 140    get the compile time state of %^H for that block.  Storing %^H in every
 141    block (or even COP) would be very expensive, so a different approach is
 142    taken.  The (running) state of %^H is serialised into a tree of HE-like
 143    structs.  Stores into %^H are chained onto the current leaf as a struct
 144    refcounted_he * with the key and the value.  Deletes from %^H are saved
 145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
 146    turned back into a regular HV by walking back up the tree from that point's
 147    leaf, ignoring any key you've already seen (placeholder or not), storing
 148    the rest into the HV structure, then removing the placeholders. Hence
 149    memory is only used to store the %^H deltas from the enclosing COP, rather
 150    than the entire %^H on each COP.
 151
 152    To cause actions on %^H to write out the serialisation records, it has
 153    magic type 'H'. This magic (itself) does nothing, but its presence causes
 154    the values to gain magic type 'h', which has entries for set and clear.
 155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
 156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
 157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
 158    it will be correctly restored when any inner compiling scope is exited.
 159 */
 160
 161 #include "EXTERN.h"
 162 #define PERL_IN_OP_C
 163 #include "perl.h"
 164 #include "keywords.h"
 165 #include "feature.h"
 166 #include "regcomp.h"
 167
 168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
 169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 171
 172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
 173
 174 /* Used to avoid recursion through the op tree in scalarvoid() and
 175    op_free()
 176 */
 177
 178 #define DEFERRED_OP_STEP 100
 179 #define DEFER_OP(o) \
 180   STMT_START { \
 181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
 182         defer_stack_alloc += DEFERRED_OP_STEP; \
 183         assert(defer_stack_alloc > 0); \
 184         Renew(defer_stack, defer_stack_alloc, OP *); \
 185     } \
 186     defer_stack[++defer_ix] = o; \
 187   } STMT_END
 188
 189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
 190
 191 /* remove any leading "empty" ops from the op_next chain whose first
 192  * node's address is stored in op_p. Store the updated address of the
 193  * first node in op_p.
 194  */
 195
 196 STATIC void
 197 S_prune_chain_head(OP** op_p)
 198 {
 199     while (*op_p
 200         && (   (*op_p)->op_type == OP_NULL
 201             || (*op_p)->op_type == OP_SCOPE
 202             || (*op_p)->op_type == OP_SCALAR
 203             || (*op_p)->op_type == OP_LINESEQ)
 204     )
 205         *op_p = (*op_p)->op_next;
 206 }
 207
 208
 209 /* See the explanatory comments above struct opslab in op.h. */
 210
 211 #ifdef PERL_DEBUG_READONLY_OPS
 212 #  define PERL_SLAB_SIZE 128
 213 #  define PERL_MAX_SLAB_SIZE 4096
 214 #  include <sys/mman.h>
 215 #endif
 216
 217 #ifndef PERL_SLAB_SIZE
 218 #  define PERL_SLAB_SIZE 64
 219 #endif
 220 #ifndef PERL_MAX_SLAB_SIZE
 221 #  define PERL_MAX_SLAB_SIZE 2048
 222 #endif
 223
 224 /* rounds up to nearest pointer */
 225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
 226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
 227
 228 static OPSLAB *
 229 S_new_slab(pTHX_ size_t sz)
 230 {
 231 #ifdef PERL_DEBUG_READONLY_OPS
 232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
 233                                    PROT_READ|PROT_WRITE,
 234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
 235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
 236                           (unsigned long) sz, slab));
 237     if (slab == MAP_FAILED) {
 238         perror("mmap failed");
 239         abort();
 240     }
 241     slab->opslab_size = (U16)sz;
 242 #else
 243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
 244 #endif
 245 #ifndef WIN32
 246     /* The context is unused in non-Windows */
 247     PERL_UNUSED_CONTEXT;
 248 #endif
 249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
 250     return slab;
 251 }
 252
 253 /* requires double parens and aTHX_ */
 254 #define DEBUG_S_warn(args)                                             \
 255     DEBUG_S(                                                            \
 256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
 257     )
 258
 259 void *
 260 Perl_Slab_Alloc(pTHX_ size_t sz)
 261 {
 262     OPSLAB *slab;
 263     OPSLAB *slab2;
 264     OPSLOT *slot;
 265     OP *o;
 266     size_t opsz, space;
 267
 268     /* We only allocate ops from the slab during subroutine compilation.
 269        We find the slab via PL_compcv, hence that must be non-NULL. It could
 270        also be pointing to a subroutine which is now fully set up (CvROOT()
 271        pointing to the top of the optree for that sub), or a subroutine
 272        which isn't using the slab allocator. If our sanity checks aren't met,
 273        don't use a slab, but allocate the OP directly from the heap.  */
 274     if (!PL_compcv || CvROOT(PL_compcv)
 275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
 276     {
 277         o = (OP*)PerlMemShared_calloc(1, sz);
 278         goto gotit;
 279     }
 280
 281     /* While the subroutine is under construction, the slabs are accessed via
 282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
 283        unneeded at runtime. Once a subroutine is constructed, the slabs are
 284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
 285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
 286        details.  */
 287     if (!CvSTART(PL_compcv)) {
 288         CvSTART(PL_compcv) =
 289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
 290         CvSLABBED_on(PL_compcv);
 291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
 292     }
 293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
 294
 295     opsz = SIZE_TO_PSIZE(sz);
 296     sz = opsz + OPSLOT_HEADER_P;
 297
 298     /* The slabs maintain a free list of OPs. In particular, constant folding
 299        will free up OPs, so it makes sense to re-use them where possible. A
 300        freed up slot is used in preference to a new allocation.  */
 301     if (slab->opslab_freed) {
 302         OP **too = &slab->opslab_freed;
 303         o = *too;
 304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
 305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
 306             DEBUG_S_warn((aTHX_ "Alas! too small"));
 307             o = *(too = &o->op_next);
 308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
 309         }
 310         if (o) {
 311             *too = o->op_next;
 312             Zero(o, opsz, I32 *);
 313             o->op_slabbed = 1;
 314             goto gotit;
 315         }
 316     }
 317
 318 #define INIT_OPSLOT \
 319             slot->opslot_slab = slab;                   \
 320             slot->opslot_next = slab2->opslab_first;    \
 321             slab2->opslab_first = slot;                 \
 322             o = &slot->opslot_op;                       \
 323             o->op_slabbed = 1
 324
 325     /* The partially-filled slab is next in the chain. */
 326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
 327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
 328         /* Remaining space is too small. */
 329
 330         /* If we can fit a BASEOP, add it to the free chain, so as not
 331            to waste it. */
 332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
 333             slot = &slab2->opslab_slots;
 334             INIT_OPSLOT;
 335             o->op_type = OP_FREED;
 336             o->op_next = slab->opslab_freed;
 337             slab->opslab_freed = o;
 338         }
 339
 340         /* Create a new slab.  Make this one twice as big. */
 341         slot = slab2->opslab_first;
 342         while (slot->opslot_next) slot = slot->opslot_next;
 343         slab2 = S_new_slab(aTHX_
 344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
 345                                         ? PERL_MAX_SLAB_SIZE
 346                                         : (DIFF(slab2, slot)+1)*2);
 347         slab2->opslab_next = slab->opslab_next;
 348         slab->opslab_next = slab2;
 349     }
 350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
 351
 352     /* Create a new op slot */
 353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
 354     assert(slot >= &slab2->opslab_slots);
 355     if (DIFF(&slab2->opslab_slots, slot)
 356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
 357         slot = &slab2->opslab_slots;
 358     INIT_OPSLOT;
 359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
 360
 361   gotit:
 362 #ifdef PERL_OP_PARENT
 363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
 364     assert(!o->op_moresib);
 365     assert(!o->op_sibparent);
 366 #endif
 367
 368     return (void *)o;
 369 }
 370
 371 #undef INIT_OPSLOT
 372
 373 #ifdef PERL_DEBUG_READONLY_OPS
 374 void
 375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
 376 {
 377     PERL_ARGS_ASSERT_SLAB_TO_RO;
 378
 379     if (slab->opslab_readonly) return;
 380     slab->opslab_readonly = 1;
 381     for (; slab; slab = slab->opslab_next) {
 382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
 383                               (unsigned long) slab->opslab_size, slab));*/
 384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
 385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
 386                              (unsigned long)slab->opslab_size, errno);
 387     }
 388 }
 389
 390 void
 391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 392 {
 393     OPSLAB *slab2;
 394
 395     PERL_ARGS_ASSERT_SLAB_TO_RW;
 396
 397     if (!slab->opslab_readonly) return;
 398     slab2 = slab;
 399     for (; slab2; slab2 = slab2->opslab_next) {
 400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
 401                               (unsigned long) size, slab2));*/
 402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
 403                      PROT_READ|PROT_WRITE)) {
 404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
 405                              (unsigned long)slab2->opslab_size, errno);
 406         }
 407     }
 408     slab->opslab_readonly = 0;
 409 }
 410
 411 #else
 412 #  define Slab_to_rw(op)    NOOP
 413 #endif
 414
 415 /* This cannot possibly be right, but it was copied from the old slab
 416    allocator, to which it was originally added, without explanation, in
 417    commit 083fcd5. */
 418 #ifdef NETWARE
 419 #    define PerlMemShared PerlMem
 420 #endif
 421
 422 /* make freed ops die if they're inadvertently executed */
 423 #ifdef DEBUGGING
 424 static OP *
 425 S_pp_freed(pTHX)
 426 {
 427     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
 428 }
 429 #endif
 430
 431 void
 432 Perl_Slab_Free(pTHX_ void *op)
 433 {
 434     OP * const o = (OP *)op;
 435     OPSLAB *slab;
 436
 437     PERL_ARGS_ASSERT_SLAB_FREE;
 438
 439 #ifdef DEBUGGING
 440     o->op_ppaddr = S_pp_freed;
 441 #endif
 442
 443     if (!o->op_slabbed) {
 444         if (!o->op_static)
 445             PerlMemShared_free(op);
 446         return;
 447     }
 448
 449     slab = OpSLAB(o);
 450     /* If this op is already freed, our refcount will get screwy. */
 451     assert(o->op_type != OP_FREED);
 452     o->op_type = OP_FREED;
 453     o->op_next = slab->opslab_freed;
 454     slab->opslab_freed = o;
 455     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
 456     OpslabREFCNT_dec_padok(slab);
 457 }
 458
 459 void
 460 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
 461 {
 462     const bool havepad = !!PL_comppad;
 463     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
 464     if (havepad) {
 465         ENTER;
 466         PAD_SAVE_SETNULLPAD();
 467     }
 468     opslab_free(slab);
 469     if (havepad) LEAVE;
 470 }
 471
 472 void
 473 Perl_opslab_free(pTHX_ OPSLAB *slab)
 474 {
 475     OPSLAB *slab2;
 476     PERL_ARGS_ASSERT_OPSLAB_FREE;
 477     PERL_UNUSED_CONTEXT;
 478     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
 479     assert(slab->opslab_refcnt == 1);
 480     do {
 481         slab2 = slab->opslab_next;
 482 #ifdef DEBUGGING
 483         slab->opslab_refcnt = ~(size_t)0;
 484 #endif
 485 #ifdef PERL_DEBUG_READONLY_OPS
 486         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
 487                                                (void*)slab));
 488         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
 489             perror("munmap failed");
 490             abort();
 491         }
 492 #else
 493         PerlMemShared_free(slab);
 494 #endif
 495         slab = slab2;
 496     } while (slab);
 497 }
 498
 499 void
 500 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
 501 {
 502     OPSLAB *slab2;
 503 #ifdef DEBUGGING
 504     size_t savestack_count = 0;
 505 #endif
 506     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
 507     slab2 = slab;
 508     do {
 509         OPSLOT *slot;
 510         for (slot = slab2->opslab_first;
 511              slot->opslot_next;
 512              slot = slot->opslot_next) {
 513             if (slot->opslot_op.op_type != OP_FREED
 514              && !(slot->opslot_op.op_savefree
 515 #ifdef DEBUGGING
 516                   && ++savestack_count
 517 #endif
 518                  )
 519             ) {
 520                 assert(slot->opslot_op.op_slabbed);
 521                 op_free(&slot->opslot_op);
 522                 if (slab->opslab_refcnt == 1) goto free;
 523             }
 524         }
 525     } while ((slab2 = slab2->opslab_next));
 526     /* > 1 because the CV still holds a reference count. */
 527     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
 528 #ifdef DEBUGGING
 529         assert(savestack_count == slab->opslab_refcnt-1);
 530 #endif
 531         /* Remove the CV’s reference count. */
 532         slab->opslab_refcnt--;
 533         return;
 534     }
 535    free:
 536     opslab_free(slab);
 537 }
 538
 539 #ifdef PERL_DEBUG_READONLY_OPS
 540 OP *
 541 Perl_op_refcnt_inc(pTHX_ OP *o)
 542 {
 543     if(o) {
 544         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 545         if (slab && slab->opslab_readonly) {
 546             Slab_to_rw(slab);
 547             ++o->op_targ;
 548             Slab_to_ro(slab);
 549         } else {
 550             ++o->op_targ;
 551         }
 552     }
 553     return o;
 554
 555 }
 556
 557 PADOFFSET
 558 Perl_op_refcnt_dec(pTHX_ OP *o)
 559 {
 560     PADOFFSET result;
 561     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
 562
 563     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
 564
 565     if (slab && slab->opslab_readonly) {
 566         Slab_to_rw(slab);
 567         result = --o->op_targ;
 568         Slab_to_ro(slab);
 569     } else {
 570         result = --o->op_targ;
 571     }
 572     return result;
 573 }
 574 #endif
 575 /*
 576  * In the following definition, the ", (OP*)0" is just to make the compiler
 577  * think the expression is of the right type: croak actually does a Siglongjmp.
 578  */
 579 #define CHECKOP(type,o) \
 580     ((PL_op_mask && PL_op_mask[type])                           \
 581      ? ( op_free((OP*)o),                                       \
 582          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 583          (OP*)0 )                                               \
 584      : PL_check[type](aTHX_ (OP*)o))
 585
 586 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 587
 588 #define OpTYPE_set(o,type) \
 589     STMT_START {                                \
 590         o->op_type = (OPCODE)type;              \
 591         o->op_ppaddr = PL_ppaddr[type];         \
 592     } STMT_END
 593
 594 STATIC OP *
 595 S_no_fh_allowed(pTHX_ OP *o)
 596 {
 597     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
 598
 599     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 600                  OP_DESC(o)));
 601     return o;
 602 }
 603
 604 STATIC OP *
 605 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 606 {
 607     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
 608     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
 609     return o;
 610 }
 611
 612 STATIC OP *
 613 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
 614 {
 615     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
 616
 617     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
 618     return o;
 619 }
 620
 621 STATIC void
 622 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
 623 {
 624     PERL_ARGS_ASSERT_BAD_TYPE_PV;
 625
 626     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 627                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
 628 }
 629
 630 /* remove flags var, its unused in all callers, move to to right end since gv
 631   and kid are always the same */
 632 STATIC void
 633 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
 634 {
 635     SV * const namesv = cv_name((CV *)gv, NULL, 0);
 636     PERL_ARGS_ASSERT_BAD_TYPE_GV;
 637
 638     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
 639                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
 640 }
 641
 642 STATIC void
 643 S_no_bareword_allowed(pTHX_ OP *o)
 644 {
 645     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
 646
 647     qerror(Perl_mess(aTHX_
 648                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
 649                      SVfARG(cSVOPo_sv)));
 650     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
 651 }
 652
 653 /* "register" allocation */
 654
 655 PADOFFSET
 656 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 657 {
 658     PADOFFSET off;
 659     const bool is_our = (PL_parser->in_my == KEY_our);
 660
 661     PERL_ARGS_ASSERT_ALLOCMY;
 662
 663     if (flags & ~SVf_UTF8)
 664         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
 665                    (UV)flags);
 666
 667     /* complain about "my $<special_var>" etc etc */
 668     if (   len
 669         && !(  is_our
 670             || isALPHA(name[1])
 671             || (   (flags & SVf_UTF8)
 672                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
 673             || (name[1] == '_' && len > 2)))
 674     {
 675         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
 676          && isASCII(name[1])
 677          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
 678             /* diag_listed_as: Can't use global %s in "%s" */
 679             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
 680                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 681                               PL_parser->in_my == KEY_state ? "state" : "my"));
 682         } else {
 683             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 684                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
 685         }
 686     }
 687
 688     /* allocate a spare slot and store the name in that slot */
 689
 690     off = pad_add_name_pvn(name, len,
 691                        (is_our ? padadd_OUR :
 692                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
 693                     PL_parser->in_my_stash,
 694                     (is_our
 695                         /* $_ is always in main::, even with our */
 696                         ? (PL_curstash && !memEQs(name,len,"$_")
 697                             ? PL_curstash
 698                             : PL_defstash)
 699                         : NULL
 700                     )
 701     );
 702     /* anon sub prototypes contains state vars should always be cloned,
 703      * otherwise the state var would be shared between anon subs */
 704
 705     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
 706         CvCLONE_on(PL_compcv);
 707
 708     return off;
 709 }
 710
 711 /*
 712 =head1 Optree Manipulation Functions
 713
 714 =for apidoc alloccopstash
 715
 716 Available only under threaded builds, this function allocates an entry in
 717 C<PL_stashpad> for the stash passed to it.
 718
 719 =cut
 720 */
 721
 722 #ifdef USE_ITHREADS
 723 PADOFFSET
 724 Perl_alloccopstash(pTHX_ HV *hv)
 725 {
 726     PADOFFSET off = 0, o = 1;
 727     bool found_slot = FALSE;
 728
 729     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
 730
 731     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
 732
 733     for (; o < PL_stashpadmax; ++o) {
 734         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
 735         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
 736             found_slot = TRUE, off = o;
 737     }
 738     if (!found_slot) {
 739         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
 740         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
 741         off = PL_stashpadmax;
 742         PL_stashpadmax += 10;
 743     }
 744
 745     PL_stashpad[PL_stashpadix = off] = hv;
 746     return off;
 747 }
 748 #endif
 749
 750 /* free the body of an op without examining its contents.
 751  * Always use this rather than FreeOp directly */
 752
 753 static void
 754 S_op_destroy(pTHX_ OP *o)
 755 {
 756     FreeOp(o);
 757 }
 758
 759 /* Destructor */
 760
 761 /*
 762 =for apidoc Am|void|op_free|OP *o
 763
 764 Free an op.  Only use this when an op is no longer linked to from any
 765 optree.
 766
 767 =cut
 768 */
 769
 770 void
 771 Perl_op_free(pTHX_ OP *o)
 772 {
 773     dVAR;
 774     OPCODE type;
 775     SSize_t defer_ix = -1;
 776     SSize_t defer_stack_alloc = 0;
 777     OP **defer_stack = NULL;
 778
 779     do {
 780
 781         /* Though ops may be freed twice, freeing the op after its slab is a
 782            big no-no. */
 783         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
 784         /* During the forced freeing of ops after compilation failure, kidops
 785            may be freed before their parents. */
 786         if (!o || o->op_type == OP_FREED)
 787             continue;
 788
 789         type = o->op_type;
 790
 791         /* an op should only ever acquire op_private flags that we know about.
 792          * If this fails, you may need to fix something in regen/op_private.
 793          * Don't bother testing if:
 794          *   * the op_ppaddr doesn't match the op; someone may have
 795          *     overridden the op and be doing strange things with it;
 796          *   * we've errored, as op flags are often left in an
 797          *     inconsistent state then. Note that an error when
 798          *     compiling the main program leaves PL_parser NULL, so
 799          *     we can't spot faults in the main code, only
 800          *     evaled/required code */
 801 #ifdef DEBUGGING
 802         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
 803             && PL_parser
 804             && !PL_parser->error_count)
 805         {
 806             assert(!(o->op_private & ~PL_op_private_valid[type]));
 807         }
 808 #endif
 809
 810         if (o->op_private & OPpREFCOUNTED) {
 811             switch (type) {
 812             case OP_LEAVESUB:
 813             case OP_LEAVESUBLV:
 814             case OP_LEAVEEVAL:
 815             case OP_LEAVE:
 816             case OP_SCOPE:
 817             case OP_LEAVEWRITE:
 818                 {
 819                 PADOFFSET refcnt;
 820                 OP_REFCNT_LOCK;
 821                 refcnt = OpREFCNT_dec(o);
 822                 OP_REFCNT_UNLOCK;
 823                 if (refcnt) {
 824                     /* Need to find and remove any pattern match ops from the list
 825                        we maintain for reset().  */
 826                     find_and_forget_pmops(o);
 827                     continue;
 828                 }
 829                 }
 830                 break;
 831             default:
 832                 break;
 833             }
 834         }
 835
 836         /* Call the op_free hook if it has been set. Do it now so that it's called
 837          * at the right time for refcounted ops, but still before all of the kids
 838          * are freed. */
 839         CALL_OPFREEHOOK(o);
 840
 841         if (o->op_flags & OPf_KIDS) {
 842             OP *kid, *nextkid;
 843             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 844                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
 845                 if (!kid || kid->op_type == OP_FREED)
 846                     /* During the forced freeing of ops after
 847                        compilation failure, kidops may be freed before
 848                        their parents. */
 849                     continue;
 850                 if (!(kid->op_flags & OPf_KIDS))
 851                     /* If it has no kids, just free it now */
 852                     op_free(kid);
 853                 else
 854                     DEFER_OP(kid);
 855             }
 856         }
 857         if (type == OP_NULL)
 858             type = (OPCODE)o->op_targ;
 859
 860         if (o->op_slabbed)
 861             Slab_to_rw(OpSLAB(o));
 862
 863         /* COP* is not cleared by op_clear() so that we may track line
 864          * numbers etc even after null() */
 865         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
 866             cop_free((COP*)o);
 867         }
 868
 869         op_clear(o);
 870         FreeOp(o);
 871         if (PL_op == o)
 872             PL_op = NULL;
 873     } while ( (o = POP_DEFERRED_OP()) );
 874
 875     Safefree(defer_stack);
 876 }
 877
 878 /* S_op_clear_gv(): free a GV attached to an OP */
 879
 880 STATIC
 881 #ifdef USE_ITHREADS
 882 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
 883 #else
 884 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
 885 #endif
 886 {
 887
 888     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
 889             || o->op_type == OP_MULTIDEREF)
 890 #ifdef USE_ITHREADS
 891                 && PL_curpad
 892                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
 893 #else
 894                 ? (GV*)(*svp) : NULL;
 895 #endif
 896     /* It's possible during global destruction that the GV is freed
 897        before the optree. Whilst the SvREFCNT_inc is happy to bump from
 898        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
 899        will trigger an assertion failure, because the entry to sv_clear
 900        checks that the scalar is not already freed.  A check of for
 901        !SvIS_FREED(gv) turns out to be invalid, because during global
 902        destruction the reference count can be forced down to zero
 903        (with SVf_BREAK set).  In which case raising to 1 and then
 904        dropping to 0 triggers cleanup before it should happen.  I
 905        *think* that this might actually be a general, systematic,
 906        weakness of the whole idea of SVf_BREAK, in that code *is*
 907        allowed to raise and lower references during global destruction,
 908        so any *valid* code that happens to do this during global
 909        destruction might well trigger premature cleanup.  */
 910     bool still_valid = gv && SvREFCNT(gv);
 911
 912     if (still_valid)
 913         SvREFCNT_inc_simple_void(gv);
 914 #ifdef USE_ITHREADS
 915     if (*ixp > 0) {
 916         pad_swipe(*ixp, TRUE);
 917         *ixp = 0;
 918     }
 919 #else
 920     SvREFCNT_dec(*svp);
 921     *svp = NULL;
 922 #endif
 923     if (still_valid) {
 924         int try_downgrade = SvREFCNT(gv) == 2;
 925         SvREFCNT_dec_NN(gv);
 926         if (try_downgrade)
 927             gv_try_downgrade(gv);
 928     }
 929 }
 930
 931
 932 void
 933 Perl_op_clear(pTHX_ OP *o)
 934 {
 935
 936     dVAR;
 937
 938     PERL_ARGS_ASSERT_OP_CLEAR;
 939
 940     switch (o->op_type) {
 941     case OP_NULL:       /* Was holding old type, if any. */
 942         /* FALLTHROUGH */
 943     case OP_ENTERTRY:
 944     case OP_ENTEREVAL:  /* Was holding hints. */
 945     case OP_ARGDEFELEM: /* Was holding signature index. */
 946         o->op_targ = 0;
 947         break;
 948     default:
 949         if (!(o->op_flags & OPf_REF)
 950             || (PL_check[o->op_type] != Perl_ck_ftst))
 951             break;
 952         /* FALLTHROUGH */
 953     case OP_GVSV:
 954     case OP_GV:
 955     case OP_AELEMFAST:
 956 #ifdef USE_ITHREADS
 957             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
 958 #else
 959             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
 960 #endif
 961         break;
 962     case OP_METHOD_REDIR:
 963     case OP_METHOD_REDIR_SUPER:
 964 #ifdef USE_ITHREADS
 965         if (cMETHOPx(o)->op_rclass_targ) {
 966             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
 967             cMETHOPx(o)->op_rclass_targ = 0;
 968         }
 969 #else
 970         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
 971         cMETHOPx(o)->op_rclass_sv = NULL;
 972 #endif
 973         /* FALLTHROUGH */
 974     case OP_METHOD_NAMED:
 975     case OP_METHOD_SUPER:
 976         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
 977         cMETHOPx(o)->op_u.op_meth_sv = NULL;
 978 #ifdef USE_ITHREADS
 979         if (o->op_targ) {
 980             pad_swipe(o->op_targ, 1);
 981             o->op_targ = 0;
 982         }
 983 #endif
 984         break;
 985     case OP_CONST:
 986     case OP_HINTSEVAL:
 987         SvREFCNT_dec(cSVOPo->op_sv);
 988         cSVOPo->op_sv = NULL;
 989 #ifdef USE_ITHREADS
 990         /** Bug #15654
 991           Even if op_clear does a pad_free for the target of the op,
 992           pad_free doesn't actually remove the sv that exists in the pad;
 993           instead it lives on. This results in that it could be reused as
 994           a target later on when the pad was reallocated.
 995         **/
 996         if(o->op_targ) {
 997           pad_swipe(o->op_targ,1);
 998           o->op_targ = 0;
 999         }
1000 #endif
1001         break;
1002     case OP_DUMP:
1003     case OP_GOTO:
1004     case OP_NEXT:
1005     case OP_LAST:
1006     case OP_REDO:
1007         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1008             break;
1009         /* FALLTHROUGH */
1010     case OP_TRANS:
1011     case OP_TRANSR:
1012         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1013             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1014         {
1015 #ifdef USE_ITHREADS
1016             if (cPADOPo->op_padix > 0) {
1017                 pad_swipe(cPADOPo->op_padix, TRUE);
1018                 cPADOPo->op_padix = 0;
1019             }
1020 #else
1021             SvREFCNT_dec(cSVOPo->op_sv);
1022             cSVOPo->op_sv = NULL;
1023 #endif
1024         }
1025         else {
1026             PerlMemShared_free(cPVOPo->op_pv);
1027             cPVOPo->op_pv = NULL;
1028         }
1029         break;
1030     case OP_SUBST:
1031         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1032         goto clear_pmop;
1033
1034     case OP_SPLIT:
1035         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1036             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1037         {
1038             if (o->op_private & OPpSPLIT_LEX)
1039                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1040             else
1041 #ifdef USE_ITHREADS
1042                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1043 #else
1044                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1045 #endif
1046         }
1047         /* FALLTHROUGH */
1048     case OP_MATCH:
1049     case OP_QR:
1050     clear_pmop:
1051         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1052             op_free(cPMOPo->op_code_list);
1053         cPMOPo->op_code_list = NULL;
1054         forget_pmop(cPMOPo);
1055         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1056         /* we use the same protection as the "SAFE" version of the PM_ macros
1057          * here since sv_clean_all might release some PMOPs
1058          * after PL_regex_padav has been cleared
1059          * and the clearing of PL_regex_padav needs to
1060          * happen before sv_clean_all
1061          */
1062 #ifdef USE_ITHREADS
1063         if(PL_regex_pad) {        /* We could be in destruction */
1064             const IV offset = (cPMOPo)->op_pmoffset;
1065             ReREFCNT_dec(PM_GETRE(cPMOPo));
1066             PL_regex_pad[offset] = &PL_sv_undef;
1067             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1068                            sizeof(offset));
1069         }
1070 #else
1071         ReREFCNT_dec(PM_GETRE(cPMOPo));
1072         PM_SETRE(cPMOPo, NULL);
1073 #endif
1074
1075         break;
1076
1077     case OP_ARGCHECK:
1078         PerlMemShared_free(cUNOP_AUXo->op_aux);
1079         break;
1080
1081     case OP_MULTICONCAT:
1082         {
1083             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1084             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1085              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1086              * utf8 shared strings */
1087             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1088             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1089             if (p1)
1090                 PerlMemShared_free(p1);
1091             if (p2 && p1 != p2)
1092                 PerlMemShared_free(p2);
1093             PerlMemShared_free(aux);
1094         }
1095         break;
1096
1097     case OP_MULTIDEREF:
1098         {
1099             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1100             UV actions = items->uv;
1101             bool last = 0;
1102             bool is_hash = FALSE;
1103
1104             while (!last) {
1105                 switch (actions & MDEREF_ACTION_MASK) {
1106
1107                 case MDEREF_reload:
1108                     actions = (++items)->uv;
1109                     continue;
1110
1111                 case MDEREF_HV_padhv_helem:
1112                     is_hash = TRUE;
1113                     /* FALLTHROUGH */
1114                 case MDEREF_AV_padav_aelem:
1115                     pad_free((++items)->pad_offset);
1116                     goto do_elem;
1117
1118                 case MDEREF_HV_gvhv_helem:
1119                     is_hash = TRUE;
1120                     /* FALLTHROUGH */
1121                 case MDEREF_AV_gvav_aelem:
1122 #ifdef USE_ITHREADS
1123                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1124 #else
1125                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1126 #endif
1127                     goto do_elem;
1128
1129                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1130                     is_hash = TRUE;
1131                     /* FALLTHROUGH */
1132                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1133 #ifdef USE_ITHREADS
1134                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1135 #else
1136                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1137 #endif
1138                     goto do_vivify_rv2xv_elem;
1139
1140                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1141                     is_hash = TRUE;
1142                     /* FALLTHROUGH */
1143                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1144                     pad_free((++items)->pad_offset);
1145                     goto do_vivify_rv2xv_elem;
1146
1147                 case MDEREF_HV_pop_rv2hv_helem:
1148                 case MDEREF_HV_vivify_rv2hv_helem:
1149                     is_hash = TRUE;
1150                     /* FALLTHROUGH */
1151                 do_vivify_rv2xv_elem:
1152                 case MDEREF_AV_pop_rv2av_aelem:
1153                 case MDEREF_AV_vivify_rv2av_aelem:
1154                 do_elem:
1155                     switch (actions & MDEREF_INDEX_MASK) {
1156                     case MDEREF_INDEX_none:
1157                         last = 1;
1158                         break;
1159                     case MDEREF_INDEX_const:
1160                         if (is_hash) {
1161 #ifdef USE_ITHREADS
1162                             /* see RT #15654 */
1163                             pad_swipe((++items)->pad_offset, 1);
1164 #else
1165                             SvREFCNT_dec((++items)->sv);
1166 #endif
1167                         }
1168                         else
1169                             items++;
1170                         break;
1171                     case MDEREF_INDEX_padsv:
1172                         pad_free((++items)->pad_offset);
1173                         break;
1174                     case MDEREF_INDEX_gvsv:
1175 #ifdef USE_ITHREADS
1176                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1177 #else
1178                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1179 #endif
1180                         break;
1181                     }
1182
1183                     if (actions & MDEREF_FLAG_last)
1184                         last = 1;
1185                     is_hash = FALSE;
1186
1187                     break;
1188
1189                 default:
1190                     assert(0);
1191                     last = 1;
1192                     break;
1193
1194                 } /* switch */
1195
1196                 actions >>= MDEREF_SHIFT;
1197             } /* while */
1198
1199             /* start of malloc is at op_aux[-1], where the length is
1200              * stored */
1201             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1202         }
1203         break;
1204     }
1205
1206     if (o->op_targ > 0) {
1207         pad_free(o->op_targ);
1208         o->op_targ = 0;
1209     }
1210 }
1211
1212 STATIC void
1213 S_cop_free(pTHX_ COP* cop)
1214 {
1215     PERL_ARGS_ASSERT_COP_FREE;
1216
1217     CopFILE_free(cop);
1218     if (! specialWARN(cop->cop_warnings))
1219         PerlMemShared_free(cop->cop_warnings);
1220     cophh_free(CopHINTHASH_get(cop));
1221     if (PL_curcop == cop)
1222        PL_curcop = NULL;
1223 }
1224
1225 STATIC void
1226 S_forget_pmop(pTHX_ PMOP *const o
1227               )
1228 {
1229     HV * const pmstash = PmopSTASH(o);
1230
1231     PERL_ARGS_ASSERT_FORGET_PMOP;
1232
1233     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1234         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1235         if (mg) {
1236             PMOP **const array = (PMOP**) mg->mg_ptr;
1237             U32 count = mg->mg_len / sizeof(PMOP**);
1238             U32 i = count;
1239
1240             while (i--) {
1241                 if (array[i] == o) {
1242                     /* Found it. Move the entry at the end to overwrite it.  */
1243                     array[i] = array[--count];
1244                     mg->mg_len = count * sizeof(PMOP**);
1245                     /* Could realloc smaller at this point always, but probably
1246                        not worth it. Probably worth free()ing if we're the
1247                        last.  */
1248                     if(!count) {
1249                         Safefree(mg->mg_ptr);
1250                         mg->mg_ptr = NULL;
1251                     }
1252                     break;
1253                 }
1254             }
1255         }
1256     }
1257     if (PL_curpm == o)
1258         PL_curpm = NULL;
1259 }
1260
1261 STATIC void
1262 S_find_and_forget_pmops(pTHX_ OP *o)
1263 {
1264     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1265
1266     if (o->op_flags & OPf_KIDS) {
1267         OP *kid = cUNOPo->op_first;
1268         while (kid) {
1269             switch (kid->op_type) {
1270             case OP_SUBST:
1271             case OP_SPLIT:
1272             case OP_MATCH:
1273             case OP_QR:
1274                 forget_pmop((PMOP*)kid);
1275             }
1276             find_and_forget_pmops(kid);
1277             kid = OpSIBLING(kid);
1278         }
1279     }
1280 }
1281
1282 /*
1283 =for apidoc Am|void|op_null|OP *o
1284
1285 Neutralizes an op when it is no longer needed, but is still linked to from
1286 other ops.
1287
1288 =cut
1289 */
1290
1291 void
1292 Perl_op_null(pTHX_ OP *o)
1293 {
1294     dVAR;
1295
1296     PERL_ARGS_ASSERT_OP_NULL;
1297
1298     if (o->op_type == OP_NULL)
1299         return;
1300     op_clear(o);
1301     o->op_targ = o->op_type;
1302     OpTYPE_set(o, OP_NULL);
1303 }
1304
1305 void
1306 Perl_op_refcnt_lock(pTHX)
1307   PERL_TSA_ACQUIRE(PL_op_mutex)
1308 {
1309 #ifdef USE_ITHREADS
1310     dVAR;
1311 #endif
1312     PERL_UNUSED_CONTEXT;
1313     OP_REFCNT_LOCK;
1314 }
1315
1316 void
1317 Perl_op_refcnt_unlock(pTHX)
1318   PERL_TSA_RELEASE(PL_op_mutex)
1319 {
1320 #ifdef USE_ITHREADS
1321     dVAR;
1322 #endif
1323     PERL_UNUSED_CONTEXT;
1324     OP_REFCNT_UNLOCK;
1325 }
1326
1327
1328 /*
1329 =for apidoc op_sibling_splice
1330
1331 A general function for editing the structure of an existing chain of
1332 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1333 you to delete zero or more sequential nodes, replacing them with zero or
1334 more different nodes.  Performs the necessary op_first/op_last
1335 housekeeping on the parent node and op_sibling manipulation on the
1336 children.  The last deleted node will be marked as as the last node by
1337 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1338
1339 Note that op_next is not manipulated, and nodes are not freed; that is the
1340 responsibility of the caller.  It also won't create a new list op for an
1341 empty list etc; use higher-level functions like op_append_elem() for that.
1342
1343 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1344 the splicing doesn't affect the first or last op in the chain.
1345
1346 C<start> is the node preceding the first node to be spliced.  Node(s)
1347 following it will be deleted, and ops will be inserted after it.  If it is
1348 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1349 beginning.
1350
1351 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1352 If -1 or greater than or equal to the number of remaining kids, all
1353 remaining kids are deleted.
1354
1355 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1356 If C<NULL>, no nodes are inserted.
1357
1358 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1359 deleted.
1360
1361 For example:
1362
1363     action                    before      after         returns
1364     ------                    -----       -----         -------
1365
1366                               P           P
1367     splice(P, A, 2, X-Y-Z)    |           |             B-C
1368                               A-B-C-D     A-X-Y-Z-D
1369
1370                               P           P
1371     splice(P, NULL, 1, X-Y)   |           |             A
1372                               A-B-C-D     X-Y-B-C-D
1373
1374                               P           P
1375     splice(P, NULL, 3, NULL)  |           |             A-B-C
1376                               A-B-C-D     D
1377
1378                               P           P
1379     splice(P, B, 0, X-Y)      |           |             NULL
1380                               A-B-C-D     A-B-X-Y-C-D
1381
1382
1383 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1384 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1385
1386 =cut
1387 */
1388
1389 OP *
1390 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1391 {
1392     OP *first;
1393     OP *rest;
1394     OP *last_del = NULL;
1395     OP *last_ins = NULL;
1396
1397     if (start)
1398         first = OpSIBLING(start);
1399     else if (!parent)
1400         goto no_parent;
1401     else
1402         first = cLISTOPx(parent)->op_first;
1403
1404     assert(del_count >= -1);
1405
1406     if (del_count && first) {
1407         last_del = first;
1408         while (--del_count && OpHAS_SIBLING(last_del))
1409             last_del = OpSIBLING(last_del);
1410         rest = OpSIBLING(last_del);
1411         OpLASTSIB_set(last_del, NULL);
1412     }
1413     else
1414         rest = first;
1415
1416     if (insert) {
1417         last_ins = insert;
1418         while (OpHAS_SIBLING(last_ins))
1419             last_ins = OpSIBLING(last_ins);
1420         OpMAYBESIB_set(last_ins, rest, NULL);
1421     }
1422     else
1423         insert = rest;
1424
1425     if (start) {
1426         OpMAYBESIB_set(start, insert, NULL);
1427     }
1428     else {
1429         if (!parent)
1430             goto no_parent;
1431         cLISTOPx(parent)->op_first = insert;
1432         if (insert)
1433             parent->op_flags |= OPf_KIDS;
1434         else
1435             parent->op_flags &= ~OPf_KIDS;
1436     }
1437
1438     if (!rest) {
1439         /* update op_last etc */
1440         U32 type;
1441         OP *lastop;
1442
1443         if (!parent)
1444             goto no_parent;
1445
1446         /* ought to use OP_CLASS(parent) here, but that can't handle
1447          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1448          * either */
1449         type = parent->op_type;
1450         if (type == OP_CUSTOM) {
1451             dTHX;
1452             type = XopENTRYCUSTOM(parent, xop_class);
1453         }
1454         else {
1455             if (type == OP_NULL)
1456                 type = parent->op_targ;
1457             type = PL_opargs[type] & OA_CLASS_MASK;
1458         }
1459
1460         lastop = last_ins ? last_ins : start ? start : NULL;
1461         if (   type == OA_BINOP
1462             || type == OA_LISTOP
1463             || type == OA_PMOP
1464             || type == OA_LOOP
1465         )
1466             cLISTOPx(parent)->op_last = lastop;
1467
1468         if (lastop)
1469             OpLASTSIB_set(lastop, parent);
1470     }
1471     return last_del ? first : NULL;
1472
1473   no_parent:
1474     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1475 }
1476
1477
1478 #ifdef PERL_OP_PARENT
1479
1480 /*
1481 =for apidoc op_parent
1482
1483 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1484 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1485
1486 =cut
1487 */
1488
1489 OP *
1490 Perl_op_parent(OP *o)
1491 {
1492     PERL_ARGS_ASSERT_OP_PARENT;
1493     while (OpHAS_SIBLING(o))
1494         o = OpSIBLING(o);
1495     return o->op_sibparent;
1496 }
1497
1498 #endif
1499
1500
1501 /* replace the sibling following start with a new UNOP, which becomes
1502  * the parent of the original sibling; e.g.
1503  *
1504  *  op_sibling_newUNOP(P, A, unop-args...)
1505  *
1506  *  P              P
1507  *  |      becomes |
1508  *  A-B-C          A-U-C
1509  *                   |
1510  *                   B
1511  *
1512  * where U is the new UNOP.
1513  *
1514  * parent and start args are the same as for op_sibling_splice();
1515  * type and flags args are as newUNOP().
1516  *
1517  * Returns the new UNOP.
1518  */
1519
1520 STATIC OP *
1521 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1522 {
1523     OP *kid, *newop;
1524
1525     kid = op_sibling_splice(parent, start, 1, NULL);
1526     newop = newUNOP(type, flags, kid);
1527     op_sibling_splice(parent, start, 0, newop);
1528     return newop;
1529 }
1530
1531
1532 /* lowest-level newLOGOP-style function - just allocates and populates
1533  * the struct. Higher-level stuff should be done by S_new_logop() /
1534  * newLOGOP(). This function exists mainly to avoid op_first assignment
1535  * being spread throughout this file.
1536  */
1537
1538 LOGOP *
1539 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1540 {
1541     dVAR;
1542     LOGOP *logop;
1543     OP *kid = first;
1544     NewOp(1101, logop, 1, LOGOP);
1545     OpTYPE_set(logop, type);
1546     logop->op_first = first;
1547     logop->op_other = other;
1548     logop->op_flags = OPf_KIDS;
1549     while (kid && OpHAS_SIBLING(kid))
1550         kid = OpSIBLING(kid);
1551     if (kid)
1552         OpLASTSIB_set(kid, (OP*)logop);
1553     return logop;
1554 }
1555
1556
1557 /* Contextualizers */
1558
1559 /*
1560 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1561
1562 Applies a syntactic context to an op tree representing an expression.
1563 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1564 or C<G_VOID> to specify the context to apply.  The modified op tree
1565 is returned.
1566
1567 =cut
1568 */
1569
1570 OP *
1571 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1572 {
1573     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1574     switch (context) {
1575         case G_SCALAR: return scalar(o);
1576         case G_ARRAY:  return list(o);
1577         case G_VOID:   return scalarvoid(o);
1578         default:
1579             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1580                        (long) context);
1581     }
1582 }
1583
1584 /*
1585
1586 =for apidoc Am|OP*|op_linklist|OP *o
1587 This function is the implementation of the L</LINKLIST> macro.  It should
1588 not be called directly.
1589
1590 =cut
1591 */
1592
1593 OP *
1594 Perl_op_linklist(pTHX_ OP *o)
1595 {
1596     OP *first;
1597
1598     PERL_ARGS_ASSERT_OP_LINKLIST;
1599
1600     if (o->op_next)
1601         return o->op_next;
1602
1603     /* establish postfix order */
1604     first = cUNOPo->op_first;
1605     if (first) {
1606         OP *kid;
1607         o->op_next = LINKLIST(first);
1608         kid = first;
1609         for (;;) {
1610             OP *sibl = OpSIBLING(kid);
1611             if (sibl) {
1612                 kid->op_next = LINKLIST(sibl);
1613                 kid = sibl;
1614             } else {
1615                 kid->op_next = o;
1616                 break;
1617             }
1618         }
1619     }
1620     else
1621         o->op_next = o;
1622
1623     return o->op_next;
1624 }
1625
1626 static OP *
1627 S_scalarkids(pTHX_ OP *o)
1628 {
1629     if (o && o->op_flags & OPf_KIDS) {
1630         OP *kid;
1631         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1632             scalar(kid);
1633     }
1634     return o;
1635 }
1636
1637 STATIC OP *
1638 S_scalarboolean(pTHX_ OP *o)
1639 {
1640     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1641
1642     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1643          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1644         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1645          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1646          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1647         if (ckWARN(WARN_SYNTAX)) {
1648             const line_t oldline = CopLINE(PL_curcop);
1649
1650             if (PL_parser && PL_parser->copline != NOLINE) {
1651                 /* This ensures that warnings are reported at the first line
1652                    of the conditional, not the last.  */
1653                 CopLINE_set(PL_curcop, PL_parser->copline);
1654             }
1655             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1656             CopLINE_set(PL_curcop, oldline);
1657         }
1658     }
1659     return scalar(o);
1660 }
1661
1662 static SV *
1663 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1664 {
1665     assert(o);
1666     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1667            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1668     {
1669         const char funny  = o->op_type == OP_PADAV
1670                          || o->op_type == OP_RV2AV ? '@' : '%';
1671         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1672             GV *gv;
1673             if (cUNOPo->op_first->op_type != OP_GV
1674              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1675                 return NULL;
1676             return varname(gv, funny, 0, NULL, 0, subscript_type);
1677         }
1678         return
1679             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1680     }
1681 }
1682
1683 static SV *
1684 S_op_varname(pTHX_ const OP *o)
1685 {
1686     return S_op_varname_subscript(aTHX_ o, 1);
1687 }
1688
1689 static void
1690 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1691 { /* or not so pretty :-) */
1692     if (o->op_type == OP_CONST) {
1693         *retsv = cSVOPo_sv;
1694         if (SvPOK(*retsv)) {
1695             SV *sv = *retsv;
1696             *retsv = sv_newmortal();
1697             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1698                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1699         }
1700         else if (!SvOK(*retsv))
1701             *retpv = "undef";
1702     }
1703     else *retpv = "...";
1704 }
1705
1706 static void
1707 S_scalar_slice_warning(pTHX_ const OP *o)
1708 {
1709     OP *kid;
1710     const bool h = o->op_type == OP_HSLICE
1711                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1712     const char lbrack =
1713         h ? '{' : '[';
1714     const char rbrack =
1715         h ? '}' : ']';
1716     SV *name;
1717     SV *keysv = NULL; /* just to silence compiler warnings */
1718     const char *key = NULL;
1719
1720     if (!(o->op_private & OPpSLICEWARNING))
1721         return;
1722     if (PL_parser && PL_parser->error_count)
1723         /* This warning can be nonsensical when there is a syntax error. */
1724         return;
1725
1726     kid = cLISTOPo->op_first;
1727     kid = OpSIBLING(kid); /* get past pushmark */
1728     /* weed out false positives: any ops that can return lists */
1729     switch (kid->op_type) {
1730     case OP_BACKTICK:
1731     case OP_GLOB:
1732     case OP_READLINE:
1733     case OP_MATCH:
1734     case OP_RV2AV:
1735     case OP_EACH:
1736     case OP_VALUES:
1737     case OP_KEYS:
1738     case OP_SPLIT:
1739     case OP_LIST:
1740     case OP_SORT:
1741     case OP_REVERSE:
1742     case OP_ENTERSUB:
1743     case OP_CALLER:
1744     case OP_LSTAT:
1745     case OP_STAT:
1746     case OP_READDIR:
1747     case OP_SYSTEM:
1748     case OP_TMS:
1749     case OP_LOCALTIME:
1750     case OP_GMTIME:
1751     case OP_ENTEREVAL:
1752         return;
1753     }
1754
1755     /* Don't warn if we have a nulled list either. */
1756     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1757         return;
1758
1759     assert(OpSIBLING(kid));
1760     name = S_op_varname(aTHX_ OpSIBLING(kid));
1761     if (!name) /* XS module fiddling with the op tree */
1762         return;
1763     S_op_pretty(aTHX_ kid, &keysv, &key);
1764     assert(SvPOK(name));
1765     sv_chop(name,SvPVX(name)+1);
1766     if (key)
1767        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1768         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1769                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1770                    "%c%s%c",
1771                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1772                     lbrack, key, rbrack);
1773     else
1774        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1775         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1776                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1777                     SVf "%c%" SVf "%c",
1778                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1779                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1780 }
1781
1782 OP *
1783 Perl_scalar(pTHX_ OP *o)
1784 {
1785     OP *kid;
1786
1787     /* assumes no premature commitment */
1788     if (!o || (PL_parser && PL_parser->error_count)
1789          || (o->op_flags & OPf_WANT)
1790          || o->op_type == OP_RETURN)
1791     {
1792         return o;
1793     }
1794
1795     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1796
1797     switch (o->op_type) {
1798     case OP_REPEAT:
1799         scalar(cBINOPo->op_first);
1800         if (o->op_private & OPpREPEAT_DOLIST) {
1801             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1802             assert(kid->op_type == OP_PUSHMARK);
1803             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1804                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1805                 o->op_private &=~ OPpREPEAT_DOLIST;
1806             }
1807         }
1808         break;
1809     case OP_OR:
1810     case OP_AND:
1811     case OP_COND_EXPR:
1812         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1813             scalar(kid);
1814         break;
1815         /* FALLTHROUGH */
1816     case OP_SPLIT:
1817     case OP_MATCH:
1818     case OP_QR:
1819     case OP_SUBST:
1820     case OP_NULL:
1821     default:
1822         if (o->op_flags & OPf_KIDS) {
1823             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1824                 scalar(kid);
1825         }
1826         break;
1827     case OP_LEAVE:
1828     case OP_LEAVETRY:
1829         kid = cLISTOPo->op_first;
1830         scalar(kid);
1831         kid = OpSIBLING(kid);
1832     do_kids:
1833         while (kid) {
1834             OP *sib = OpSIBLING(kid);
1835             if (sib && kid->op_type != OP_LEAVEWHEN
1836              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1837                 || (  sib->op_targ != OP_NEXTSTATE
1838                    && sib->op_targ != OP_DBSTATE  )))
1839                 scalarvoid(kid);
1840             else
1841                 scalar(kid);
1842             kid = sib;
1843         }
1844         PL_curcop = &PL_compiling;
1845         break;
1846     case OP_SCOPE:
1847     case OP_LINESEQ:
1848     case OP_LIST:
1849         kid = cLISTOPo->op_first;
1850         goto do_kids;
1851     case OP_SORT:
1852         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1853         break;
1854     case OP_KVHSLICE:
1855     case OP_KVASLICE:
1856     {
1857         /* Warn about scalar context */
1858         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1859         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1860         SV *name;
1861         SV *keysv;
1862         const char *key = NULL;
1863
1864         /* This warning can be nonsensical when there is a syntax error. */
1865         if (PL_parser && PL_parser->error_count)
1866             break;
1867
1868         if (!ckWARN(WARN_SYNTAX)) break;
1869
1870         kid = cLISTOPo->op_first;
1871         kid = OpSIBLING(kid); /* get past pushmark */
1872         assert(OpSIBLING(kid));
1873         name = S_op_varname(aTHX_ OpSIBLING(kid));
1874         if (!name) /* XS module fiddling with the op tree */
1875             break;
1876         S_op_pretty(aTHX_ kid, &keysv, &key);
1877         assert(SvPOK(name));
1878         sv_chop(name,SvPVX(name)+1);
1879         if (key)
1880   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1881             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1882                        "%%%" SVf "%c%s%c in scalar context better written "
1883                        "as $%" SVf "%c%s%c",
1884                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1885                         lbrack, key, rbrack);
1886         else
1887   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1888             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1889                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1890                        "written as $%" SVf "%c%" SVf "%c",
1891                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1892                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1893     }
1894     }
1895     return o;
1896 }
1897
1898 OP *
1899 Perl_scalarvoid(pTHX_ OP *arg)
1900 {
1901     dVAR;
1902     OP *kid;
1903     SV* sv;
1904     SSize_t defer_stack_alloc = 0;
1905     SSize_t defer_ix = -1;
1906     OP **defer_stack = NULL;
1907     OP *o = arg;
1908
1909     PERL_ARGS_ASSERT_SCALARVOID;
1910
1911     do {
1912         U8 want;
1913         SV *useless_sv = NULL;
1914         const char* useless = NULL;
1915
1916         if (o->op_type == OP_NEXTSTATE
1917             || o->op_type == OP_DBSTATE
1918             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1919                                           || o->op_targ == OP_DBSTATE)))
1920             PL_curcop = (COP*)o;                /* for warning below */
1921
1922         /* assumes no premature commitment */
1923         want = o->op_flags & OPf_WANT;
1924         if ((want && want != OPf_WANT_SCALAR)
1925             || (PL_parser && PL_parser->error_count)
1926             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1927         {
1928             continue;
1929         }
1930
1931         if ((o->op_private & OPpTARGET_MY)
1932             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1933         {
1934             /* newASSIGNOP has already applied scalar context, which we
1935                leave, as if this op is inside SASSIGN.  */
1936             continue;
1937         }
1938
1939         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1940
1941         switch (o->op_type) {
1942         default:
1943             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1944                 break;
1945             /* FALLTHROUGH */
1946         case OP_REPEAT:
1947             if (o->op_flags & OPf_STACKED)
1948                 break;
1949             if (o->op_type == OP_REPEAT)
1950                 scalar(cBINOPo->op_first);
1951             goto func_ops;
1952         case OP_CONCAT:
1953             if ((o->op_flags & OPf_STACKED) &&
1954                     !(o->op_private & OPpCONCAT_NESTED))
1955                 break;
1956             goto func_ops;
1957         case OP_SUBSTR:
1958             if (o->op_private == 4)
1959                 break;
1960             /* FALLTHROUGH */
1961         case OP_WANTARRAY:
1962         case OP_GV:
1963         case OP_SMARTMATCH:
1964         case OP_AV2ARYLEN:
1965         case OP_REF:
1966         case OP_REFGEN:
1967         case OP_SREFGEN:
1968         case OP_DEFINED:
1969         case OP_HEX:
1970         case OP_OCT:
1971         case OP_LENGTH:
1972         case OP_VEC:
1973         case OP_INDEX:
1974         case OP_RINDEX:
1975         case OP_SPRINTF:
1976         case OP_KVASLICE:
1977         case OP_KVHSLICE:
1978         case OP_UNPACK:
1979         case OP_PACK:
1980         case OP_JOIN:
1981         case OP_LSLICE:
1982         case OP_ANONLIST:
1983         case OP_ANONHASH:
1984         case OP_SORT:
1985         case OP_REVERSE:
1986         case OP_RANGE:
1987         case OP_FLIP:
1988         case OP_FLOP:
1989         case OP_CALLER:
1990         case OP_FILENO:
1991         case OP_EOF:
1992         case OP_TELL:
1993         case OP_GETSOCKNAME:
1994         case OP_GETPEERNAME:
1995         case OP_READLINK:
1996         case OP_TELLDIR:
1997         case OP_GETPPID:
1998         case OP_GETPGRP:
1999         case OP_GETPRIORITY:
2000         case OP_TIME:
2001         case OP_TMS:
2002         case OP_LOCALTIME:
2003         case OP_GMTIME:
2004         case OP_GHBYNAME:
2005         case OP_GHBYADDR:
2006         case OP_GHOSTENT:
2007         case OP_GNBYNAME:
2008         case OP_GNBYADDR:
2009         case OP_GNETENT:
2010         case OP_GPBYNAME:
2011         case OP_GPBYNUMBER:
2012         case OP_GPROTOENT:
2013         case OP_GSBYNAME:
2014         case OP_GSBYPORT:
2015         case OP_GSERVENT:
2016         case OP_GPWNAM:
2017         case OP_GPWUID:
2018         case OP_GGRNAM:
2019         case OP_GGRGID:
2020         case OP_GETLOGIN:
2021         case OP_PROTOTYPE:
2022         case OP_RUNCV:
2023         func_ops:
2024             useless = OP_DESC(o);
2025             break;
2026
2027         case OP_GVSV:
2028         case OP_PADSV:
2029         case OP_PADAV:
2030         case OP_PADHV:
2031         case OP_PADANY:
2032         case OP_AELEM:
2033         case OP_AELEMFAST:
2034         case OP_AELEMFAST_LEX:
2035         case OP_ASLICE:
2036         case OP_HELEM:
2037         case OP_HSLICE:
2038             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2039                 /* Otherwise it's "Useless use of grep iterator" */
2040                 useless = OP_DESC(o);
2041             break;
2042
2043         case OP_SPLIT:
2044             if (!(o->op_private & OPpSPLIT_ASSIGN))
2045                 useless = OP_DESC(o);
2046             break;
2047
2048         case OP_NOT:
2049             kid = cUNOPo->op_first;
2050             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2051                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2052                 goto func_ops;
2053             }
2054             useless = "negative pattern binding (!~)";
2055             break;
2056
2057         case OP_SUBST:
2058             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2059                 useless = "non-destructive substitution (s///r)";
2060             break;
2061
2062         case OP_TRANSR:
2063             useless = "non-destructive transliteration (tr///r)";
2064             break;
2065
2066         case OP_RV2GV:
2067         case OP_RV2SV:
2068         case OP_RV2AV:
2069         case OP_RV2HV:
2070             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2071                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2072                 useless = "a variable";
2073             break;
2074
2075         case OP_CONST:
2076             sv = cSVOPo_sv;
2077             if (cSVOPo->op_private & OPpCONST_STRICT)
2078                 no_bareword_allowed(o);
2079             else {
2080                 if (ckWARN(WARN_VOID)) {
2081                     NV nv;
2082                     /* don't warn on optimised away booleans, eg
2083                      * use constant Foo, 5; Foo || print; */
2084                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2085                         useless = NULL;
2086                     /* the constants 0 and 1 are permitted as they are
2087                        conventionally used as dummies in constructs like
2088                        1 while some_condition_with_side_effects;  */
2089                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2090                         useless = NULL;
2091                     else if (SvPOK(sv)) {
2092                         SV * const dsv = newSVpvs("");
2093                         useless_sv
2094                             = Perl_newSVpvf(aTHX_
2095                                             "a constant (%s)",
2096                                             pv_pretty(dsv, SvPVX_const(sv),
2097                                                       SvCUR(sv), 32, NULL, NULL,
2098                                                       PERL_PV_PRETTY_DUMP
2099                                                       | PERL_PV_ESCAPE_NOCLEAR
2100                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2101                         SvREFCNT_dec_NN(dsv);
2102                     }
2103                     else if (SvOK(sv)) {
2104                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2105                     }
2106                     else
2107                         useless = "a constant (undef)";
2108                 }
2109             }
2110             op_null(o);         /* don't execute or even remember it */
2111             break;
2112
2113         case OP_POSTINC:
2114             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2115             break;
2116
2117         case OP_POSTDEC:
2118             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2119             break;
2120
2121         case OP_I_POSTINC:
2122             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2123             break;
2124
2125         case OP_I_POSTDEC:
2126             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2127             break;
2128
2129         case OP_SASSIGN: {
2130             OP *rv2gv;
2131             UNOP *refgen, *rv2cv;
2132             LISTOP *exlist;
2133
2134             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2135                 break;
2136
2137             rv2gv = ((BINOP *)o)->op_last;
2138             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2139                 break;
2140
2141             refgen = (UNOP *)((BINOP *)o)->op_first;
2142
2143             if (!refgen || (refgen->op_type != OP_REFGEN
2144                             && refgen->op_type != OP_SREFGEN))
2145                 break;
2146
2147             exlist = (LISTOP *)refgen->op_first;
2148             if (!exlist || exlist->op_type != OP_NULL
2149                 || exlist->op_targ != OP_LIST)
2150                 break;
2151
2152             if (exlist->op_first->op_type != OP_PUSHMARK
2153                 && exlist->op_first != exlist->op_last)
2154                 break;
2155
2156             rv2cv = (UNOP*)exlist->op_last;
2157
2158             if (rv2cv->op_type != OP_RV2CV)
2159                 break;
2160
2161             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2162             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2163             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2164
2165             o->op_private |= OPpASSIGN_CV_TO_GV;
2166             rv2gv->op_private |= OPpDONT_INIT_GV;
2167             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2168
2169             break;
2170         }
2171
2172         case OP_AASSIGN: {
2173             inplace_aassign(o);
2174             break;
2175         }
2176
2177         case OP_OR:
2178         case OP_AND:
2179             kid = cLOGOPo->op_first;
2180             if (kid->op_type == OP_NOT
2181                 && (kid->op_flags & OPf_KIDS)) {
2182                 if (o->op_type == OP_AND) {
2183                     OpTYPE_set(o, OP_OR);
2184                 } else {
2185                     OpTYPE_set(o, OP_AND);
2186                 }
2187                 op_null(kid);
2188             }
2189             /* FALLTHROUGH */
2190
2191         case OP_DOR:
2192         case OP_COND_EXPR:
2193         case OP_ENTERGIVEN:
2194         case OP_ENTERWHEN:
2195             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2196                 if (!(kid->op_flags & OPf_KIDS))
2197                     scalarvoid(kid);
2198                 else
2199                     DEFER_OP(kid);
2200         break;
2201
2202         case OP_NULL:
2203             if (o->op_flags & OPf_STACKED)
2204                 break;
2205             /* FALLTHROUGH */
2206         case OP_NEXTSTATE:
2207         case OP_DBSTATE:
2208         case OP_ENTERTRY:
2209         case OP_ENTER:
2210             if (!(o->op_flags & OPf_KIDS))
2211                 break;
2212             /* FALLTHROUGH */
2213         case OP_SCOPE:
2214         case OP_LEAVE:
2215         case OP_LEAVETRY:
2216         case OP_LEAVELOOP:
2217         case OP_LINESEQ:
2218         case OP_LEAVEGIVEN:
2219         case OP_LEAVEWHEN:
2220         kids:
2221             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2222                 if (!(kid->op_flags & OPf_KIDS))
2223                     scalarvoid(kid);
2224                 else
2225                     DEFER_OP(kid);
2226             break;
2227         case OP_LIST:
2228             /* If the first kid after pushmark is something that the padrange
2229                optimisation would reject, then null the list and the pushmark.
2230             */
2231             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2232                 && (  !(kid = OpSIBLING(kid))
2233                       || (  kid->op_type != OP_PADSV
2234                             && kid->op_type != OP_PADAV
2235                             && kid->op_type != OP_PADHV)
2236                       || kid->op_private & ~OPpLVAL_INTRO
2237                       || !(kid = OpSIBLING(kid))
2238                       || (  kid->op_type != OP_PADSV
2239                             && kid->op_type != OP_PADAV
2240                             && kid->op_type != OP_PADHV)
2241                       || kid->op_private & ~OPpLVAL_INTRO)
2242             ) {
2243                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2244                 op_null(o); /* NULL the list */
2245             }
2246             goto kids;
2247         case OP_ENTEREVAL:
2248             scalarkids(o);
2249             break;
2250         case OP_SCALAR:
2251             scalar(o);
2252             break;
2253         }
2254
2255         if (useless_sv) {
2256             /* mortalise it, in case warnings are fatal.  */
2257             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2258                            "Useless use of %" SVf " in void context",
2259                            SVfARG(sv_2mortal(useless_sv)));
2260         }
2261         else if (useless) {
2262             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2263                            "Useless use of %s in void context",
2264                            useless);
2265         }
2266     } while ( (o = POP_DEFERRED_OP()) );
2267
2268     Safefree(defer_stack);
2269
2270     return arg;
2271 }
2272
2273 static OP *
2274 S_listkids(pTHX_ OP *o)
2275 {
2276     if (o && o->op_flags & OPf_KIDS) {
2277         OP *kid;
2278         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2279             list(kid);
2280     }
2281     return o;
2282 }
2283
2284 OP *
2285 Perl_list(pTHX_ OP *o)
2286 {
2287     OP *kid;
2288
2289     /* assumes no premature commitment */
2290     if (!o || (o->op_flags & OPf_WANT)
2291          || (PL_parser && PL_parser->error_count)
2292          || o->op_type == OP_RETURN)
2293     {
2294         return o;
2295     }
2296
2297     if ((o->op_private & OPpTARGET_MY)
2298         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2299     {
2300         return o;                               /* As if inside SASSIGN */
2301     }
2302
2303     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2304
2305     switch (o->op_type) {
2306     case OP_FLOP:
2307         list(cBINOPo->op_first);
2308         break;
2309     case OP_REPEAT:
2310         if (o->op_private & OPpREPEAT_DOLIST
2311          && !(o->op_flags & OPf_STACKED))
2312         {
2313             list(cBINOPo->op_first);
2314             kid = cBINOPo->op_last;
2315             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2316              && SvIVX(kSVOP_sv) == 1)
2317             {
2318                 op_null(o); /* repeat */
2319                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2320                 /* const (rhs): */
2321                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2322             }
2323         }
2324         break;
2325     case OP_OR:
2326     case OP_AND:
2327     case OP_COND_EXPR:
2328         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2329             list(kid);
2330         break;
2331     default:
2332     case OP_MATCH:
2333     case OP_QR:
2334     case OP_SUBST:
2335     case OP_NULL:
2336         if (!(o->op_flags & OPf_KIDS))
2337             break;
2338         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2339             list(cBINOPo->op_first);
2340             return gen_constant_list(o);
2341         }
2342         listkids(o);
2343         break;
2344     case OP_LIST:
2345         listkids(o);
2346         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2347             op_null(cUNOPo->op_first); /* NULL the pushmark */
2348             op_null(o); /* NULL the list */
2349         }
2350         break;
2351     case OP_LEAVE:
2352     case OP_LEAVETRY:
2353         kid = cLISTOPo->op_first;
2354         list(kid);
2355         kid = OpSIBLING(kid);
2356     do_kids:
2357         while (kid) {
2358             OP *sib = OpSIBLING(kid);
2359             if (sib && kid->op_type != OP_LEAVEWHEN)
2360                 scalarvoid(kid);
2361             else
2362                 list(kid);
2363             kid = sib;
2364         }
2365         PL_curcop = &PL_compiling;
2366         break;
2367     case OP_SCOPE:
2368     case OP_LINESEQ:
2369         kid = cLISTOPo->op_first;
2370         goto do_kids;
2371     }
2372     return o;
2373 }
2374
2375 static OP *
2376 S_scalarseq(pTHX_ OP *o)
2377 {
2378     if (o) {
2379         const OPCODE type = o->op_type;
2380
2381         if (type == OP_LINESEQ || type == OP_SCOPE ||
2382             type == OP_LEAVE || type == OP_LEAVETRY)
2383         {
2384             OP *kid, *sib;
2385             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2386                 if ((sib = OpSIBLING(kid))
2387                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2388                     || (  sib->op_targ != OP_NEXTSTATE
2389                        && sib->op_targ != OP_DBSTATE  )))
2390                 {
2391                     scalarvoid(kid);
2392                 }
2393             }
2394             PL_curcop = &PL_compiling;
2395         }
2396         o->op_flags &= ~OPf_PARENS;
2397         if (PL_hints & HINT_BLOCK_SCOPE)
2398             o->op_flags |= OPf_PARENS;
2399     }
2400     else
2401         o = newOP(OP_STUB, 0);
2402     return o;
2403 }
2404
2405 STATIC OP *
2406 S_modkids(pTHX_ OP *o, I32 type)
2407 {
2408     if (o && o->op_flags & OPf_KIDS) {
2409         OP *kid;
2410         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2411             op_lvalue(kid, type);
2412     }
2413     return o;
2414 }
2415
2416
2417 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2418  * const fields. Also, convert CONST keys to HEK-in-SVs.
2419  * rop is the op that retrieves the hash;
2420  * key_op is the first key
2421  */
2422
2423 STATIC void
2424 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2425 {
2426     PADNAME *lexname;
2427     GV **fields;
2428     bool check_fields;
2429
2430     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2431     if (rop) {
2432         if (rop->op_first->op_type == OP_PADSV)
2433             /* @$hash{qw(keys here)} */
2434             rop = (UNOP*)rop->op_first;
2435         else {
2436             /* @{$hash}{qw(keys here)} */
2437             if (rop->op_first->op_type == OP_SCOPE
2438                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2439                 {
2440                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2441                 }
2442             else
2443                 rop = NULL;
2444         }
2445     }
2446
2447     lexname = NULL; /* just to silence compiler warnings */
2448     fields  = NULL; /* just to silence compiler warnings */
2449
2450     check_fields =
2451             rop
2452          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2453              SvPAD_TYPED(lexname))
2454          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2455          && isGV(*fields) && GvHV(*fields);
2456
2457     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2458         SV **svp, *sv;
2459         if (key_op->op_type != OP_CONST)
2460             continue;
2461         svp = cSVOPx_svp(key_op);
2462
2463         /* make sure it's not a bareword under strict subs */
2464         if (key_op->op_private & OPpCONST_BARE &&
2465             key_op->op_private & OPpCONST_STRICT)
2466         {
2467             no_bareword_allowed((OP*)key_op);
2468         }
2469
2470         /* Make the CONST have a shared SV */
2471         if (   !SvIsCOW_shared_hash(sv = *svp)
2472             && SvTYPE(sv) < SVt_PVMG
2473             && SvOK(sv)
2474             && !SvROK(sv))
2475         {
2476             SSize_t keylen;
2477             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2478             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2479             SvREFCNT_dec_NN(sv);
2480             *svp = nsv;
2481         }
2482
2483         if (   check_fields
2484             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2485         {
2486             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2487                         "in variable %" PNf " of type %" HEKf,
2488                         SVfARG(*svp), PNfARG(lexname),
2489                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2490         }
2491     }
2492 }
2493
2494 /* info returned by S_sprintf_is_multiconcatable() */
2495
2496 struct sprintf_ismc_info {
2497     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2498     char  *start;     /* start of raw format string */
2499     char  *end;       /* bytes after end of raw format string */
2500     STRLEN total_len; /* total length (in bytes) of format string, not
2501                          including '%s' and  half of '%%' */
2502     STRLEN variant;   /* number of bytes by which total_len_p would grow
2503                          if upgraded to utf8 */
2504     bool   utf8;      /* whether the format is utf8 */
2505 };
2506
2507
2508 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2509  * i.e. its format argument is a const string with only '%s' and '%%'
2510  * formats, and the number of args is known, e.g.
2511  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2512  * but not
2513  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2514  *
2515  * If successful, the sprintf_ismc_info struct pointed to by info will be
2516  * populated.
2517  */
2518
2519 STATIC bool
2520 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2521 {
2522     OP    *pm, *constop, *kid;
2523     SV    *sv;
2524     char  *s, *e, *p;
2525     SSize_t nargs, nformats;
2526     STRLEN cur, total_len, variant;
2527     bool   utf8;
2528
2529     /* if sprintf's behaviour changes, die here so that someone
2530      * can decide whether to enhance this function or skip optimising
2531      * under those new circumstances */
2532     assert(!(o->op_flags & OPf_STACKED));
2533     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2534     assert(!(o->op_private & ~OPpARG4_MASK));
2535
2536     pm = cUNOPo->op_first;
2537     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2538         return FALSE;
2539     constop = OpSIBLING(pm);
2540     if (!constop || constop->op_type != OP_CONST)
2541         return FALSE;
2542     sv = cSVOPx_sv(constop);
2543     if (SvMAGICAL(sv) || !SvPOK(sv))
2544         return FALSE;
2545
2546     s = SvPV(sv, cur);
2547     e = s + cur;
2548
2549     /* Scan format for %% and %s and work out how many %s there are.
2550      * Abandon if other format types are found.
2551      */
2552
2553     nformats  = 0;
2554     total_len = 0;
2555     variant   = 0;
2556
2557     for (p = s; p < e; p++) {
2558         if (*p != '%') {
2559             total_len++;
2560             if (!UTF8_IS_INVARIANT(*p))
2561                 variant++;
2562             continue;
2563         }
2564         p++;
2565         if (p >= e)
2566             return FALSE; /* lone % at end gives "Invalid conversion" */
2567         if (*p == '%')
2568             total_len++;
2569         else if (*p == 's')
2570             nformats++;
2571         else
2572             return FALSE;
2573     }
2574
2575     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2576         return FALSE;
2577
2578     utf8 = cBOOL(SvUTF8(sv));
2579     if (utf8)
2580         variant = 0;
2581
2582     /* scan args; they must all be in scalar cxt */
2583
2584     nargs = 0;
2585     kid = OpSIBLING(constop);
2586
2587     while (kid) {
2588         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2589             return FALSE;
2590         nargs++;
2591         kid = OpSIBLING(kid);
2592     }
2593
2594     if (nargs != nformats)
2595         return FALSE; /* e.g. sprintf("%s%s", $a); */
2596
2597
2598     info->nargs      = nargs;
2599     info->start      = s;
2600     info->end        = e;
2601     info->total_len  = total_len;
2602     info->variant    = variant;
2603     info->utf8       = utf8;
2604
2605     return TRUE;
2606 }
2607
2608
2609
2610 /* S_maybe_multiconcat():
2611  *
2612  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2613  * convert it (and its children) into an OP_MULTICONCAT. See the code
2614  * comments just before pp_multiconcat() for the full details of what
2615  * OP_MULTICONCAT supports.
2616  *
2617  * Basically we're looking for an optree with a chain of OP_CONCATS down
2618  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2619  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2620  *
2621  *      $x = "$a$b-$c"
2622  *
2623  *  looks like
2624  *
2625  *      SASSIGN
2626  *         |
2627  *      STRINGIFY   -- PADSV[$x]
2628  *         |
2629  *         |
2630  *      ex-PUSHMARK -- CONCAT/S
2631  *                        |
2632  *                     CONCAT/S  -- PADSV[$d]
2633  *                        |
2634  *                     CONCAT    -- CONST["-"]
2635  *                        |
2636  *                     PADSV[$a] -- PADSV[$b]
2637  *
2638  * Note that at this stage the OP_SASSIGN may have already been optimised
2639  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2640  */
2641
2642 STATIC void
2643 S_maybe_multiconcat(pTHX_ OP *o)
2644 {
2645     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2646     OP *topop;       /* the top-most op in the concat tree (often equals o,
2647                         unless there are assign/stringify ops above it */
2648     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2649     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2650     OP *targetop;    /* the op corresponding to target=... or target.=... */
2651     OP *stringop;    /* the OP_STRINGIFY op, if any */
2652     OP *nextop;      /* used for recreating the op_next chain without consts */
2653     OP *kid;         /* general-purpose op pointer */
2654     UNOP_AUX_item *aux;
2655     UNOP_AUX_item *lenp;
2656     char *const_str, *p;
2657     struct sprintf_ismc_info sprintf_info;
2658
2659                      /* store info about each arg in args[];
2660                       * toparg is the highest used slot; argp is a general
2661                       * pointer to args[] slots */
2662     struct {
2663         void *p;      /* initially points to const sv (or null for op);
2664                          later, set to SvPV(constsv), with ... */
2665         STRLEN len;   /* ... len set to SvPV(..., len) */
2666     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2667
2668     SSize_t nargs  = 0;
2669     SSize_t nconst = 0;
2670     STRLEN variant;
2671     bool utf8 = FALSE;
2672     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2673                                  the last-processed arg will the LHS of one,
2674                                  as args are processed in reverse order */
2675     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2676     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2677     U8 flags          = 0;   /* what will become the op_flags and ... */
2678     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2679     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2680     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2681
2682     /* -----------------------------------------------------------------
2683      * Phase 1:
2684      *
2685      * Examine the optree non-destructively to determine whether it's
2686      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2687      * information about the optree in args[].
2688      */
2689
2690     argp     = args;
2691     targmyop = NULL;
2692     targetop = NULL;
2693     stringop = NULL;
2694     topop    = o;
2695     parentop = o;
2696
2697     assert(   o->op_type == OP_SASSIGN
2698            || o->op_type == OP_CONCAT
2699            || o->op_type == OP_SPRINTF
2700            || o->op_type == OP_STRINGIFY);
2701
2702     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2703
2704     /* first see if, at the top of the tree, there is an assign,
2705      * append and/or stringify */
2706
2707     if (topop->op_type == OP_SASSIGN) {
2708         /* expr = ..... */
2709         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2710             return;
2711         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2712             return;
2713         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2714
2715         parentop = topop;
2716         topop = cBINOPo->op_first;
2717         targetop = OpSIBLING(topop);
2718         if (!targetop) /* probably some sort of syntax error */
2719             return;
2720     }
2721     else if (   topop->op_type == OP_CONCAT
2722              && (topop->op_flags & OPf_STACKED)
2723              && (cUNOPo->op_first->op_flags & OPf_MOD)
2724              && (!(topop->op_private & OPpCONCAT_NESTED))
2725             )
2726     {
2727         /* expr .= ..... */
2728
2729         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2730          * decide what to do about it */
2731         assert(!(o->op_private & OPpTARGET_MY));
2732
2733         /* barf on unknown flags */
2734         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2735         private_flags |= OPpMULTICONCAT_APPEND;
2736         targetop = cBINOPo->op_first;
2737         parentop = topop;
2738         topop    = OpSIBLING(targetop);
2739
2740         /* $x .= <FOO> gets optimised to rcatline instead */
2741         if (topop->op_type == OP_READLINE)
2742             return;
2743     }
2744
2745     if (targetop) {
2746         /* Can targetop (the LHS) if it's a padsv, be be optimised
2747          * away and use OPpTARGET_MY instead?
2748          */
2749         if (    (targetop->op_type == OP_PADSV)
2750             && !(targetop->op_private & OPpDEREF)
2751             && !(targetop->op_private & OPpPAD_STATE)
2752                /* we don't support 'my $x .= ...' */
2753             && (   o->op_type == OP_SASSIGN
2754                 || !(targetop->op_private & OPpLVAL_INTRO))
2755         )
2756             is_targable = TRUE;
2757     }
2758
2759     if (topop->op_type == OP_STRINGIFY) {
2760         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2761             return;
2762         stringop = topop;
2763
2764         /* barf on unknown flags */
2765         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2766
2767         if ((topop->op_private & OPpTARGET_MY)) {
2768             if (o->op_type == OP_SASSIGN)
2769                 return; /* can't have two assigns */
2770             targmyop = topop;
2771         }
2772
2773         private_flags |= OPpMULTICONCAT_STRINGIFY;
2774         parentop = topop;
2775         topop = cBINOPx(topop)->op_first;
2776         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2777         topop = OpSIBLING(topop);
2778     }
2779
2780     if (topop->op_type == OP_SPRINTF) {
2781         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2782             return;
2783         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2784             nargs     = sprintf_info.nargs;
2785             total_len = sprintf_info.total_len;
2786             variant   = sprintf_info.variant;
2787             utf8      = sprintf_info.utf8;
2788             is_sprintf = TRUE;
2789             private_flags |= OPpMULTICONCAT_FAKE;
2790             toparg = argp;
2791             /* we have an sprintf op rather than a concat optree.
2792              * Skip most of the code below which is associated with
2793              * processing that optree. We also skip phase 2, determining
2794              * whether its cost effective to optimise, since for sprintf,
2795              * multiconcat is *always* faster */
2796             goto create_aux;
2797         }
2798         /* note that even if the sprintf itself isn't multiconcatable,
2799          * the expression as a whole may be, e.g. in
2800          *    $x .= sprintf("%d",...)
2801          * the sprintf op will be left as-is, but the concat/S op may
2802          * be upgraded to multiconcat
2803          */
2804     }
2805     else if (topop->op_type == OP_CONCAT) {
2806         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2807             return;
2808
2809         if ((topop->op_private & OPpTARGET_MY)) {
2810             if (o->op_type == OP_SASSIGN || targmyop)
2811                 return; /* can't have two assigns */
2812             targmyop = topop;
2813         }
2814     }
2815
2816     /* Is it safe to convert a sassign/stringify/concat op into
2817      * a multiconcat? */
2818     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2819     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2820     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2821     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2822     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2823                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2824     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2825                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2826
2827     /* Now scan the down the tree looking for a series of
2828      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2829      * stacked). For example this tree:
2830      *
2831      *     |
2832      *   CONCAT/STACKED
2833      *     |
2834      *   CONCAT/STACKED -- EXPR5
2835      *     |
2836      *   CONCAT/STACKED -- EXPR4
2837      *     |
2838      *   CONCAT -- EXPR3
2839      *     |
2840      *   EXPR1  -- EXPR2
2841      *
2842      * corresponds to an expression like
2843      *
2844      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2845      *
2846      * Record info about each EXPR in args[]: in particular, whether it is
2847      * a stringifiable OP_CONST and if so what the const sv is.
2848      *
2849      * The reason why the last concat can't be STACKED is the difference
2850      * between
2851      *
2852      *    ((($a .= $a) .= $a) .= $a) .= $a
2853      *
2854      * and
2855      *    $a . $a . $a . $a . $a
2856      *
2857      * The main difference between the optrees for those two constructs
2858      * is the presence of the last STACKED. As well as modifying $a,
2859      * the former sees the changed $a between each concat, so if $s is
2860      * initially 'a', the first returns 'a' x 16, while the latter returns
2861      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2862      */
2863
2864     kid = topop;
2865
2866     for (;;) {
2867         OP *argop;
2868         SV *sv;
2869         bool last = FALSE;
2870
2871         if (    kid->op_type == OP_CONCAT
2872             && !kid_is_last
2873         ) {
2874             OP *k1, *k2;
2875             k1 = cUNOPx(kid)->op_first;
2876             k2 = OpSIBLING(k1);
2877             /* shouldn't happen except maybe after compile err? */
2878             if (!k2)
2879                 return;
2880
2881             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2882             if (kid->op_private & OPpTARGET_MY)
2883                 kid_is_last = TRUE;
2884
2885             stacked_last = (kid->op_flags & OPf_STACKED);
2886             if (!stacked_last)
2887                 kid_is_last = TRUE;
2888
2889             kid   = k1;
2890             argop = k2;
2891         }
2892         else {
2893             argop = kid;
2894             last = TRUE;
2895         }
2896
2897         if (   nargs              >  PERL_MULTICONCAT_MAXARG        - 2
2898             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2899         {
2900             /* At least two spare slots are needed to decompose both
2901              * concat args. If there are no slots left, continue to
2902              * examine the rest of the optree, but don't push new values
2903              * on args[]. If the optree as a whole is legal for conversion
2904              * (in particular that the last concat isn't STACKED), then
2905              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2906              * can be converted into an OP_MULTICONCAT now, with the first
2907              * child of that op being the remainder of the optree -
2908              * which may itself later be converted to a multiconcat op
2909              * too.
2910              */
2911             if (last) {
2912                 /* the last arg is the rest of the optree */
2913                 argp++->p = NULL;
2914                 nargs++;
2915             }
2916         }
2917         else if (   argop->op_type == OP_CONST
2918             && ((sv = cSVOPx_sv(argop)))
2919             /* defer stringification until runtime of 'constant'
2920              * things that might stringify variantly, e.g. the radix
2921              * point of NVs, or overloaded RVs */
2922             && (SvPOK(sv) || SvIOK(sv))
2923             && (!SvGMAGICAL(sv))
2924         ) {
2925             argp++->p = sv;
2926             utf8   |= cBOOL(SvUTF8(sv));
2927             nconst++;
2928         }
2929         else {
2930             argp++->p = NULL;
2931             nargs++;
2932         }
2933
2934         if (last)
2935             break;
2936     }
2937
2938     toparg = argp - 1;
2939
2940     if (stacked_last)
2941         return; /* we don't support ((A.=B).=C)...) */
2942
2943     /* look for two adjacent consts and don't fold them together:
2944      *     $o . "a" . "b"
2945      * should do
2946      *     $o->concat("a")->concat("b")
2947      * rather than
2948      *     $o->concat("ab")
2949      * (but $o .=  "a" . "b" should still fold)
2950      */
2951     {
2952         bool seen_nonconst = FALSE;
2953         for (argp = toparg; argp >= args; argp--) {
2954             if (argp->p == NULL) {
2955                 seen_nonconst = TRUE;
2956                 continue;
2957             }
2958             if (!seen_nonconst)
2959                 continue;
2960             if (argp[1].p) {
2961                 /* both previous and current arg were constants;
2962                  * leave the current OP_CONST as-is */
2963                 argp->p = NULL;
2964                 nconst--;
2965                 nargs++;
2966             }
2967         }
2968     }
2969
2970     /* -----------------------------------------------------------------
2971      * Phase 2:
2972      *
2973      * At this point we have determined that the optree *can* be converted
2974      * into a multiconcat. Having gathered all the evidence, we now decide
2975      * whether it *should*.
2976      */
2977
2978
2979     /* we need at least one concat action, e.g.:
2980      *
2981      *  Y . Z
2982      *  X = Y . Z
2983      *  X .= Y
2984      *
2985      * otherwise we could be doing something like $x = "foo", which
2986      * if treated as as a concat, would fail to COW.
2987      */
2988     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2989         return;
2990
2991     /* Benchmarking seems to indicate that we gain if:
2992      * * we optimise at least two actions into a single multiconcat
2993      *    (e.g concat+concat, sassign+concat);
2994      * * or if we can eliminate at least 1 OP_CONST;
2995      * * or if we can eliminate a padsv via OPpTARGET_MY
2996      */
2997
2998     if (
2999            /* eliminated at least one OP_CONST */
3000            nconst >= 1
3001            /* eliminated an OP_SASSIGN */
3002         || o->op_type == OP_SASSIGN
3003            /* eliminated an OP_PADSV */
3004         || (!targmyop && is_targable)
3005     )
3006         /* definitely a net gain to optimise */
3007         goto optimise;
3008
3009     /* ... if not, what else? */
3010
3011     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3012      * multiconcat is faster (due to not creating a temporary copy of
3013      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3014      * faster.
3015      */
3016     if (   nconst == 0
3017          && nargs == 2
3018          && targmyop
3019          && topop->op_type == OP_CONCAT
3020     ) {
3021         PADOFFSET t = targmyop->op_targ;
3022         OP *k1 = cBINOPx(topop)->op_first;
3023         OP *k2 = cBINOPx(topop)->op_last;
3024         if (   k2->op_type == OP_PADSV
3025             && k2->op_targ == t
3026             && (   k1->op_type != OP_PADSV
3027                 || k1->op_targ != t)
3028         )
3029             goto optimise;
3030     }
3031
3032     /* need at least two concats */
3033     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3034         return;
3035
3036
3037
3038     /* -----------------------------------------------------------------
3039      * Phase 3:
3040      *
3041      * At this point the optree has been verified as ok to be optimised
3042      * into an OP_MULTICONCAT. Now start changing things.
3043      */
3044
3045    optimise:
3046
3047     /* stringify all const args and determine utf8ness */
3048
3049     variant = 0;
3050     for (argp = args; argp <= toparg; argp++) {
3051         SV *sv = (SV*)argp->p;
3052         if (!sv)
3053             continue; /* not a const op */
3054         if (utf8 && !SvUTF8(sv))
3055             sv_utf8_upgrade_nomg(sv);
3056         argp->p = SvPV_nomg(sv, argp->len);
3057         total_len += argp->len;
3058
3059         /* see if any strings would grow if converted to utf8 */
3060         if (!utf8) {
3061             char *p    = (char*)argp->p;
3062             STRLEN len = argp->len;
3063             while (len--) {
3064                 U8 c = *p++;
3065                 if (!UTF8_IS_INVARIANT(c))
3066                     variant++;
3067             }
3068         }
3069     }
3070
3071     /* create and populate aux struct */
3072
3073   create_aux:
3074
3075     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3076                     sizeof(UNOP_AUX_item)
3077                     *  (
3078                            PERL_MULTICONCAT_HEADER_SIZE
3079                          + ((nargs + 1) * (variant ? 2 : 1))
3080                         )
3081                     );
3082     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3083
3084     /* Extract all the non-const expressions from the concat tree then
3085      * dispose of the old tree, e.g. convert the tree from this:
3086      *
3087      *  o => SASSIGN
3088      *         |
3089      *       STRINGIFY   -- TARGET
3090      *         |
3091      *       ex-PUSHMARK -- CONCAT
3092      *                        |
3093      *                      CONCAT -- EXPR5
3094      *                        |
3095      *                      CONCAT -- EXPR4
3096      *                        |
3097      *                      CONCAT -- EXPR3
3098      *                        |
3099      *                      EXPR1  -- EXPR2
3100      *
3101      *
3102      * to:
3103      *
3104      *  o => MULTICONCAT
3105      *         |
3106      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3107      *
3108      * except that if EXPRi is an OP_CONST, it's discarded.
3109      *
3110      * During the conversion process, EXPR ops are stripped from the tree
3111      * and unshifted onto o. Finally, any of o's remaining original
3112      * childen are discarded and o is converted into an OP_MULTICONCAT.
3113      *
3114      * In this middle of this, o may contain both: unshifted args on the
3115      * left, and some remaining original args on the right. lastkidop
3116      * is set to point to the right-most unshifted arg to delineate
3117      * between the two sets.
3118      */
3119
3120
3121     if (is_sprintf) {
3122         /* create a copy of the format with the %'s removed, and record
3123          * the sizes of the const string segments in the aux struct */
3124         char *q, *oldq;
3125         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3126
3127         p    = sprintf_info.start;
3128         q    = const_str;
3129         oldq = q;
3130         for (; p < sprintf_info.end; p++) {
3131             if (*p == '%') {
3132                 p++;
3133                 if (*p != '%') {
3134                     (lenp++)->ssize = q - oldq;
3135                     oldq = q;
3136                     continue;
3137                 }
3138             }
3139             *q++ = *p;
3140         }
3141         lenp->ssize = q - oldq;
3142         assert((STRLEN)(q - const_str) == total_len);
3143
3144         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3145          * may or may not be topop) The pushmark and const ops need to be
3146          * kept in case they're an op_next entry point.
3147          */
3148         lastkidop = cLISTOPx(topop)->op_last;
3149         kid = cUNOPx(topop)->op_first; /* pushmark */
3150         op_null(kid);
3151         op_null(OpSIBLING(kid));       /* const */
3152         if (o != topop) {
3153             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3154             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3155             lastkidop->op_next = o;
3156         }
3157     }
3158     else {
3159         p = const_str;
3160         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3161
3162         lenp->ssize = -1;
3163
3164         /* Concatenate all const strings into const_str.
3165          * Note that args[] contains the RHS args in reverse order, so
3166          * we scan args[] from top to bottom to get constant strings
3167          * in L-R order
3168          */
3169         for (argp = toparg; argp >= args; argp--) {
3170             if (!argp->p)
3171                 /* not a const op */
3172                 (++lenp)->ssize = -1;
3173             else {
3174                 STRLEN l = argp->len;
3175                 Copy(argp->p, p, l, char);
3176                 p += l;
3177                 if (lenp->ssize == -1)
3178                     lenp->ssize = l;
3179                 else
3180                     lenp->ssize += l;
3181             }
3182         }
3183
3184         kid = topop;
3185         nextop = o;
3186         lastkidop = NULL;
3187
3188         for (argp = args; argp <= toparg; argp++) {
3189             /* only keep non-const args, except keep the first-in-next-chain
3190              * arg no matter what it is (but nulled if OP_CONST), because it
3191              * may be the entry point to this subtree from the previous
3192              * op_next.
3193              */
3194             bool last = (argp == toparg);
3195             OP *prev;
3196
3197             /* set prev to the sibling *before* the arg to be cut out,
3198              * e.g.:
3199              *
3200              *         |
3201              * kid=  CONST
3202              *         |
3203              * prev= CONST -- EXPR
3204              *         |
3205              */
3206             if (argp == args && kid->op_type != OP_CONCAT) {
3207                 /* in e.g. '$x . = f(1)' there's no RHS concat tree
3208                  * so the expression to be cut isn't kid->op_last but
3209                  * kid itself */
3210                 OP *o1, *o2;
3211                 /* find the op before kid */
3212                 o1 = NULL;
3213                 o2 = cUNOPx(parentop)->op_first;
3214                 while (o2 && o2 != kid) {
3215                     o1 = o2;
3216                     o2 = OpSIBLING(o2);
3217                 }
3218                 assert(o2 == kid);
3219                 prev = o1;
3220                 kid  = parentop;
3221             }
3222             else if (kid == o && lastkidop)
3223                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3224             else
3225                 prev = last ? NULL : cUNOPx(kid)->op_first;
3226
3227             if (!argp->p || last) {
3228                 /* cut RH op */
3229                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3230                 /* and unshift to front of o */
3231                 op_sibling_splice(o, NULL, 0, aop);
3232                 /* record the right-most op added to o: later we will
3233                  * free anything to the right of it */
3234                 if (!lastkidop)
3235                     lastkidop = aop;
3236                 aop->op_next = nextop;
3237                 if (last) {
3238                     if (argp->p)
3239                         /* null the const at start of op_next chain */
3240                         op_null(aop);
3241                 }
3242                 else if (prev)
3243                     nextop = prev->op_next;
3244             }
3245
3246             /* the last two arguments are both attached to the same concat op */
3247             if (argp < toparg - 1)
3248                 kid = prev;
3249         }
3250     }
3251
3252     /* Populate the aux struct */
3253
3254     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3255     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3256     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3257     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3258     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3259
3260     /* if variant > 0, calculate a variant const string and lengths where
3261      * the utf8 version of the string will take 'variant' more bytes than
3262      * the plain one. */
3263
3264     if (variant) {
3265         char              *p = const_str;
3266         STRLEN          ulen = total_len + variant;
3267         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3268         UNOP_AUX_item *ulens = lens + (nargs + 1);
3269         char             *up = (char*)PerlMemShared_malloc(ulen);
3270         SSize_t            n;
3271
3272         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3273         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3274
3275         for (n = 0; n < (nargs + 1); n++) {
3276             SSize_t i;
3277             char * orig_up = up;
3278             for (i = (lens++)->ssize; i > 0; i--) {
3279                 U8 c = *p++;
3280                 append_utf8_from_native_byte(c, (U8**)&up);
3281             }
3282             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3283         }
3284     }
3285
3286     if (stringop) {
3287         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3288          * that op's first child - an ex-PUSHMARK - because the op_next of
3289          * the previous op may point to it (i.e. it's the entry point for
3290          * the o optree)
3291          */
3292         OP *pmop =
3293             (stringop == o)
3294                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3295                 : op_sibling_splice(stringop, NULL, 1, NULL);
3296         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3297         op_sibling_splice(o, NULL, 0, pmop);
3298         if (!lastkidop)
3299             lastkidop = pmop;
3300     }
3301
3302     /* Optimise
3303      *    target  = A.B.C...
3304      *    target .= A.B.C...
3305      */
3306
3307     if (targetop) {
3308         assert(!targmyop);
3309
3310         if (o->op_type == OP_SASSIGN) {
3311             /* Move the target subtree from being the last of o's children
3312              * to being the last of o's preserved children.
3313              * Note the difference between 'target = ...' and 'target .= ...':
3314              * for the former, target is executed last; for the latter,
3315              * first.
3316              */
3317             kid = OpSIBLING(lastkidop);
3318             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3319             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3320             lastkidop->op_next = kid->op_next;
3321             lastkidop = targetop;
3322         }
3323         else {
3324             /* Move the target subtree from being the first of o's
3325              * original children to being the first of *all* o's children.
3326              */
3327             if (lastkidop) {
3328                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3329                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3330             }
3331             else {
3332                 /* if the RHS of .= doesn't contain a concat (e.g.
3333                  * $x .= "foo"), it gets missed by the "strip ops from the
3334                  * tree and add to o" loop earlier */
3335                 assert(topop->op_type != OP_CONCAT);
3336                 if (stringop) {
3337                     /* in e.g. $x .= "$y", move the $y expression
3338                      * from being a child of OP_STRINGIFY to being the
3339                      * second child of the OP_CONCAT
3340                      */
3341                     assert(cUNOPx(stringop)->op_first == topop);
3342                     op_sibling_splice(stringop, NULL, 1, NULL);
3343                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3344                 }
3345                 assert(topop == OpSIBLING(cBINOPo->op_first));
3346                 if (toparg->p)
3347                     op_null(topop);
3348                 lastkidop = topop;
3349             }
3350         }
3351
3352         if (is_targable) {
3353             /* optimise
3354              *  my $lex  = A.B.C...
3355              *     $lex  = A.B.C...
3356              *     $lex .= A.B.C...
3357              * The original padsv op is kept but nulled in case it's the
3358              * entry point for the optree (which it will be for
3359              * '$lex .=  ... '
3360              */
3361             private_flags |= OPpTARGET_MY;
3362             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3363             o->op_targ = targetop->op_targ;
3364             targetop->op_targ = 0;
3365             op_null(targetop);
3366         }
3367         else
3368             flags |= OPf_STACKED;
3369     }
3370     else if (targmyop) {
3371         private_flags |= OPpTARGET_MY;
3372         if (o != targmyop) {
3373             o->op_targ = targmyop->op_targ;
3374             targmyop->op_targ = 0;
3375         }
3376     }
3377
3378     /* detach the emaciated husk of the sprintf/concat optree and free it */
3379     for (;;) {
3380         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3381         if (!kid)
3382             break;
3383         op_free(kid);
3384     }
3385
3386     /* and convert o into a multiconcat */
3387
3388     o->op_flags        = (flags|OPf_KIDS|stacked_last
3389                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3390     o->op_private      = private_flags;
3391     o->op_type         = OP_MULTICONCAT;
3392     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3393     cUNOP_AUXo->op_aux = aux;
3394 }
3395
3396
3397 /* do all the final processing on an optree (e.g. running the peephole
3398  * optimiser on it), then attach it to cv (if cv is non-null)
3399  */
3400
3401 static void
3402 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3403 {
3404     OP **startp;
3405
3406     /* XXX for some reason, evals, require and main optrees are
3407      * never attached to their CV; instead they just hang off
3408      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3409      * and get manually freed when appropriate */
3410     if (cv)
3411         startp = &CvSTART(cv);
3412     else
3413         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3414
3415     *startp = start;
3416     optree->op_private |= OPpREFCOUNTED;
3417     OpREFCNT_set(optree, 1);
3418     optimize_optree(optree);
3419     CALL_PEEP(*startp);
3420     finalize_optree(optree);
3421     S_prune_chain_head(startp);
3422
3423     if (cv) {
3424         /* now that optimizer has done its work, adjust pad values */
3425         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3426                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3427     }
3428 }
3429
3430
3431 /*
3432 =for apidoc optimize_optree
3433
3434 This function applies some optimisations to the optree in top-down order.
3435 It is called before the peephole optimizer, which processes ops in
3436 execution order. Note that finalize_optree() also does a top-down scan,
3437 but is called *after* the peephole optimizer.
3438
3439 =cut
3440 */
3441
3442 void
3443 Perl_optimize_optree(pTHX_ OP* o)
3444 {
3445     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3446
3447     ENTER;
3448     SAVEVPTR(PL_curcop);
3449
3450     optimize_op(o);
3451
3452     LEAVE;
3453 }
3454
3455
3456 /* helper for optimize_optree() which optimises on op then recurses
3457  * to optimise any children.
3458  */
3459
3460 STATIC void
3461 S_optimize_op(pTHX_ OP* o)
3462 {
3463     OP *kid;
3464
3465     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3466     assert(o->op_type != OP_FREED);
3467
3468     switch (o->op_type) {
3469     case OP_NEXTSTATE:
3470     case OP_DBSTATE:
3471         PL_curcop = ((COP*)o);          /* for warnings */
3472         break;
3473
3474
3475     case OP_CONCAT:
3476     case OP_SASSIGN:
3477     case OP_STRINGIFY:
3478     case OP_SPRINTF:
3479         S_maybe_multiconcat(aTHX_ o);
3480         break;
3481
3482     case OP_SUBST:
3483         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3484             optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3485         break;
3486
3487     default:
3488         break;
3489     }
3490
3491     if (!(o->op_flags & OPf_KIDS))
3492         return;
3493
3494     for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3495         optimize_op(kid);
3496 }
3497
3498
3499 /*
3500 =for apidoc finalize_optree
3501
3502 This function finalizes the optree.  Should be called directly after
3503 the complete optree is built.  It does some additional
3504 checking which can't be done in the normal C<ck_>xxx functions and makes
3505 the tree thread-safe.
3506
3507 =cut
3508 */
3509 void
3510 Perl_finalize_optree(pTHX_ OP* o)
3511 {
3512     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3513
3514     ENTER;
3515     SAVEVPTR(PL_curcop);
3516
3517     finalize_op(o);
3518
3519     LEAVE;
3520 }
3521
3522 #ifdef USE_ITHREADS
3523 /* Relocate sv to the pad for thread safety.
3524  * Despite being a "constant", the SV is written to,
3525  * for reference counts, sv_upgrade() etc. */
3526 PERL_STATIC_INLINE void
3527 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3528 {
3529     PADOFFSET ix;
3530     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3531     if (!*svp) return;
3532     ix = pad_alloc(OP_CONST, SVf_READONLY);
3533     SvREFCNT_dec(PAD_SVl(ix));
3534     PAD_SETSV(ix, *svp);
3535     /* XXX I don't know how this isn't readonly already. */
3536     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3537     *svp = NULL;
3538     *targp = ix;
3539 }
3540 #endif
3541
3542
3543 STATIC void
3544 S_finalize_op(pTHX_ OP* o)
3545 {
3546     PERL_ARGS_ASSERT_FINALIZE_OP;
3547
3548     assert(o->op_type != OP_FREED);
3549
3550     switch (o->op_type) {
3551     case OP_NEXTSTATE:
3552     case OP_DBSTATE:
3553         PL_curcop = ((COP*)o);          /* for warnings */
3554         break;
3555     case OP_EXEC:
3556         if (OpHAS_SIBLING(o)) {
3557             OP *sib = OpSIBLING(o);
3558             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3559                 && ckWARN(WARN_EXEC)
3560                 && OpHAS_SIBLING(sib))
3561             {
3562                     const OPCODE type = OpSIBLING(sib)->op_type;
3563                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3564                         const line_t oldline = CopLINE(PL_curcop);
3565                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3566                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3567                             "Statement unlikely to be reached");
3568                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3569                             "\t(Maybe you meant system() when you said exec()?)\n");
3570                         CopLINE_set(PL_curcop, oldline);
3571                     }
3572             }
3573         }
3574         break;
3575
3576     case OP_GV:
3577         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3578             GV * const gv = cGVOPo_gv;
3579             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3580                 /* XXX could check prototype here instead of just carping */
3581                 SV * const sv = sv_newmortal();
3582                 gv_efullname3(sv, gv, NULL);
3583                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3584                     "%" SVf "() called too early to check prototype",
3585                     SVfARG(sv));
3586             }
3587         }
3588         break;
3589
3590     case OP_CONST:
3591         if (cSVOPo->op_private & OPpCONST_STRICT)
3592             no_bareword_allowed(o);
3593 #ifdef USE_ITHREADS
3594         /* FALLTHROUGH */
3595     case OP_HINTSEVAL:
3596         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3597 #endif
3598         break;
3599
3600 #ifdef USE_ITHREADS
3601     /* Relocate all the METHOP's SVs to the pad for thread safety. */
3602     case OP_METHOD_NAMED:
3603     case OP_METHOD_SUPER:
3604     case OP_METHOD_REDIR:
3605     case OP_METHOD_REDIR_SUPER:
3606         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3607         break;
3608 #endif
3609
3610     case OP_HELEM: {
3611         UNOP *rop;
3612         SVOP *key_op;
3613         OP *kid;
3614
3615         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3616             break;
3617
3618         rop = (UNOP*)((BINOP*)o)->op_first;
3619
3620         goto check_keys;
3621
3622     case OP_HSLICE:
3623         S_scalar_slice_warning(aTHX_ o);
3624         /* FALLTHROUGH */
3625
3626     case OP_KVHSLICE:
3627         kid = OpSIBLING(cLISTOPo->op_first);
3628         if (/* I bet there's always a pushmark... */
3629             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3630             && OP_TYPE_ISNT_NN(kid, OP_CONST))
3631         {
3632             break;
3633         }
3634
3635         key_op = (SVOP*)(kid->op_type == OP_CONST
3636                                 ? kid
3637                                 : OpSIBLING(kLISTOP->op_first));
3638
3639         rop = (UNOP*)((LISTOP*)o)->op_last;
3640
3641       check_keys:
3642         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3643             rop = NULL;
3644         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3645         break;
3646     }
3647     case OP_NULL:
3648         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3649             break;
3650         /* FALLTHROUGH */
3651     case OP_ASLICE:
3652         S_scalar_slice_warning(aTHX_ o);
3653         break;
3654
3655     case OP_SUBST: {
3656         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3657             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3658         break;
3659     }
3660     default:
3661         break;
3662     }
3663
3664     if (o->op_flags & OPf_KIDS) {
3665         OP *kid;
3666
3667 #ifdef DEBUGGING
3668         /* check that op_last points to the last sibling, and that
3669          * the last op_sibling/op_sibparent field points back to the
3670          * parent, and that the only ops with KIDS are those which are
3671          * entitled to them */
3672         U32 type = o->op_type;
3673         U32 family;
3674         bool has_last;
3675
3676         if (type == OP_NULL) {
3677             type = o->op_targ;
3678             /* ck_glob creates a null UNOP with ex-type GLOB
3679              * (which is a list op. So pretend it wasn't a listop */
3680             if (type == OP_GLOB)
3681                 type = OP_NULL;
3682         }
3683         family = PL_opargs[type] & OA_CLASS_MASK;
3684
3685         has_last = (   family == OA_BINOP
3686                     || family == OA_LISTOP
3687                     || family == OA_PMOP
3688                     || family == OA_LOOP
3689                    );
3690         assert(  has_last /* has op_first and op_last, or ...
3691               ... has (or may have) op_first: */
3692               || family == OA_UNOP
3693               || family == OA_UNOP_AUX
3694               || family == OA_LOGOP
3695               || family == OA_BASEOP_OR_UNOP
3696               || family == OA_FILESTATOP
3697               || family == OA_LOOPEXOP
3698               || family == OA_METHOP
3699               || type == OP_CUSTOM
3700               || type == OP_NULL /* new_logop does this */
3701               );
3702
3703         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3704 #  ifdef PERL_OP_PARENT
3705             if (!OpHAS_SIBLING(kid)) {
3706                 if (has_last)
3707                     assert(kid == cLISTOPo->op_last);
3708                 assert(kid->op_sibparent == o);
3709             }
3710 #  else
3711             if (has_last && !OpHAS_SIBLING(kid))
3712                 assert(kid == cLISTOPo->op_last);
3713 #  endif
3714         }
3715 #endif
3716
3717         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3718             finalize_op(kid);
3719     }
3720 }
3721
3722 /*
3723 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3724
3725 Propagate lvalue ("modifiable") context to an op and its children.
3726 C<type> represents the context type, roughly based on the type of op that
3727 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3728 because it has no op type of its own (it is signalled by a flag on
3729 the lvalue op).
3730
3731 This function detects things that can't be modified, such as C<$x+1>, and
3732 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3733 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3734
3735 It also flags things that need to behave specially in an lvalue context,
3736 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3737
3738 =cut
3739 */
3740
3741 static void
3742 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3743 {
3744     CV *cv = PL_compcv;
3745     PadnameLVALUE_on(pn);
3746     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3747         cv = CvOUTSIDE(cv);
3748         /* RT #127786: cv can be NULL due to an eval within the DB package
3749          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3750          * unless they contain an eval, but calling eval within DB
3751          * pretends the eval was done in the caller's scope.
3752          */
3753         if (!cv)
3754             break;
3755         assert(CvPADLIST(cv));
3756         pn =
3757            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3758         assert(PadnameLEN(pn));
3759         PadnameLVALUE_on(pn);
3760     }
3761 }
3762
3763 static bool
3764 S_vivifies(const OPCODE type)
3765 {
3766     switch(type) {
3767     case OP_RV2AV:     case   OP_ASLICE:
3768     case OP_RV2HV:     case OP_KVASLICE:
3769     case OP_RV2SV:     case   OP_HSLICE:
3770     case OP_AELEMFAST: case OP_KVHSLICE:
3771     case OP_HELEM:
3772     case OP_AELEM:
3773         return 1;
3774     }
3775     return 0;
3776 }
3777
3778 static void
3779 S_lvref(pTHX_ OP *o, I32 type)
3780 {
3781     dVAR;
3782     OP *kid;
3783     switch (o->op_type) {
3784     case OP_COND_EXPR:
3785         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3786              kid = OpSIBLING(kid))
3787             S_lvref(aTHX_ kid, type);
3788         /* FALLTHROUGH */
3789     case OP_PUSHMARK:
3790         return;
3791     case OP_RV2AV:
3792         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3793         o->op_flags |= OPf_STACKED;
3794         if (o->op_flags & OPf_PARENS) {
3795             if (o->op_private & OPpLVAL_INTRO) {
3796                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3797                       "localized parenthesized array in list assignment"));
3798                 return;
3799             }
3800           slurpy:
3801             OpTYPE_set(o, OP_LVAVREF);
3802             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3803             o->op_flags |= OPf_MOD|OPf_REF;
3804             return;
3805         }
3806         o->op_private |= OPpLVREF_AV;
3807         goto checkgv;
3808     case OP_RV2CV:
3809         kid = cUNOPo->op_first;
3810         if (kid->op_type == OP_NULL)
3811             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3812                 ->op_first;
3813         o->op_private = OPpLVREF_CV;
3814         if (kid->op_type == OP_GV)
3815             o->op_flags |= OPf_STACKED;
3816         else if (kid->op_type == OP_PADCV) {
3817             o->op_targ = kid->op_targ;
3818             kid->op_targ = 0;
3819             op_free(cUNOPo->op_first);
3820             cUNOPo->op_first = NULL;
3821             o->op_flags &=~ OPf_KIDS;
3822         }
3823         else goto badref;
3824         break;
3825     case OP_RV2HV:
3826         if (o->op_flags & OPf_PARENS) {
3827           parenhash:
3828             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3829                                  "parenthesized hash in list assignment"));
3830                 return;
3831         }
3832         o->op_private |= OPpLVREF_HV;
3833         /* FALLTHROUGH */
3834     case OP_RV2SV:
3835       checkgv:
3836         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3837         o->op_flags |= OPf_STACKED;
3838         break;
3839     case OP_PADHV:
3840         if (o->op_flags & OPf_PARENS) goto parenhash;
3841         o->op_private |= OPpLVREF_HV;
3842         /* FALLTHROUGH */
3843     case OP_PADSV:
3844         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3845         break;
3846     case OP_PADAV:
3847         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3848         if (o->op_flags & OPf_PARENS) goto slurpy;
3849         o->op_private |= OPpLVREF_AV;
3850         break;
3851     case OP_AELEM:
3852     case OP_HELEM:
3853         o->op_private |= OPpLVREF_ELEM;
3854         o->op_flags   |= OPf_STACKED;
3855         break;
3856     case OP_ASLICE:
3857     case OP_HSLICE:
3858         OpTYPE_set(o, OP_LVREFSLICE);
3859         o->op_private &= OPpLVAL_INTRO;
3860         return;
3861     case OP_NULL:
3862         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3863             goto badref;
3864         else if (!(o->op_flags & OPf_KIDS))
3865             return;
3866         if (o->op_targ != OP_LIST) {
3867             S_lvref(aTHX_ cBINOPo->op_first, type);
3868             return;
3869         }
3870         /* FALLTHROUGH */
3871     case OP_LIST:
3872         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3873             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3874             S_lvref(aTHX_ kid, type);
3875         }
3876         return;
3877     case OP_STUB:
3878         if (o->op_flags & OPf_PARENS)
3879             return;
3880         /* FALLTHROUGH */
3881     default:
3882       badref:
3883         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3884         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3885                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3886                       ? "do block"
3887                       : OP_DESC(o),
3888                      PL_op_desc[type]));
3889         return;
3890     }
3891     OpTYPE_set(o, OP_LVREF);
3892     o->op_private &=
3893         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3894     if (type == OP_ENTERLOOP)
3895         o->op_private |= OPpLVREF_ITER;
3896 }
3897
3898 PERL_STATIC_INLINE bool
3899 S_potential_mod_type(I32 type)
3900 {
3901     /* Types that only potentially result in modification.  */
3902     return type == OP_GREPSTART || type == OP_ENTERSUB
3903         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3904 }
3905
3906 OP *
3907 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3908 {
3909     dVAR;
3910     OP *kid;
3911     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3912     int localize = -1;
3913
3914     if (!o || (PL_parser && PL_parser->error_count))
3915         return o;
3916
3917     if ((o->op_private & OPpTARGET_MY)
3918         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3919     {
3920         return o;
3921     }
3922
3923     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3924
3925     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3926
3927     switch (o->op_type) {
3928     case OP_UNDEF:
3929         PL_modcount++;
3930         return o;
3931     case OP_STUB:
3932         if ((o->op_flags & OPf_PARENS))
3933             break;
3934         goto nomod;
3935     case OP_ENTERSUB:
3936         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3937             !(o->op_flags & OPf_STACKED)) {
3938             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3939             assert(cUNOPo->op_first->op_type == OP_NULL);
3940             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3941             break;
3942         }
3943         else {                          /* lvalue subroutine call */
3944             o->op_private |= OPpLVAL_INTRO;
3945             PL_modcount = RETURN_UNLIMITED_NUMBER;
3946             if (S_potential_mod_type(type)) {
3947                 o->op_private |= OPpENTERSUB_INARGS;
3948                 break;
3949             }
3950             else {                      /* Compile-time error message: */
3951                 OP *kid = cUNOPo->op_first;
3952                 CV *cv;
3953                 GV *gv;
3954                 SV *namesv;
3955
3956                 if (kid->op_type != OP_PUSHMARK) {
3957                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3958                         Perl_croak(aTHX_
3959                                 "panic: unexpected lvalue entersub "
3960                                 "args: type/targ %ld:%" UVuf,
3961                                 (long)kid->op_type, (UV)kid->op_targ);
3962                     kid = kLISTOP->op_first;
3963                 }
3964                 while (OpHAS_SIBLING(kid))
3965                     kid = OpSIBLING(kid);
3966                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3967                     break;      /* Postpone until runtime */
3968                 }
3969
3970                 kid = kUNOP->op_first;
3971                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3972                     kid = kUNOP->op_first;
3973                 if (kid->op_type == OP_NULL)
3974                     Perl_croak(aTHX_
3975                                "Unexpected constant lvalue entersub "
3976                                "entry via type/targ %ld:%" UVuf,
3977                                (long)kid->op_type, (UV)kid->op_targ);
3978                 if (kid->op_type != OP_GV) {
3979                     break;
3980                 }
3981
3982                 gv = kGVOP_gv;
3983                 cv = isGV(gv)
3984                     ? GvCV(gv)
3985                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3986                         ? MUTABLE_CV(SvRV(gv))
3987                         : NULL;
3988                 if (!cv)
3989                     break;
3990                 if (CvLVALUE(cv))
3991                     break;
3992                 if (flags & OP_LVALUE_NO_CROAK)
3993                     return NULL;
3994
3995                 namesv = cv_name(cv, NULL, 0);
3996                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3997                                      "subroutine call of &%" SVf " in %s",
3998                                      SVfARG(namesv), PL_op_desc[type]),
3999                            SvUTF8(namesv));
4000                 return o;
4001             }
4002         }
4003         /* FALLTHROUGH */
4004     default:
4005       nomod:
4006         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4007         /* grep, foreach, subcalls, refgen */
4008         if (S_potential_mod_type(type))
4009             break;
4010         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4011                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4012                       ? "do block"
4013                       : OP_DESC(o)),
4014                      type ? PL_op_desc[type] : "local"));
4015         return o;
4016
4017     case OP_PREINC:
4018     case OP_PREDEC:
4019     case OP_POW:
4020     case OP_MULTIPLY:
4021     case OP_DIVIDE:
4022     case OP_MODULO:
4023     case OP_ADD:
4024     case OP_SUBTRACT:
4025     case OP_CONCAT:
4026     case OP_LEFT_SHIFT:
4027     case OP_RIGHT_SHIFT:
4028     case OP_BIT_AND:
4029     case OP_BIT_XOR:
4030     case OP_BIT_OR:
4031     case OP_I_MULTIPLY:
4032     case OP_I_DIVIDE:
4033     case OP_I_MODULO:
4034     case OP_I_ADD:
4035     case OP_I_SUBTRACT:
4036         if (!(o->op_flags & OPf_STACKED))
4037             goto nomod;
4038         PL_modcount++;
4039         break;
4040
4041     case OP_REPEAT:
4042         if (o->op_flags & OPf_STACKED) {
4043             PL_modcount++;
4044             break;
4045         }
4046         if (!(o->op_private & OPpREPEAT_DOLIST))
4047             goto nomod;
4048         else {
4049             const I32 mods = PL_modcount;
4050             modkids(cBINOPo->op_first, type);
4051             if (type != OP_AASSIGN)
4052                 goto nomod;
4053             kid = cBINOPo->op_last;
4054             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4055                 const IV iv = SvIV(kSVOP_sv);
4056                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4057                     PL_modcount =
4058                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4059             }
4060             else
4061                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4062         }
4063         break;
4064
4065     case OP_COND_EXPR:
4066         localize = 1;
4067         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4068             op_lvalue(kid, type);
4069         break;
4070
4071     case OP_RV2AV:
4072     case OP_RV2HV:
4073         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4074            PL_modcount = RETURN_UNLIMITED_NUMBER;
4075             return o;           /* Treat \(@foo) like ordinary list. */
4076         }
4077         /* FALLTHROUGH */
4078     case OP_RV2GV:
4079         if (scalar_mod_type(o, type))
4080             goto nomod;
4081         ref(cUNOPo->op_first, o->op_type);
4082         /* FALLTHROUGH */
4083     case OP_ASLICE:
4084     case OP_HSLICE:
4085         localize = 1;
4086         /* FALLTHROUGH */
4087     case OP_AASSIGN:
4088         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4089         if (type == OP_LEAVESUBLV && (
4090                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4091              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4092            ))
4093             o->op_private |= OPpMAYBE_LVSUB;
4094         /* FALLTHROUGH */
4095     case OP_NEXTSTATE:
4096     case OP_DBSTATE:
4097        PL_modcount = RETURN_UNLIMITED_NUMBER;
4098         break;
4099     case OP_KVHSLICE:
4100     case OP_KVASLICE:
4101     case OP_AKEYS:
4102         if (type == OP_LEAVESUBLV)
4103             o->op_private |= OPpMAYBE_LVSUB;
4104         goto nomod;
4105     case OP_AVHVSWITCH:
4106         if (type == OP_LEAVESUBLV
4107          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4108             o->op_private |= OPpMAYBE_LVSUB;
4109         goto nomod;
4110     case OP_AV2ARYLEN:
4111         PL_hints |= HINT_BLOCK_SCOPE;
4112         if (type == OP_LEAVESUBLV)
4113             o->op_private |= OPpMAYBE_LVSUB;
4114         PL_modcount++;
4115         break;
4116     case OP_RV2SV:
4117         ref(cUNOPo->op_first, o->op_type);
4118         localize = 1;
4119         /* FALLTHROUGH */
4120     case OP_GV:
4121         PL_hints |= HINT_BLOCK_SCOPE;
4122         /* FALLTHROUGH */
4123     case OP_SASSIGN:
4124     case OP_ANDASSIGN:
4125     case OP_ORASSIGN:
4126     case OP_DORASSIGN:
4127         PL_modcount++;
4128         break;
4129
4130     case OP_AELEMFAST:
4131     case OP_AELEMFAST_LEX:
4132         localize = -1;
4133         PL_modcount++;
4134         break;
4135
4136     case OP_PADAV:
4137     case OP_PADHV:
4138        PL_modcount = RETURN_UNLIMITED_NUMBER;
4139         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4140             return o;           /* Treat \(@foo) like ordinary list. */
4141         if (scalar_mod_type(o, type))
4142             goto nomod;
4143         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4144           && type == OP_LEAVESUBLV)
4145             o->op_private |= OPpMAYBE_LVSUB;
4146         /* FALLTHROUGH */
4147     case OP_PADSV:
4148         PL_modcount++;
4149         if (!type) /* local() */
4150             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4151                               PNfARG(PAD_COMPNAME(o->op_targ)));
4152         if (!(o->op_private & OPpLVAL_INTRO)
4153          || (  type != OP_SASSIGN && type != OP_AASSIGN
4154             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4155             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4156         break;
4157
4158     case OP_PUSHMARK:
4159         localize = 0;
4160         break;
4161
4162     case OP_KEYS:
4163         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4164             goto nomod;
4165         goto lvalue_func;
4166     case OP_SUBSTR:
4167         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4168             goto nomod;
4169         /* FALLTHROUGH */
4170     case OP_POS:
4171     case OP_VEC:
4172       lvalue_func:
4173         if (type == OP_LEAVESUBLV)
4174             o->op_private |= OPpMAYBE_LVSUB;
4175         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4176             /* substr and vec */
4177             /* If this op is in merely potential (non-fatal) modifiable
4178                context, then apply OP_ENTERSUB context to
4179                the kid op (to avoid croaking).  Other-
4180                wise pass this op’s own type so the correct op is mentioned
4181                in error messages.  */
4182             op_lvalue(OpSIBLING(cBINOPo->op_first),
4183                       S_potential_mod_type(type)
4184                         ? (I32)OP_ENTERSUB
4185                         : o->op_type);
4186         }
4187         break;
4188
4189     case OP_AELEM:
4190     case OP_HELEM:
4191         ref(cBINOPo->op_first, o->op_type);
4192         if (type == OP_ENTERSUB &&
4193              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4194             o->op_private |= OPpLVAL_DEFER;
4195         if (type == OP_LEAVESUBLV)
4196             o->op_private |= OPpMAYBE_LVSUB;
4197         localize = 1;
4198         PL_modcount++;
4199         break;
4200
4201     case OP_LEAVE:
4202     case OP_LEAVELOOP:
4203         o->op_private |= OPpLVALUE;
4204         /* FALLTHROUGH */
4205     case OP_SCOPE:
4206     case OP_ENTER:
4207     case OP_LINESEQ:
4208         localize = 0;
4209         if (o->op_flags & OPf_KIDS)
4210             op_lvalue(cLISTOPo->op_last, type);
4211         break;
4212
4213     case OP_NULL:
4214         localize = 0;
4215         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4216             goto nomod;
4217         else if (!(o->op_flags & OPf_KIDS))
4218             break;
4219
4220         if (o->op_targ != OP_LIST) {
4221             OP *sib = OpSIBLING(cLISTOPo->op_first);
4222             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4223              * that looks like
4224              *
4225              *   null
4226              *      arg
4227              *      trans
4228              *
4229              * compared with things like OP_MATCH which have the argument
4230              * as a child:
4231              *
4232              *   match
4233              *      arg
4234              *
4235              * so handle specially to correctly get "Can't modify" croaks etc
4236              */
4237
4238             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4239             {
4240                 /* this should trigger a "Can't modify transliteration" err */
4241                 op_lvalue(sib, type);
4242             }
4243             op_lvalue(cBINOPo->op_first, type);
4244             break;
4245         }
4246         /* FALLTHROUGH */
4247     case OP_LIST:
4248         localize = 0;
4249         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4250             /* elements might be in void context because the list is
4251                in scalar context or because they are attribute sub calls */
4252             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4253                 op_lvalue(kid, type);
4254         break;
4255
4256     case OP_COREARGS:
4257         return o;
4258
4259     case OP_AND:
4260     case OP_OR:
4261         if (type == OP_LEAVESUBLV
4262          || !S_vivifies(cLOGOPo->op_first->op_type))
4263             op_lvalue(cLOGOPo->op_first, type);
4264         if (type == OP_LEAVESUBLV
4265          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4266             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4267         goto nomod;
4268
4269     case OP_SREFGEN:
4270         if (type == OP_NULL) { /* local */
4271           local_refgen:
4272             if (!FEATURE_MYREF_IS_ENABLED)
4273                 Perl_croak(aTHX_ "The experimental declared_refs "
4274                                  "feature is not enabled");
4275             Perl_ck_warner_d(aTHX_
4276                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4277                     "Declaring references is experimental");
4278             op_lvalue(cUNOPo->op_first, OP_NULL);
4279             return o;
4280         }
4281         if (type != OP_AASSIGN && type != OP_SASSIGN
4282          && type != OP_ENTERLOOP)
4283             goto nomod;
4284         /* Don’t bother applying lvalue context to the ex-list.  */
4285         kid = cUNOPx(cUNOPo->op_first)->op_first;
4286         assert (!OpHAS_SIBLING(kid));
4287         goto kid_2lvref;
4288     case OP_REFGEN:
4289         if (type == OP_NULL) /* local */
4290             goto local_refgen;
4291         if (type != OP_AASSIGN) goto nomod;
4292         kid = cUNOPo->op_first;
4293       kid_2lvref:
4294         {
4295             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4296             S_lvref(aTHX_ kid, type);
4297             if (!PL_parser || PL_parser->error_count == ec) {
4298                 if (!FEATURE_REFALIASING_IS_ENABLED)
4299                     Perl_croak(aTHX_
4300                        "Experimental aliasing via reference not enabled");
4301                 Perl_ck_warner_d(aTHX_
4302                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4303                                 "Aliasing via reference is experimental");
4304             }
4305         }
4306         if (o->op_type == OP_REFGEN)
4307             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4308         op_null(o);
4309         return o;
4310
4311     case OP_SPLIT:
4312         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4313             /* This is actually @array = split.  */
4314             PL_modcount = RETURN_UNLIMITED_NUMBER;
4315             break;
4316         }
4317         goto nomod;
4318
4319     case OP_SCALAR:
4320         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4321         goto nomod;
4322     }
4323
4324     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4325        their argument is a filehandle; thus \stat(".") should not set
4326        it. AMS 20011102 */
4327     if (type == OP_REFGEN &&
4328         PL_check[o->op_type] == Perl_ck_ftst)
4329         return o;
4330
4331     if (type != OP_LEAVESUBLV)
4332         o->op_flags |= OPf_MOD;
4333
4334     if (type == OP_AASSIGN || type == OP_SASSIGN)
4335         o->op_flags |= OPf_SPECIAL
4336                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4337     else if (!type) { /* local() */
4338         switch (localize) {
4339         case 1:
4340             o->op_private |= OPpLVAL_INTRO;
4341             o->op_flags &= ~OPf_SPECIAL;
4342             PL_hints |= HINT_BLOCK_SCOPE;
4343             break;
4344         case 0:
4345             break;
4346         case -1:
4347             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4348                            "Useless localization of %s", OP_DESC(o));
4349         }
4350     }
4351     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4352              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4353         o->op_flags |= OPf_REF;
4354     return o;
4355 }
4356
4357 STATIC bool
4358 S_scalar_mod_type(const OP *o, I32 type)
4359 {
4360     switch (type) {
4361     case OP_POS:
4362     case OP_SASSIGN:
4363         if (o && o->op_type == OP_RV2GV)
4364             return FALSE;
4365         /* FALLTHROUGH */
4366     case OP_PREINC:
4367     case OP_PREDEC:
4368     case OP_POSTINC:
4369     case OP_POSTDEC:
4370     case OP_I_PREINC:
4371     case OP_I_PREDEC:
4372     case OP_I_POSTINC:
4373     case OP_I_POSTDEC:
4374     case OP_POW:
4375     case OP_MULTIPLY:
4376     case OP_DIVIDE:
4377     case OP_MODULO:
4378     case OP_REPEAT:
4379     case OP_ADD:
4380     case OP_SUBTRACT:
4381     case OP_I_MULTIPLY:
4382     case OP_I_DIVIDE:
4383     case OP_I_MODULO:
4384     case OP_I_ADD:
4385     case OP_I_SUBTRACT:
4386     case OP_LEFT_SHIFT:
4387     case OP_RIGHT_SHIFT:
4388     case OP_BIT_AND:
4389     case OP_BIT_XOR:
4390     case OP_BIT_OR:
4391     case OP_NBIT_AND:
4392     case OP_NBIT_XOR:
4393     case OP_NBIT_OR:
4394     case OP_SBIT_AND:
4395     case OP_SBIT_XOR:
4396     case OP_SBIT_OR:
4397     case OP_CONCAT:
4398     case OP_SUBST:
4399     case OP_TRANS:
4400     case OP_TRANSR:
4401     case OP_READ:
4402     case OP_SYSREAD:
4403     case OP_RECV:
4404     case OP_ANDASSIGN:
4405     case OP_ORASSIGN:
4406     case OP_DORASSIGN:
4407     case OP_VEC:
4408     case OP_SUBSTR:
4409         return TRUE;
4410     default:
4411         return FALSE;
4412     }
4413 }
4414
4415 STATIC bool
4416 S_is_handle_constructor(const OP *o, I32 numargs)
4417 {
4418     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4419
4420     switch (o->op_type) {
4421     case OP_PIPE_OP:
4422     case OP_SOCKPAIR:
4423         if (numargs == 2)
4424             return TRUE;
4425         /* FALLTHROUGH */
4426     case OP_SYSOPEN:
4427     case OP_OPEN:
4428     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4429     case OP_SOCKET:
4430     case OP_OPEN_DIR:
4431     case OP_ACCEPT:
4432         if (numargs == 1)
4433             return TRUE;
4434         /* FALLTHROUGH */
4435     default:
4436         return FALSE;
4437     }
4438 }
4439
4440 static OP *
4441 S_refkids(pTHX_ OP *o, I32 type)
4442 {
4443     if (o && o->op_flags & OPf_KIDS) {
4444         OP *kid;
4445         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4446             ref(kid, type);
4447     }
4448     return o;
4449 }
4450
4451 OP *
4452 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4453 {
4454     dVAR;
4455     OP *kid;
4456
4457     PERL_ARGS_ASSERT_DOREF;
4458
4459     if (PL_parser && PL_parser->error_count)
4460         return o;
4461
4462     switch (o->op_type) {
4463     case OP_ENTERSUB:
4464         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4465             !(o->op_flags & OPf_STACKED)) {
4466             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4467             assert(cUNOPo->op_first->op_type == OP_NULL);
4468             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4469             o->op_flags |= OPf_SPECIAL;
4470         }
4471         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4472             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4473                               : type == OP_RV2HV ? OPpDEREF_HV
4474                               : OPpDEREF_SV);
4475             o->op_flags |= OPf_MOD;
4476         }
4477
4478         break;
4479
4480     case OP_COND_EXPR:
4481         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4482             doref(kid, type, set_op_ref);
4483         break;
4484     case OP_RV2SV:
4485         if (type == OP_DEFINED)
4486             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4487         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4488         /* FALLTHROUGH */
4489     case OP_PADSV:
4490         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4491             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4492                               : type == OP_RV2HV ? OPpDEREF_HV
4493                               : OPpDEREF_SV);
4494             o->op_flags |= OPf_MOD;
4495         }
4496         break;
4497
4498     case OP_RV2AV:
4499     case OP_RV2HV:
4500         if (set_op_ref)
4501             o->op_flags |= OPf_REF;
4502         /* FALLTHROUGH */
4503     case OP_RV2GV:
4504         if (type == OP_DEFINED)
4505             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4506         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4507         break;
4508
4509     case OP_PADAV:
4510     case OP_PADHV:
4511         if (set_op_ref)
4512             o->op_flags |= OPf_REF;
4513         break;
4514
4515     case OP_SCALAR:
4516     case OP_NULL:
4517         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4518             break;
4519         doref(cBINOPo->op_first, type, set_op_ref);
4520         break;
4521     case OP_AELEM:
4522     case OP_HELEM:
4523         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4524         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4525             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4526                               : type == OP_RV2HV ? OPpDEREF_HV
4527                               : OPpDEREF_SV);
4528             o->op_flags |= OPf_MOD;
4529         }
4530         break;
4531
4532     case OP_SCOPE:
4533     case OP_LEAVE:
4534         set_op_ref = FALSE;
4535         /* FALLTHROUGH */
4536     case OP_ENTER:
4537     case OP_LIST:
4538         if (!(o->op_flags & OPf_KIDS))
4539             break;
4540         doref(cLISTOPo->op_last, type, set_op_ref);
4541         break;
4542     default:
4543         break;
4544     }
4545     return scalar(o);
4546
4547 }
4548
4549 STATIC OP *
4550 S_dup_attrlist(pTHX_ OP *o)
4551 {
4552     OP *rop;
4553
4554     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4555
4556     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4557      * where the first kid is OP_PUSHMARK and the remaining ones
4558      * are OP_CONST.  We need to push the OP_CONST values.
4559      */
4560     if (o->op_type == OP_CONST)
4561         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4562     else {
4563         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4564         rop = NULL;
4565         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4566             if (o->op_type == OP_CONST)
4567                 rop = op_append_elem(OP_LIST, rop,
4568                                   newSVOP(OP_CONST, o->op_flags,
4569                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4570         }
4571     }
4572     return rop;
4573 }
4574
4575 STATIC void
4576 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4577 {
4578     PERL_ARGS_ASSERT_APPLY_ATTRS;
4579     {
4580         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4581
4582         /* fake up C<use attributes $pkg,$rv,@attrs> */
4583
4584 #define ATTRSMODULE "attributes"
4585 #define ATTRSMODULE_PM "attributes.pm"
4586
4587         Perl_load_module(
4588           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4589           newSVpvs(ATTRSMODULE),
4590           NULL,
4591           op_prepend_elem(OP_LIST,
4592                           newSVOP(OP_CONST, 0, stashsv),
4593                           op_prepend_elem(OP_LIST,
4594                                           newSVOP(OP_CONST, 0,
4595                                                   newRV(target)),
4596                                           dup_attrlist(attrs))));
4597     }
4598 }
4599
4600 STATIC void
4601 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4602 {
4603     OP *pack, *imop, *arg;
4604     SV *meth, *stashsv, **svp;
4605
4606     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4607
4608     if (!attrs)
4609         return;
4610
4611     assert(target->op_type == OP_PADSV ||
4612            target->op_type == OP_PADHV ||
4613            target->op_type == OP_PADAV);
4614
4615     /* Ensure that attributes.pm is loaded. */
4616     /* Don't force the C<use> if we don't need it. */
4617     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4618     if (svp && *svp != &PL_sv_undef)
4619         NOOP;   /* already in %INC */
4620     else
4621         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4622                                newSVpvs(ATTRSMODULE), NULL);
4623
4624     /* Need package name for method call. */
4625     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4626
4627     /* Build up the real arg-list. */
4628     stashsv = newSVhek(HvNAME_HEK(stash));
4629
4630     arg = newOP(OP_PADSV, 0);
4631     arg->op_targ = target->op_targ;
4632     arg = op_prepend_elem(OP_LIST,
4633                        newSVOP(OP_CONST, 0, stashsv),
4634                        op_prepend_elem(OP_LIST,
4635                                     newUNOP(OP_REFGEN, 0,
4636                                             arg),
4637                                     dup_attrlist(attrs)));
4638
4639     /* Fake up a method call to import */
4640     meth = newSVpvs_share("import");
4641     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4642                    op_append_elem(OP_LIST,
4643                                op_prepend_elem(OP_LIST, pack, arg),
4644                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4645
4646     /* Combine the ops. */
4647     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4648 }
4649
4650 /*
4651 =notfor apidoc apply_attrs_string
4652
4653 Attempts to apply a list of attributes specified by the C<attrstr> and
4654 C<len> arguments to the subroutine identified by the C<cv> argument which
4655 is expected to be associated with the package identified by the C<stashpv>
4656 argument (see L<attributes>).  It gets this wrong, though, in that it
4657 does not correctly identify the boundaries of the individual attribute
4658 specifications within C<attrstr>.  This is not really intended for the
4659 public API, but has to be listed here for systems such as AIX which
4660 need an explicit export list for symbols.  (It's called from XS code
4661 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4662 to respect attribute syntax properly would be welcome.
4663
4664 =cut
4665 */
4666
4667 void
4668 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4669                         const char *attrstr, STRLEN len)
4670 {
4671     OP *attrs = NULL;
4672
4673     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4674
4675     if (!len) {
4676         len = strlen(attrstr);
4677     }
4678
4679     while (len) {
4680         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4681         if (len) {
4682             const char * const sstr = attrstr;
4683             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4684             attrs = op_append_elem(OP_LIST, attrs,
4685                                 newSVOP(OP_CONST, 0,
4686                                         newSVpvn(sstr, attrstr-sstr)));
4687         }
4688     }
4689
4690     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4691                      newSVpvs(ATTRSMODULE),
4692                      NULL, op_prepend_elem(OP_LIST,
4693                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4694                                   op_prepend_elem(OP_LIST,
4695                                                newSVOP(OP_CONST, 0,
4696                                                        newRV(MUTABLE_SV(cv))),
4697                                                attrs)));
4698 }
4699
4700 STATIC void
4701 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4702                         bool curstash)
4703 {
4704     OP *new_proto = NULL;
4705     STRLEN pvlen;
4706     char *pv;
4707     OP *o;
4708
4709     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4710
4711     if (!*attrs)
4712         return;
4713
4714     o = *attrs;
4715     if (o->op_type == OP_CONST) {
4716         pv = SvPV(cSVOPo_sv, pvlen);
4717         if (memBEGINs(pv, pvlen, "prototype(")) {
4718             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4719             SV ** const tmpo = cSVOPx_svp(o);
4720             SvREFCNT_dec(cSVOPo_sv);
4721             *tmpo = tmpsv;
4722             new_proto = o;
4723             *attrs = NULL;
4724         }
4725     } else if (o->op_type == OP_LIST) {
4726         OP * lasto;
4727         assert(o->op_flags & OPf_KIDS);
4728         lasto = cLISTOPo->op_first;
4729         assert(lasto->op_type == OP_PUSHMARK);
4730         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4731             if (o->op_type == OP_CONST) {
4732                 pv = SvPV(cSVOPo_sv, pvlen);
4733                 if (memBEGINs(pv, pvlen, "prototype(")) {
4734                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4735                     SV ** const tmpo = cSVOPx_svp(o);
4736                     SvREFCNT_dec(cSVOPo_sv);
4737                     *tmpo = tmpsv;
4738                     if (new_proto && ckWARN(WARN_MISC)) {
4739                         STRLEN new_len;
4740                         const char * newp = SvPV(cSVOPo_sv, new_len);
4741                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4742                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4743                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4744                         op_free(new_proto);
4745                     }
4746                     else if (new_proto)
4747                         op_free(new_proto);
4748                     new_proto = o;
4749                     /* excise new_proto from the list */
4750                     op_sibling_splice(*attrs, lasto, 1, NULL);
4751                     o = lasto;
4752                     continue;
4753                 }
4754             }
4755             lasto = o;
4756         }
4757         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4758            would get pulled in with no real need */
4759         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4760             op_free(*attrs);
4761             *attrs = NULL;
4762         }
4763     }
4764
4765     if (new_proto) {
4766         SV *svname;
4767         if (isGV(name)) {
4768             svname = sv_newmortal();
4769             gv_efullname3(svname, name, NULL);
4770         }
4771         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4772             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4773         else
4774             svname = (SV *)name;
4775         if (ckWARN(WARN_ILLEGALPROTO))
4776             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4777                                  curstash);
4778         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4779             STRLEN old_len, new_len;
4780             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4781             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4782
4783             if (curstash && svname == (SV *)name
4784              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4785                 svname = sv_2mortal(newSVsv(PL_curstname));
4786                 sv_catpvs(svname, "::");
4787                 sv_catsv(svname, (SV *)name);
4788             }
4789
4790             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4791                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4792                 " in %" SVf,
4793                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4794                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4795                 SVfARG(svname));
4796         }
4797         if (*proto)
4798             op_free(*proto);
4799         *proto = new_proto;
4800     }
4801 }
4802
4803 static void
4804 S_cant_declare(pTHX_ OP *o)
4805 {
4806     if (o->op_type == OP_NULL
4807      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4808         o = cUNOPo->op_first;
4809     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4810                              o->op_type == OP_NULL
4811                                && o->op_flags & OPf_SPECIAL
4812                                  ? "do block"
4813                                  : OP_DESC(o),
4814                              PL_parser->in_my == KEY_our   ? "our"   :
4815                              PL_parser->in_my == KEY_state ? "state" :
4816                                                              "my"));
4817 }
4818
4819 STATIC OP *
4820 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4821 {
4822     I32 type;
4823     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4824
4825     PERL_ARGS_ASSERT_MY_KID;
4826
4827     if (!o || (PL_parser && PL_parser->error_count))
4828         return o;
4829
4830     type = o->op_type;
4831
4832     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4833         OP *kid;
4834         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4835             my_kid(kid, attrs, imopsp);
4836         return o;
4837     } else if (type == OP_UNDEF || type == OP_STUB) {
4838         return o;
4839     } else if (type == OP_RV2SV ||      /* "our" declaration */
4840                type == OP_RV2AV ||
4841                type == OP_RV2HV) {
4842         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4843             S_cant_declare(aTHX_ o);
4844         } else if (attrs) {
4845             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4846             assert(PL_parser);
4847             PL_parser->in_my = FALSE;
4848             PL_parser->in_my_stash = NULL;
4849             apply_attrs(GvSTASH(gv),
4850                         (type == OP_RV2SV ? GvSVn(gv) :
4851                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4852                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4853                         attrs);
4854         }
4855         o->op_private |= OPpOUR_INTRO;
4856         return o;
4857     }
4858     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4859         if (!FEATURE_MYREF_IS_ENABLED)
4860             Perl_croak(aTHX_ "The experimental declared_refs "
4861                              "feature is not enabled");
4862         Perl_ck_warner_d(aTHX_
4863              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4864             "Declaring references is experimental");
4865         /* Kid is a nulled OP_LIST, handled above.  */
4866         my_kid(cUNOPo->op_first, attrs, imopsp);
4867         return o;
4868     }
4869     else if (type != OP_PADSV &&
4870              type != OP_PADAV &&
4871              type != OP_PADHV &&
4872              type != OP_PUSHMARK)
4873     {
4874         S_cant_declare(aTHX_ o);
4875         return o;
4876     }
4877     else if (attrs && type != OP_PUSHMARK) {
4878         HV *stash;
4879
4880         assert(PL_parser);
4881         PL_parser->in_my = FALSE;
4882         PL_parser->in_my_stash = NULL;
4883
4884         /* check for C<my Dog $spot> when deciding package */
4885         stash = PAD_COMPNAME_TYPE(o->op_targ);
4886         if (!stash)
4887             stash = PL_curstash;
4888         apply_attrs_my(stash, o, attrs, imopsp);
4889     }
4890     o->op_flags |= OPf_MOD;
4891     o->op_private |= OPpLVAL_INTRO;
4892     if (stately)
4893         o->op_private |= OPpPAD_STATE;
4894     return o;
4895 }
4896
4897 OP *
4898 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4899 {
4900     OP *rops;
4901     int maybe_scalar = 0;
4902
4903     PERL_ARGS_ASSERT_MY_ATTRS;
4904
4905 /* [perl #17376]: this appears to be premature, and results in code such as
4906    C< our(%x); > executing in list mode rather than void mode */
4907 #if 0
4908     if (o->op_flags & OPf_PARENS)
4909         list(o);
4910     else
4911         maybe_scalar = 1;
4912 #else
4913     maybe_scalar = 1;
4914 #endif
4915     if (attrs)
4916         SAVEFREEOP(attrs);
4917     rops = NULL;
4918     o = my_kid(o, attrs, &rops);
4919     if (rops) {
4920         if (maybe_scalar && o->op_type == OP_PADSV) {
4921             o = scalar(op_append_list(OP_LIST, rops, o));
4922             o->op_private |= OPpLVAL_INTRO;
4923         }
4924         else {
4925             /* The listop in rops might have a pushmark at the beginning,
4926                which will mess up list assignment. */
4927             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4928             if (rops->op_type == OP_LIST &&
4929                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4930             {
4931                 OP * const pushmark = lrops->op_first;
4932                 /* excise pushmark */
4933                 op_sibling_splice(rops, NULL, 1, NULL);
4934                 op_free(pushmark);
4935             }
4936             o = op_append_list(OP_LIST, o, rops);
4937         }
4938     }
4939     PL_parser->in_my = FALSE;
4940     PL_parser->in_my_stash = NULL;
4941     return o;
4942 }
4943
4944 OP *
4945 Perl_sawparens(pTHX_ OP *o)
4946 {
4947     PERL_UNUSED_CONTEXT;
4948     if (o)
4949         o->op_flags |= OPf_PARENS;
4950     return o;
4951 }
4952
4953 OP *
4954 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4955 {
4956     OP *o;
4957     bool ismatchop = 0;
4958     const OPCODE ltype = left->op_type;
4959     const OPCODE rtype = right->op_type;
4960
4961     PERL_ARGS_ASSERT_BIND_MATCH;
4962
4963     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4964           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4965     {
4966       const char * const desc
4967           = PL_op_desc[(
4968                           rtype == OP_SUBST || rtype == OP_TRANS
4969                        || rtype == OP_TRANSR
4970                        )
4971                        ? (int)rtype : OP_MATCH];
4972       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4973       SV * const name =
4974         S_op_varname(aTHX_ left);
4975       if (name)
4976         Perl_warner(aTHX_ packWARN(WARN_MISC),
4977              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4978              desc, SVfARG(name), SVfARG(name));
4979       else {
4980         const char * const sample = (isary
4981              ? "@array" : "%hash");
4982         Perl_warner(aTHX_ packWARN(WARN_MISC),
4983              "Applying %s to %s will act on scalar(%s)",
4984              desc, sample, sample);
4985       }
4986     }
4987
4988     if (rtype == OP_CONST &&
4989         cSVOPx(right)->op_private & OPpCONST_BARE &&
4990         cSVOPx(right)->op_private & OPpCONST_STRICT)
4991     {
4992         no_bareword_allowed(right);
4993     }
4994
4995     /* !~ doesn't make sense with /r, so error on it for now */
4996     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4997         type == OP_NOT)
4998         /* diag_listed_as: Using !~ with %s doesn't make sense */
4999         yyerror("Using !~ with s///r doesn't make sense");
5000     if (rtype == OP_TRANSR && type == OP_NOT)
5001         /* diag_listed_as: Using !~ with %s doesn't make sense */
5002         yyerror("Using !~ with tr///r doesn't make sense");
5003
5004     ismatchop = (rtype == OP_MATCH ||
5005                  rtype == OP_SUBST ||
5006                  rtype == OP_TRANS || rtype == OP_TRANSR)
5007              && !(right->op_flags & OPf_SPECIAL);
5008     if (ismatchop && right->op_private & OPpTARGET_MY) {
5009         right->op_targ = 0;
5010         right->op_private &= ~OPpTARGET_MY;
5011     }
5012     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5013         if (left->op_type == OP_PADSV
5014          && !(left->op_private & OPpLVAL_INTRO))
5015         {
5016             right->op_targ = left->op_targ;
5017             op_free(left);
5018             o = right;
5019         }
5020         else {
5021             right->op_flags |= OPf_STACKED;
5022             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5023             ! (rtype == OP_TRANS &&
5024                right->op_private & OPpTRANS_IDENTICAL) &&
5025             ! (rtype == OP_SUBST &&
5026                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5027                 left = op_lvalue(left, rtype);
5028             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5029                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5030             else
5031                 o = op_prepend_elem(rtype, scalar(left), right);
5032         }
5033         if (type == OP_NOT)
5034             return newUNOP(OP_NOT, 0, scalar(o));
5035         return o;
5036     }
5037     else
5038         return bind_match(type, left,
5039                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5040 }
5041
5042 OP *
5043 Perl_invert(pTHX_ OP *o)
5044 {
5045     if (!o)
5046         return NULL;
5047     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5048 }
5049
5050 /*
5051 =for apidoc Amx|OP *|op_scope|OP *o
5052
5053 Wraps up an op tree with some additional ops so that at runtime a dynamic
5054 scope will be created.  The original ops run in the new dynamic scope,
5055 and then, provided that they exit normally, the scope will be unwound.
5056 The additional ops used to create and unwind the dynamic scope will
5057 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5058 instead if the ops are simple enough to not need the full dynamic scope
5059 structure.
5060
5061 =cut
5062 */
5063
5064 OP *
5065 Perl_op_scope(pTHX_ OP *o)
5066 {
5067     dVAR;
5068     if (o) {
5069         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5070             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5071             OpTYPE_set(o, OP_LEAVE);
5072         }
5073         else if (o->op_type == OP_LINESEQ) {
5074             OP *kid;
5075             OpTYPE_set(o, OP_SCOPE);
5076             kid = ((LISTOP*)o)->op_first;
5077             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5078                 op_null(kid);
5079
5080                 /* The following deals with things like 'do {1 for 1}' */
5081                 kid = OpSIBLING(kid);
5082                 if (kid &&
5083                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5084                     op_null(kid);
5085             }
5086         }
5087         else
5088             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5089     }
5090     return o;
5091 }
5092
5093 OP *
5094 Perl_op_unscope(pTHX_ OP *o)
5095 {
5096     if (o && o->op_type == OP_LINESEQ) {
5097         OP *kid = cLISTOPo->op_first;
5098         for(; kid; kid = OpSIBLING(kid))
5099             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5100                 op_null(kid);
5101     }
5102     return o;
5103 }
5104
5105 /*
5106 =for apidoc Am|int|block_start|int full
5107
5108 Handles compile-time scope entry.
5109 Arranges for hints to be restored on block
5110 exit and also handles pad sequence numbers to make lexical variables scope
5111 right.  Returns a savestack index for use with C<block_end>.
5112
5113 =cut
5114 */
5115
5116 int
5117 Perl_block_start(pTHX_ int full)
5118 {
5119     const int retval = PL_savestack_ix;
5120
5121     PL_compiling.cop_seq = PL_cop_seqmax;
5122     COP_SEQMAX_INC;
5123     pad_block_start(full);
5124     SAVEHINTS();
5125     PL_hints &= ~HINT_BLOCK_SCOPE;
5126     SAVECOMPILEWARNINGS();
5127     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5128     SAVEI32(PL_compiling.cop_seq);
5129     PL_compiling.cop_seq = 0;
5130
5131     CALL_BLOCK_HOOKS(bhk_start, full);
5132
5133     return retval;
5134 }
5135
5136 /*
5137 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5138
5139 Handles compile-time scope exit.  C<floor>
5140 is the savestack index returned by
5141 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5142 possibly modified.
5143
5144 =cut
5145 */
5146
5147 OP*
5148 Perl_block_end(pTHX_ I32 floor, OP *seq)
5149 {
5150     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5151     OP* retval = scalarseq(seq);
5152     OP *o;
5153
5154     /* XXX Is the null PL_parser check necessary here? */
5155     assert(PL_parser); /* Let’s find out under debugging builds.  */
5156     if (PL_parser && PL_parser->parsed_sub) {
5157         o = newSTATEOP(0, NULL, NULL);
5158         op_null(o);
5159         retval = op_append_elem(OP_LINESEQ, retval, o);
5160     }
5161
5162     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5163
5164     LEAVE_SCOPE(floor);
5165     if (needblockscope)
5166         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5167     o = pad_leavemy();
5168
5169     if (o) {
5170         /* pad_leavemy has created a sequence of introcv ops for all my
5171            subs declared in the block.  We have to replicate that list with
5172            clonecv ops, to deal with this situation:
5173
5174                sub {
5175                    my sub s1;
5176                    my sub s2;
5177                    sub s1 { state sub foo { \&s2 } }
5178                }->()
5179
5180            Originally, I was going to have introcv clone the CV and turn
5181            off the stale flag.  Since &s1 is declared before &s2, the
5182            introcv op for &s1 is executed (on sub entry) before the one for
5183            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5184            cloned, since it is a state sub) closes over &s2 and expects
5185            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5186            then &s2 is still marked stale.  Since &s1 is not active, and
5187            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5188            ble will not stay shared’ warning.  Because it is the same stub
5189            that will be used when the introcv op for &s2 is executed, clos-
5190            ing over it is safe.  Hence, we have to turn off the stale flag
5191            on all lexical subs in the block before we clone any of them.
5192            Hence, having introcv clone the sub cannot work.  So we create a
5193            list of ops like this:
5194
5195                lineseq
5196                   |
5197                   +-- introcv
5198                   |
5199                   +-- introcv
5200                   |
5201                   +-- introcv
5202                   |
5203                   .
5204                   .
5205                   .
5206                   |
5207                   +-- clonecv
5208                   |
5209                   +-- clonecv
5210                   |
5211                   +-- clonecv
5212                   |
5213                   .
5214                   .
5215                   .
5216          */
5217         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5218         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5219         for (;; kid = OpSIBLING(kid)) {
5220             OP *newkid = newOP(OP_CLONECV, 0);
5221             newkid->op_targ = kid->op_targ;
5222             o = op_append_elem(OP_LINESEQ, o, newkid);
5223             if (kid == last) break;
5224         }
5225         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5226     }
5227
5228     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5229
5230     return retval;
5231 }
5232
5233 /*
5234 =head1 Compile-time scope hooks
5235
5236 =for apidoc Aox||blockhook_register
5237
5238 Register a set of hooks to be called when the Perl lexical scope changes
5239 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5240
5241 =cut
5242 */
5243
5244 void
5245 Perl_blockhook_register(pTHX_ BHK *hk)
5246 {
5247     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5248
5249     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5250 }
5251
5252 void
5253 Perl_newPROG(pTHX_ OP *o)
5254 {
5255     OP *start;
5256
5257     PERL_ARGS_ASSERT_NEWPROG;
5258
5259     if (PL_in_eval) {
5260         PERL_CONTEXT *cx;
5261         I32 i;
5262         if (PL_eval_root)
5263                 return;
5264         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5265                                ((PL_in_eval & EVAL_KEEPERR)
5266                                 ? OPf_SPECIAL : 0), o);
5267
5268         cx = CX_CUR();
5269         assert(CxTYPE(cx) == CXt_EVAL);
5270
5271         if ((cx->blk_gimme & G_WANT) == G_VOID)
5272             scalarvoid(PL_eval_root);
5273         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5274             list(PL_eval_root);
5275         else
5276             scalar(PL_eval_root);
5277
5278         start = op_linklist(PL_eval_root);
5279         PL_eval_root->op_next = 0;
5280         i = PL_savestack_ix;
5281         SAVEFREEOP(o);
5282         ENTER;
5283         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5284         LEAVE;
5285         PL_savestack_ix = i;
5286     }
5287     else {
5288         if (o->op_type == OP_STUB) {
5289             /* This block is entered if nothing is compiled for the main
5290                program. This will be the case for an genuinely empty main
5291                program, or one which only has BEGIN blocks etc, so already
5292                run and freed.
5293
5294                Historically (5.000) the guard above was !o. However, commit
5295                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5296                c71fccf11fde0068, changed perly.y so that newPROG() is now
5297                called with the output of block_end(), which returns a new
5298                OP_STUB for the case of an empty optree. ByteLoader (and
5299                maybe other things) also take this path, because they set up
5300                PL_main_start and PL_main_root directly, without generating an
5301                optree.
5302
5303                If the parsing the main program aborts (due to parse errors,
5304                or due to BEGIN or similar calling exit), then newPROG()
5305                isn't even called, and hence this code path and its cleanups
5306                are skipped. This shouldn't make a make a difference:
5307                * a non-zero return from perl_parse is a failure, and
5308                  perl_destruct() should be called immediately.
5309                * however, if exit(0) is called during the parse, then
5310                  perl_parse() returns 0, and perl_run() is called. As
5311                  PL_main_start will be NULL, perl_run() will return
5312                  promptly, and the exit code will remain 0.
5313             */
5314
5315             PL_comppad_name = 0;
5316             PL_compcv = 0;
5317             S_op_destroy(aTHX_ o);
5318             return;
5319         }
5320         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5321         PL_curcop = &PL_compiling;
5322         start = LINKLIST(PL_main_root);
5323         PL_main_root->op_next = 0;
5324         S_process_optree(aTHX_ NULL, PL_main_root, start);
5325         cv_forget_slab(PL_compcv);
5326         PL_compcv = 0;
5327
5328         /* Register with debugger */
5329         if (PERLDB_INTER) {
5330             CV * const cv = get_cvs("DB::postponed", 0);
5331             if (cv) {
5332                 dSP;
5333                 PUSHMARK(SP);
5334                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5335                 PUTBACK;
5336                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5337             }
5338         }
5339     }
5340 }
5341
5342 OP *
5343 Perl_localize(pTHX_ OP *o, I32 lex)
5344 {
5345     PERL_ARGS_ASSERT_LOCALIZE;
5346
5347     if (o->op_flags & OPf_PARENS)
5348 /* [perl #17376]: this appears to be premature, and results in code such as
5349    C< our(%x); > executing in list mode rather than void mode */
5350 #if 0
5351         list(o);
5352 #else
5353         NOOP;
5354 #endif
5355     else {
5356         if ( PL_parser->bufptr > PL_parser->oldbufptr
5357             && PL_parser->bufptr[-1] == ','
5358             && ckWARN(WARN_PARENTHESIS))
5359         {
5360             char *s = PL_parser->bufptr;
5361             bool sigil = FALSE;
5362
5363             /* some heuristics to detect a potential error */
5364             while (*s && (strchr(", \t\n", *s)))
5365                 s++;
5366
5367             while (1) {
5368                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5369                        && *++s
5370                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5371                     s++;
5372                     sigil = TRUE;
5373                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5374                         s++;
5375                     while (*s && (strchr(", \t\n", *s)))
5376                         s++;
5377                 }
5378                 else
5379                     break;
5380             }
5381             if (sigil && (*s == ';' || *s == '=')) {
5382                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5383                                 "Parentheses missing around \"%s\" list",
5384                                 lex
5385                                     ? (PL_parser->in_my == KEY_our
5386                                         ? "our"
5387                                         : PL_parser->in_my == KEY_state
5388                                             ? "state"
5389                                             : "my")
5390                                     : "local");
5391             }
5392         }
5393     }
5394     if (lex)
5395         o = my(o);
5396     else
5397         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5398     PL_parser->in_my = FALSE;
5399     PL_parser->in_my_stash = NULL;
5400     return o;
5401 }
5402
5403 OP *
5404 Perl_jmaybe(pTHX_ OP *o)
5405 {
5406     PERL_ARGS_ASSERT_JMAYBE;
5407
5408     if (o->op_type == OP_LIST) {
5409         OP * const o2
5410             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5411         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5412     }
5413     return o;
5414 }
5415
5416 PERL_STATIC_INLINE OP *
5417 S_op_std_init(pTHX_ OP *o)
5418 {
5419     I32 type = o->op_type;
5420
5421     PERL_ARGS_ASSERT_OP_STD_INIT;
5422
5423     if (PL_opargs[type] & OA_RETSCALAR)
5424         scalar(o);
5425     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5426         o->op_targ = pad_alloc(type, SVs_PADTMP);
5427
5428     return o;
5429 }
5430
5431 PERL_STATIC_INLINE OP *
5432 S_op_integerize(pTHX_ OP *o)
5433 {
5434     I32 type = o->op_type;
5435
5436     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5437
5438     /* integerize op. */
5439     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5440     {
5441         dVAR;
5442         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5443     }
5444
5445     if (type == OP_NEGATE)
5446         /* XXX might want a ck_negate() for this */
5447         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5448
5449     return o;
5450 }
5451
5452 static OP *
5453 S_fold_constants(pTHX_ OP *const o)
5454 {
5455     dVAR;
5456     OP * volatile curop;
5457     OP *newop;
5458     volatile I32 type = o->op_type;
5459     bool is_stringify;
5460     SV * volatile sv = NULL;
5461     int ret = 0;
5462     OP *old_next;
5463     SV * const oldwarnhook = PL_warnhook;
5464     SV * const olddiehook  = PL_diehook;
5465     COP not_compiling;
5466     U8 oldwarn = PL_dowarn;
5467     I32 old_cxix;
5468     dJMPENV;
5469
5470     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5471
5472     if (!(PL_opargs[type] & OA_FOLDCONST))
5473         goto nope;
5474
5475     switch (type) {
5476     case OP_UCFIRST:
5477     case OP_LCFIRST:
5478     case OP_UC:
5479     case OP_LC:
5480     case OP_FC:
5481 #ifdef USE_LOCALE_CTYPE
5482         if (IN_LC_COMPILETIME(LC_CTYPE))
5483             goto nope;
5484 #endif
5485         break;
5486     case OP_SLT:
5487     case OP_SGT:
5488     case OP_SLE:
5489     case OP_SGE:
5490     case OP_SCMP:
5491 #ifdef USE_LOCALE_COLLATE
5492         if (IN_LC_COMPILETIME(LC_COLLATE))
5493             goto nope;
5494 #endif
5495         break;
5496     case OP_SPRINTF:
5497         /* XXX what about the numeric ops? */
5498 #ifdef USE_LOCALE_NUMERIC
5499         if (IN_LC_COMPILETIME(LC_NUMERIC))
5500             goto nope;
5501 #endif
5502         break;
5503     case OP_PACK:
5504         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5505           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5506             goto nope;
5507         {
5508             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5509             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5510             {
5511                 const char *s = SvPVX_const(sv);
5512                 while (s < SvEND(sv)) {
5513                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5514                     s++;
5515                 }
5516             }
5517         }
5518         break;
5519     case OP_REPEAT:
5520         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5521         break;
5522     case OP_SREFGEN:
5523         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5524          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5525             goto nope;
5526     }
5527
5528     if (PL_parser && PL_parser->error_count)
5529         goto nope;              /* Don't try to run w/ errors */
5530
5531     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5532         switch (curop->op_type) {
5533         case OP_CONST:
5534             if (   (curop->op_private & OPpCONST_BARE)
5535                 && (curop->op_private & OPpCONST_STRICT)) {
5536                 no_bareword_allowed(curop);
5537                 goto nope;
5538             }
5539             /* FALLTHROUGH */
5540         case OP_LIST:
5541         case OP_SCALAR:
5542         case OP_NULL:
5543         case OP_PUSHMARK:
5544             /* Foldable; move to next op in list */
5545             break;
5546
5547         default:
5548             /* No other op types are considered foldable */
5549             goto nope;
5550         }
5551     }
5552
5553     curop = LINKLIST(o);
5554     old_next = o->op_next;
5555     o->op_next = 0;
5556     PL_op = curop;
5557
5558     old_cxix = cxstack_ix;
5559     create_eval_scope(NULL, G_FAKINGEVAL);
5560
5561     /* Verify that we don't need to save it:  */
5562     assert(PL_curcop == &PL_compiling);
5563     StructCopy(&PL_compiling, &not_compiling, COP);
5564     PL_curcop = &not_compiling;
5565     /* The above ensures that we run with all the correct hints of the
5566        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5567     assert(IN_PERL_RUNTIME);
5568     PL_warnhook = PERL_WARNHOOK_FATAL;
5569     PL_diehook  = NULL;
5570     JMPENV_PUSH(ret);
5571
5572     /* Effective $^W=1.  */
5573     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5574         PL_dowarn |= G_WARN_ON;
5575
5576     switch (ret) {
5577     case 0:
5578         CALLRUNOPS(aTHX);
5579         sv = *(PL_stack_sp--);
5580         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5581             pad_swipe(o->op_targ,  FALSE);
5582         }
5583         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5584             SvREFCNT_inc_simple_void(sv);
5585             SvTEMP_off(sv);
5586         }
5587         else { assert(SvIMMORTAL(sv)); }
5588         break;
5589     case 3:
5590         /* Something tried to die.  Abandon constant folding.  */
5591         /* Pretend the error never happened.  */
5592         CLEAR_ERRSV();
5593         o->op_next = old_next;
5594         break;
5595     default:
5596         JMPENV_POP;
5597         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5598         PL_warnhook = oldwarnhook;
5599         PL_diehook  = olddiehook;
5600         /* XXX note that this croak may fail as we've already blown away
5601          * the stack - eg any nested evals */
5602         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5603     }
5604     JMPENV_POP;
5605     PL_dowarn   = oldwarn;
5606     PL_warnhook = oldwarnhook;
5607     PL_diehook  = olddiehook;
5608     PL_curcop = &PL_compiling;
5609
5610     /* if we croaked, depending on how we croaked the eval scope
5611      * may or may not have already been popped */
5612     if (cxstack_ix > old_cxix) {
5613         assert(cxstack_ix == old_cxix + 1);
5614         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5615         delete_eval_scope();
5616     }
5617     if (ret)
5618         goto nope;
5619
5620     /* OP_STRINGIFY and constant folding are used to implement qq.
5621        Here the constant folding is an implementation detail that we
5622        want to hide.  If the stringify op is itself already marked
5623        folded, however, then it is actually a folded join.  */
5624     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5625     op_free(o);
5626     assert(sv);
5627     if (is_stringify)
5628         SvPADTMP_off(sv);
5629     else if (!SvIMMORTAL(sv)) {
5630         SvPADTMP_on(sv);
5631         SvREADONLY_on(sv);
5632     }
5633     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5634     if (!is_stringify) newop->op_folded = 1;
5635     return newop;
5636
5637  nope:
5638     return o;
5639 }
5640
5641 static OP *
5642 S_gen_constant_list(pTHX_ OP *o)
5643 {
5644     dVAR;
5645     OP *curop, *old_next;
5646     SV * const oldwarnhook = PL_warnhook;
5647     SV * const olddiehook  = PL_diehook;
5648     COP *old_curcop;
5649     U8 oldwarn = PL_dowarn;
5650     SV **svp;
5651     AV *av;
5652     I32 old_cxix;
5653     COP not_compiling;
5654     int ret = 0;
5655     dJMPENV;
5656     bool op_was_null;
5657
5658     list(o);
5659     if (PL_parser && PL_parser->error_count)
5660         return o;               /* Don't attempt to run with errors */
5661
5662     curop = LINKLIST(o);
5663     old_next = o->op_next;
5664     o->op_next = 0;
5665     op_was_null = o->op_type == OP_NULL;
5666     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5667         o->op_type = OP_CUSTOM;
5668     CALL_PEEP(curop);
5669     if (op_was_null)
5670         o->op_type = OP_NULL;
5671     S_prune_chain_head(&curop);
5672     PL_op = curop;
5673
5674     old_cxix = cxstack_ix;
5675     create_eval_scope(NULL, G_FAKINGEVAL);
5676
5677     old_curcop = PL_curcop;
5678     StructCopy(old_curcop, &not_compiling, COP);
5679     PL_curcop = &not_compiling;
5680     /* The above ensures that we run with all the correct hints of the
5681        current COP, but that IN_PERL_RUNTIME is true. */
5682     assert(IN_PERL_RUNTIME);
5683     PL_warnhook = PERL_WARNHOOK_FATAL;
5684     PL_diehook  = NULL;
5685     JMPENV_PUSH(ret);
5686
5687     /* Effective $^W=1.  */
5688     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5689         PL_dowarn |= G_WARN_ON;
5690
5691     switch (ret) {
5692     case 0:
5693 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5694         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5695 #endif
5696         Perl_pp_pushmark(aTHX);
5697         CALLRUNOPS(aTHX);
5698         PL_op = curop;
5699         assert (!(curop->op_flags & OPf_SPECIAL));
5700         assert(curop->op_type == OP_RANGE);
5701         Perl_pp_anonlist(aTHX);
5702         break;
5703     case 3:
5704         CLEAR_ERRSV();
5705         o->op_next = old_next;
5706         break;
5707     default:
5708         JMPENV_POP;
5709         PL_warnhook = oldwarnhook;
5710         PL_diehook = olddiehook;
5711         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5712             ret);
5713     }
5714
5715     JMPENV_POP;
5716     PL_dowarn = oldwarn;
5717     PL_warnhook = oldwarnhook;
5718     PL_diehook = olddiehook;
5719     PL_curcop = old_curcop;
5720
5721     if (cxstack_ix > old_cxix) {
5722         assert(cxstack_ix == old_cxix + 1);
5723         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5724         delete_eval_scope();
5725     }
5726     if (ret)
5727         return o;
5728
5729     OpTYPE_set(o, OP_RV2AV);
5730     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5731     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5732     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5733     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5734
5735     /* replace subtree with an OP_CONST */
5736     curop = ((UNOP*)o)->op_first;
5737     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5738     op_free(curop);
5739
5740     if (AvFILLp(av) != -1)
5741         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5742         {
5743             SvPADTMP_on(*svp);
5744             SvREADONLY_on(*svp);
5745         }
5746     LINKLIST(o);
5747     return list(o);
5748 }
5749
5750 /*
5751 =head1 Optree Manipulation Functions
5752 */
5753
5754 /* List constructors */
5755
5756 /*
5757 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5758
5759 Append an item to the list of ops contained directly within a list-type
5760 op, returning the lengthened list.  C<first> is the list-type op,
5761 and C<last> is the op to append to the list.  C<optype> specifies the
5762 intended opcode for the list.  If C<first> is not already a list of the
5763 right type, it will be upgraded into one.  If either C<first> or C<last>
5764 is null, the other is returned unchanged.
5765
5766 =cut
5767 */
5768
5769 OP *
5770 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5771 {
5772     if (!first)
5773         return last;
5774
5775     if (!last)
5776         return first;
5777
5778     if (first->op_type != (unsigned)type
5779         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5780     {
5781         return newLISTOP(type, 0, first, last);
5782     }
5783
5784     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5785     first->op_flags |= OPf_KIDS;
5786     return first;
5787 }
5788
5789 /*
5790 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5791
5792 Concatenate the lists of ops contained directly within two list-type ops,
5793 returning the combined list.  C<first> and C<last> are the list-type ops
5794 to concatenate.  C<optype> specifies the intended opcode for the list.
5795 If either C<first> or C<last> is not already a list of the right type,
5796 it will be upgraded into one.  If either C<first> or C<last> is null,
5797 the other is returned unchanged.
5798
5799 =cut
5800 */
5801
5802 OP *
5803 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5804 {
5805     if (!first)
5806         return last;
5807
5808     if (!last)
5809         return first;
5810
5811     if (first->op_type != (unsigned)type)
5812         return op_prepend_elem(type, first, last);
5813
5814     if (last->op_type != (unsigned)type)
5815         return op_append_elem(type, first, last);
5816
5817     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5818     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5819     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5820     first->op_flags |= (last->op_flags & OPf_KIDS);
5821
5822     S_op_destroy(aTHX_ last);
5823
5824     return first;
5825 }
5826
5827 /*
5828 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5829
5830 Prepend an item to the list of ops contained directly within a list-type
5831 op, returning the lengthened list.  C<first> is the op to prepend to the
5832 list, and C<last> is the list-type op.  C<optype> specifies the intended
5833 opcode for the list.  If C<last> is not already a list of the right type,
5834 it will be upgraded into one.  If either C<first> or C<last> is null,
5835 the other is returned unchanged.
5836
5837 =cut
5838 */
5839
5840 OP *
5841 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5842 {
5843     if (!first)
5844         return last;
5845
5846     if (!last)
5847         return first;
5848
5849     if (last->op_type == (unsigned)type) {
5850         if (type == OP_LIST) {  /* already a PUSHMARK there */
5851             /* insert 'first' after pushmark */
5852             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5853             if (!(first->op_flags & OPf_PARENS))
5854                 last->op_flags &= ~OPf_PARENS;
5855         }
5856         else
5857             op_sibling_splice(last, NULL, 0, first);
5858         last->op_flags |= OPf_KIDS;
5859         return last;
5860     }
5861
5862     return newLISTOP(type, 0, first, last);
5863 }
5864
5865 /*
5866 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5867
5868 Converts C<o> into a list op if it is not one already, and then converts it
5869 into the specified C<type>, calling its check function, allocating a target if
5870 it needs one, and folding constants.
5871
5872 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5873 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5874 C<op_convert_list> to make it the right type.
5875
5876 =cut
5877 */
5878
5879 OP *
5880 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5881 {
5882     dVAR;
5883     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5884     if (!o || o->op_type != OP_LIST)
5885         o = force_list(o, 0);
5886     else
5887     {
5888         o->op_flags &= ~OPf_WANT;
5889         o->op_private &= ~OPpLVAL_INTRO;
5890     }
5891
5892     if (!(PL_opargs[type] & OA_MARK))
5893         op_null(cLISTOPo->op_first);
5894     else {
5895         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5896         if (kid2 && kid2->op_type == OP_COREARGS) {
5897             op_null(cLISTOPo->op_first);
5898             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5899         }
5900     }
5901
5902     if (type != OP_SPLIT)
5903         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5904          * ck_split() create a real PMOP and leave the op's type as listop
5905          * for now. Otherwise op_free() etc will crash.
5906          */
5907         OpTYPE_set(o, type);
5908
5909     o->op_flags |= flags;
5910     if (flags & OPf_FOLDED)
5911         o->op_folded = 1;
5912
5913     o = CHECKOP(type, o);
5914     if (o->op_type != (unsigned)type)
5915         return o;
5916
5917     return fold_constants(op_integerize(op_std_init(o)));
5918 }
5919
5920 /* Constructors */
5921
5922
5923 /*
5924 =head1 Optree construction
5925
5926 =for apidoc Am|OP *|newNULLLIST
5927
5928 Constructs, checks, and returns a new C<stub> op, which represents an
5929 empty list expression.
5930
5931 =cut
5932 */
5933
5934 OP *
5935 Perl_newNULLLIST(pTHX)
5936 {
5937     return newOP(OP_STUB, 0);
5938 }
5939
5940 /* promote o and any siblings to be a list if its not already; i.e.
5941  *
5942  *  o - A - B
5943  *
5944  * becomes
5945  *
5946  *  list
5947  *    |
5948  *  pushmark - o - A - B
5949  *
5950  * If nullit it true, the list op is nulled.
5951  */
5952
5953 static OP *
5954 S_force_list(pTHX_ OP *o, bool nullit)
5955 {
5956     if (!o || o->op_type != OP_LIST) {
5957         OP *rest = NULL;
5958         if (o) {
5959             /* manually detach any siblings then add them back later */
5960             rest = OpSIBLING(o);
5961             OpLASTSIB_set(o, NULL);
5962         }
5963         o = newLISTOP(OP_LIST, 0, o, NULL);
5964         if (rest)
5965             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5966     }
5967     if (nullit)
5968         op_null(o);
5969     return o;
5970 }
5971
5972 /*
5973 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5974
5975 Constructs, checks, and returns an op of any list type.  C<type> is
5976 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5977 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5978 supply up to two ops to be direct children of the list op; they are
5979 consumed by this function and become part of the constructed op tree.
5980
5981 For most list operators, the check function expects all the kid ops to be
5982 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5983 appropriate.  What you want to do in that case is create an op of type
5984 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5985 See L</op_convert_list> for more information.
5986
5987
5988 =cut
5989 */
5990
5991 OP *
5992 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5993 {
5994     dVAR;
5995     LISTOP *listop;
5996
5997     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5998         || type == OP_CUSTOM);
5999
6000     NewOp(1101, listop, 1, LISTOP);
6001
6002     OpTYPE_set(listop, type);
6003     if (first || last)
6004         flags |= OPf_KIDS;
6005     listop->op_flags = (U8)flags;
6006
6007     if (!last && first)
6008         last = first;
6009     else if (!first && last)
6010         first = last;
6011     else if (first)
6012         OpMORESIB_set(first, last);
6013     listop->op_first = first;
6014     listop->op_last = last;
6015     if (type == OP_LIST) {
6016         OP* const pushop = newOP(OP_PUSHMARK, 0);
6017         OpMORESIB_set(pushop, first);
6018         listop->op_first = pushop;
6019         listop->op_flags |= OPf_KIDS;
6020         if (!last)
6021             listop->op_last = pushop;
6022     }
6023     if (listop->op_last)
6024         OpLASTSIB_set(listop->op_last, (OP*)listop);
6025
6026     return CHECKOP(type, listop);
6027 }
6028
6029 /*
6030 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6031
6032 Constructs, checks, and returns an op of any base type (any type that
6033 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6034 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6035 of C<op_private>.
6036
6037 =cut
6038 */
6039
6040 OP *
6041 Perl_newOP(pTHX_ I32 type, I32 flags)
6042 {
6043     dVAR;
6044     OP *o;
6045
6046     if (type == -OP_ENTEREVAL) {
6047         type = OP_ENTEREVAL;
6048         flags |= OPpEVAL_BYTES<<8;
6049     }
6050
6051     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6052         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6053         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6054         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6055
6056     NewOp(1101, o, 1, OP);
6057     OpTYPE_set(o, type);
6058     o->op_flags = (U8)flags;
6059
6060     o->op_next = o;
6061     o->op_private = (U8)(0 | (flags >> 8));
6062     if (PL_opargs[type] & OA_RETSCALAR)
6063         scalar(o);
6064     if (PL_opargs[type] & OA_TARGET)
6065         o->op_targ = pad_alloc(type, SVs_PADTMP);
6066     return CHECKOP(type, o);
6067 }
6068
6069 /*
6070 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6071
6072 Constructs, checks, and returns an op of any unary type.  C<type> is
6073 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6074 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6075 bits, the eight bits of C<op_private>, except that the bit with value 1
6076 is automatically set.  C<first> supplies an optional op to be the direct
6077 child of the unary op; it is consumed by this function and become part
6078 of the constructed op tree.
6079
6080 =cut
6081 */
6082
6083 OP *
6084 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6085 {
6086     dVAR;
6087     UNOP *unop;
6088
6089     if (type == -OP_ENTEREVAL) {
6090         type = OP_ENTEREVAL;
6091         flags |= OPpEVAL_BYTES<<8;
6092     }
6093
6094     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6095         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6096         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6097         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6098         || type == OP_SASSIGN
6099         || type == OP_ENTERTRY
6100         || type == OP_CUSTOM
6101         || type == OP_NULL );
6102
6103     if (!first)
6104         first = newOP(OP_STUB, 0);
6105     if (PL_opargs[type] & OA_MARK)
6106         first = force_list(first, 1);
6107
6108     NewOp(1101, unop, 1, UNOP);
6109     OpTYPE_set(unop, type);
6110     unop->op_first = first;
6111     unop->op_flags = (U8)(flags | OPf_KIDS);
6112     unop->op_private = (U8)(1 | (flags >> 8));
6113
6114     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6115         OpLASTSIB_set(first, (OP*)unop);
6116
6117     unop = (UNOP*) CHECKOP(type, unop);
6118     if (unop->op_next)
6119         return (OP*)unop;
6120
6121     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6122 }
6123
6124 /*
6125 =for apidoc newUNOP_AUX
6126
6127 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6128 initialised to C<aux>
6129
6130 =cut
6131 */
6132
6133 OP *
6134 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6135 {
6136     dVAR;
6137     UNOP_AUX *unop;
6138
6139     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6140         || type == OP_CUSTOM);
6141
6142     NewOp(1101, unop, 1, UNOP_AUX);
6143     unop->op_type = (OPCODE)type;
6144     unop->op_ppaddr = PL_ppaddr[type];
6145     unop->op_first = first;
6146     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6147     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6148     unop->op_aux = aux;
6149
6150     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6151         OpLASTSIB_set(first, (OP*)unop);
6152
6153     unop = (UNOP_AUX*) CHECKOP(type, unop);
6154
6155     return op_std_init((OP *) unop);
6156 }
6157
6158 /*
6159 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6160
6161 Constructs, checks, and returns an op of method type with a method name
6162 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6163 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6164 and, shifted up eight bits, the eight bits of C<op_private>, except that
6165 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6166 op which evaluates method name; it is consumed by this function and
6167 become part of the constructed op tree.
6168 Supported optypes: C<OP_METHOD>.
6169
6170 =cut
6171 */
6172
6173 static OP*
6174 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6175     dVAR;
6176     METHOP *methop;
6177
6178     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6179         || type == OP_CUSTOM);
6180
6181     NewOp(1101, methop, 1, METHOP);
6182     if (dynamic_meth) {
6183         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6184         methop->op_flags = (U8)(flags | OPf_KIDS);
6185         methop->op_u.op_first = dynamic_meth;
6186         methop->op_private = (U8)(1 | (flags >> 8));
6187
6188         if (!OpHAS_SIBLING(dynamic_meth))
6189             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6190     }
6191     else {
6192         assert(const_meth);
6193         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6194         methop->op_u.op_meth_sv = const_meth;
6195         methop->op_private = (U8)(0 | (flags >> 8));
6196         methop->op_next = (OP*)methop;
6197     }
6198
6199 #ifdef USE_ITHREADS
6200     methop->op_rclass_targ = 0;
6201 #else
6202     methop->op_rclass_sv = NULL;
6203 #endif
6204
6205     OpTYPE_set(methop, type);
6206     return CHECKOP(type, methop);
6207 }
6208
6209 OP *
6210 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6211     PERL_ARGS_ASSERT_NEWMETHOP;
6212     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6213 }
6214
6215 /*
6216 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6217
6218 Constructs, checks, and returns an op of method type with a constant
6219 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6220 C<op_flags>, and, shifted up eight bits, the eight bits of
6221 C<op_private>.  C<const_meth> supplies a constant method name;
6222 it must be a shared COW string.
6223 Supported optypes: C<OP_METHOD_NAMED>.
6224
6225 =cut
6226 */
6227
6228 OP *
6229 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6230     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6231     return newMETHOP_internal(type, flags, NULL, const_meth);
6232 }
6233
6234 /*
6235 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6236
6237 Constructs, checks, and returns an op of any binary type.  C<type>
6238 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6239 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6240 the eight bits of C<op_private>, except that the bit with value 1 or
6241 2 is automatically set as required.  C<first> and C<last> supply up to
6242 two ops to be the direct children of the binary op; they are consumed
6243 by this function and become part of the constructed op tree.
6244
6245 =cut
6246 */
6247
6248 OP *
6249 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6250 {
6251     dVAR;
6252     BINOP *binop;
6253
6254     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6255         || type == OP_NULL || type == OP_CUSTOM);
6256
6257     NewOp(1101, binop, 1, BINOP);
6258
6259     if (!first)
6260         first = newOP(OP_NULL, 0);
6261
6262     OpTYPE_set(binop, type);
6263     binop->op_first = first;
6264     binop->op_flags = (U8)(flags | OPf_KIDS);
6265     if (!last) {
6266         last = first;
6267         binop->op_private = (U8)(1 | (flags >> 8));
6268     }
6269     else {
6270         binop->op_private = (U8)(2 | (flags >> 8));
6271         OpMORESIB_set(first, last);
6272     }
6273
6274     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6275         OpLASTSIB_set(last, (OP*)binop);
6276
6277     binop->op_last = OpSIBLING(binop->op_first);
6278     if (binop->op_last)
6279         OpLASTSIB_set(binop->op_last, (OP*)binop);
6280
6281     binop = (BINOP*)CHECKOP(type, binop);
6282     if (binop->op_next || binop->op_type != (OPCODE)type)
6283         return (OP*)binop;
6284
6285     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6286 }
6287
6288 static int uvcompare(const void *a, const void *b)
6289     __attribute__nonnull__(1)
6290     __attribute__nonnull__(2)
6291     __attribute__pure__;
6292 static int uvcompare(const void *a, const void *b)
6293 {
6294     if (*((const UV *)a) < (*(const UV *)b))
6295         return -1;
6296     if (*((const UV *)a) > (*(const UV *)b))
6297         return 1;
6298     if (*((const UV *)a+1) < (*(const UV *)b+1))
6299         return -1;
6300     if (*((const UV *)a+1) > (*(const UV *)b+1))
6301         return 1;
6302     return 0;
6303 }
6304
6305 static OP *
6306 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6307 {
6308     SV * const tstr = ((SVOP*)expr)->op_sv;
6309     SV * const rstr =
6310                               ((SVOP*)repl)->op_sv;
6311     STRLEN tlen;
6312     STRLEN rlen;
6313     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6314     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6315     I32 i;
6316     I32 j;
6317     I32 grows = 0;
6318     short *tbl;
6319
6320     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
6321     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
6322     I32 del              = o->op_private & OPpTRANS_DELETE;
6323     SV* swash;
6324
6325     PERL_ARGS_ASSERT_PMTRANS;
6326
6327     PL_hints |= HINT_BLOCK_SCOPE;
6328
6329     if (SvUTF8(tstr))
6330         o->op_private |= OPpTRANS_FROM_UTF;
6331
6332     if (SvUTF8(rstr))
6333         o->op_private |= OPpTRANS_TO_UTF;
6334
6335     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6336         SV* const listsv = newSVpvs("# comment\n");
6337         SV* transv = NULL;
6338         const U8* tend = t + tlen;
6339         const U8* rend = r + rlen;
6340         STRLEN ulen;
6341         UV tfirst = 1;
6342         UV tlast = 0;
6343         IV tdiff;
6344         STRLEN tcount = 0;
6345         UV rfirst = 1;
6346         UV rlast = 0;
6347         IV rdiff;
6348         STRLEN rcount = 0;
6349         IV diff;
6350         I32 none = 0;
6351         U32 max = 0;
6352         I32 bits;
6353         I32 havefinal = 0;
6354         U32 final = 0;
6355         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6356         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6357         U8* tsave = NULL;
6358         U8* rsave = NULL;
6359         const U32 flags = UTF8_ALLOW_DEFAULT;
6360
6361         if (!from_utf) {
6362             STRLEN len = tlen;
6363             t = tsave = bytes_to_utf8(t, &len);
6364             tend = t + len;
6365         }
6366         if (!to_utf && rlen) {
6367             STRLEN len = rlen;
6368             r = rsave = bytes_to_utf8(r, &len);
6369             rend = r + len;
6370         }
6371
6372 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6373  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6374  * odd.  */
6375
6376         if (complement) {
6377             U8 tmpbuf[UTF8_MAXBYTES+1];
6378             UV *cp;
6379             UV nextmin = 0;
6380             Newx(cp, 2*tlen, UV);
6381             i = 0;
6382             transv = newSVpvs("");
6383             while (t < tend) {
6384                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6385                 t += ulen;
6386                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6387                     t++;
6388                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6389                     t += ulen;
6390                 }
6391                 else {
6392                  cp[2*i+1] = cp[2*i];
6393                 }
6394                 i++;
6395             }
6396             qsort(cp, i, 2*sizeof(UV), uvcompare);
6397             for (j = 0; j < i; j++) {
6398                 UV  val = cp[2*j];
6399                 diff = val - nextmin;
6400                 if (diff > 0) {
6401                     t = uvchr_to_utf8(tmpbuf,nextmin);
6402                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6403                     if (diff > 1) {
6404                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6405                         t = uvchr_to_utf8(tmpbuf, val - 1);
6406                         sv_catpvn(transv, (char *)&range_mark, 1);
6407                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6408                     }
6409                 }
6410                 val = cp[2*j+1];
6411                 if (val >= nextmin)
6412                     nextmin = val + 1;
6413             }
6414             t = uvchr_to_utf8(tmpbuf,nextmin);
6415             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6416             {
6417                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6418                 sv_catpvn(transv, (char *)&range_mark, 1);
6419             }
6420             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6421             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6422             t = (const U8*)SvPVX_const(transv);
6423             tlen = SvCUR(transv);
6424             tend = t + tlen;
6425             Safefree(cp);
6426         }
6427         else if (!rlen && !del) {
6428             r = t; rlen = tlen; rend = tend;
6429         }
6430         if (!squash) {
6431                 if ((!rlen && !del) || t == r ||
6432                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6433                 {
6434                     o->op_private |= OPpTRANS_IDENTICAL;
6435                 }
6436         }
6437
6438         while (t < tend || tfirst <= tlast) {
6439             /* see if we need more "t" chars */
6440             if (tfirst > tlast) {
6441                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6442                 t += ulen;
6443                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6444                     t++;
6445                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6446                     t += ulen;
6447                 }
6448                 else
6449                     tlast = tfirst;
6450             }
6451
6452             /* now see if we need more "r" chars */
6453             if (rfirst > rlast) {
6454                 if (r < rend) {
6455                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6456                     r += ulen;
6457                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6458                         r++;
6459                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6460                         r += ulen;
6461                     }
6462                     else
6463                         rlast = rfirst;
6464                 }
6465                 else {
6466                     if (!havefinal++)
6467                         final = rlast;
6468                     rfirst = rlast = 0xffffffff;
6469                 }
6470             }
6471
6472             /* now see which range will peter out first, if either. */
6473             tdiff = tlast - tfirst;
6474             rdiff = rlast - rfirst;
6475             tcount += tdiff + 1;
6476             rcount += rdiff + 1;
6477
6478             if (tdiff <= rdiff)
6479                 diff = tdiff;
6480             else
6481                 diff = rdiff;
6482
6483             if (rfirst == 0xffffffff) {
6484                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6485                 if (diff > 0)
6486                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6487                                    (long)tfirst, (long)tlast);
6488                 else
6489                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6490             }
6491             else {
6492                 if (diff > 0)
6493                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6494                                    (long)tfirst, (long)(tfirst + diff),
6495                                    (long)rfirst);
6496                 else
6497                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6498                                    (long)tfirst, (long)rfirst);
6499
6500                 if (rfirst + diff > max)
6501                     max = rfirst + diff;
6502                 if (!grows)
6503                     grows = (tfirst < rfirst &&
6504                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6505                 rfirst += diff + 1;
6506             }
6507             tfirst += diff + 1;
6508         }
6509
6510         none = ++max;
6511         if (del)
6512             del = ++max;
6513
6514         if (max > 0xffff)
6515             bits = 32;
6516         else if (max > 0xff)
6517             bits = 16;
6518         else
6519             bits = 8;
6520
6521         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6522 #ifdef USE_ITHREADS
6523         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6524         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6525         PAD_SETSV(cPADOPo->op_padix, swash);
6526         SvPADTMP_on(swash);
6527         SvREADONLY_on(swash);
6528 #else
6529         cSVOPo->op_sv = swash;
6530 #endif
6531         SvREFCNT_dec(listsv);
6532         SvREFCNT_dec(transv);
6533
6534         if (!del && havefinal && rlen)
6535             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6536                            newSVuv((UV)final), 0);
6537
6538         Safefree(tsave);
6539         Safefree(rsave);
6540
6541         tlen = tcount;
6542         rlen = rcount;
6543         if (r < rend)
6544             rlen++;
6545         else if (rlast == 0xffffffff)
6546             rlen = 0;
6547
6548         goto warnins;
6549     }
6550
6551     tbl = (short*)PerlMemShared_calloc(
6552         (o->op_private & OPpTRANS_COMPLEMENT) &&
6553             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
6554         sizeof(short));
6555     cPVOPo->op_pv = (char*)tbl;
6556     if (complement) {
6557         for (i = 0; i < (I32)tlen; i++)
6558             tbl[t[i]] = -1;
6559         for (i = 0, j = 0; i < 256; i++) {
6560             if (!tbl[i]) {
6561                 if (j >= (I32)rlen) {
6562                     if (del)
6563                         tbl[i] = -2;
6564                     else if (rlen)
6565                         tbl[i] = r[j-1];
6566                     else
6567                         tbl[i] = (short)i;
6568                 }
6569                 else {
6570                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
6571                         grows = 1;
6572                     tbl[i] = r[j++];
6573                 }
6574             }
6575         }
6576         if (!del) {
6577             if (!rlen) {
6578                 j = rlen;
6579                 if (!squash)
6580                     o->op_private |= OPpTRANS_IDENTICAL;
6581             }
6582             else if (j >= (I32)rlen)
6583                 j = rlen - 1;
6584             else {
6585                 tbl =
6586                     (short *)
6587                     PerlMemShared_realloc(tbl,
6588                                           (0x101+rlen-j) * sizeof(short));
6589                 cPVOPo->op_pv = (char*)tbl;
6590             }
6591             tbl[0x100] = (short)(rlen - j);
6592             for (i=0; i < (I32)rlen - j; i++)
6593                 tbl[0x101+i] = r[j+i];
6594         }
6595     }
6596     else {
6597         if (!rlen && !del) {
6598             r = t; rlen = tlen;
6599             if (!squash)
6600                 o->op_private |= OPpTRANS_IDENTICAL;
6601         }
6602         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6603             o->op_private |= OPpTRANS_IDENTICAL;
6604         }
6605         for (i = 0; i < 256; i++)
6606             tbl[i] = -1;
6607         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
6608             if (j >= (I32)rlen) {
6609                 if (del) {
6610                     if (tbl[t[i]] == -1)
6611                         tbl[t[i]] = -2;
6612                     continue;
6613                 }
6614                 --j;
6615             }
6616             if (tbl[t[i]] == -1) {
6617                 if (     UVCHR_IS_INVARIANT(t[i])
6618                     && ! UVCHR_IS_INVARIANT(r[j]))
6619                     grows = 1;
6620                 tbl[t[i]] = r[j];
6621             }
6622         }
6623     }
6624
6625   warnins:
6626     if(del && rlen == tlen) {
6627         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6628     } else if(rlen > tlen && !complement) {
6629         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6630     }
6631
6632     if (grows)
6633         o->op_private |= OPpTRANS_GROWS;
6634     op_free(expr);
6635     op_free(repl);
6636
6637     return o;
6638 }
6639
6640 /*
6641 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6642
6643 Constructs, checks, and returns an op of any pattern matching type.
6644 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6645 and, shifted up eight bits, the eight bits of C<op_private>.
6646
6647 =cut
6648 */
6649
6650 OP *
6651 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6652 {
6653     dVAR;
6654     PMOP *pmop;
6655
6656     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6657         || type == OP_CUSTOM);
6658
6659     NewOp(1101, pmop, 1, PMOP);
6660     OpTYPE_set(pmop, type);
6661     pmop->op_flags = (U8)flags;
6662     pmop->op_private = (U8)(0 | (flags >> 8));
6663     if (PL_opargs[type] & OA_RETSCALAR)
6664         scalar((OP *)pmop);
6665
6666     if (PL_hints & HINT_RE_TAINT)
6667         pmop->op_pmflags |= PMf_RETAINT;
6668 #ifdef USE_LOCALE_CTYPE
6669     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6670         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6671     }
6672     else
6673 #endif
6674          if (IN_UNI_8_BIT) {
6675         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6676     }
6677     if (PL_hints & HINT_RE_FLAGS) {
6678         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6679          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6680         );
6681         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6682         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6683          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6684         );
6685         if (reflags && SvOK(reflags)) {
6686             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6687         }
6688     }
6689
6690
6691 #ifdef USE_ITHREADS
6692     assert(SvPOK(PL_regex_pad[0]));
6693     if (SvCUR(PL_regex_pad[0])) {
6694         /* Pop off the "packed" IV from the end.  */
6695         SV *const repointer_list = PL_regex_pad[0];
6696         const char *p = SvEND(repointer_list) - sizeof(IV);
6697         const IV offset = *((IV*)p);
6698
6699         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6700
6701         SvEND_set(repointer_list, p);
6702
6703         pmop->op_pmoffset = offset;
6704         /* This slot should be free, so assert this:  */
6705         assert(PL_regex_pad[offset] == &PL_sv_undef);
6706     } else {
6707         SV * const repointer = &PL_sv_undef;
6708         av_push(PL_regex_padav, repointer);
6709         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6710         PL_regex_pad = AvARRAY(PL_regex_padav);
6711     }
6712 #endif
6713
6714     return CHECKOP(type, pmop);
6715 }
6716
6717 static void
6718 S_set_haseval(pTHX)
6719 {
6720     PADOFFSET i = 1;
6721     PL_cv_has_eval = 1;
6722     /* Any pad names in scope are potentially lvalues.  */
6723     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6724         PADNAME *pn = PAD_COMPNAME_SV(i);
6725         if (!pn || !PadnameLEN(pn))
6726             continue;
6727         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6728             S_mark_padname_lvalue(aTHX_ pn);
6729     }
6730 }
6731
6732 /* Given some sort of match op o, and an expression expr containing a
6733  * pattern, either compile expr into a regex and attach it to o (if it's
6734  * constant), or convert expr into a runtime regcomp op sequence (if it's
6735  * not)
6736  *
6737  * Flags currently has 2 bits of meaning:
6738  * 1: isreg indicates that the pattern is part of a regex construct, eg
6739  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6740  * split "pattern", which aren't. In the former case, expr will be a list
6741  * if the pattern contains more than one term (eg /a$b/).
6742  * 2: The pattern is for a split.
6743  *
6744  * When the pattern has been compiled within a new anon CV (for
6745  * qr/(?{...})/ ), then floor indicates the savestack level just before
6746  * the new sub was created
6747  */
6748
6749 OP *
6750 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6751 {
6752     PMOP *pm;
6753     LOGOP *rcop;
6754     I32 repl_has_vars = 0;
6755     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6756     bool is_compiletime;
6757     bool has_code;
6758     bool isreg    = cBOOL(flags & 1);
6759     bool is_split = cBOOL(flags & 2);
6760
6761     PERL_ARGS_ASSERT_PMRUNTIME;
6762
6763     if (is_trans) {
6764         return pmtrans(o, expr, repl);
6765     }
6766
6767     /* find whether we have any runtime or code elements;
6768      * at the same time, temporarily set the op_next of each DO block;
6769      * then when we LINKLIST, this will cause the DO blocks to be excluded
6770      * from the op_next chain (and from having LINKLIST recursively
6771      * applied to them). We fix up the DOs specially later */
6772
6773     is_compiletime = 1;
6774     has_code = 0;
6775     if (expr->op_type == OP_LIST) {
6776         OP *o;
6777         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6778             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6779                 has_code = 1;
6780                 assert(!o->op_next);
6781                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6782                     assert(PL_parser && PL_parser->error_count);
6783                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6784                        the op we were expecting to see, to avoid crashing
6785                        elsewhere.  */
6786                     op_sibling_splice(expr, o, 0,
6787                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6788                 }
6789                 o->op_next = OpSIBLING(o);
6790             }
6791             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6792                 is_compiletime = 0;
6793         }
6794     }
6795     else if (expr->op_type != OP_CONST)
6796         is_compiletime = 0;
6797
6798     LINKLIST(expr);
6799
6800     /* fix up DO blocks; treat each one as a separate little sub;
6801      * also, mark any arrays as LIST/REF */
6802
6803     if (expr->op_type == OP_LIST) {
6804         OP *o;
6805         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6806
6807             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6808                 assert( !(o->op_flags  & OPf_WANT));
6809                 /* push the array rather than its contents. The regex
6810                  * engine will retrieve and join the elements later */
6811                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6812                 continue;
6813             }
6814
6815             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6816                 continue;
6817             o->op_next = NULL; /* undo temporary hack from above */
6818             scalar(o);
6819             LINKLIST(o);
6820             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6821                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6822                 /* skip ENTER */
6823                 assert(leaveop->op_first->op_type == OP_ENTER);
6824                 assert(OpHAS_SIBLING(leaveop->op_first));
6825                 o->op_next = OpSIBLING(leaveop->op_first);
6826                 /* skip leave */
6827                 assert(leaveop->op_flags & OPf_KIDS);
6828                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6829                 leaveop->op_next = NULL; /* stop on last op */
6830                 op_null((OP*)leaveop);
6831             }
6832             else {
6833                 /* skip SCOPE */
6834                 OP *scope = cLISTOPo->op_first;
6835                 assert(scope->op_type == OP_SCOPE);
6836                 assert(scope->op_flags & OPf_KIDS);
6837                 scope->op_next = NULL; /* stop on last op */
6838                 op_null(scope);
6839             }
6840
6841             if (is_compiletime)
6842                 /* runtime finalizes as part of finalizing whole tree */
6843                 optimize_optree(o);
6844
6845             /* have to peep the DOs individually as we've removed it from
6846              * the op_next chain */
6847             CALL_PEEP(o);
6848             S_prune_chain_head(&(o->op_next));
6849             if (is_compiletime)
6850                 /* runtime finalizes as part of finalizing whole tree */
6851                 finalize_optree(o);
6852         }
6853     }
6854     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6855         assert( !(expr->op_flags  & OPf_WANT));
6856         /* push the array rather than its contents. The regex
6857          * engine will retrieve and join the elements later */
6858         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6859     }
6860
6861     PL_hints |= HINT_BLOCK_SCOPE;
6862     pm = (PMOP*)o;
6863     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6864
6865     if (is_compiletime) {
6866         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6867         regexp_engine const *eng = current_re_engine();
6868
6869         if (is_split) {
6870             /* make engine handle split ' ' specially */
6871             pm->op_pmflags |= PMf_SPLIT;
6872             rx_flags |= RXf_SPLIT;
6873         }
6874
6875         /* Skip compiling if parser found an error for this pattern */
6876         if (pm->op_pmflags & PMf_HAS_ERROR) {
6877             return o;
6878         }
6879
6880         if (!has_code || !eng->op_comp) {
6881             /* compile-time simple constant pattern */
6882
6883             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
6884                 /* whoops! we guessed that a qr// had a code block, but we
6885                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
6886                  * that isn't required now. Note that we have to be pretty
6887                  * confident that nothing used that CV's pad while the
6888                  * regex was parsed, except maybe op targets for \Q etc.
6889                  * If there were any op targets, though, they should have
6890                  * been stolen by constant folding.
6891                  */
6892 #ifdef DEBUGGING
6893                 SSize_t i = 0;
6894                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
6895                 while (++i <= AvFILLp(PL_comppad)) {
6896 #  ifdef USE_PAD_RESET
6897                     /* under USE_PAD_RESET, pad swipe replaces a swiped
6898                      * folded constant with a fresh padtmp */
6899                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
6900 #  else
6901                     assert(!PL_curpad[i]);
6902 #  endif
6903                 }
6904 #endif
6905                 /* But we know that one op is using this CV's slab. */
6906                 cv_forget_slab(PL_compcv);
6907                 LEAVE_SCOPE(floor);
6908                 pm->op_pmflags &= ~PMf_HAS_CV;
6909             }
6910
6911             PM_SETRE(pm,
6912                 eng->op_comp
6913                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6914                                         rx_flags, pm->op_pmflags)
6915                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6916                                         rx_flags, pm->op_pmflags)
6917             );
6918             op_free(expr);
6919         }
6920         else {
6921             /* compile-time pattern that includes literal code blocks */
6922             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
6923                         rx_flags,
6924                         (pm->op_pmflags |
6925                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
6926                     );
6927             PM_SETRE(pm, re);
6928             if (pm->op_pmflags & PMf_HAS_CV) {
6929                 CV *cv;
6930                 /* this QR op (and the anon sub we embed it in) is never
6931                  * actually executed. It's just a placeholder where we can
6932                  * squirrel away expr in op_code_list without the peephole
6933                  * optimiser etc processing it for a second time */
6934                 OP *qr = newPMOP(OP_QR, 0);
6935                 ((PMOP*)qr)->op_code_list = expr;
6936
6937                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
6938                 SvREFCNT_inc_simple_void(PL_compcv);
6939                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
6940                 ReANY(re)->qr_anoncv = cv;
6941
6942                 /* attach the anon CV to the pad so that
6943                  * pad_fixup_inner_anons() can find it */
6944                 (void)pad_add_anon(cv, o->op_type);
6945                 SvREFCNT_inc_simple_void(cv);
6946             }
6947             else {
6948                 pm->op_code_list = expr;
6949             }
6950         }
6951     }
6952     else {
6953         /* runtime pattern: build chain of regcomp etc ops */
6954         bool reglist;
6955         PADOFFSET cv_targ = 0;
6956
6957         reglist = isreg && expr->op_type == OP_LIST;
6958         if (reglist)
6959             op_null(expr);
6960
6961         if (has_code) {
6962             pm->op_code_list = expr;
6963             /* don't free op_code_list; its ops are embedded elsewhere too */
6964             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
6965         }
6966
6967         if (is_split)
6968             /* make engine handle split ' ' specially */
6969             pm->op_pmflags |= PMf_SPLIT;
6970
6971         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
6972          * to allow its op_next to be pointed past the regcomp and
6973          * preceding stacking ops;
6974          * OP_REGCRESET is there to reset taint before executing the
6975          * stacking ops */
6976         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
6977             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
6978
6979         if (pm->op_pmflags & PMf_HAS_CV) {
6980             /* we have a runtime qr with literal code. This means
6981              * that the qr// has been wrapped in a new CV, which
6982              * means that runtime consts, vars etc will have been compiled
6983              * against a new pad. So... we need to execute those ops
6984              * within the environment of the new CV. So wrap them in a call
6985              * to a new anon sub. i.e. for
6986              *
6987              *     qr/a$b(?{...})/,
6988              *
6989              * we build an anon sub that looks like
6990              *
6991              *     sub { "a", $b, '(?{...})' }
6992              *
6993              * and call it, passing the returned list to regcomp.
6994              * Or to put it another way, the list of ops that get executed
6995              * are:
6996              *
6997              *     normal              PMf_HAS_CV
6998              *     ------              -------------------
6999              *                         pushmark (for regcomp)
7000              *                         pushmark (for entersub)
7001              *                         anoncode
7002              *                         srefgen
7003              *                         entersub
7004              *     regcreset                  regcreset
7005              *     pushmark                   pushmark
7006              *     const("a")                 const("a")
7007              *     gvsv(b)                    gvsv(b)
7008              *     const("(?{...})")          const("(?{...})")
7009              *                                leavesub
7010              *     regcomp             regcomp
7011              */
7012
7013             SvREFCNT_inc_simple_void(PL_compcv);
7014             CvLVALUE_on(PL_compcv);
7015             /* these lines are just an unrolled newANONATTRSUB */
7016             expr = newSVOP(OP_ANONCODE, 0,
7017                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7018             cv_targ = expr->op_targ;
7019             expr = newUNOP(OP_REFGEN, 0, expr);
7020
7021             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7022         }
7023
7024         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7025         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7026                            | (reglist ? OPf_STACKED : 0);
7027         rcop->op_targ = cv_targ;
7028
7029         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7030         if (PL_hints & HINT_RE_EVAL)
7031             S_set_haseval(aTHX);
7032
7033         /* establish postfix order */
7034         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7035             LINKLIST(expr);
7036             rcop->op_next = expr;
7037             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7038         }
7039         else {
7040             rcop->op_next = LINKLIST(expr);
7041             expr->op_next = (OP*)rcop;
7042         }
7043
7044         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7045     }
7046
7047     if (repl) {
7048         OP *curop = repl;
7049         bool konst;
7050         /* If we are looking at s//.../e with a single statement, get past
7051            the implicit do{}. */
7052         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7053              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7054              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7055          {
7056             OP *sib;
7057             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7058             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7059              && !OpHAS_SIBLING(sib))
7060                 curop = sib;
7061         }
7062         if (curop->op_type == OP_CONST)
7063             konst = TRUE;
7064         else if (( (curop->op_type == OP_RV2SV ||
7065                     curop->op_type == OP_RV2AV ||
7066                     curop->op_type == OP_RV2HV ||
7067                     curop->op_type == OP_RV2GV)
7068                    && cUNOPx(curop)->op_first
7069                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7070                 || curop->op_type == OP_PADSV
7071                 || curop->op_type == OP_PADAV
7072                 || curop->op_type == OP_PADHV
7073                 || curop->op_type == OP_PADANY) {
7074             repl_has_vars = 1;
7075             konst = TRUE;
7076         }
7077         else konst = FALSE;
7078         if (konst
7079             && !(repl_has_vars
7080                  && (!PM_GETRE(pm)
7081                      || !RX_PRELEN(PM_GETRE(pm))
7082                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7083         {
7084             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7085             op_prepend_elem(o->op_type, scalar(repl), o);
7086         }
7087         else {
7088             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7089             rcop->op_private = 1;
7090
7091             /* establish postfix order */
7092             rcop->op_next = LINKLIST(repl);
7093             repl->op_next = (OP*)rcop;
7094
7095             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7096             assert(!(pm->op_pmflags & PMf_ONCE));
7097             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7098             rcop->op_next = 0;
7099         }
7100     }
7101
7102     return (OP*)pm;
7103 }
7104
7105 /*
7106 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7107
7108 Constructs, checks, and returns an op of any type that involves an
7109 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7110 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7111 takes ownership of one reference to it.
7112
7113 =cut
7114 */
7115
7116 OP *
7117 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7118 {
7119     dVAR;
7120     SVOP *svop;
7121
7122     PERL_ARGS_ASSERT_NEWSVOP;
7123
7124     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7125         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7126         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7127         || type == OP_CUSTOM);
7128
7129     NewOp(1101, svop, 1, SVOP);
7130     OpTYPE_set(svop, type);
7131     svop->op_sv = sv;
7132     svop->op_next = (OP*)svop;
7133     svop->op_flags = (U8)flags;
7134     svop->op_private = (U8)(0 | (flags >> 8));
7135     if (PL_opargs[type] & OA_RETSCALAR)
7136         scalar((OP*)svop);
7137     if (PL_opargs[type] & OA_TARGET)
7138         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7139     return CHECKOP(type, svop);
7140 }
7141
7142 /*
7143 =for apidoc Am|OP *|newDEFSVOP|
7144
7145 Constructs and returns an op to access C<$_>.
7146
7147 =cut
7148 */
7149
7150 OP *
7151 Perl_newDEFSVOP(pTHX)
7152 {
7153         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7154 }
7155
7156 #ifdef USE_ITHREADS
7157
7158 /*
7159 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7160
7161 Constructs, checks, and returns an op of any type that involves a
7162 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7163 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7164 is populated with C<sv>; this function takes ownership of one reference
7165 to it.
7166
7167 This function only exists if Perl has been compiled to use ithreads.
7168
7169 =cut
7170 */
7171
7172 OP *
7173 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7174 {
7175     dVAR;
7176     PADOP *padop;
7177
7178     PERL_ARGS_ASSERT_NEWPADOP;
7179
7180     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7181         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7182         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7183         || type == OP_CUSTOM);
7184
7185     NewOp(1101, padop, 1, PADOP);
7186     OpTYPE_set(padop, type);
7187     padop->op_padix =
7188         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7189     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7190     PAD_SETSV(padop->op_padix, sv);
7191     assert(sv);
7192     padop->op_next = (OP*)padop;
7193     padop->op_flags = (U8)flags;
7194     if (PL_opargs[type] & OA_RETSCALAR)
7195         scalar((OP*)padop);
7196     if (PL_opargs[type] & OA_TARGET)
7197         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7198     return CHECKOP(type, padop);
7199 }
7200
7201 #endif /* USE_ITHREADS */
7202
7203 /*
7204 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7205
7206 Constructs, checks, and returns an op of any type that involves an
7207 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7208 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7209 reference; calling this function does not transfer ownership of any
7210 reference to it.
7211
7212 =cut
7213 */
7214
7215 OP *
7216 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7217 {
7218     PERL_ARGS_ASSERT_NEWGVOP;
7219
7220 #ifdef USE_ITHREADS
7221     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7222 #else
7223     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7224 #endif
7225 }
7226
7227 /*
7228 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7229
7230 Constructs, checks, and returns an op of any type that involves an
7231 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7232 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7233 Depending on the op type, the memory referenced by C<pv> may be freed
7234 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7235 have been allocated using C<PerlMemShared_malloc>.
7236
7237 =cut
7238 */
7239
7240 OP *
7241 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7242 {
7243     dVAR;
7244     const bool utf8 = cBOOL(flags & SVf_UTF8);
7245     PVOP *pvop;
7246
7247     flags &= ~SVf_UTF8;
7248
7249     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7250         || type == OP_RUNCV || type == OP_CUSTOM
7251         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7252
7253     NewOp(1101, pvop, 1, PVOP);
7254     OpTYPE_set(pvop, type);
7255     pvop->op_pv = pv;
7256     pvop->op_next = (OP*)pvop;
7257     pvop->op_flags = (U8)flags;
7258     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7259     if (PL_opargs[type] & OA_RETSCALAR)
7260         scalar((OP*)pvop);
7261     if (PL_opargs[type] & OA_TARGET)
7262         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7263     return CHECKOP(type, pvop);
7264 }
7265
7266 void
7267 Perl_package(pTHX_ OP *o)
7268 {
7269     SV *const sv = cSVOPo->op_sv;
7270
7271     PERL_ARGS_ASSERT_PACKAGE;
7272
7273     SAVEGENERICSV(PL_curstash);
7274     save_item(PL_curstname);
7275
7276     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7277
7278     sv_setsv(PL_curstname, sv);
7279
7280     PL_hints |= HINT_BLOCK_SCOPE;
7281     PL_parser->copline = NOLINE;
7282
7283     op_free(o);
7284 }
7285
7286 void
7287 Perl_package_version( pTHX_ OP *v )
7288 {
7289     U32 savehints = PL_hints;
7290     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7291     PL_hints &= ~HINT_STRICT_VARS;
7292     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7293     PL_hints = savehints;
7294     op_free(v);
7295 }
7296
7297 void
7298 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7299 {
7300     OP *pack;
7301     OP *imop;
7302     OP *veop;
7303     SV *use_version = NULL;
7304
7305     PERL_ARGS_ASSERT_UTILIZE;
7306
7307     if (idop->op_type != OP_CONST)
7308         Perl_croak(aTHX_ "Module name must be constant");
7309
7310     veop = NULL;
7311
7312     if (version) {
7313         SV * const vesv = ((SVOP*)version)->op_sv;
7314
7315         if (!arg && !SvNIOKp(vesv)) {
7316             arg = version;
7317         }
7318         else {
7319             OP *pack;
7320             SV *meth;
7321
7322             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7323                 Perl_croak(aTHX_ "Version number must be a constant number");
7324
7325             /* Make copy of idop so we don't free it twice */
7326             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7327
7328             /* Fake up a method call to VERSION */
7329             meth = newSVpvs_share("VERSION");
7330             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7331                             op_append_elem(OP_LIST,
7332                                         op_prepend_elem(OP_LIST, pack, version),
7333                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7334         }
7335     }
7336
7337     /* Fake up an import/unimport */
7338     if (arg && arg->op_type == OP_STUB) {
7339         imop = arg;             /* no import on explicit () */
7340     }
7341     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7342         imop = NULL;            /* use 5.0; */
7343         if (aver)
7344             use_version = ((SVOP*)idop)->op_sv;
7345         else
7346             idop->op_private |= OPpCONST_NOVER;
7347     }
7348     else {
7349         SV *meth;
7350
7351         /* Make copy of idop so we don't free it twice */
7352         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7353
7354         /* Fake up a method call to import/unimport */
7355         meth = aver
7356             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7357         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7358                        op_append_elem(OP_LIST,
7359                                    op_prepend_elem(OP_LIST, pack, arg),
7360                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7361                        ));
7362     }
7363
7364     /* Fake up the BEGIN {}, which does its thing immediately. */
7365     newATTRSUB(floor,
7366         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7367         NULL,
7368         NULL,
7369         op_append_elem(OP_LINESEQ,
7370             op_append_elem(OP_LINESEQ,
7371                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7372                 newSTATEOP(0, NULL, veop)),
7373             newSTATEOP(0, NULL, imop) ));
7374
7375     if (use_version) {
7376         /* Enable the
7377          * feature bundle that corresponds to the required version. */
7378         use_version = sv_2mortal(new_version(use_version));
7379         S_enable_feature_bundle(aTHX_ use_version);
7380
7381         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7382         if (vcmp(use_version,
7383                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7384             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7385                 PL_hints |= HINT_STRICT_REFS;
7386             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7387                 PL_hints |= HINT_STRICT_SUBS;
7388             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7389                 PL_hints |= HINT_STRICT_VARS;
7390         }
7391         /* otherwise they are off */
7392         else {
7393             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7394                 PL_hints &= ~HINT_STRICT_REFS;
7395             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7396                 PL_hints &= ~HINT_STRICT_SUBS;
7397             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7398                 PL_hints &= ~HINT_STRICT_VARS;
7399         }
7400     }
7401
7402     /* The "did you use incorrect case?" warning used to be here.
7403      * The problem is that on case-insensitive filesystems one
7404      * might get false positives for "use" (and "require"):
7405      * "use Strict" or "require CARP" will work.  This causes
7406      * portability problems for the script: in case-strict
7407      * filesystems the script will stop working.
7408      *
7409      * The "incorrect case" warning checked whether "use Foo"
7410      * imported "Foo" to your namespace, but that is wrong, too:
7411      * there is no requirement nor promise in the language that
7412      * a Foo.pm should or would contain anything in package "Foo".
7413      *
7414      * There is very little Configure-wise that can be done, either:
7415      * the case-sensitivity of the build filesystem of Perl does not
7416      * help in guessing the case-sensitivity of the runtime environment.
7417      */
7418
7419     PL_hints |= HINT_BLOCK_SCOPE;
7420     PL_parser->copline = NOLINE;
7421     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7422 }
7423
7424 /*
7425 =head1 Embedding Functions
7426
7427 =for apidoc load_module
7428
7429 Loads the module whose name is pointed to by the string part of C<name>.
7430 Note that the actual module name, not its filename, should be given.
7431 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7432 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7433 trailing arguments can be used to specify arguments to the module's C<import()>
7434 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7435 on the flags. The flags argument is a bitwise-ORed collection of any of
7436 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7437 (or 0 for no flags).
7438
7439 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7440 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7441 the trailing optional arguments may be omitted entirely. Otherwise, if
7442 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7443 exactly one C<OP*>, containing the op tree that produces the relevant import
7444 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7445 will be used as import arguments; and the list must be terminated with C<(SV*)
7446 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7447 set, the trailing C<NULL> pointer is needed even if no import arguments are
7448 desired. The reference count for each specified C<SV*> argument is
7449 decremented. In addition, the C<name> argument is modified.
7450
7451 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7452 than C<use>.
7453
7454 =cut */
7455
7456 void
7457 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7458 {
7459     va_list args;
7460
7461     PERL_ARGS_ASSERT_LOAD_MODULE;
7462
7463     va_start(args, ver);
7464     vload_module(flags, name, ver, &args);
7465     va_end(args);
7466 }
7467
7468 #ifdef PERL_IMPLICIT_CONTEXT
7469 void
7470 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7471 {
7472     dTHX;
7473     va_list args;
7474     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7475     va_start(args, ver);
7476     vload_module(flags, name, ver, &args);
7477     va_end(args);
7478 }
7479 #endif
7480
7481 void
7482 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7483 {
7484     OP *veop, *imop;
7485     OP * const modname = newSVOP(OP_CONST, 0, name);
7486
7487     PERL_ARGS_ASSERT_VLOAD_MODULE;
7488
7489     modname->op_private |= OPpCONST_BARE;
7490     if (ver) {
7491         veop = newSVOP(OP_CONST, 0, ver);
7492     }
7493     else
7494         veop = NULL;
7495     if (flags & PERL_LOADMOD_NOIMPORT) {
7496         imop = sawparens(newNULLLIST());
7497     }
7498     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7499         imop = va_arg(*args, OP*);
7500     }
7501     else {
7502         SV *sv;
7503         imop = NULL;
7504         sv = va_arg(*args, SV*);
7505         while (sv) {
7506             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7507             sv = va_arg(*args, SV*);
7508         }
7509     }
7510
7511     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7512      * that it has a PL_parser to play with while doing that, and also
7513      * that it doesn't mess with any existing parser, by creating a tmp
7514      * new parser with lex_start(). This won't actually be used for much,
7515      * since pp_require() will create another parser for the real work.
7516      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7517
7518     ENTER;
7519     SAVEVPTR(PL_curcop);
7520     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7521     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7522             veop, modname, imop);
7523     LEAVE;
7524 }
7525
7526 PERL_STATIC_INLINE OP *
7527 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7528 {
7529     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7530                    newLISTOP(OP_LIST, 0, arg,
7531                              newUNOP(OP_RV2CV, 0,
7532                                      newGVOP(OP_GV, 0, gv))));
7533 }
7534
7535 OP *
7536 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7537 {
7538     OP *doop;
7539     GV *gv;
7540
7541     PERL_ARGS_ASSERT_DOFILE;
7542
7543     if (!force_builtin && (gv = gv_override("do", 2))) {
7544         doop = S_new_entersubop(aTHX_ gv, term);
7545     }
7546     else {
7547         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7548     }
7549     return doop;
7550 }
7551
7552 /*
7553 =head1 Optree construction
7554
7555 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7556
7557 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7558 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7559 be set automatically, and, shifted up eight bits, the eight bits of
7560 C<op_private>, except that the bit with value 1 or 2 is automatically
7561 set as required.  C<listval> and C<subscript> supply the parameters of
7562 the slice; they are consumed by this function and become part of the
7563 constructed op tree.
7564
7565 =cut
7566 */
7567
7568 OP *
7569 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7570 {
7571     return newBINOP(OP_LSLICE, flags,
7572             list(force_list(subscript, 1)),
7573             list(force_list(listval,   1)) );
7574 }
7575
7576 #define ASSIGN_LIST   1
7577 #define ASSIGN_REF    2
7578
7579 STATIC I32
7580 S_assignment_type(pTHX_ const OP *o)
7581 {
7582     unsigned type;
7583     U8 flags;
7584     U8 ret;
7585
7586     if (!o)
7587         return TRUE;
7588
7589     if (o->op_type == OP_SREFGEN)
7590     {
7591         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7592         type = kid->op_type;
7593         flags = o->op_flags | kid->op_flags;
7594         if (!(flags & OPf_PARENS)
7595           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7596               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7597             return ASSIGN_REF;
7598         ret = ASSIGN_REF;
7599     } else {
7600         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7601             o = cUNOPo->op_first;
7602         flags = o->op_flags;
7603         type = o->op_type;
7604         ret = 0;
7605     }
7606
7607     if (type == OP_COND_EXPR) {
7608         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7609         const I32 t = assignment_type(sib);
7610         const I32 f = assignment_type(OpSIBLING(sib));
7611
7612         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7613             return ASSIGN_LIST;
7614         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7615             yyerror("Assignment to both a list and a scalar");
7616         return FALSE;
7617     }
7618
7619     if (type == OP_LIST &&
7620         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7621         o->op_private & OPpLVAL_INTRO)
7622         return ret;
7623
7624     if (type == OP_LIST || flags & OPf_PARENS ||
7625         type == OP_RV2AV || type == OP_RV2HV ||
7626         type == OP_ASLICE || type == OP_HSLICE ||
7627         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7628         return TRUE;
7629
7630     if (type == OP_PADAV || type == OP_PADHV)
7631         return TRUE;
7632
7633     if (type == OP_RV2SV)
7634         return ret;
7635
7636     return ret;
7637 }
7638
7639 static OP *
7640 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7641 {
7642     const PADOFFSET target = padop->op_targ;
7643     OP *const other = newOP(OP_PADSV,
7644                             padop->op_flags
7645                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7646     OP *const first = newOP(OP_NULL, 0);
7647     OP *const nullop = newCONDOP(0, first, initop, other);
7648     /* XXX targlex disabled for now; see ticket #124160
7649         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7650      */
7651     OP *const condop = first->op_next;
7652
7653     OpTYPE_set(condop, OP_ONCE);
7654     other->op_targ = target;
7655     nullop->op_flags |= OPf_WANT_SCALAR;
7656
7657     /* Store the initializedness of state vars in a separate
7658        pad entry.  */
7659     condop->op_targ =
7660       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7661     /* hijacking PADSTALE for uninitialized state variables */
7662     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7663
7664     return nullop;
7665 }
7666
7667 /*
7668 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7669
7670 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7671 supply the parameters of the assignment; they are consumed by this
7672 function and become part of the constructed op tree.
7673
7674 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7675 a suitable conditional optree is constructed.  If C<optype> is the opcode
7676 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7677 performs the binary operation and assigns the result to the left argument.
7678 Either way, if C<optype> is non-zero then C<flags> has no effect.
7679
7680 If C<optype> is zero, then a plain scalar or list assignment is
7681 constructed.  Which type of assignment it is is automatically determined.
7682 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7683 will be set automatically, and, shifted up eight bits, the eight bits
7684 of C<op_private>, except that the bit with value 1 or 2 is automatically
7685 set as required.
7686
7687 =cut
7688 */
7689
7690 OP *
7691 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7692 {
7693     OP *o;
7694     I32 assign_type;
7695
7696     if (optype) {
7697         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7698             right = scalar(right);
7699             return newLOGOP(optype, 0,
7700                 op_lvalue(scalar(left), optype),
7701                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7702         }
7703         else {
7704             return newBINOP(optype, OPf_STACKED,
7705                 op_lvalue(scalar(left), optype), scalar(right));
7706         }
7707     }
7708
7709     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7710         OP *state_var_op = NULL;
7711         static const char no_list_state[] = "Initialization of state variables"
7712             " in list currently forbidden";
7713         OP *curop;
7714
7715         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7716             left->op_private &= ~ OPpSLICEWARNING;
7717
7718         PL_modcount = 0;
7719         left = op_lvalue(left, OP_AASSIGN);
7720         curop = list(force_list(left, 1));
7721         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7722         o->op_private = (U8)(0 | (flags >> 8));
7723
7724         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7725         {
7726             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7727             if (!(left->op_flags & OPf_PARENS) &&
7728                     lop->op_type == OP_PUSHMARK &&
7729                     (vop = OpSIBLING(lop)) &&
7730                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7731                     !(vop->op_flags & OPf_PARENS) &&
7732                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7733                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7734                     (eop = OpSIBLING(vop)) &&
7735                     eop->op_type == OP_ENTERSUB &&
7736                     !OpHAS_SIBLING(eop)) {
7737                 state_var_op = vop;
7738             } else {
7739                 while (lop) {
7740                     if ((lop->op_type == OP_PADSV ||
7741                          lop->op_type == OP_PADAV ||
7742                          lop->op_type == OP_PADHV ||
7743                          lop->op_type == OP_PADANY)
7744                       && (lop->op_private & OPpPAD_STATE)
7745                     )
7746                         yyerror(no_list_state);
7747                     lop = OpSIBLING(lop);
7748                 }
7749             }
7750         }
7751         else if (  (left->op_private & OPpLVAL_INTRO)
7752                 && (left->op_private & OPpPAD_STATE)
7753                 && (   left->op_type == OP_PADSV
7754                     || left->op_type == OP_PADAV
7755                     || left->op_type == OP_PADHV
7756                     || left->op_type == OP_PADANY)
7757         ) {
7758                 /* All single variable list context state assignments, hence
7759                    state ($a) = ...
7760                    (state $a) = ...
7761                    state @a = ...
7762                    state (@a) = ...
7763                    (state @a) = ...
7764                    state %a = ...
7765                    state (%a) = ...
7766                    (state %a) = ...
7767                 */
7768                 if (left->op_flags & OPf_PARENS)
7769                     yyerror(no_list_state);
7770                 else
7771                     state_var_op = left;
7772         }
7773
7774         /* optimise @a = split(...) into:
7775         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7776         * @a, my @a, local @a:  split(...)          (where @a is attached to
7777         *                                            the split op itself)
7778         */
7779
7780         if (   right
7781             && right->op_type == OP_SPLIT
7782             /* don't do twice, e.g. @b = (@a = split) */
7783             && !(right->op_private & OPpSPLIT_ASSIGN))
7784         {
7785             OP *gvop = NULL;
7786
7787             if (   (  left->op_type == OP_RV2AV
7788                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7789                 || left->op_type == OP_PADAV)
7790             {
7791                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7792                 OP *tmpop;
7793                 if (gvop) {
7794 #ifdef USE_ITHREADS
7795                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7796                         = cPADOPx(gvop)->op_padix;
7797                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7798 #else
7799                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7800                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7801                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7802 #endif
7803                     right->op_private |=
7804                         left->op_private & OPpOUR_INTRO;
7805                 }
7806                 else {
7807                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7808                     left->op_targ = 0;  /* steal it */
7809                     right->op_private |= OPpSPLIT_LEX;
7810                 }
7811                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7812
7813               detach_split:
7814                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7815                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7816                 assert(OpSIBLING(tmpop) == right);
7817                 assert(!OpHAS_SIBLING(right));
7818                 /* detach the split subtreee from the o tree,
7819                  * then free the residual o tree */
7820                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7821                 op_free(o);                     /* blow off assign */
7822                 right->op_private |= OPpSPLIT_ASSIGN;
7823                 right->op_flags &= ~OPf_WANT;
7824                         /* "I don't know and I don't care." */
7825                 return right;
7826             }
7827             else if (left->op_type == OP_RV2AV) {
7828                 /* @{expr} */
7829
7830                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7831                 assert(OpSIBLING(pushop) == left);
7832                 /* Detach the array ...  */
7833                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7834                 /* ... and attach it to the split.  */
7835                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7836                                   0, left);
7837                 right->op_flags |= OPf_STACKED;
7838                 /* Detach split and expunge aassign as above.  */
7839                 goto detach_split;
7840             }
7841             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7842                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
7843             {
7844                 /* convert split(...,0) to split(..., PL_modcount+1) */
7845                 SV ** const svp =
7846                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7847                 SV * const sv = *svp;
7848                 if (SvIOK(sv) && SvIVX(sv) == 0)
7849                 {
7850                   if (right->op_private & OPpSPLIT_IMPLIM) {
7851                     /* our own SV, created in ck_split */
7852                     SvREADONLY_off(sv);
7853                     sv_setiv(sv, PL_modcount+1);
7854                   }
7855                   else {
7856                     /* SV may belong to someone else */
7857                     SvREFCNT_dec(sv);
7858                     *svp = newSViv(PL_modcount+1);
7859                   }
7860                 }
7861             }
7862         }
7863
7864         if (state_var_op)
7865             o = S_newONCEOP(aTHX_ o, state_var_op);
7866         return o;
7867     }
7868     if (assign_type == ASSIGN_REF)
7869         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7870     if (!right)
7871         right = newOP(OP_UNDEF, 0);
7872     if (right->op_type == OP_READLINE) {
7873         right->op_flags |= OPf_STACKED;
7874         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7875                 scalar(right));
7876     }
7877     else {
7878         o = newBINOP(OP_SASSIGN, flags,
7879             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
7880     }
7881     return o;
7882 }
7883
7884 /*
7885 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
7886
7887 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
7888 but will be a C<dbstate> op if debugging is enabled for currently-compiled
7889 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
7890 If C<label> is non-null, it supplies the name of a label to attach to
7891 the state op; this function takes ownership of the memory pointed at by
7892 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
7893 for the state op.
7894
7895 If C<o> is null, the state op is returned.  Otherwise the state op is
7896 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
7897 is consumed by this function and becomes part of the returned op tree.
7898
7899 =cut
7900 */
7901
7902 OP *
7903 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
7904 {
7905     dVAR;
7906     const U32 seq = intro_my();
7907     const U32 utf8 = flags & SVf_UTF8;
7908     COP *cop;
7909
7910     PL_parser->parsed_sub = 0;
7911
7912     flags &= ~SVf_UTF8;
7913
7914     NewOp(1101, cop, 1, COP);
7915     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
7916         OpTYPE_set(cop, OP_DBSTATE);
7917     }
7918     else {
7919         OpTYPE_set(cop, OP_NEXTSTATE);
7920     }
7921     cop->op_flags = (U8)flags;
7922     CopHINTS_set(cop, PL_hints);
7923 #ifdef VMS
7924     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
7925 #endif
7926     cop->op_next = (OP*)cop;
7927
7928     cop->cop_seq = seq;
7929     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7930     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
7931     if (label) {
7932         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
7933
7934         PL_hints |= HINT_BLOCK_SCOPE;
7935         /* It seems that we need to defer freeing this pointer, as other parts
7936            of the grammar end up wanting to copy it after this op has been
7937            created. */
7938         SAVEFREEPV(label);
7939     }
7940
7941     if (PL_parser->preambling != NOLINE) {
7942         CopLINE_set(cop, PL_parser->preambling);
7943         PL_parser->copline = NOLINE;
7944     }
7945     else if (PL_parser->copline == NOLINE)
7946         CopLINE_set(cop, CopLINE(PL_curcop));
7947     else {
7948         CopLINE_set(cop, PL_parser->copline);
7949         PL_parser->copline = NOLINE;
7950     }
7951 #ifdef USE_ITHREADS
7952     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
7953 #else
7954     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
7955 #endif
7956     CopSTASH_set(cop, PL_curstash);
7957
7958     if (cop->op_type == OP_DBSTATE) {
7959         /* this line can have a breakpoint - store the cop in IV */
7960         AV *av = CopFILEAVx(PL_curcop);
7961         if (av) {
7962             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
7963             if (svp && *svp != &PL_sv_undef ) {
7964                 (void)SvIOK_on(*svp);
7965                 SvIV_set(*svp, PTR2IV(cop));
7966             }
7967         }
7968     }
7969
7970     if (flags & OPf_SPECIAL)
7971         op_null((OP*)cop);
7972     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
7973 }
7974
7975 /*
7976 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
7977
7978 Constructs, checks, and returns a logical (flow control) op.  C<type>
7979 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
7980 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
7981 the eight bits of C<op_private>, except that the bit with value 1 is
7982 automatically set.  C<first> supplies the expression controlling the
7983 flow, and C<other> supplies the side (alternate) chain of ops; they are
7984 consumed by this function and become part of the constructed op tree.
7985
7986 =cut
7987 */
7988
7989 OP *
7990 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
7991 {
7992     PERL_ARGS_ASSERT_NEWLOGOP;
7993
7994     return new_logop(type, flags, &first, &other);
7995 }
7996
7997 STATIC OP *
7998 S_search_const(pTHX_ OP *o)
7999 {
8000     PERL_ARGS_ASSERT_SEARCH_CONST;
8001
8002     switch (o->op_type) {
8003         case OP_CONST:
8004             return o;
8005         case OP_NULL:
8006             if (o->op_flags & OPf_KIDS)
8007                 return search_const(cUNOPo->op_first);
8008             break;
8009         case OP_LEAVE:
8010         case OP_SCOPE:
8011         case OP_LINESEQ:
8012         {
8013             OP *kid;
8014             if (!(o->op_flags & OPf_KIDS))
8015                 return NULL;
8016             kid = cLISTOPo->op_first;
8017             do {
8018                 switch (kid->op_type) {
8019                     case OP_ENTER:
8020                     case OP_NULL:
8021                     case OP_NEXTSTATE:
8022                         kid = OpSIBLING(kid);
8023                         break;
8024                     default:
8025                         if (kid != cLISTOPo->op_last)
8026                             return NULL;
8027                         goto last;
8028                 }
8029             } while (kid);
8030             if (!kid)
8031                 kid = cLISTOPo->op_last;
8032           last:
8033             return search_const(kid);
8034         }
8035     }
8036
8037     return NULL;
8038 }
8039
8040 STATIC OP *
8041 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8042 {
8043     dVAR;
8044     LOGOP *logop;
8045     OP *o;
8046     OP *first;
8047     OP *other;
8048     OP *cstop = NULL;
8049     int prepend_not = 0;
8050
8051     PERL_ARGS_ASSERT_NEW_LOGOP;
8052
8053     first = *firstp;
8054     other = *otherp;
8055
8056     /* [perl #59802]: Warn about things like "return $a or $b", which
8057        is parsed as "(return $a) or $b" rather than "return ($a or
8058        $b)".  NB: This also applies to xor, which is why we do it
8059        here.
8060      */
8061     switch (first->op_type) {
8062     case OP_NEXT:
8063     case OP_LAST:
8064     case OP_REDO:
8065         /* XXX: Perhaps we should emit a stronger warning for these.
8066            Even with the high-precedence operator they don't seem to do
8067            anything sensible.
8068
8069            But until we do, fall through here.
8070          */
8071     case OP_RETURN:
8072     case OP_EXIT:
8073     case OP_DIE:
8074     case OP_GOTO:
8075         /* XXX: Currently we allow people to "shoot themselves in the
8076            foot" by explicitly writing "(return $a) or $b".
8077
8078            Warn unless we are looking at the result from folding or if
8079            the programmer explicitly grouped the operators like this.
8080            The former can occur with e.g.
8081
8082                 use constant FEATURE => ( $] >= ... );
8083                 sub { not FEATURE and return or do_stuff(); }
8084          */
8085         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8086             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8087                            "Possible precedence issue with control flow operator");
8088         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8089            the "or $b" part)?
8090         */
8091         break;
8092     }
8093
8094     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8095         return newBINOP(type, flags, scalar(first), scalar(other));
8096
8097     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8098         || type == OP_CUSTOM);
8099
8100     scalarboolean(first);
8101
8102     /* search for a constant op that could let us fold the test */
8103     if ((cstop = search_const(first))) {
8104         if (cstop->op_private & OPpCONST_STRICT)
8105             no_bareword_allowed(cstop);
8106         else if ((cstop->op_private & OPpCONST_BARE))
8107                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8108         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8109             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8110             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8111             /* Elide the (constant) lhs, since it can't affect the outcome */
8112             *firstp = NULL;
8113             if (other->op_type == OP_CONST)
8114                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8115             op_free(first);
8116             if (other->op_type == OP_LEAVE)
8117                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8118             else if (other->op_type == OP_MATCH
8119                   || other->op_type == OP_SUBST
8120                   || other->op_type == OP_TRANSR
8121                   || other->op_type == OP_TRANS)
8122                 /* Mark the op as being unbindable with =~ */
8123                 other->op_flags |= OPf_SPECIAL;
8124
8125             other->op_folded = 1;
8126             return other;
8127         }
8128         else {
8129             /* Elide the rhs, since the outcome is entirely determined by
8130              * the (constant) lhs */
8131
8132             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8133             const OP *o2 = other;
8134             if ( ! (o2->op_type == OP_LIST
8135                     && (( o2 = cUNOPx(o2)->op_first))
8136                     && o2->op_type == OP_PUSHMARK
8137                     && (( o2 = OpSIBLING(o2))) )
8138             )
8139                 o2 = other;
8140             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8141                         || o2->op_type == OP_PADHV)
8142                 && o2->op_private & OPpLVAL_INTRO
8143                 && !(o2->op_private & OPpPAD_STATE))
8144             {
8145                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8146                                 "Deprecated use of my() in false conditional. "
8147                                 "This will be a fatal error in Perl 5.30");
8148             }
8149
8150             *otherp = NULL;
8151             if (cstop->op_type == OP_CONST)
8152                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8153             op_free(other);
8154             return first;
8155         }
8156     }
8157     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8158         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8159     {
8160         const OP * const k1 = ((UNOP*)first)->op_first;
8161         const OP * const k2 = OpSIBLING(k1);
8162         OPCODE warnop = 0;
8163         switch (first->op_type)
8164         {
8165         case OP_NULL:
8166             if (k2 && k2->op_type == OP_READLINE
8167                   && (k2->op_flags & OPf_STACKED)
8168                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8169             {
8170                 warnop = k2->op_type;
8171             }
8172             break;
8173
8174         case OP_SASSIGN:
8175             if (k1->op_type == OP_READDIR
8176                   || k1->op_type == OP_GLOB
8177                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8178                  || k1->op_type == OP_EACH
8179                  || k1->op_type == OP_AEACH)
8180             {
8181                 warnop = ((k1->op_type == OP_NULL)
8182                           ? (OPCODE)k1->op_targ : k1->op_type);
8183             }
8184             break;
8185         }
8186         if (warnop) {
8187             const line_t oldline = CopLINE(PL_curcop);
8188             /* This ensures that warnings are reported at the first line
8189                of the construction, not the last.  */
8190             CopLINE_set(PL_curcop, PL_parser->copline);
8191             Perl_warner(aTHX_ packWARN(WARN_MISC),
8192                  "Value of %s%s can be \"0\"; test with defined()",
8193                  PL_op_desc[warnop],
8194                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8195                   ? " construct" : "() operator"));
8196             CopLINE_set(PL_curcop, oldline);
8197         }
8198     }
8199
8200     /* optimize AND and OR ops that have NOTs as children */
8201     if (first->op_type == OP_NOT
8202         && (first->op_flags & OPf_KIDS)
8203         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8204             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8205         ) {
8206         if (type == OP_AND || type == OP_OR) {
8207             if (type == OP_AND)
8208                 type = OP_OR;
8209             else
8210                 type = OP_AND;
8211             op_null(first);
8212             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8213                 op_null(other);
8214                 prepend_not = 1; /* prepend a NOT op later */
8215             }
8216         }
8217     }
8218
8219     logop = alloc_LOGOP(type, first, LINKLIST(other));
8220     logop->op_flags |= (U8)flags;
8221     logop->op_private = (U8)(1 | (flags >> 8));
8222
8223     /* establish postfix order */
8224     logop->op_next = LINKLIST(first);
8225     first->op_next = (OP*)logop;
8226     assert(!OpHAS_SIBLING(first));
8227     op_sibling_splice((OP*)logop, first, 0, other);
8228
8229     CHECKOP(type,logop);
8230
8231     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8232                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8233                 (OP*)logop);
8234     other->op_next = o;
8235
8236     return o;
8237 }
8238
8239 /*
8240 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8241
8242 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8243 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8244 will be set automatically, and, shifted up eight bits, the eight bits of
8245 C<op_private>, except that the bit with value 1 is automatically set.
8246 C<first> supplies the expression selecting between the two branches,
8247 and C<trueop> and C<falseop> supply the branches; they are consumed by
8248 this function and become part of the constructed op tree.
8249
8250 =cut
8251 */
8252
8253 OP *
8254 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8255 {
8256     dVAR;
8257     LOGOP *logop;
8258     OP *start;
8259     OP *o;
8260     OP *cstop;
8261
8262     PERL_ARGS_ASSERT_NEWCONDOP;
8263
8264     if (!falseop)
8265         return newLOGOP(OP_AND, 0, first, trueop);
8266     if (!trueop)
8267         return newLOGOP(OP_OR, 0, first, falseop);
8268
8269     scalarboolean(first);
8270     if ((cstop = search_const(first))) {
8271         /* Left or right arm of the conditional?  */
8272         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8273         OP *live = left ? trueop : falseop;
8274         OP *const dead = left ? falseop : trueop;
8275         if (cstop->op_private & OPpCONST_BARE &&
8276             cstop->op_private & OPpCONST_STRICT) {
8277             no_bareword_allowed(cstop);
8278         }
8279         op_free(first);
8280         op_free(dead);
8281         if (live->op_type == OP_LEAVE)
8282             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8283         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8284               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8285             /* Mark the op as being unbindable with =~ */
8286             live->op_flags |= OPf_SPECIAL;
8287         live->op_folded = 1;
8288         return live;
8289     }
8290     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8291     logop->op_flags |= (U8)flags;
8292     logop->op_private = (U8)(1 | (flags >> 8));
8293     logop->op_next = LINKLIST(falseop);
8294
8295     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8296             logop);
8297
8298     /* establish postfix order */
8299     start = LINKLIST(first);
8300     first->op_next = (OP*)logop;
8301
8302     /* make first, trueop, falseop siblings */
8303     op_sibling_splice((OP*)logop, first,  0, trueop);
8304     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8305
8306     o = newUNOP(OP_NULL, 0, (OP*)logop);
8307
8308     trueop->op_next = falseop->op_next = o;
8309
8310     o->op_next = start;
8311     return o;
8312 }
8313
8314 /*
8315 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8316
8317 Constructs and returns a C<range> op, with subordinate C<flip> and
8318 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8319 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8320 for both the C<flip> and C<range> ops, except that the bit with value
8321 1 is automatically set.  C<left> and C<right> supply the expressions
8322 controlling the endpoints of the range; they are consumed by this function
8323 and become part of the constructed op tree.
8324
8325 =cut
8326 */
8327
8328 OP *
8329 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8330 {
8331     LOGOP *range;
8332     OP *flip;
8333     OP *flop;
8334     OP *leftstart;
8335     OP *o;
8336
8337     PERL_ARGS_ASSERT_NEWRANGE;
8338
8339     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8340     range->op_flags = OPf_KIDS;
8341     leftstart = LINKLIST(left);
8342     range->op_private = (U8)(1 | (flags >> 8));
8343
8344     /* make left and right siblings */
8345     op_sibling_splice((OP*)range, left, 0, right);
8346
8347     range->op_next = (OP*)range;
8348     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8349     flop = newUNOP(OP_FLOP, 0, flip);
8350     o = newUNOP(OP_NULL, 0, flop);
8351     LINKLIST(flop);
8352     range->op_next = leftstart;
8353
8354     left->op_next = flip;
8355     right->op_next = flop;
8356
8357     range->op_targ =
8358         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8359     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8360     flip->op_targ =
8361         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8362     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8363     SvPADTMP_on(PAD_SV(flip->op_targ));
8364
8365     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8366     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8367
8368     /* check barewords before they might be optimized aways */
8369     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8370         no_bareword_allowed(left);
8371     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8372         no_bareword_allowed(right);
8373
8374     flip->op_next = o;
8375     if (!flip->op_private || !flop->op_private)
8376         LINKLIST(o);            /* blow off optimizer unless constant */
8377
8378     return o;
8379 }
8380
8381 /*
8382 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8383
8384 Constructs, checks, and returns an op tree expressing a loop.  This is
8385 only a loop in the control flow through the op tree; it does not have
8386 the heavyweight loop structure that allows exiting the loop by C<last>
8387 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8388 top-level op, except that some bits will be set automatically as required.
8389 C<expr> supplies the expression controlling loop iteration, and C<block>
8390 supplies the body of the loop; they are consumed by this function and
8391 become part of the constructed op tree.  C<debuggable> is currently
8392 unused and should always be 1.
8393
8394 =cut
8395 */
8396
8397 OP *
8398 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8399 {
8400     OP* listop;
8401     OP* o;
8402     const bool once = block && block->op_flags & OPf_SPECIAL &&
8403                       block->op_type == OP_NULL;
8404
8405     PERL_UNUSED_ARG(debuggable);
8406
8407     if (expr) {
8408         if (once && (
8409               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8410            || (  expr->op_type == OP_NOT
8411               && cUNOPx(expr)->op_first->op_type == OP_CONST
8412               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8413               )
8414            ))
8415             /* Return the block now, so that S_new_logop does not try to
8416                fold it away. */
8417             return block;       /* do {} while 0 does once */
8418         if (expr->op_type == OP_READLINE
8419             || expr->op_type == OP_READDIR
8420             || expr->op_type == OP_GLOB
8421             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8422             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8423             expr = newUNOP(OP_DEFINED, 0,
8424                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8425         } else if (expr->op_flags & OPf_KIDS) {
8426             const OP * const k1 = ((UNOP*)expr)->op_first;
8427             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8428             switch (expr->op_type) {
8429               case OP_NULL:
8430                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8431                       && (k2->op_flags & OPf_STACKED)
8432                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8433                     expr = newUNOP(OP_DEFINED, 0, expr);
8434                 break;
8435
8436               case OP_SASSIGN:
8437                 if (k1 && (k1->op_type == OP_READDIR
8438                       || k1->op_type == OP_GLOB
8439                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8440                      || k1->op_type == OP_EACH
8441                      || k1->op_type == OP_AEACH))
8442                     expr = newUNOP(OP_DEFINED, 0, expr);
8443                 break;
8444             }
8445         }
8446     }
8447
8448     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8449      * op, in listop. This is wrong. [perl #27024] */
8450     if (!block)
8451         block = newOP(OP_NULL, 0);
8452     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8453     o = new_logop(OP_AND, 0, &expr, &listop);
8454
8455     if (once) {
8456         ASSUME(listop);
8457     }
8458
8459     if (listop)
8460         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8461
8462     if (once && o != listop)
8463     {
8464         assert(cUNOPo->op_first->op_type == OP_AND
8465             || cUNOPo->op_first->op_type == OP_OR);
8466         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8467     }
8468
8469     if (o == listop)
8470         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8471
8472     o->op_flags |= flags;
8473     o = op_scope(o);
8474     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8475     return o;
8476 }
8477
8478 /*
8479 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8480
8481 Constructs, checks, and returns an op tree expressing a C<while> loop.
8482 This is a heavyweight loop, with structure that allows exiting the loop
8483 by C<last> and suchlike.
8484
8485 C<loop> is an optional preconstructed C<enterloop> op to use in the
8486 loop; if it is null then a suitable op will be constructed automatically.
8487 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8488 main body of the loop, and C<cont> optionally supplies a C<continue> block
8489 that operates as a second half of the body.  All of these optree inputs
8490 are consumed by this function and become part of the constructed op tree.
8491
8492 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8493 op and, shifted up eight bits, the eight bits of C<op_private> for
8494 the C<leaveloop> op, except that (in both cases) some bits will be set
8495 automatically.  C<debuggable> is currently unused and should always be 1.
8496 C<has_my> can be supplied as true to force the
8497 loop body to be enclosed in its own scope.
8498
8499 =cut
8500 */
8501
8502 OP *
8503 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8504         OP *expr, OP *block, OP *cont, I32 has_my)
8505 {
8506     dVAR;
8507     OP *redo;
8508     OP *next = NULL;
8509     OP *listop;
8510     OP *o;
8511     U8 loopflags = 0;
8512
8513     PERL_UNUSED_ARG(debuggable);
8514
8515     if (expr) {
8516         if (expr->op_type == OP_READLINE
8517          || expr->op_type == OP_READDIR
8518          || expr->op_type == OP_GLOB
8519          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8520                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8521             expr = newUNOP(OP_DEFINED, 0,
8522                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8523         } else if (expr->op_flags & OPf_KIDS) {
8524             const OP * const k1 = ((UNOP*)expr)->op_first;
8525             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8526             switch (expr->op_type) {
8527               case OP_NULL:
8528                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8529                       && (k2->op_flags & OPf_STACKED)
8530                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8531                     expr = newUNOP(OP_DEFINED, 0, expr);
8532                 break;
8533
8534               case OP_SASSIGN:
8535                 if (k1 && (k1->op_type == OP_READDIR
8536                       || k1->op_type == OP_GLOB
8537                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8538                      || k1->op_type == OP_EACH
8539                      || k1->op_type == OP_AEACH))
8540                     expr = newUNOP(OP_DEFINED, 0, expr);
8541                 break;
8542             }
8543         }
8544     }
8545
8546     if (!block)
8547         block = newOP(OP_NULL, 0);
8548     else if (cont || has_my) {
8549         block = op_scope(block);
8550     }
8551
8552     if (cont) {
8553         next = LINKLIST(cont);
8554     }
8555     if (expr) {
8556         OP * const unstack = newOP(OP_UNSTACK, 0);
8557         if (!next)
8558             next = unstack;
8559         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8560     }
8561
8562     assert(block);
8563     listop = op_append_list(OP_LINESEQ, block, cont);
8564     assert(listop);
8565     redo = LINKLIST(listop);
8566
8567     if (expr) {
8568         scalar(listop);
8569         o = new_logop(OP_AND, 0, &expr, &listop);
8570         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8571             op_free((OP*)loop);
8572             return expr;                /* listop already freed by new_logop */
8573         }
8574         if (listop)
8575             ((LISTOP*)listop)->op_last->op_next =
8576                 (o == listop ? redo : LINKLIST(o));
8577     }
8578     else
8579         o = listop;
8580
8581     if (!loop) {
8582         NewOp(1101,loop,1,LOOP);
8583         OpTYPE_set(loop, OP_ENTERLOOP);
8584         loop->op_private = 0;
8585         loop->op_next = (OP*)loop;
8586     }
8587
8588     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8589
8590     loop->op_redoop = redo;
8591     loop->op_lastop = o;
8592     o->op_private |= loopflags;
8593
8594     if (next)
8595         loop->op_nextop = next;
8596     else
8597         loop->op_nextop = o;
8598
8599     o->op_flags |= flags;
8600     o->op_private |= (flags >> 8);
8601     return o;
8602 }
8603
8604 /*
8605 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8606
8607 Constructs, checks, and returns an op tree expressing a C<foreach>
8608 loop (iteration through a list of values).  This is a heavyweight loop,
8609 with structure that allows exiting the loop by C<last> and suchlike.
8610
8611 C<sv> optionally supplies the variable that will be aliased to each
8612 item in turn; if null, it defaults to C<$_>.
8613 C<expr> supplies the list of values to iterate over.  C<block> supplies
8614 the main body of the loop, and C<cont> optionally supplies a C<continue>
8615 block that operates as a second half of the body.  All of these optree
8616 inputs are consumed by this function and become part of the constructed
8617 op tree.
8618
8619 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8620 op and, shifted up eight bits, the eight bits of C<op_private> for
8621 the C<leaveloop> op, except that (in both cases) some bits will be set
8622 automatically.
8623
8624 =cut
8625 */
8626
8627 OP *
8628 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8629 {
8630     dVAR;
8631     LOOP *loop;
8632     OP *wop;
8633     PADOFFSET padoff = 0;
8634     I32 iterflags = 0;
8635     I32 iterpflags = 0;
8636
8637     PERL_ARGS_ASSERT_NEWFOROP;
8638
8639     if (sv) {
8640         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8641             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8642             OpTYPE_set(sv, OP_RV2GV);
8643
8644             /* The op_type check is needed to prevent a possible segfault
8645              * if the loop variable is undeclared and 'strict vars' is in
8646              * effect. This is illegal but is nonetheless parsed, so we
8647              * may reach this point with an OP_CONST where we're expecting
8648              * an OP_GV.
8649              */
8650             if (cUNOPx(sv)->op_first->op_type == OP_GV
8651              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8652                 iterpflags |= OPpITER_DEF;
8653         }
8654         else if (sv->op_type == OP_PADSV) { /* private variable */
8655             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8656             padoff = sv->op_targ;
8657             sv->op_targ = 0;
8658             op_free(sv);
8659             sv = NULL;
8660             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8661         }
8662         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8663             NOOP;
8664         else
8665             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8666         if (padoff) {
8667             PADNAME * const pn = PAD_COMPNAME(padoff);
8668             const char * const name = PadnamePV(pn);
8669
8670             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8671                 iterpflags |= OPpITER_DEF;
8672         }
8673     }
8674     else {
8675         sv = newGVOP(OP_GV, 0, PL_defgv);
8676         iterpflags |= OPpITER_DEF;
8677     }
8678
8679     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8680         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8681         iterflags |= OPf_STACKED;
8682     }
8683     else if (expr->op_type == OP_NULL &&
8684              (expr->op_flags & OPf_KIDS) &&
8685              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8686     {
8687         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8688          * set the STACKED flag to indicate that these values are to be
8689          * treated as min/max values by 'pp_enteriter'.
8690          */
8691         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8692         LOGOP* const range = (LOGOP*) flip->op_first;
8693         OP* const left  = range->op_first;
8694         OP* const right = OpSIBLING(left);
8695         LISTOP* listop;
8696
8697         range->op_flags &= ~OPf_KIDS;
8698         /* detach range's children */
8699         op_sibling_splice((OP*)range, NULL, -1, NULL);
8700
8701         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8702         listop->op_first->op_next = range->op_next;
8703         left->op_next = range->op_other;
8704         right->op_next = (OP*)listop;
8705         listop->op_next = listop->op_first;
8706
8707         op_free(expr);
8708         expr = (OP*)(listop);
8709         op_null(expr);
8710         iterflags |= OPf_STACKED;
8711     }
8712     else {
8713         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8714     }
8715
8716     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8717                                   op_append_elem(OP_LIST, list(expr),
8718                                                  scalar(sv)));
8719     assert(!loop->op_next);
8720     /* for my  $x () sets OPpLVAL_INTRO;
8721      * for our $x () sets OPpOUR_INTRO */
8722     loop->op_private = (U8)iterpflags;
8723     if (loop->op_slabbed
8724      && DIFF(loop, OpSLOT(loop)->opslot_next)
8725          < SIZE_TO_PSIZE(sizeof(LOOP)))
8726     {
8727         LOOP *tmp;
8728         NewOp(1234,tmp,1,LOOP);
8729         Copy(loop,tmp,1,LISTOP);
8730 #ifdef PERL_OP_PARENT
8731         assert(loop->op_last->op_sibparent == (OP*)loop);
8732         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8733 #endif
8734         S_op_destroy(aTHX_ (OP*)loop);
8735         loop = tmp;
8736     }
8737     else if (!loop->op_slabbed)
8738     {
8739         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8740 #ifdef PERL_OP_PARENT
8741         OpLASTSIB_set(loop->op_last, (OP*)loop);
8742 #endif
8743     }
8744     loop->op_targ = padoff;
8745     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8746     return wop;
8747 }
8748
8749 /*
8750 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8751
8752 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8753 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8754 determining the target of the op; it is consumed by this function and
8755 becomes part of the constructed op tree.
8756
8757 =cut
8758 */
8759
8760 OP*
8761 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8762 {
8763     OP *o = NULL;
8764
8765     PERL_ARGS_ASSERT_NEWLOOPEX;
8766
8767     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8768         || type == OP_CUSTOM);
8769
8770     if (type != OP_GOTO) {
8771         /* "last()" means "last" */
8772         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8773             o = newOP(type, OPf_SPECIAL);
8774         }
8775     }
8776     else {
8777         /* Check whether it's going to be a goto &function */
8778         if (label->op_type == OP_ENTERSUB
8779                 && !(label->op_flags & OPf_STACKED))
8780             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8781     }
8782
8783     /* Check for a constant argument */
8784     if (label->op_type == OP_CONST) {
8785             SV * const sv = ((SVOP *)label)->op_sv;
8786             STRLEN l;
8787             const char *s = SvPV_const(sv,l);
8788             if (l == strlen(s)) {
8789                 o = newPVOP(type,
8790                             SvUTF8(((SVOP*)label)->op_sv),
8791                             savesharedpv(
8792                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8793             }
8794     }
8795
8796     /* If we have already created an op, we do not need the label. */
8797     if (o)
8798                 op_free(label);
8799     else o = newUNOP(type, OPf_STACKED, label);
8800
8801     PL_hints |= HINT_BLOCK_SCOPE;
8802     return o;
8803 }
8804
8805 /* if the condition is a literal array or hash
8806    (or @{ ... } etc), make a reference to it.
8807  */
8808 STATIC OP *
8809 S_ref_array_or_hash(pTHX_ OP *cond)
8810 {
8811     if (cond
8812     && (cond->op_type == OP_RV2AV
8813     ||  cond->op_type == OP_PADAV
8814     ||  cond->op_type == OP_RV2HV
8815     ||  cond->op_type == OP_PADHV))
8816
8817         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8818
8819     else if(cond
8820     && (cond->op_type == OP_ASLICE
8821     ||  cond->op_type == OP_KVASLICE
8822     ||  cond->op_type == OP_HSLICE
8823     ||  cond->op_type == OP_KVHSLICE)) {
8824
8825         /* anonlist now needs a list from this op, was previously used in
8826          * scalar context */
8827         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8828         cond->op_flags |= OPf_WANT_LIST;
8829
8830         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8831     }
8832
8833     else
8834         return cond;
8835 }
8836
8837 /* These construct the optree fragments representing given()
8838    and when() blocks.
8839
8840    entergiven and enterwhen are LOGOPs; the op_other pointer
8841    points up to the associated leave op. We need this so we
8842    can put it in the context and make break/continue work.
8843    (Also, of course, pp_enterwhen will jump straight to
8844    op_other if the match fails.)
8845  */
8846
8847 STATIC OP *
8848 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8849                    I32 enter_opcode, I32 leave_opcode,
8850                    PADOFFSET entertarg)
8851 {
8852     dVAR;
8853     LOGOP *enterop;
8854     OP *o;
8855
8856     PERL_ARGS_ASSERT_NEWGIVWHENOP;
8857     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8858
8859     enterop = alloc_LOGOP(enter_opcode, block, NULL);
8860     enterop->op_targ = 0;
8861     enterop->op_private = 0;
8862
8863     o = newUNOP(leave_opcode, 0, (OP *) enterop);
8864
8865     if (cond) {
8866         /* prepend cond if we have one */
8867         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8868
8869         o->op_next = LINKLIST(cond);
8870         cond->op_next = (OP *) enterop;
8871     }
8872     else {
8873         /* This is a default {} block */
8874         enterop->op_flags |= OPf_SPECIAL;
8875         o      ->op_flags |= OPf_SPECIAL;
8876
8877         o->op_next = (OP *) enterop;
8878     }
8879
8880     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
8881                                        entergiven and enterwhen both
8882                                        use ck_null() */
8883
8884     enterop->op_next = LINKLIST(block);
8885     block->op_next = enterop->op_other = o;
8886
8887     return o;
8888 }
8889
8890 /* Does this look like a boolean operation? For these purposes
8891    a boolean operation is:
8892      - a subroutine call [*]
8893      - a logical connective
8894      - a comparison operator
8895      - a filetest operator, with the exception of -s -M -A -C
8896      - defined(), exists() or eof()
8897      - /$re/ or $foo =~ /$re/
8898
8899    [*] possibly surprising
8900  */
8901 STATIC bool
8902 S_looks_like_bool(pTHX_ const OP *o)
8903 {
8904     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
8905
8906     switch(o->op_type) {
8907         case OP_OR:
8908         case OP_DOR:
8909             return looks_like_bool(cLOGOPo->op_first);
8910
8911         case OP_AND:
8912         {
8913             OP* sibl = OpSIBLING(cLOGOPo->op_first);
8914             ASSUME(sibl);
8915             return (
8916                 looks_like_bool(cLOGOPo->op_first)
8917              && looks_like_bool(sibl));
8918         }
8919
8920         case OP_NULL:
8921         case OP_SCALAR:
8922             return (
8923                 o->op_flags & OPf_KIDS
8924             && looks_like_bool(cUNOPo->op_first));
8925
8926         case OP_ENTERSUB:
8927
8928         case OP_NOT:    case OP_XOR:
8929
8930         case OP_EQ:     case OP_NE:     case OP_LT:
8931         case OP_GT:     case OP_LE:     case OP_GE:
8932
8933         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
8934         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
8935
8936         case OP_SEQ:    case OP_SNE:    case OP_SLT:
8937         case OP_SGT:    case OP_SLE:    case OP_SGE:
8938
8939         case OP_SMARTMATCH:
8940
8941         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
8942         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
8943         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
8944         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
8945         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
8946         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
8947         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
8948         case OP_FTTEXT:   case OP_FTBINARY:
8949
8950         case OP_DEFINED: case OP_EXISTS:
8951         case OP_MATCH:   case OP_EOF:
8952
8953         case OP_FLOP:
8954
8955             return TRUE;
8956
8957         case OP_CONST:
8958             /* Detect comparisons that have been optimized away */
8959             if (cSVOPo->op_sv == &PL_sv_yes
8960             ||  cSVOPo->op_sv == &PL_sv_no)
8961
8962                 return TRUE;
8963             else
8964                 return FALSE;
8965
8966         /* FALLTHROUGH */
8967         default:
8968             return FALSE;
8969     }
8970 }
8971
8972 /*
8973 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
8974
8975 Constructs, checks, and returns an op tree expressing a C<given> block.
8976 C<cond> supplies the expression to whose value C<$_> will be locally
8977 aliased, and C<block> supplies the body of the C<given> construct; they
8978 are consumed by this function and become part of the constructed op tree.
8979 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
8980
8981 =cut
8982 */
8983
8984 OP *
8985 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
8986 {
8987     PERL_ARGS_ASSERT_NEWGIVENOP;
8988     PERL_UNUSED_ARG(defsv_off);
8989
8990     assert(!defsv_off);
8991     return newGIVWHENOP(
8992         ref_array_or_hash(cond),
8993         block,
8994         OP_ENTERGIVEN, OP_LEAVEGIVEN,
8995         0);
8996 }
8997
8998 /*
8999 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9000
9001 Constructs, checks, and returns an op tree expressing a C<when> block.
9002 C<cond> supplies the test expression, and C<block> supplies the block
9003 that will be executed if the test evaluates to true; they are consumed
9004 by this function and become part of the constructed op tree.  C<cond>
9005 will be interpreted DWIMically, often as a comparison against C<$_>,
9006 and may be null to generate a C<default> block.
9007
9008 =cut
9009 */
9010
9011 OP *
9012 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9013 {
9014     const bool cond_llb = (!cond || looks_like_bool(cond));
9015     OP *cond_op;
9016
9017     PERL_ARGS_ASSERT_NEWWHENOP;
9018
9019     if (cond_llb)
9020         cond_op = cond;
9021     else {
9022         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9023                 newDEFSVOP(),
9024                 scalar(ref_array_or_hash(cond)));
9025     }
9026
9027     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9028 }
9029
9030 /* must not conflict with SVf_UTF8 */
9031 #define CV_CKPROTO_CURSTASH     0x1
9032
9033 void
9034 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9035                     const STRLEN len, const U32 flags)
9036 {
9037     SV *name = NULL, *msg;
9038     const char * cvp = SvROK(cv)
9039                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9040                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9041                            : ""
9042                         : CvPROTO(cv);
9043     STRLEN clen = CvPROTOLEN(cv), plen = len;
9044
9045     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9046
9047     if (p == NULL && cvp == NULL)
9048         return;
9049
9050     if (!ckWARN_d(WARN_PROTOTYPE))
9051         return;
9052
9053     if (p && cvp) {
9054         p = S_strip_spaces(aTHX_ p, &plen);
9055         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9056         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9057             if (plen == clen && memEQ(cvp, p, plen))
9058                 return;
9059         } else {
9060             if (flags & SVf_UTF8) {
9061                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9062                     return;
9063             }
9064             else {
9065                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9066                     return;
9067             }
9068         }
9069     }
9070
9071     msg = sv_newmortal();
9072
9073     if (gv)
9074     {
9075         if (isGV(gv))
9076             gv_efullname3(name = sv_newmortal(), gv, NULL);
9077         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9078             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9079         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9080             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9081             sv_catpvs(name, "::");
9082             if (SvROK(gv)) {
9083                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9084                 assert (CvNAMED(SvRV_const(gv)));
9085                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9086             }
9087             else sv_catsv(name, (SV *)gv);
9088         }
9089         else name = (SV *)gv;
9090     }
9091     sv_setpvs(msg, "Prototype mismatch:");
9092     if (name)
9093         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9094     if (cvp)
9095         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9096             UTF8fARG(SvUTF8(cv),clen,cvp)
9097         );
9098     else
9099         sv_catpvs(msg, ": none");
9100     sv_catpvs(msg, " vs ");
9101     if (p)
9102         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9103     else
9104         sv_catpvs(msg, "none");
9105     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9106 }
9107
9108 static void const_sv_xsub(pTHX_ CV* cv);
9109 static void const_av_xsub(pTHX_ CV* cv);
9110
9111 /*
9112
9113 =head1 Optree Manipulation Functions
9114
9115 =for apidoc cv_const_sv
9116
9117 If C<cv> is a constant sub eligible for inlining, returns the constant
9118 value returned by the sub.  Otherwise, returns C<NULL>.
9119
9120 Constant subs can be created with C<newCONSTSUB> or as described in
9121 L<perlsub/"Constant Functions">.
9122
9123 =cut
9124 */
9125 SV *
9126 Perl_cv_const_sv(const CV *const cv)
9127 {
9128     SV *sv;
9129     if (!cv)
9130         return NULL;
9131     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9132         return NULL;
9133     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9134     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9135     return sv;
9136 }
9137
9138 SV *
9139 Perl_cv_const_sv_or_av(const CV * const cv)
9140 {
9141     if (!cv)
9142         return NULL;
9143     if (SvROK(cv)) return SvRV((SV *)cv);
9144     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9145     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9146 }
9147
9148 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9149  * Can be called in 2 ways:
9150  *
9151  * !allow_lex
9152  *      look for a single OP_CONST with attached value: return the value
9153  *
9154  * allow_lex && !CvCONST(cv);
9155  *
9156  *      examine the clone prototype, and if contains only a single
9157  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9158  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9159  *      a candidate for "constizing" at clone time, and return NULL.
9160  */
9161
9162 static SV *
9163 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9164 {
9165     SV *sv = NULL;
9166     bool padsv = FALSE;
9167
9168     assert(o);
9169     assert(cv);
9170
9171     for (; o; o = o->op_next) {
9172         const OPCODE type = o->op_type;
9173
9174         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9175              || type == OP_NULL
9176              || type == OP_PUSHMARK)
9177                 continue;
9178         if (type == OP_DBSTATE)
9179                 continue;
9180         if (type == OP_LEAVESUB)
9181             break;
9182         if (sv)
9183             return NULL;
9184         if (type == OP_CONST && cSVOPo->op_sv)
9185             sv = cSVOPo->op_sv;
9186         else if (type == OP_UNDEF && !o->op_private) {
9187             sv = newSV(0);
9188             SAVEFREESV(sv);
9189         }
9190         else if (allow_lex && type == OP_PADSV) {
9191                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9192                 {
9193                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9194                     padsv = TRUE;
9195                 }
9196                 else
9197                     return NULL;
9198         }
9199         else {
9200             return NULL;
9201         }
9202     }
9203     if (padsv) {
9204         CvCONST_on(cv);
9205         return NULL;
9206     }
9207     return sv;
9208 }
9209
9210 static void
9211 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9212                         PADNAME * const name, SV ** const const_svp)
9213 {
9214     assert (cv);
9215     assert (o || name);
9216     assert (const_svp);
9217     if (!block) {
9218         if (CvFLAGS(PL_compcv)) {
9219             /* might have had built-in attrs applied */
9220             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9221             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9222              && ckWARN(WARN_MISC))
9223             {
9224                 /* protect against fatal warnings leaking compcv */
9225                 SAVEFREESV(PL_compcv);
9226                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9227                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9228             }
9229             CvFLAGS(cv) |=
9230                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9231                   & ~(CVf_LVALUE * pureperl));
9232         }
9233         return;
9234     }
9235
9236     /* redundant check for speed: */
9237     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9238         const line_t oldline = CopLINE(PL_curcop);
9239         SV *namesv = o
9240             ? cSVOPo->op_sv
9241             : sv_2mortal(newSVpvn_utf8(
9242                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9243               ));
9244         if (PL_parser && PL_parser->copline != NOLINE)
9245             /* This ensures that warnings are reported at the first
9246                line of a redefinition, not the last.  */
9247             CopLINE_set(PL_curcop, PL_parser->copline);
9248         /* protect against fatal warnings leaking compcv */
9249         SAVEFREESV(PL_compcv);
9250         report_redefined_cv(namesv, cv, const_svp);
9251         SvREFCNT_inc_simple_void_NN(PL_compcv);
9252         CopLINE_set(PL_curcop, oldline);
9253     }
9254     SAVEFREESV(cv);
9255     return;
9256 }
9257
9258 CV *
9259 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9260 {
9261     CV **spot;
9262     SV **svspot;
9263     const char *ps;
9264     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9265     U32 ps_utf8 = 0;
9266     CV *cv = NULL;
9267     CV *compcv = PL_compcv;
9268     SV *const_sv;
9269     PADNAME *name;
9270     PADOFFSET pax = o->op_targ;
9271     CV *outcv = CvOUTSIDE(PL_compcv);
9272     CV *clonee = NULL;
9273     HEK *hek = NULL;
9274     bool reusable = FALSE;
9275     OP *start = NULL;
9276 #ifdef PERL_DEBUG_READONLY_OPS
9277     OPSLAB *slab = NULL;
9278 #endif
9279
9280     PERL_ARGS_ASSERT_NEWMYSUB;
9281
9282     PL_hints |= HINT_BLOCK_SCOPE;
9283
9284     /* Find the pad slot for storing the new sub.
9285        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9286        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9287        ing sub.  And then we need to dig deeper if this is a lexical from
9288        outside, as in:
9289            my sub foo; sub { sub foo { } }
9290      */
9291   redo:
9292     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9293     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9294         pax = PARENT_PAD_INDEX(name);
9295         outcv = CvOUTSIDE(outcv);
9296         assert(outcv);
9297         goto redo;
9298     }
9299     svspot =
9300         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9301                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9302     spot = (CV **)svspot;
9303
9304     if (!(PL_parser && PL_parser->error_count))
9305         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9306
9307     if (proto) {
9308         assert(proto->op_type == OP_CONST);
9309         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9310         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9311     }
9312     else
9313         ps = NULL;
9314
9315     if (proto)
9316         SAVEFREEOP(proto);
9317     if (attrs)
9318         SAVEFREEOP(attrs);
9319
9320     if (PL_parser && PL_parser->error_count) {
9321         op_free(block);
9322         SvREFCNT_dec(PL_compcv);
9323         PL_compcv = 0;
9324         goto done;
9325     }
9326
9327     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9328         cv = *spot;
9329         svspot = (SV **)(spot = &clonee);
9330     }
9331     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9332         cv = *spot;
9333     else {
9334         assert (SvTYPE(*spot) == SVt_PVCV);
9335         if (CvNAMED(*spot))
9336             hek = CvNAME_HEK(*spot);
9337         else {
9338             dVAR;
9339             U32 hash;
9340             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9341             CvNAME_HEK_set(*spot, hek =
9342                 share_hek(
9343                     PadnamePV(name)+1,
9344                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9345                     hash
9346                 )
9347             );
9348             CvLEXICAL_on(*spot);
9349         }
9350         cv = PadnamePROTOCV(name);
9351         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9352     }
9353
9354     if (block) {
9355         /* This makes sub {}; work as expected.  */
9356         if (block->op_type == OP_STUB) {
9357             const line_t l = PL_parser->copline;
9358             op_free(block);
9359             block = newSTATEOP(0, NULL, 0);
9360             PL_parser->copline = l;
9361         }
9362         block = CvLVALUE(compcv)
9363              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9364                    ? newUNOP(OP_LEAVESUBLV, 0,
9365                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9366                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9367         start = LINKLIST(block);
9368         block->op_next = 0;
9369         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9370             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9371         else
9372             const_sv = NULL;
9373     }
9374     else
9375         const_sv = NULL;
9376
9377     if (cv) {
9378         const bool exists = CvROOT(cv) || CvXSUB(cv);
9379
9380         /* if the subroutine doesn't exist and wasn't pre-declared
9381          * with a prototype, assume it will be AUTOLOADed,
9382          * skipping the prototype check
9383          */
9384         if (exists || SvPOK(cv))
9385             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9386                                  ps_utf8);
9387         /* already defined? */
9388         if (exists) {
9389             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9390             if (block)
9391                 cv = NULL;
9392             else {
9393                 if (attrs)
9394                     goto attrs;
9395                 /* just a "sub foo;" when &foo is already defined */
9396                 SAVEFREESV(compcv);
9397                 goto done;
9398             }
9399         }
9400         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9401             cv = NULL;
9402             reusable = TRUE;
9403         }
9404     }
9405
9406     if (const_sv) {
9407         SvREFCNT_inc_simple_void_NN(const_sv);
9408         SvFLAGS(const_sv) |= SVs_PADTMP;
9409         if (cv) {
9410             assert(!CvROOT(cv) && !CvCONST(cv));
9411             cv_forget_slab(cv);
9412         }
9413         else {
9414             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9415             CvFILE_set_from_cop(cv, PL_curcop);
9416             CvSTASH_set(cv, PL_curstash);
9417             *spot = cv;
9418         }
9419         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9420         CvXSUBANY(cv).any_ptr = const_sv;
9421         CvXSUB(cv) = const_sv_xsub;
9422         CvCONST_on(cv);
9423         CvISXSUB_on(cv);
9424         PoisonPADLIST(cv);
9425         CvFLAGS(cv) |= CvMETHOD(compcv);
9426         op_free(block);
9427         SvREFCNT_dec(compcv);
9428         PL_compcv = NULL;
9429         goto setname;
9430     }
9431
9432     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9433        determine whether this sub definition is in the same scope as its
9434        declaration.  If this sub definition is inside an inner named pack-
9435        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9436        the package sub.  So check PadnameOUTER(name) too.
9437      */
9438     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9439         assert(!CvWEAKOUTSIDE(compcv));
9440         SvREFCNT_dec(CvOUTSIDE(compcv));
9441         CvWEAKOUTSIDE_on(compcv);
9442     }
9443     /* XXX else do we have a circular reference? */
9444
9445     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9446         /* transfer PL_compcv to cv */
9447         if (block) {
9448             cv_flags_t preserved_flags =
9449                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9450             PADLIST *const temp_padl = CvPADLIST(cv);
9451             CV *const temp_cv = CvOUTSIDE(cv);
9452             const cv_flags_t other_flags =
9453                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9454             OP * const cvstart = CvSTART(cv);
9455
9456             SvPOK_off(cv);
9457             CvFLAGS(cv) =
9458                 CvFLAGS(compcv) | preserved_flags;
9459             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9460             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9461             CvPADLIST_set(cv, CvPADLIST(compcv));
9462             CvOUTSIDE(compcv) = temp_cv;
9463             CvPADLIST_set(compcv, temp_padl);
9464             CvSTART(cv) = CvSTART(compcv);
9465             CvSTART(compcv) = cvstart;
9466             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9467             CvFLAGS(compcv) |= other_flags;
9468
9469             if (CvFILE(cv) && CvDYNFILE(cv)) {
9470                 Safefree(CvFILE(cv));
9471             }
9472
9473             /* inner references to compcv must be fixed up ... */
9474             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9475             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9476                 ++PL_sub_generation;
9477         }
9478         else {
9479             /* Might have had built-in attributes applied -- propagate them. */
9480             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9481         }
9482         /* ... before we throw it away */
9483         SvREFCNT_dec(compcv);
9484         PL_compcv = compcv = cv;
9485     }
9486     else {
9487         cv = compcv;
9488         *spot = cv;
9489     }
9490
9491   setname:
9492     CvLEXICAL_on(cv);
9493     if (!CvNAME_HEK(cv)) {
9494         if (hek) (void)share_hek_hek(hek);
9495         else {
9496             dVAR;
9497             U32 hash;
9498             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9499             hek = share_hek(PadnamePV(name)+1,
9500                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9501                       hash);
9502         }
9503         CvNAME_HEK_set(cv, hek);
9504     }
9505
9506     if (const_sv)
9507         goto clone;
9508
9509     CvFILE_set_from_cop(cv, PL_curcop);
9510     CvSTASH_set(cv, PL_curstash);
9511
9512     if (ps) {
9513         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9514         if (ps_utf8)
9515             SvUTF8_on(MUTABLE_SV(cv));
9516     }
9517
9518     if (block) {
9519         /* If we assign an optree to a PVCV, then we've defined a
9520          * subroutine that the debugger could be able to set a breakpoint
9521          * in, so signal to pp_entereval that it should not throw away any
9522          * saved lines at scope exit.  */
9523
9524         PL_breakable_sub_gen++;
9525         CvROOT(cv) = block;
9526         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9527            itself has a refcount. */
9528         CvSLABBED_off(cv);
9529         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9530 #ifdef PERL_DEBUG_READONLY_OPS
9531         slab = (OPSLAB *)CvSTART(cv);
9532 #endif
9533         S_process_optree(aTHX_ cv, block, start);
9534     }
9535
9536   attrs:
9537     if (attrs) {
9538         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9539         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9540     }
9541
9542     if (block) {
9543         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9544             SV * const tmpstr = sv_newmortal();
9545             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9546                                                   GV_ADDMULTI, SVt_PVHV);
9547             HV *hv;
9548             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9549                                           CopFILE(PL_curcop),
9550                                           (long)PL_subline,
9551                                           (long)CopLINE(PL_curcop));
9552             if (HvNAME_HEK(PL_curstash)) {
9553                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9554                 sv_catpvs(tmpstr, "::");
9555             }
9556             else
9557                 sv_setpvs(tmpstr, "__ANON__::");
9558
9559             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9560                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9561             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9562                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9563             hv = GvHVn(db_postponed);
9564             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9565                 CV * const pcv = GvCV(db_postponed);
9566                 if (pcv) {
9567                     dSP;
9568                     PUSHMARK(SP);
9569                     XPUSHs(tmpstr);
9570                     PUTBACK;
9571                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9572                 }
9573             }
9574         }
9575     }
9576
9577   clone:
9578     if (clonee) {
9579         assert(CvDEPTH(outcv));
9580         spot = (CV **)
9581             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9582         if (reusable)
9583             cv_clone_into(clonee, *spot);
9584         else *spot = cv_clone(clonee);
9585         SvREFCNT_dec_NN(clonee);
9586         cv = *spot;
9587     }
9588
9589     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9590         PADOFFSET depth = CvDEPTH(outcv);
9591         while (--depth) {
9592             SV *oldcv;
9593             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9594             oldcv = *svspot;
9595             *svspot = SvREFCNT_inc_simple_NN(cv);
9596             SvREFCNT_dec(oldcv);
9597         }
9598     }
9599
9600   done:
9601     if (PL_parser)
9602         PL_parser->copline = NOLINE;
9603     LEAVE_SCOPE(floor);
9604 #ifdef PERL_DEBUG_READONLY_OPS
9605     if (slab)
9606         Slab_to_ro(slab);
9607 #endif
9608     op_free(o);
9609     return cv;
9610 }
9611
9612 /*
9613 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9614
9615 Construct a Perl subroutine, also performing some surrounding jobs.
9616
9617 This function is expected to be called in a Perl compilation context,
9618 and some aspects of the subroutine are taken from global variables
9619 associated with compilation.  In particular, C<PL_compcv> represents
9620 the subroutine that is currently being compiled.  It must be non-null
9621 when this function is called, and some aspects of the subroutine being
9622 constructed are taken from it.  The constructed subroutine may actually
9623 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9624
9625 If C<block> is null then the subroutine will have no body, and for the
9626 time being it will be an error to call it.  This represents a forward
9627 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9628 non-null then it provides the Perl code of the subroutine body, which
9629 will be executed when the subroutine is called.  This body includes
9630 any argument unwrapping code resulting from a subroutine signature or
9631 similar.  The pad use of the code must correspond to the pad attached
9632 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9633 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9634 by this function and will become part of the constructed subroutine.
9635
9636 C<proto> specifies the subroutine's prototype, unless one is supplied
9637 as an attribute (see below).  If C<proto> is null, then the subroutine
9638 will not have a prototype.  If C<proto> is non-null, it must point to a
9639 C<const> op whose value is a string, and the subroutine will have that
9640 string as its prototype.  If a prototype is supplied as an attribute, the
9641 attribute takes precedence over C<proto>, but in that case C<proto> should
9642 preferably be null.  In any case, C<proto> is consumed by this function.
9643
9644 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9645 attributes take effect by built-in means, being applied to C<PL_compcv>
9646 immediately when seen.  Other attributes are collected up and attached
9647 to the subroutine by this route.  C<attrs> may be null to supply no
9648 attributes, or point to a C<const> op for a single attribute, or point
9649 to a C<list> op whose children apart from the C<pushmark> are C<const>
9650 ops for one or more attributes.  Each C<const> op must be a string,
9651 giving the attribute name optionally followed by parenthesised arguments,
9652 in the manner in which attributes appear in Perl source.  The attributes
9653 will be applied to the sub by this function.  C<attrs> is consumed by
9654 this function.
9655
9656 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9657 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9658 must point to a C<const> op, which will be consumed by this function,
9659 and its string value supplies a name for the subroutine.  The name may
9660 be qualified or unqualified, and if it is unqualified then a default
9661 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9662 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9663 by which the subroutine will be named.
9664
9665 If there is already a subroutine of the specified name, then the new
9666 sub will either replace the existing one in the glob or be merged with
9667 the existing one.  A warning may be generated about redefinition.
9668
9669 If the subroutine has one of a few special names, such as C<BEGIN> or
9670 C<END>, then it will be claimed by the appropriate queue for automatic
9671 running of phase-related subroutines.  In this case the relevant glob will
9672 be left not containing any subroutine, even if it did contain one before.
9673 In the case of C<BEGIN>, the subroutine will be executed and the reference
9674 to it disposed of before this function returns.
9675
9676 The function returns a pointer to the constructed subroutine.  If the sub
9677 is anonymous then ownership of one counted reference to the subroutine
9678 is transferred to the caller.  If the sub is named then the caller does
9679 not get ownership of a reference.  In most such cases, where the sub
9680 has a non-phase name, the sub will be alive at the point it is returned
9681 by virtue of being contained in the glob that names it.  A phase-named
9682 subroutine will usually be alive by virtue of the reference owned by the
9683 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9684 been executed, will quite likely have been destroyed already by the
9685 time this function returns, making it erroneous for the caller to make
9686 any use of the returned pointer.  It is the caller's responsibility to
9687 ensure that it knows which of these situations applies.
9688
9689 =cut
9690 */
9691
9692 /* _x = extended */
9693 CV *
9694 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9695                             OP *block, bool o_is_gv)
9696 {
9697     GV *gv;
9698     const char *ps;
9699     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9700     U32 ps_utf8 = 0;
9701     CV *cv = NULL;     /* the previous CV with this name, if any */
9702     SV *const_sv;
9703     const bool ec = PL_parser && PL_parser->error_count;
9704     /* If the subroutine has no body, no attributes, and no builtin attributes
9705        then it's just a sub declaration, and we may be able to get away with
9706        storing with a placeholder scalar in the symbol table, rather than a
9707        full CV.  If anything is present then it will take a full CV to
9708        store it.  */
9709     const I32 gv_fetch_flags
9710         = ec ? GV_NOADD_NOINIT :
9711         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9712         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9713     STRLEN namlen = 0;
9714     const char * const name =
9715          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9716     bool has_name;
9717     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9718     bool evanescent = FALSE;
9719     OP *start = NULL;
9720 #ifdef PERL_DEBUG_READONLY_OPS
9721     OPSLAB *slab = NULL;
9722 #endif
9723
9724     if (o_is_gv) {
9725         gv = (GV*)o;
9726         o = NULL;
9727         has_name = TRUE;
9728     } else if (name) {
9729         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9730            hek and CvSTASH pointer together can imply the GV.  If the name
9731            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9732            CvSTASH, so forego the optimisation if we find any.
9733            Also, we may be called from load_module at run time, so
9734            PL_curstash (which sets CvSTASH) may not point to the stash the
9735            sub is stored in.  */
9736         const I32 flags =
9737            ec ? GV_NOADD_NOINIT
9738               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9739                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9740                     ? gv_fetch_flags
9741                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9742         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9743         has_name = TRUE;
9744     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9745         SV * const sv = sv_newmortal();
9746         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9747                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9748                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9749         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9750         has_name = TRUE;
9751     } else if (PL_curstash) {
9752         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9753         has_name = FALSE;
9754     } else {
9755         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9756         has_name = FALSE;
9757     }
9758
9759     if (!ec) {
9760         if (isGV(gv)) {
9761             move_proto_attr(&proto, &attrs, gv, 0);
9762         } else {
9763             assert(cSVOPo);
9764             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9765         }
9766     }
9767
9768     if (proto) {
9769         assert(proto->op_type == OP_CONST);
9770         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9771         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9772     }
9773     else
9774         ps = NULL;
9775
9776     if (o)
9777         SAVEFREEOP(o);
9778     if (proto)
9779         SAVEFREEOP(proto);
9780     if (attrs)
9781         SAVEFREEOP(attrs);
9782
9783     if (ec) {
9784         op_free(block);
9785
9786         if (name)
9787             SvREFCNT_dec(PL_compcv);
9788         else
9789             cv = PL_compcv;
9790
9791         PL_compcv = 0;
9792         if (name && block) {
9793             const char *s = (char *) my_memrchr(name, ':', namlen);
9794             s = s ? s+1 : name;
9795             if (strEQ(s, "BEGIN")) {
9796                 if (PL_in_eval & EVAL_KEEPERR)
9797                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9798                 else {
9799                     SV * const errsv = ERRSV;
9800                     /* force display of errors found but not reported */
9801                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9802                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9803                 }
9804             }
9805         }
9806         goto done;
9807     }
9808
9809     if (!block && SvTYPE(gv) != SVt_PVGV) {
9810         /* If we are not defining a new sub and the existing one is not a
9811            full GV + CV... */
9812         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9813             /* We are applying attributes to an existing sub, so we need it
9814                upgraded if it is a constant.  */
9815             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9816                 gv_init_pvn(gv, PL_curstash, name, namlen,
9817                             SVf_UTF8 * name_is_utf8);
9818         }
9819         else {                  /* Maybe prototype now, and had at maximum
9820                                    a prototype or const/sub ref before.  */
9821             if (SvTYPE(gv) > SVt_NULL) {
9822                 cv_ckproto_len_flags((const CV *)gv,
9823                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9824                                     ps_len, ps_utf8);
9825             }
9826
9827             if (!SvROK(gv)) {
9828                 if (ps) {
9829                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9830                     if (ps_utf8)
9831                         SvUTF8_on(MUTABLE_SV(gv));
9832                 }
9833                 else
9834                     sv_setiv(MUTABLE_SV(gv), -1);
9835             }
9836
9837             SvREFCNT_dec(PL_compcv);
9838             cv = PL_compcv = NULL;
9839             goto done;
9840         }
9841     }
9842
9843     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9844         ? NULL
9845         : isGV(gv)
9846             ? GvCV(gv)
9847             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9848                 ? (CV *)SvRV(gv)
9849                 : NULL;
9850
9851     if (block) {
9852         assert(PL_parser);
9853         /* This makes sub {}; work as expected.  */
9854         if (block->op_type == OP_STUB) {
9855             const line_t l = PL_parser->copline;
9856             op_free(block);
9857             block = newSTATEOP(0, NULL, 0);
9858             PL_parser->copline = l;
9859         }
9860         block = CvLVALUE(PL_compcv)
9861              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9862                     && (!isGV(gv) || !GvASSUMECV(gv)))
9863                    ? newUNOP(OP_LEAVESUBLV, 0,
9864                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9865                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9866         start = LINKLIST(block);
9867         block->op_next = 0;
9868         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9869             const_sv =
9870                 S_op_const_sv(aTHX_ start, PL_compcv,
9871                                         cBOOL(CvCLONE(PL_compcv)));
9872         else
9873             const_sv = NULL;
9874     }
9875     else
9876         const_sv = NULL;
9877
9878     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
9879         cv_ckproto_len_flags((const CV *)gv,
9880                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9881                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
9882         if (SvROK(gv)) {
9883             /* All the other code for sub redefinition warnings expects the
9884                clobbered sub to be a CV.  Instead of making all those code
9885                paths more complex, just inline the RV version here.  */
9886             const line_t oldline = CopLINE(PL_curcop);
9887             assert(IN_PERL_COMPILETIME);
9888             if (PL_parser && PL_parser->copline != NOLINE)
9889                 /* This ensures that warnings are reported at the first
9890                    line of a redefinition, not the last.  */
9891                 CopLINE_set(PL_curcop, PL_parser->copline);
9892             /* protect against fatal warnings leaking compcv */
9893             SAVEFREESV(PL_compcv);
9894
9895             if (ckWARN(WARN_REDEFINE)
9896              || (  ckWARN_d(WARN_REDEFINE)
9897                 && (  !const_sv || SvRV(gv) == const_sv
9898                    || sv_cmp(SvRV(gv), const_sv)  ))) {
9899                 assert(cSVOPo);
9900                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9901                           "Constant subroutine %" SVf " redefined",
9902                           SVfARG(cSVOPo->op_sv));
9903             }
9904
9905             SvREFCNT_inc_simple_void_NN(PL_compcv);
9906             CopLINE_set(PL_curcop, oldline);
9907             SvREFCNT_dec(SvRV(gv));
9908         }
9909     }
9910
9911     if (cv) {
9912         const bool exists = CvROOT(cv) || CvXSUB(cv);
9913
9914         /* if the subroutine doesn't exist and wasn't pre-declared
9915          * with a prototype, assume it will be AUTOLOADed,
9916          * skipping the prototype check
9917          */
9918         if (exists || SvPOK(cv))
9919             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
9920         /* already defined (or promised)? */
9921         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
9922             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
9923             if (block)
9924                 cv = NULL;
9925             else {
9926                 if (attrs)
9927                     goto attrs;
9928                 /* just a "sub foo;" when &foo is already defined */
9929                 SAVEFREESV(PL_compcv);
9930                 goto done;
9931             }
9932         }
9933     }
9934
9935     if (const_sv) {
9936         SvREFCNT_inc_simple_void_NN(const_sv);
9937         SvFLAGS(const_sv) |= SVs_PADTMP;
9938         if (cv) {
9939             assert(!CvROOT(cv) && !CvCONST(cv));
9940             cv_forget_slab(cv);
9941             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9942             CvXSUBANY(cv).any_ptr = const_sv;
9943             CvXSUB(cv) = const_sv_xsub;
9944             CvCONST_on(cv);
9945             CvISXSUB_on(cv);
9946             PoisonPADLIST(cv);
9947             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9948         }
9949         else {
9950             if (isGV(gv) || CvMETHOD(PL_compcv)) {
9951                 if (name && isGV(gv))
9952                     GvCV_set(gv, NULL);
9953                 cv = newCONSTSUB_flags(
9954                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
9955                     const_sv
9956                 );
9957                 assert(cv);
9958                 assert(SvREFCNT((SV*)cv) != 0);
9959                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
9960             }
9961             else {
9962                 if (!SvROK(gv)) {
9963                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
9964                     prepare_SV_for_RV((SV *)gv);
9965                     SvOK_off((SV *)gv);
9966                     SvROK_on(gv);
9967                 }
9968                 SvRV_set(gv, const_sv);
9969             }
9970         }
9971         op_free(block);
9972         SvREFCNT_dec(PL_compcv);
9973         PL_compcv = NULL;
9974         goto done;
9975     }
9976
9977     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
9978     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
9979         cv = NULL;
9980
9981     if (cv) {                           /* must reuse cv if autoloaded */
9982         /* transfer PL_compcv to cv */
9983         if (block) {
9984             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
9985             PADLIST *const temp_av = CvPADLIST(cv);
9986             CV *const temp_cv = CvOUTSIDE(cv);
9987             const cv_flags_t other_flags =
9988                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9989             OP * const cvstart = CvSTART(cv);
9990
9991             if (isGV(gv)) {
9992                 CvGV_set(cv,gv);
9993                 assert(!CvCVGV_RC(cv));
9994                 assert(CvGV(cv) == gv);
9995             }
9996             else {
9997                 dVAR;
9998                 U32 hash;
9999                 PERL_HASH(hash, name, namlen);
10000                 CvNAME_HEK_set(cv,
10001                                share_hek(name,
10002                                          name_is_utf8
10003                                             ? -(SSize_t)namlen
10004                                             :  (SSize_t)namlen,
10005                                          hash));
10006             }
10007
10008             SvPOK_off(cv);
10009             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10010                                              | CvNAMED(cv);
10011             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10012             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10013             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10014             CvOUTSIDE(PL_compcv) = temp_cv;
10015             CvPADLIST_set(PL_compcv, temp_av);
10016             CvSTART(cv) = CvSTART(PL_compcv);
10017             CvSTART(PL_compcv) = cvstart;
10018             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10019             CvFLAGS(PL_compcv) |= other_flags;
10020
10021             if (CvFILE(cv) && CvDYNFILE(cv)) {
10022                 Safefree(CvFILE(cv));
10023             }
10024             CvFILE_set_from_cop(cv, PL_curcop);
10025             CvSTASH_set(cv, PL_curstash);
10026
10027             /* inner references to PL_compcv must be fixed up ... */
10028             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10029             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10030                 ++PL_sub_generation;
10031         }
10032         else {
10033             /* Might have had built-in attributes applied -- propagate them. */
10034             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10035         }
10036         /* ... before we throw it away */
10037         SvREFCNT_dec(PL_compcv);
10038         PL_compcv = cv;
10039     }
10040     else {
10041         cv = PL_compcv;
10042         if (name && isGV(gv)) {
10043             GvCV_set(gv, cv);
10044             GvCVGEN(gv) = 0;
10045             if (HvENAME_HEK(GvSTASH(gv)))
10046                 /* sub Foo::bar { (shift)+1 } */
10047                 gv_method_changed(gv);
10048         }
10049         else if (name) {
10050             if (!SvROK(gv)) {
10051                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10052                 prepare_SV_for_RV((SV *)gv);
10053                 SvOK_off((SV *)gv);
10054                 SvROK_on(gv);
10055             }
10056             SvRV_set(gv, (SV *)cv);
10057             if (HvENAME_HEK(PL_curstash))
10058                 mro_method_changed_in(PL_curstash);
10059         }
10060     }
10061     assert(cv);
10062     assert(SvREFCNT((SV*)cv) != 0);
10063
10064     if (!CvHASGV(cv)) {
10065         if (isGV(gv))
10066             CvGV_set(cv, gv);
10067         else {
10068             dVAR;
10069             U32 hash;
10070             PERL_HASH(hash, name, namlen);
10071             CvNAME_HEK_set(cv, share_hek(name,
10072                                          name_is_utf8
10073                                             ? -(SSize_t)namlen
10074                                             :  (SSize_t)namlen,
10075                                          hash));
10076         }
10077         CvFILE_set_from_cop(cv, PL_curcop);
10078         CvSTASH_set(cv, PL_curstash);
10079     }
10080
10081     if (ps) {
10082         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10083         if ( ps_utf8 )
10084             SvUTF8_on(MUTABLE_SV(cv));
10085     }
10086
10087     if (block) {
10088         /* If we assign an optree to a PVCV, then we've defined a
10089          * subroutine that the debugger could be able to set a breakpoint
10090          * in, so signal to pp_entereval that it should not throw away any
10091          * saved lines at scope exit.  */
10092
10093         PL_breakable_sub_gen++;
10094         CvROOT(cv) = block;
10095         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10096            itself has a refcount. */
10097         CvSLABBED_off(cv);
10098         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10099 #ifdef PERL_DEBUG_READONLY_OPS
10100         slab = (OPSLAB *)CvSTART(cv);
10101 #endif
10102         S_process_optree(aTHX_ cv, block, start);
10103     }
10104
10105   attrs:
10106     if (attrs) {
10107         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10108         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10109                         ? GvSTASH(CvGV(cv))
10110                         : PL_curstash;
10111         if (!name)
10112             SAVEFREESV(cv);
10113         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10114         if (!name)
10115             SvREFCNT_inc_simple_void_NN(cv);
10116     }
10117
10118     if (block && has_name) {
10119         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10120             SV * const tmpstr = cv_name(cv,NULL,0);
10121             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10122                                                   GV_ADDMULTI, SVt_PVHV);
10123             HV *hv;
10124             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10125                                           CopFILE(PL_curcop),
10126                                           (long)PL_subline,
10127                                           (long)CopLINE(PL_curcop));
10128             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10129                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10130             hv = GvHVn(db_postponed);
10131             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10132                 CV * const pcv = GvCV(db_postponed);
10133                 if (pcv) {
10134                     dSP;
10135                     PUSHMARK(SP);
10136                     XPUSHs(tmpstr);
10137                     PUTBACK;
10138                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10139                 }
10140             }
10141         }
10142
10143         if (name) {
10144             if (PL_parser && PL_parser->error_count)
10145                 clear_special_blocks(name, gv, cv);
10146             else
10147                 evanescent =
10148                     process_special_blocks(floor, name, gv, cv);
10149         }
10150     }
10151     assert(cv);
10152
10153   done:
10154     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10155     if (PL_parser)
10156         PL_parser->copline = NOLINE;
10157     LEAVE_SCOPE(floor);
10158
10159     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10160     if (!evanescent) {
10161 #ifdef PERL_DEBUG_READONLY_OPS
10162     if (slab)
10163         Slab_to_ro(slab);
10164 #endif
10165     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10166         pad_add_weakref(cv);
10167     }
10168     return cv;
10169 }
10170
10171 STATIC void
10172 S_clear_special_blocks(pTHX_ const char *const fullname,
10173                        GV *const gv, CV *const cv) {
10174     const char *colon;
10175     const char *name;
10176
10177     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10178
10179     colon = strrchr(fullname,':');
10180     name = colon ? colon + 1 : fullname;
10181
10182     if ((*name == 'B' && strEQ(name, "BEGIN"))
10183         || (*name == 'E' && strEQ(name, "END"))
10184         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10185         || (*name == 'C' && strEQ(name, "CHECK"))
10186         || (*name == 'I' && strEQ(name, "INIT"))) {
10187         if (!isGV(gv)) {
10188             (void)CvGV(cv);
10189             assert(isGV(gv));
10190         }
10191         GvCV_set(gv, NULL);
10192         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10193     }
10194 }
10195
10196 /* Returns true if the sub has been freed.  */
10197 STATIC bool
10198 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10199                          GV *const gv,
10200                          CV *const cv)
10201 {
10202     const char *const colon = strrchr(fullname,':');
10203     const char *const name = colon ? colon + 1 : fullname;
10204
10205     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10206
10207     if (*name == 'B') {
10208         if (strEQ(name, "BEGIN")) {
10209             const I32 oldscope = PL_scopestack_ix;
10210             dSP;
10211             (void)CvGV(cv);
10212             if (floor) LEAVE_SCOPE(floor);
10213             ENTER;
10214             PUSHSTACKi(PERLSI_REQUIRE);
10215             SAVECOPFILE(&PL_compiling);
10216             SAVECOPLINE(&PL_compiling);
10217             SAVEVPTR(PL_curcop);
10218
10219             DEBUG_x( dump_sub(gv) );
10220             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10221             GvCV_set(gv,0);             /* cv has been hijacked */
10222             call_list(oldscope, PL_beginav);
10223
10224             POPSTACK;
10225             LEAVE;
10226             return !PL_savebegin;
10227         }
10228         else
10229             return FALSE;
10230     } else {
10231         if (*name == 'E') {
10232             if strEQ(name, "END") {
10233                 DEBUG_x( dump_sub(gv) );
10234                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10235             } else
10236                 return FALSE;
10237         } else if (*name == 'U') {
10238             if (strEQ(name, "UNITCHECK")) {
10239                 /* It's never too late to run a unitcheck block */
10240                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10241             }
10242             else
10243                 return FALSE;
10244         } else if (*name == 'C') {
10245             if (strEQ(name, "CHECK")) {
10246                 if (PL_main_start)
10247                     /* diag_listed_as: Too late to run %s block */
10248                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10249                                    "Too late to run CHECK block");
10250                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10251             }
10252             else
10253                 return FALSE;
10254         } else if (*name == 'I') {
10255             if (strEQ(name, "INIT")) {
10256                 if (PL_main_start)
10257                     /* diag_listed_as: Too late to run %s block */
10258                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10259                                    "Too late to run INIT block");
10260                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10261             }
10262             else
10263                 return FALSE;
10264         } else
10265             return FALSE;
10266         DEBUG_x( dump_sub(gv) );
10267         (void)CvGV(cv);
10268         GvCV_set(gv,0);         /* cv has been hijacked */
10269         return FALSE;
10270     }
10271 }
10272
10273 /*
10274 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10275
10276 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10277 rather than of counted length, and no flags are set.  (This means that
10278 C<name> is always interpreted as Latin-1.)
10279
10280 =cut
10281 */
10282
10283 CV *
10284 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10285 {
10286     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10287 }
10288
10289 /*
10290 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10291
10292 Construct a constant subroutine, also performing some surrounding
10293 jobs.  A scalar constant-valued subroutine is eligible for inlining
10294 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10295 123 }>>.  Other kinds of constant subroutine have other treatment.
10296
10297 The subroutine will have an empty prototype and will ignore any arguments
10298 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10299 is null, the subroutine will yield an empty list.  If C<sv> points to a
10300 scalar, the subroutine will always yield that scalar.  If C<sv> points
10301 to an array, the subroutine will always yield a list of the elements of
10302 that array in list context, or the number of elements in the array in
10303 scalar context.  This function takes ownership of one counted reference
10304 to the scalar or array, and will arrange for the object to live as long
10305 as the subroutine does.  If C<sv> points to a scalar then the inlining
10306 assumes that the value of the scalar will never change, so the caller
10307 must ensure that the scalar is not subsequently written to.  If C<sv>
10308 points to an array then no such assumption is made, so it is ostensibly
10309 safe to mutate the array or its elements, but whether this is really
10310 supported has not been determined.
10311
10312 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10313 Other aspects of the subroutine will be left in their default state.
10314 The caller is free to mutate the subroutine beyond its initial state
10315 after this function has returned.
10316
10317 If C<name> is null then the subroutine will be anonymous, with its
10318 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10319 subroutine will be named accordingly, referenced by the appropriate glob.
10320 C<name> is a string of length C<len> bytes giving a sigilless symbol
10321 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10322 otherwise.  The name may be either qualified or unqualified.  If the
10323 name is unqualified then it defaults to being in the stash specified by
10324 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10325 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10326 semantics.
10327
10328 C<flags> should not have bits set other than C<SVf_UTF8>.
10329
10330 If there is already a subroutine of the specified name, then the new sub
10331 will replace the existing one in the glob.  A warning may be generated
10332 about the redefinition.
10333
10334 If the subroutine has one of a few special names, such as C<BEGIN> or
10335 C<END>, then it will be claimed by the appropriate queue for automatic
10336 running of phase-related subroutines.  In this case the relevant glob will
10337 be left not containing any subroutine, even if it did contain one before.
10338 Execution of the subroutine will likely be a no-op, unless C<sv> was
10339 a tied array or the caller modified the subroutine in some interesting
10340 way before it was executed.  In the case of C<BEGIN>, the treatment is
10341 buggy: the sub will be executed when only half built, and may be deleted
10342 prematurely, possibly causing a crash.
10343
10344 The function returns a pointer to the constructed subroutine.  If the sub
10345 is anonymous then ownership of one counted reference to the subroutine
10346 is transferred to the caller.  If the sub is named then the caller does
10347 not get ownership of a reference.  In most such cases, where the sub
10348 has a non-phase name, the sub will be alive at the point it is returned
10349 by virtue of being contained in the glob that names it.  A phase-named
10350 subroutine will usually be alive by virtue of the reference owned by
10351 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10352 destroyed already by the time this function returns, but currently bugs
10353 occur in that case before the caller gets control.  It is the caller's
10354 responsibility to ensure that it knows which of these situations applies.
10355
10356 =cut
10357 */
10358
10359 CV *
10360 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10361                              U32 flags, SV *sv)
10362 {
10363     CV* cv;
10364     const char *const file = CopFILE(PL_curcop);
10365
10366     ENTER;
10367
10368     if (IN_PERL_RUNTIME) {
10369         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10370          * an op shared between threads. Use a non-shared COP for our
10371          * dirty work */
10372          SAVEVPTR(PL_curcop);
10373          SAVECOMPILEWARNINGS();
10374          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10375          PL_curcop = &PL_compiling;
10376     }
10377     SAVECOPLINE(PL_curcop);
10378     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10379
10380     SAVEHINTS();
10381     PL_hints &= ~HINT_BLOCK_SCOPE;
10382
10383     if (stash) {
10384         SAVEGENERICSV(PL_curstash);
10385         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10386     }
10387
10388     /* Protect sv against leakage caused by fatal warnings. */
10389     if (sv) SAVEFREESV(sv);
10390
10391     /* file becomes the CvFILE. For an XS, it's usually static storage,
10392        and so doesn't get free()d.  (It's expected to be from the C pre-
10393        processor __FILE__ directive). But we need a dynamically allocated one,
10394        and we need it to get freed.  */
10395     cv = newXS_len_flags(name, len,
10396                          sv && SvTYPE(sv) == SVt_PVAV
10397                              ? const_av_xsub
10398                              : const_sv_xsub,
10399                          file ? file : "", "",
10400                          &sv, XS_DYNAMIC_FILENAME | flags);
10401     assert(cv);
10402     assert(SvREFCNT((SV*)cv) != 0);
10403     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10404     CvCONST_on(cv);
10405
10406     LEAVE;
10407
10408     return cv;
10409 }
10410
10411 /*
10412 =for apidoc U||newXS
10413
10414 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10415 static storage, as it is used directly as CvFILE(), without a copy being made.
10416
10417 =cut
10418 */
10419
10420 CV *
10421 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10422 {
10423     PERL_ARGS_ASSERT_NEWXS;
10424     return newXS_len_flags(
10425         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10426     );
10427 }
10428
10429 CV *
10430 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10431                  const char *const filename, const char *const proto,
10432                  U32 flags)
10433 {
10434     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10435     return newXS_len_flags(
10436        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10437     );
10438 }
10439
10440 CV *
10441 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10442 {
10443     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10444     return newXS_len_flags(
10445         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10446     );
10447 }
10448
10449 /*
10450 =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
10451
10452 Construct an XS subroutine, also performing some surrounding jobs.
10453
10454 The subroutine will have the entry point C<subaddr>.  It will have
10455 the prototype specified by the nul-terminated string C<proto>, or
10456 no prototype if C<proto> is null.  The prototype string is copied;
10457 the caller can mutate the supplied string afterwards.  If C<filename>
10458 is non-null, it must be a nul-terminated filename, and the subroutine
10459 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10460 point directly to the supplied string, which must be static.  If C<flags>
10461 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10462 be taken instead.
10463
10464 Other aspects of the subroutine will be left in their default state.
10465 If anything else needs to be done to the subroutine for it to function
10466 correctly, it is the caller's responsibility to do that after this
10467 function has constructed it.  However, beware of the subroutine
10468 potentially being destroyed before this function returns, as described
10469 below.
10470
10471 If C<name> is null then the subroutine will be anonymous, with its
10472 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10473 subroutine will be named accordingly, referenced by the appropriate glob.
10474 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10475 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10476 The name may be either qualified or unqualified, with the stash defaulting
10477 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10478 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10479 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10480 the stash if necessary, with C<GV_ADDMULTI> semantics.
10481
10482 If there is already a subroutine of the specified name, then the new sub
10483 will replace the existing one in the glob.  A warning may be generated
10484 about the redefinition.  If the old subroutine was C<CvCONST> then the
10485 decision about whether to warn is influenced by an expectation about
10486 whether the new subroutine will become a constant of similar value.
10487 That expectation is determined by C<const_svp>.  (Note that the call to
10488 this function doesn't make the new subroutine C<CvCONST> in any case;
10489 that is left to the caller.)  If C<const_svp> is null then it indicates
10490 that the new subroutine will not become a constant.  If C<const_svp>
10491 is non-null then it indicates that the new subroutine will become a
10492 constant, and it points to an C<SV*> that provides the constant value
10493 that the subroutine will have.
10494
10495 If the subroutine has one of a few special names, such as C<BEGIN> or
10496 C<END>, then it will be claimed by the appropriate queue for automatic
10497 running of phase-related subroutines.  In this case the relevant glob will
10498 be left not containing any subroutine, even if it did contain one before.
10499 In the case of C<BEGIN>, the subroutine will be executed and the reference
10500 to it disposed of before this function returns, and also before its
10501 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10502 constructed by this function to be ready for execution then the caller
10503 must prevent this happening by giving the subroutine a different name.
10504
10505 The function returns a pointer to the constructed subroutine.  If the sub
10506 is anonymous then ownership of one counted reference to the subroutine
10507 is transferred to the caller.  If the sub is named then the caller does
10508 not get ownership of a reference.  In most such cases, where the sub
10509 has a non-phase name, the sub will be alive at the point it is returned
10510 by virtue of being contained in the glob that names it.  A phase-named
10511 subroutine will usually be alive by virtue of the reference owned by the
10512 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10513 been executed, will quite likely have been destroyed already by the
10514 time this function returns, making it erroneous for the caller to make
10515 any use of the returned pointer.  It is the caller's responsibility to
10516 ensure that it knows which of these situations applies.
10517
10518 =cut
10519 */
10520
10521 CV *
10522 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10523                            XSUBADDR_t subaddr, const char *const filename,
10524                            const char *const proto, SV **const_svp,
10525                            U32 flags)
10526 {
10527     CV *cv;
10528     bool interleave = FALSE;
10529     bool evanescent = FALSE;
10530
10531     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10532
10533     {
10534         GV * const gv = gv_fetchpvn(
10535                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10536                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10537                                 sizeof("__ANON__::__ANON__") - 1,
10538                             GV_ADDMULTI | flags, SVt_PVCV);
10539
10540         if ((cv = (name ? GvCV(gv) : NULL))) {
10541             if (GvCVGEN(gv)) {
10542                 /* just a cached method */
10543                 SvREFCNT_dec(cv);
10544                 cv = NULL;
10545             }
10546             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10547                 /* already defined (or promised) */
10548                 /* Redundant check that allows us to avoid creating an SV
10549                    most of the time: */
10550                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10551                     report_redefined_cv(newSVpvn_flags(
10552                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10553                                         ),
10554                                         cv, const_svp);
10555                 }
10556                 interleave = TRUE;
10557                 ENTER;
10558                 SAVEFREESV(cv);
10559                 cv = NULL;
10560             }
10561         }
10562
10563         if (cv)                         /* must reuse cv if autoloaded */
10564             cv_undef(cv);
10565         else {
10566             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10567             if (name) {
10568                 GvCV_set(gv,cv);
10569                 GvCVGEN(gv) = 0;
10570                 if (HvENAME_HEK(GvSTASH(gv)))
10571                     gv_method_changed(gv); /* newXS */
10572             }
10573         }
10574         assert(cv);
10575         assert(SvREFCNT((SV*)cv) != 0);
10576
10577         CvGV_set(cv, gv);
10578         if(filename) {
10579             /* XSUBs can't be perl lang/perl5db.pl debugged
10580             if (PERLDB_LINE_OR_SAVESRC)
10581                 (void)gv_fetchfile(filename); */
10582             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10583             if (flags & XS_DYNAMIC_FILENAME) {
10584                 CvDYNFILE_on(cv);
10585                 CvFILE(cv) = savepv(filename);
10586             } else {
10587             /* NOTE: not copied, as it is expected to be an external constant string */
10588                 CvFILE(cv) = (char *)filename;
10589             }
10590         } else {
10591             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10592             CvFILE(cv) = (char*)PL_xsubfilename;
10593         }
10594         CvISXSUB_on(cv);
10595         CvXSUB(cv) = subaddr;
10596 #ifndef PERL_IMPLICIT_CONTEXT
10597         CvHSCXT(cv) = &PL_stack_sp;
10598 #else
10599         PoisonPADLIST(cv);
10600 #endif
10601
10602         if (name)
10603             evanescent = process_special_blocks(0, name, gv, cv);
10604         else
10605             CvANON_on(cv);
10606     } /* <- not a conditional branch */
10607
10608     assert(cv);
10609     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10610
10611     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10612     if (interleave) LEAVE;
10613     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10614     return cv;
10615 }
10616
10617 CV *
10618 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10619 {
10620     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10621     GV *cvgv;
10622     PERL_ARGS_ASSERT_NEWSTUB;
10623     assert(!GvCVu(gv));
10624     GvCV_set(gv, cv);
10625     GvCVGEN(gv) = 0;
10626     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10627         gv_method_changed(gv);
10628     if (SvFAKE(gv)) {
10629         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10630         SvFAKE_off(cvgv);
10631     }
10632     else cvgv = gv;
10633     CvGV_set(cv, cvgv);
10634     CvFILE_set_from_cop(cv, PL_curcop);
10635     CvSTASH_set(cv, PL_curstash);
10636     GvMULTI_on(gv);
10637     return cv;
10638 }
10639
10640 void
10641 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10642 {
10643     CV *cv;
10644     GV *gv;
10645     OP *root;
10646     OP *start;
10647
10648     if (PL_parser && PL_parser->error_count) {
10649         op_free(block);
10650         goto finish;
10651     }
10652
10653     gv = o
10654         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10655         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10656
10657     GvMULTI_on(gv);
10658     if ((cv = GvFORM(gv))) {
10659         if (ckWARN(WARN_REDEFINE)) {
10660             const line_t oldline = CopLINE(PL_curcop);
10661             if (PL_parser && PL_parser->copline != NOLINE)
10662                 CopLINE_set(PL_curcop, PL_parser->copline);
10663             if (o) {
10664                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10665                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10666             } else {
10667                 /* diag_listed_as: Format %s redefined */
10668                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10669                             "Format STDOUT redefined");
10670             }
10671             CopLINE_set(PL_curcop, oldline);
10672         }
10673         SvREFCNT_dec(cv);
10674     }
10675     cv = PL_compcv;
10676     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10677     CvGV_set(cv, gv);
10678     CvFILE_set_from_cop(cv, PL_curcop);
10679
10680
10681     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10682     CvROOT(cv) = root;
10683     start = LINKLIST(root);
10684     root->op_next = 0;
10685     S_process_optree(aTHX_ cv, root, start);
10686     cv_forget_slab(cv);
10687
10688   finish:
10689     op_free(o);
10690     if (PL_parser)
10691         PL_parser->copline = NOLINE;
10692     LEAVE_SCOPE(floor);
10693     PL_compiling.cop_seq = 0;
10694 }
10695
10696 OP *
10697 Perl_newANONLIST(pTHX_ OP *o)
10698 {
10699     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10700 }
10701
10702 OP *
10703 Perl_newANONHASH(pTHX_ OP *o)
10704 {
10705     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10706 }
10707
10708 OP *
10709 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10710 {
10711     return newANONATTRSUB(floor, proto, NULL, block);
10712 }
10713
10714 OP *
10715 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10716 {
10717     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10718     OP * anoncode =
10719         newSVOP(OP_ANONCODE, 0,
10720                 cv);
10721     if (CvANONCONST(cv))
10722         anoncode = newUNOP(OP_ANONCONST, 0,
10723                            op_convert_list(OP_ENTERSUB,
10724                                            OPf_STACKED|OPf_WANT_SCALAR,
10725                                            anoncode));
10726     return newUNOP(OP_REFGEN, 0, anoncode);
10727 }
10728
10729 OP *
10730 Perl_oopsAV(pTHX_ OP *o)
10731 {
10732     dVAR;
10733
10734     PERL_ARGS_ASSERT_OOPSAV;
10735
10736     switch (o->op_type) {
10737     case OP_PADSV:
10738     case OP_PADHV:
10739         OpTYPE_set(o, OP_PADAV);
10740         return ref(o, OP_RV2AV);
10741
10742     case OP_RV2SV:
10743     case OP_RV2HV:
10744         OpTYPE_set(o, OP_RV2AV);
10745         ref(o, OP_RV2AV);
10746         break;
10747
10748     default:
10749         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10750         break;
10751     }
10752     return o;
10753 }
10754
10755 OP *
10756 Perl_oopsHV(pTHX_ OP *o)
10757 {
10758     dVAR;
10759
10760     PERL_ARGS_ASSERT_OOPSHV;
10761
10762     switch (o->op_type) {
10763     case OP_PADSV:
10764     case OP_PADAV:
10765         OpTYPE_set(o, OP_PADHV);
10766         return ref(o, OP_RV2HV);
10767
10768     case OP_RV2SV:
10769     case OP_RV2AV:
10770         OpTYPE_set(o, OP_RV2HV);
10771         /* rv2hv steals the bottom bit for its own uses */
10772         o->op_private &= ~OPpARG1_MASK;
10773         ref(o, OP_RV2HV);
10774         break;
10775
10776     default:
10777         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10778         break;
10779     }
10780     return o;
10781 }
10782
10783 OP *
10784 Perl_newAVREF(pTHX_ OP *o)
10785 {
10786     dVAR;
10787
10788     PERL_ARGS_ASSERT_NEWAVREF;
10789
10790     if (o->op_type == OP_PADANY) {
10791         OpTYPE_set(o, OP_PADAV);
10792         return o;
10793     }
10794     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10795         Perl_croak(aTHX_ "Can't use an array as a reference");
10796     }
10797     return newUNOP(OP_RV2AV, 0, scalar(o));
10798 }
10799
10800 OP *
10801 Perl_newGVREF(pTHX_ I32 type, OP *o)
10802 {
10803     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10804         return newUNOP(OP_NULL, 0, o);
10805     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10806 }
10807
10808 OP *
10809 Perl_newHVREF(pTHX_ OP *o)
10810 {
10811     dVAR;
10812
10813     PERL_ARGS_ASSERT_NEWHVREF;
10814
10815     if (o->op_type == OP_PADANY) {
10816         OpTYPE_set(o, OP_PADHV);
10817         return o;
10818     }
10819     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10820         Perl_croak(aTHX_ "Can't use a hash as a reference");
10821     }
10822     return newUNOP(OP_RV2HV, 0, scalar(o));
10823 }
10824
10825 OP *
10826 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10827 {
10828     if (o->op_type == OP_PADANY) {
10829         dVAR;
10830         OpTYPE_set(o, OP_PADCV);
10831     }
10832     return newUNOP(OP_RV2CV, flags, scalar(o));
10833 }
10834
10835 OP *
10836 Perl_newSVREF(pTHX_ OP *o)
10837 {
10838     dVAR;
10839
10840     PERL_ARGS_ASSERT_NEWSVREF;
10841
10842     if (o->op_type == OP_PADANY) {
10843         OpTYPE_set(o, OP_PADSV);
10844         scalar(o);
10845         return o;
10846     }
10847     return newUNOP(OP_RV2SV, 0, scalar(o));
10848 }
10849
10850 /* Check routines. See the comments at the top of this file for details
10851  * on when these are called */
10852
10853 OP *
10854 Perl_ck_anoncode(pTHX_ OP *o)
10855 {
10856     PERL_ARGS_ASSERT_CK_ANONCODE;
10857
10858     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10859     cSVOPo->op_sv = NULL;
10860     return o;
10861 }
10862
10863 static void
10864 S_io_hints(pTHX_ OP *o)
10865 {
10866 #if O_BINARY != 0 || O_TEXT != 0
10867     HV * const table =
10868         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10869     if (table) {
10870         SV **svp = hv_fetchs(table, "open_IN", FALSE);
10871         if (svp && *svp) {
10872             STRLEN len = 0;
10873             const char *d = SvPV_const(*svp, len);
10874             const I32 mode = mode_from_discipline(d, len);
10875             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10876 #  if O_BINARY != 0
10877             if (mode & O_BINARY)
10878                 o->op_private |= OPpOPEN_IN_RAW;
10879 #  endif
10880 #  if O_TEXT != 0
10881             if (mode & O_TEXT)
10882                 o->op_private |= OPpOPEN_IN_CRLF;
10883 #  endif
10884         }
10885
10886         svp = hv_fetchs(table, "open_OUT", FALSE);
10887         if (svp && *svp) {
10888             STRLEN len = 0;
10889             const char *d = SvPV_const(*svp, len);
10890             const I32 mode = mode_from_discipline(d, len);
10891             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10892 #  if O_BINARY != 0
10893             if (mode & O_BINARY)
10894                 o->op_private |= OPpOPEN_OUT_RAW;
10895 #  endif
10896 #  if O_TEXT != 0
10897             if (mode & O_TEXT)
10898                 o->op_private |= OPpOPEN_OUT_CRLF;
10899 #  endif
10900         }
10901     }
10902 #else
10903     PERL_UNUSED_CONTEXT;
10904     PERL_UNUSED_ARG(o);
10905 #endif
10906 }
10907
10908 OP *
10909 Perl_ck_backtick(pTHX_ OP *o)
10910 {
10911     GV *gv;
10912     OP *newop = NULL;
10913     OP *sibl;
10914     PERL_ARGS_ASSERT_CK_BACKTICK;
10915     o = ck_fun(o);
10916     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
10917     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
10918      && (gv = gv_override("readpipe",8)))
10919     {
10920         /* detach rest of siblings from o and its first child */
10921         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10922         newop = S_new_entersubop(aTHX_ gv, sibl);
10923     }
10924     else if (!(o->op_flags & OPf_KIDS))
10925         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
10926     if (newop) {
10927         op_free(o);
10928         return newop;
10929     }
10930     S_io_hints(aTHX_ o);
10931     return o;
10932 }
10933
10934 OP *
10935 Perl_ck_bitop(pTHX_ OP *o)
10936 {
10937     PERL_ARGS_ASSERT_CK_BITOP;
10938
10939     o->op_private = (U8)(PL_hints & HINT_INTEGER);
10940
10941     if (o->op_type == OP_NBIT_OR     || o->op_type == OP_SBIT_OR
10942      || o->op_type == OP_NBIT_XOR    || o->op_type == OP_SBIT_XOR
10943      || o->op_type == OP_NBIT_AND    || o->op_type == OP_SBIT_AND
10944      || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
10945         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
10946                               "The bitwise feature is experimental");
10947     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
10948             && OP_IS_INFIX_BIT(o->op_type))
10949     {
10950         const OP * const left = cBINOPo->op_first;
10951         const OP * const right = OpSIBLING(left);
10952         if ((OP_IS_NUMCOMPARE(left->op_type) &&
10953                 (left->op_flags & OPf_PARENS) == 0) ||
10954             (OP_IS_NUMCOMPARE(right->op_type) &&
10955                 (right->op_flags & OPf_PARENS) == 0))
10956             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
10957                           "Possible precedence problem on bitwise %s operator",
10958                            o->op_type ==  OP_BIT_OR
10959                          ||o->op_type == OP_NBIT_OR  ? "|"
10960                         :  o->op_type ==  OP_BIT_AND
10961                          ||o->op_type == OP_NBIT_AND ? "&"
10962                         :  o->op_type ==  OP_BIT_XOR
10963                          ||o->op_type == OP_NBIT_XOR ? "^"
10964                         :  o->op_type == OP_SBIT_OR  ? "|."
10965                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
10966                            );
10967     }
10968     return o;
10969 }
10970
10971 PERL_STATIC_INLINE bool
10972 is_dollar_bracket(pTHX_ const OP * const o)
10973 {
10974     const OP *kid;
10975     PERL_UNUSED_CONTEXT;
10976     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
10977         && (kid = cUNOPx(o)->op_first)
10978         && kid->op_type == OP_GV
10979         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
10980 }
10981
10982 /* for lt, gt, le, ge, eq, ne and their i_ variants */
10983
10984 OP *
10985 Perl_ck_cmp(pTHX_ OP *o)
10986 {
10987     bool is_eq;
10988     bool neg;
10989     bool reverse;
10990     bool iv0;
10991     OP *indexop, *constop, *start;
10992     SV *sv;
10993     IV iv;
10994
10995     PERL_ARGS_ASSERT_CK_CMP;
10996
10997     is_eq = (   o->op_type == OP_EQ
10998              || o->op_type == OP_NE
10999              || o->op_type == OP_I_EQ
11000              || o->op_type == OP_I_NE);
11001
11002     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11003         const OP *kid = cUNOPo->op_first;
11004         if (kid &&
11005             (
11006                 (   is_dollar_bracket(aTHX_ kid)
11007                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11008                 )
11009              || (   kid->op_type == OP_CONST
11010                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11011                 )
11012            )
11013         )
11014             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11015                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11016     }
11017
11018     /* convert (index(...) == -1) and variations into
11019      *   (r)index/BOOL(,NEG)
11020      */
11021
11022     reverse = FALSE;
11023
11024     indexop = cUNOPo->op_first;
11025     constop = OpSIBLING(indexop);
11026     start = NULL;
11027     if (indexop->op_type == OP_CONST) {
11028         constop = indexop;
11029         indexop = OpSIBLING(constop);
11030         start = constop;
11031         reverse = TRUE;
11032     }
11033
11034     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11035         return o;
11036
11037     /* ($lex = index(....)) == -1 */
11038     if (indexop->op_private & OPpTARGET_MY)
11039         return o;
11040
11041     if (constop->op_type != OP_CONST)
11042         return o;
11043
11044     sv = cSVOPx_sv(constop);
11045     if (!(sv && SvIOK_notUV(sv)))
11046         return o;
11047
11048     iv = SvIVX(sv);
11049     if (iv != -1 && iv != 0)
11050         return o;
11051     iv0 = (iv == 0);
11052
11053     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11054         if (!(iv0 ^ reverse))
11055             return o;
11056         neg = iv0;
11057     }
11058     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11059         if (iv0 ^ reverse)
11060             return o;
11061         neg = !iv0;
11062     }
11063     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11064         if (!(iv0 ^ reverse))
11065             return o;
11066         neg = !iv0;
11067     }
11068     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11069         if (iv0 ^ reverse)
11070             return o;
11071         neg = iv0;
11072     }
11073     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11074         if (iv0)
11075             return o;
11076         neg = TRUE;
11077     }
11078     else {
11079         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11080         if (iv0)
11081             return o;
11082         neg = FALSE;
11083     }
11084
11085     indexop->op_flags &= ~OPf_PARENS;
11086     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11087     indexop->op_private |= OPpTRUEBOOL;
11088     if (neg)
11089         indexop->op_private |= OPpINDEX_BOOLNEG;
11090     /* cut out the index op and free the eq,const ops */
11091     (void)op_sibling_splice(o, start, 1, NULL);
11092     op_free(o);
11093
11094     return indexop;
11095 }
11096
11097
11098 OP *
11099 Perl_ck_concat(pTHX_ OP *o)
11100 {
11101     const OP * const kid = cUNOPo->op_first;
11102
11103     PERL_ARGS_ASSERT_CK_CONCAT;
11104     PERL_UNUSED_CONTEXT;
11105
11106     /* reuse the padtmp returned by the concat child */
11107     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11108             !(kUNOP->op_first->op_flags & OPf_MOD))
11109     {
11110         o->op_flags |= OPf_STACKED;
11111         o->op_private |= OPpCONCAT_NESTED;
11112     }
11113     return o;
11114 }
11115
11116 OP *
11117 Perl_ck_spair(pTHX_ OP *o)
11118 {
11119     dVAR;
11120
11121     PERL_ARGS_ASSERT_CK_SPAIR;
11122
11123     if (o->op_flags & OPf_KIDS) {
11124         OP* newop;
11125         OP* kid;
11126         OP* kidkid;
11127         const OPCODE type = o->op_type;
11128         o = modkids(ck_fun(o), type);
11129         kid    = cUNOPo->op_first;
11130         kidkid = kUNOP->op_first;
11131         newop = OpSIBLING(kidkid);
11132         if (newop) {
11133             const OPCODE type = newop->op_type;
11134             if (OpHAS_SIBLING(newop))
11135                 return o;
11136             if (o->op_type == OP_REFGEN
11137              && (  type == OP_RV2CV
11138                 || (  !(newop->op_flags & OPf_PARENS)
11139                    && (  type == OP_RV2AV || type == OP_PADAV
11140                       || type == OP_RV2HV || type == OP_PADHV))))
11141                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11142             else if (OP_GIMME(newop,0) != G_SCALAR)
11143                 return o;
11144         }
11145         /* excise first sibling */
11146         op_sibling_splice(kid, NULL, 1, NULL);
11147         op_free(kidkid);
11148     }
11149     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11150      * and OP_CHOMP into OP_SCHOMP */
11151     o->op_ppaddr = PL_ppaddr[++o->op_type];
11152     return ck_fun(o);
11153 }
11154
11155 OP *
11156 Perl_ck_delete(pTHX_ OP *o)
11157 {
11158     PERL_ARGS_ASSERT_CK_DELETE;
11159
11160     o = ck_fun(o);
11161     o->op_private = 0;
11162     if (o->op_flags & OPf_KIDS) {
11163         OP * const kid = cUNOPo->op_first;
11164         switch (kid->op_type) {
11165         case OP_ASLICE:
11166             o->op_flags |= OPf_SPECIAL;
11167             /* FALLTHROUGH */
11168         case OP_HSLICE:
11169             o->op_private |= OPpSLICE;
11170             break;
11171         case OP_AELEM:
11172             o->op_flags |= OPf_SPECIAL;
11173             /* FALLTHROUGH */
11174         case OP_HELEM:
11175             break;
11176         case OP_KVASLICE:
11177             o->op_flags |= OPf_SPECIAL;
11178             /* FALLTHROUGH */
11179         case OP_KVHSLICE:
11180             o->op_private |= OPpKVSLICE;
11181             break;
11182         default:
11183             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11184                              "element or slice");
11185         }
11186         if (kid->op_private & OPpLVAL_INTRO)
11187             o->op_private |= OPpLVAL_INTRO;
11188         op_null(kid);
11189     }
11190     return o;
11191 }
11192
11193 OP *
11194 Perl_ck_eof(pTHX_ OP *o)
11195 {
11196     PERL_ARGS_ASSERT_CK_EOF;
11197
11198     if (o->op_flags & OPf_KIDS) {
11199         OP *kid;
11200         if (cLISTOPo->op_first->op_type == OP_STUB) {
11201             OP * const newop
11202                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11203             op_free(o);
11204             o = newop;
11205         }
11206         o = ck_fun(o);
11207         kid = cLISTOPo->op_first;
11208         if (kid->op_type == OP_RV2GV)
11209             kid->op_private |= OPpALLOW_FAKE;
11210     }
11211     return o;
11212 }
11213
11214
11215 OP *
11216 Perl_ck_eval(pTHX_ OP *o)
11217 {
11218     dVAR;
11219
11220     PERL_ARGS_ASSERT_CK_EVAL;
11221
11222     PL_hints |= HINT_BLOCK_SCOPE;
11223     if (o->op_flags & OPf_KIDS) {
11224         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11225         assert(kid);
11226
11227         if (o->op_type == OP_ENTERTRY) {
11228             LOGOP *enter;
11229
11230             /* cut whole sibling chain free from o */
11231             op_sibling_splice(o, NULL, -1, NULL);
11232             op_free(o);
11233
11234             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11235
11236             /* establish postfix order */
11237             enter->op_next = (OP*)enter;
11238
11239             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11240             OpTYPE_set(o, OP_LEAVETRY);
11241             enter->op_other = o;
11242             return o;
11243         }
11244         else {
11245             scalar((OP*)kid);
11246             S_set_haseval(aTHX);
11247         }
11248     }
11249     else {
11250         const U8 priv = o->op_private;
11251         op_free(o);
11252         /* the newUNOP will recursively call ck_eval(), which will handle
11253          * all the stuff at the end of this function, like adding
11254          * OP_HINTSEVAL
11255          */
11256         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11257     }
11258     o->op_targ = (PADOFFSET)PL_hints;
11259     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11260     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11261      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11262         /* Store a copy of %^H that pp_entereval can pick up. */
11263         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11264                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11265         /* append hhop to only child  */
11266         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11267
11268         o->op_private |= OPpEVAL_HAS_HH;
11269     }
11270     if (!(o->op_private & OPpEVAL_BYTES)
11271          && FEATURE_UNIEVAL_IS_ENABLED)
11272             o->op_private |= OPpEVAL_UNICODE;
11273     return o;
11274 }
11275
11276 OP *
11277 Perl_ck_exec(pTHX_ OP *o)
11278 {
11279     PERL_ARGS_ASSERT_CK_EXEC;
11280
11281     if (o->op_flags & OPf_STACKED) {
11282         OP *kid;
11283         o = ck_fun(o);
11284         kid = OpSIBLING(cUNOPo->op_first);
11285         if (kid->op_type == OP_RV2GV)
11286             op_null(kid);
11287     }
11288     else
11289         o = listkids(o);
11290     return o;
11291 }
11292
11293 OP *
11294 Perl_ck_exists(pTHX_ OP *o)
11295 {
11296     PERL_ARGS_ASSERT_CK_EXISTS;
11297
11298     o = ck_fun(o);
11299     if (o->op_flags & OPf_KIDS) {
11300         OP * const kid = cUNOPo->op_first;
11301         if (kid->op_type == OP_ENTERSUB) {
11302             (void) ref(kid, o->op_type);
11303             if (kid->op_type != OP_RV2CV
11304                         && !(PL_parser && PL_parser->error_count))
11305                 Perl_croak(aTHX_
11306                           "exists argument is not a subroutine name");
11307             o->op_private |= OPpEXISTS_SUB;
11308         }
11309         else if (kid->op_type == OP_AELEM)
11310             o->op_flags |= OPf_SPECIAL;
11311         else if (kid->op_type != OP_HELEM)
11312             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11313                              "element or a subroutine");
11314         op_null(kid);
11315     }
11316     return o;
11317 }
11318
11319 OP *
11320 Perl_ck_rvconst(pTHX_ OP *o)
11321 {
11322     dVAR;
11323     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11324
11325     PERL_ARGS_ASSERT_CK_RVCONST;
11326
11327     if (o->op_type == OP_RV2HV)
11328         /* rv2hv steals the bottom bit for its own uses */
11329         o->op_private &= ~OPpARG1_MASK;
11330
11331     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11332
11333     if (kid->op_type == OP_CONST) {
11334         int iscv;
11335         GV *gv;
11336         SV * const kidsv = kid->op_sv;
11337
11338         /* Is it a constant from cv_const_sv()? */
11339         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11340             return o;
11341         }
11342         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11343         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11344             const char *badthing;
11345             switch (o->op_type) {
11346             case OP_RV2SV:
11347                 badthing = "a SCALAR";
11348                 break;
11349             case OP_RV2AV:
11350                 badthing = "an ARRAY";
11351                 break;
11352             case OP_RV2HV:
11353                 badthing = "a HASH";
11354                 break;
11355             default:
11356                 badthing = NULL;
11357                 break;
11358             }
11359             if (badthing)
11360                 Perl_croak(aTHX_
11361                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11362                            SVfARG(kidsv), badthing);
11363         }
11364         /*
11365          * This is a little tricky.  We only want to add the symbol if we
11366          * didn't add it in the lexer.  Otherwise we get duplicate strict
11367          * warnings.  But if we didn't add it in the lexer, we must at
11368          * least pretend like we wanted to add it even if it existed before,
11369          * or we get possible typo warnings.  OPpCONST_ENTERED says
11370          * whether the lexer already added THIS instance of this symbol.
11371          */
11372         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11373         gv = gv_fetchsv(kidsv,
11374                 o->op_type == OP_RV2CV
11375                         && o->op_private & OPpMAY_RETURN_CONSTANT
11376                     ? GV_NOEXPAND
11377                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11378                 iscv
11379                     ? SVt_PVCV
11380                     : o->op_type == OP_RV2SV
11381                         ? SVt_PV
11382                         : o->op_type == OP_RV2AV
11383                             ? SVt_PVAV
11384                             : o->op_type == OP_RV2HV
11385                                 ? SVt_PVHV
11386                                 : SVt_PVGV);
11387         if (gv) {
11388             if (!isGV(gv)) {
11389                 assert(iscv);
11390                 assert(SvROK(gv));
11391                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11392                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11393                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11394             }
11395             OpTYPE_set(kid, OP_GV);
11396             SvREFCNT_dec(kid->op_sv);
11397 #ifdef USE_ITHREADS
11398             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11399             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11400             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11401             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11402             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11403 #else
11404             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11405 #endif
11406             kid->op_private = 0;
11407             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11408             SvFAKE_off(gv);
11409         }
11410     }
11411     return o;
11412 }
11413
11414 OP *
11415 Perl_ck_ftst(pTHX_ OP *o)
11416 {
11417     dVAR;
11418     const I32 type = o->op_type;
11419
11420     PERL_ARGS_ASSERT_CK_FTST;
11421
11422     if (o->op_flags & OPf_REF) {
11423         NOOP;
11424     }
11425     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11426         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11427         const OPCODE kidtype = kid->op_type;
11428
11429         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11430          && !kid->op_folded) {
11431             OP * const newop = newGVOP(type, OPf_REF,
11432                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11433             op_free(o);
11434             return newop;
11435         }
11436
11437         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11438             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11439             if (name) {
11440                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11441                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11442                             array_passed_to_stat, name);
11443             }
11444             else {
11445                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11446                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11447             }
11448        }
11449         scalar((OP *) kid);
11450         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11451             o->op_private |= OPpFT_ACCESS;
11452         if (type != OP_STAT && type != OP_LSTAT
11453             && PL_check[kidtype] == Perl_ck_ftst
11454             && kidtype != OP_STAT && kidtype != OP_LSTAT
11455         ) {
11456             o->op_private |= OPpFT_STACKED;
11457             kid->op_private |= OPpFT_STACKING;
11458             if (kidtype == OP_FTTTY && (
11459                    !(kid->op_private & OPpFT_STACKED)
11460                 || kid->op_private & OPpFT_AFTER_t
11461                ))
11462                 o->op_private |= OPpFT_AFTER_t;
11463         }
11464     }
11465     else {
11466         op_free(o);
11467         if (type == OP_FTTTY)
11468             o = newGVOP(type, OPf_REF, PL_stdingv);
11469         else
11470             o = newUNOP(type, 0, newDEFSVOP());
11471     }
11472     return o;
11473 }
11474
11475 OP *
11476 Perl_ck_fun(pTHX_ OP *o)
11477 {
11478     const int type = o->op_type;
11479     I32 oa = PL_opargs[type] >> OASHIFT;
11480
11481     PERL_ARGS_ASSERT_CK_FUN;
11482
11483     if (o->op_flags & OPf_STACKED) {
11484         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11485             oa &= ~OA_OPTIONAL;
11486         else
11487             return no_fh_allowed(o);
11488     }
11489
11490     if (o->op_flags & OPf_KIDS) {
11491         OP *prev_kid = NULL;
11492         OP *kid = cLISTOPo->op_first;
11493         I32 numargs = 0;
11494         bool seen_optional = FALSE;
11495
11496         if (kid->op_type == OP_PUSHMARK ||
11497             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11498         {
11499             prev_kid = kid;
11500             kid = OpSIBLING(kid);
11501         }
11502         if (kid && kid->op_type == OP_COREARGS) {
11503             bool optional = FALSE;
11504             while (oa) {
11505                 numargs++;
11506                 if (oa & OA_OPTIONAL) optional = TRUE;
11507                 oa = oa >> 4;
11508             }
11509             if (optional) o->op_private |= numargs;
11510             return o;
11511         }
11512
11513         while (oa) {
11514             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11515                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11516                     kid = newDEFSVOP();
11517                     /* append kid to chain */
11518                     op_sibling_splice(o, prev_kid, 0, kid);
11519                 }
11520                 seen_optional = TRUE;
11521             }
11522             if (!kid) break;
11523
11524             numargs++;
11525             switch (oa & 7) {
11526             case OA_SCALAR:
11527                 /* list seen where single (scalar) arg expected? */
11528                 if (numargs == 1 && !(oa >> 4)
11529                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11530                 {
11531                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11532                 }
11533                 if (type != OP_DELETE) scalar(kid);
11534                 break;
11535             case OA_LIST:
11536                 if (oa < 16) {
11537                     kid = 0;
11538                     continue;
11539                 }
11540                 else
11541                     list(kid);
11542                 break;
11543             case OA_AVREF:
11544                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11545                     && !OpHAS_SIBLING(kid))
11546                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11547                                    "Useless use of %s with no values",
11548                                    PL_op_desc[type]);
11549
11550                 if (kid->op_type == OP_CONST
11551                       && (  !SvROK(cSVOPx_sv(kid))
11552                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11553                         )
11554                     bad_type_pv(numargs, "array", o, kid);
11555                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11556                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11557                                          PL_op_desc[type]), 0);
11558                 }
11559                 else {
11560                     op_lvalue(kid, type);
11561                 }
11562                 break;
11563             case OA_HVREF:
11564                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11565                     bad_type_pv(numargs, "hash", o, kid);
11566                 op_lvalue(kid, type);
11567                 break;
11568             case OA_CVREF:
11569                 {
11570                     /* replace kid with newop in chain */
11571                     OP * const newop =
11572                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11573                     newop->op_next = newop;
11574                     kid = newop;
11575                 }
11576                 break;
11577             case OA_FILEREF:
11578                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11579                     if (kid->op_type == OP_CONST &&
11580                         (kid->op_private & OPpCONST_BARE))
11581                     {
11582                         OP * const newop = newGVOP(OP_GV, 0,
11583                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11584                         /* replace kid with newop in chain */
11585                         op_sibling_splice(o, prev_kid, 1, newop);
11586                         op_free(kid);
11587                         kid = newop;
11588                     }
11589                     else if (kid->op_type == OP_READLINE) {
11590                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11591                         bad_type_pv(numargs, "HANDLE", o, kid);
11592                     }
11593                     else {
11594                         I32 flags = OPf_SPECIAL;
11595                         I32 priv = 0;
11596                         PADOFFSET targ = 0;
11597
11598                         /* is this op a FH constructor? */
11599                         if (is_handle_constructor(o,numargs)) {
11600                             const char *name = NULL;
11601                             STRLEN len = 0;
11602                             U32 name_utf8 = 0;
11603                             bool want_dollar = TRUE;
11604
11605                             flags = 0;
11606                             /* Set a flag to tell rv2gv to vivify
11607                              * need to "prove" flag does not mean something
11608                              * else already - NI-S 1999/05/07
11609                              */
11610                             priv = OPpDEREF;
11611                             if (kid->op_type == OP_PADSV) {
11612                                 PADNAME * const pn
11613                                     = PAD_COMPNAME_SV(kid->op_targ);
11614                                 name = PadnamePV (pn);
11615                                 len  = PadnameLEN(pn);
11616                                 name_utf8 = PadnameUTF8(pn);
11617                             }
11618                             else if (kid->op_type == OP_RV2SV
11619                                      && kUNOP->op_first->op_type == OP_GV)
11620                             {
11621                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11622                                 name = GvNAME(gv);
11623                                 len = GvNAMELEN(gv);
11624                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11625                             }
11626                             else if (kid->op_type == OP_AELEM
11627                                      || kid->op_type == OP_HELEM)
11628                             {
11629                                  OP *firstop;
11630                                  OP *op = ((BINOP*)kid)->op_first;
11631                                  name = NULL;
11632                                  if (op) {
11633                                       SV *tmpstr = NULL;
11634                                       const char * const a =
11635                                            kid->op_type == OP_AELEM ?
11636                                            "[]" : "{}";
11637                                       if (((op->op_type == OP_RV2AV) ||
11638                                            (op->op_type == OP_RV2HV)) &&
11639                                           (firstop = ((UNOP*)op)->op_first) &&
11640                                           (firstop->op_type == OP_GV)) {
11641                                            /* packagevar $a[] or $h{} */
11642                                            GV * const gv = cGVOPx_gv(firstop);
11643                                            if (gv)
11644                                                 tmpstr =
11645                                                      Perl_newSVpvf(aTHX_
11646                                                                    "%s%c...%c",
11647                                                                    GvNAME(gv),
11648                                                                    a[0], a[1]);
11649                                       }
11650                                       else if (op->op_type == OP_PADAV
11651                                                || op->op_type == OP_PADHV) {
11652                                            /* lexicalvar $a[] or $h{} */
11653                                            const char * const padname =
11654                                                 PAD_COMPNAME_PV(op->op_targ);
11655                                            if (padname)
11656                                                 tmpstr =
11657                                                      Perl_newSVpvf(aTHX_
11658                                                                    "%s%c...%c",
11659                                                                    padname + 1,
11660                                                                    a[0], a[1]);
11661                                       }
11662                                       if (tmpstr) {
11663                                            name = SvPV_const(tmpstr, len);
11664                                            name_utf8 = SvUTF8(tmpstr);
11665                                            sv_2mortal(tmpstr);
11666                                       }
11667                                  }
11668                                  if (!name) {
11669                                       name = "__ANONIO__";
11670                                       len = 10;
11671                                       want_dollar = FALSE;
11672                                  }
11673                                  op_lvalue(kid, type);
11674                             }
11675                             if (name) {
11676                                 SV *namesv;
11677                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11678                                 namesv = PAD_SVl(targ);
11679                                 if (want_dollar && *name != '$')
11680                                     sv_setpvs(namesv, "$");
11681                                 else
11682                                     SvPVCLEAR(namesv);
11683                                 sv_catpvn(namesv, name, len);
11684                                 if ( name_utf8 ) SvUTF8_on(namesv);
11685                             }
11686                         }
11687                         scalar(kid);
11688                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11689                                     OP_RV2GV, flags);
11690                         kid->op_targ = targ;
11691                         kid->op_private |= priv;
11692                     }
11693                 }
11694                 scalar(kid);
11695                 break;
11696             case OA_SCALARREF:
11697                 if ((type == OP_UNDEF || type == OP_POS)
11698                     && numargs == 1 && !(oa >> 4)
11699                     && kid->op_type == OP_LIST)
11700                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11701                 op_lvalue(scalar(kid), type);
11702                 break;
11703             }
11704             oa >>= 4;
11705             prev_kid = kid;
11706             kid = OpSIBLING(kid);
11707         }
11708         /* FIXME - should the numargs or-ing move after the too many
11709          * arguments check? */
11710         o->op_private |= numargs;
11711         if (kid)
11712             return too_many_arguments_pv(o,OP_DESC(o), 0);
11713         listkids(o);
11714     }
11715     else if (PL_opargs[type] & OA_DEFGV) {
11716         /* Ordering of these two is important to keep f_map.t passing.  */
11717         op_free(o);
11718         return newUNOP(type, 0, newDEFSVOP());
11719     }
11720
11721     if (oa) {
11722         while (oa & OA_OPTIONAL)
11723             oa >>= 4;
11724         if (oa && oa != OA_LIST)
11725             return too_few_arguments_pv(o,OP_DESC(o), 0);
11726     }
11727     return o;
11728 }
11729
11730 OP *
11731 Perl_ck_glob(pTHX_ OP *o)
11732 {
11733     GV *gv;
11734
11735     PERL_ARGS_ASSERT_CK_GLOB;
11736
11737     o = ck_fun(o);
11738     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11739         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11740
11741     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11742     {
11743         /* convert
11744          *     glob
11745          *       \ null - const(wildcard)
11746          * into
11747          *     null
11748          *       \ enter
11749          *            \ list
11750          *                 \ mark - glob - rv2cv
11751          *                             |        \ gv(CORE::GLOBAL::glob)
11752          *                             |
11753          *                              \ null - const(wildcard)
11754          */
11755         o->op_flags |= OPf_SPECIAL;
11756         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11757         o = S_new_entersubop(aTHX_ gv, o);
11758         o = newUNOP(OP_NULL, 0, o);
11759         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11760         return o;
11761     }
11762     else o->op_flags &= ~OPf_SPECIAL;
11763 #if !defined(PERL_EXTERNAL_GLOB)
11764     if (!PL_globhook) {
11765         ENTER;
11766         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11767                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11768         LEAVE;
11769     }
11770 #endif /* !PERL_EXTERNAL_GLOB */
11771     gv = (GV *)newSV(0);
11772     gv_init(gv, 0, "", 0, 0);
11773     gv_IOadd(gv);
11774     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11775     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11776     scalarkids(o);
11777     return o;
11778 }
11779
11780 OP *
11781 Perl_ck_grep(pTHX_ OP *o)
11782 {
11783     LOGOP *gwop;
11784     OP *kid;
11785     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11786
11787     PERL_ARGS_ASSERT_CK_GREP;
11788
11789     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11790
11791     if (o->op_flags & OPf_STACKED) {
11792         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11793         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11794             return no_fh_allowed(o);
11795         o->op_flags &= ~OPf_STACKED;
11796     }
11797     kid = OpSIBLING(cLISTOPo->op_first);
11798     if (type == OP_MAPWHILE)
11799         list(kid);
11800     else
11801         scalar(kid);
11802     o = ck_fun(o);
11803     if (PL_parser && PL_parser->error_count)
11804         return o;
11805     kid = OpSIBLING(cLISTOPo->op_first);
11806     if (kid->op_type != OP_NULL)
11807         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11808     kid = kUNOP->op_first;
11809
11810     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11811     kid->op_next = (OP*)gwop;
11812     o->op_private = gwop->op_private = 0;
11813     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11814
11815     kid = OpSIBLING(cLISTOPo->op_first);
11816     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11817         op_lvalue(kid, OP_GREPSTART);
11818
11819     return (OP*)gwop;
11820 }
11821
11822 OP *
11823 Perl_ck_index(pTHX_ OP *o)
11824 {
11825     PERL_ARGS_ASSERT_CK_INDEX;
11826
11827     if (o->op_flags & OPf_KIDS) {
11828         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11829         if (kid)
11830             kid = OpSIBLING(kid);                       /* get past "big" */
11831         if (kid && kid->op_type == OP_CONST) {
11832             const bool save_taint = TAINT_get;
11833             SV *sv = kSVOP->op_sv;
11834             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11835                 && SvOK(sv) && !SvROK(sv))
11836             {
11837                 sv = newSV(0);
11838                 sv_copypv(sv, kSVOP->op_sv);
11839                 SvREFCNT_dec_NN(kSVOP->op_sv);
11840                 kSVOP->op_sv = sv;
11841             }
11842             if (SvOK(sv)) fbm_compile(sv, 0);
11843             TAINT_set(save_taint);
11844 #ifdef NO_TAINT_SUPPORT
11845             PERL_UNUSED_VAR(save_taint);
11846 #endif
11847         }
11848     }
11849     return ck_fun(o);
11850 }
11851
11852 OP *
11853 Perl_ck_lfun(pTHX_ OP *o)
11854 {
11855     const OPCODE type = o->op_type;
11856
11857     PERL_ARGS_ASSERT_CK_LFUN;
11858
11859     return modkids(ck_fun(o), type);
11860 }
11861
11862 OP *
11863 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
11864 {
11865     PERL_ARGS_ASSERT_CK_DEFINED;
11866
11867     if ((o->op_flags & OPf_KIDS)) {
11868         switch (cUNOPo->op_first->op_type) {
11869         case OP_RV2AV:
11870         case OP_PADAV:
11871             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11872                              " (Maybe you should just omit the defined()?)");
11873             NOT_REACHED; /* NOTREACHED */
11874             break;
11875         case OP_RV2HV:
11876         case OP_PADHV:
11877             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11878                              " (Maybe you should just omit the defined()?)");
11879             NOT_REACHED; /* NOTREACHED */
11880             break;
11881         default:
11882             /* no warning */
11883             break;
11884         }
11885     }
11886     return ck_rfun(o);
11887 }
11888
11889 OP *
11890 Perl_ck_readline(pTHX_ OP *o)
11891 {
11892     PERL_ARGS_ASSERT_CK_READLINE;
11893
11894     if (o->op_flags & OPf_KIDS) {
11895          OP *kid = cLISTOPo->op_first;
11896          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11897     }
11898     else {
11899         OP * const newop
11900             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
11901         op_free(o);
11902         return newop;
11903     }
11904     return o;
11905 }
11906
11907 OP *
11908 Perl_ck_rfun(pTHX_ OP *o)
11909 {
11910     const OPCODE type = o->op_type;
11911
11912     PERL_ARGS_ASSERT_CK_RFUN;
11913
11914     return refkids(ck_fun(o), type);
11915 }
11916
11917 OP *
11918 Perl_ck_listiob(pTHX_ OP *o)
11919 {
11920     OP *kid;
11921
11922     PERL_ARGS_ASSERT_CK_LISTIOB;
11923
11924     kid = cLISTOPo->op_first;
11925     if (!kid) {
11926         o = force_list(o, 1);
11927         kid = cLISTOPo->op_first;
11928     }
11929     if (kid->op_type == OP_PUSHMARK)
11930         kid = OpSIBLING(kid);
11931     if (kid && o->op_flags & OPf_STACKED)
11932         kid = OpSIBLING(kid);
11933     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
11934         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
11935          && !kid->op_folded) {
11936             o->op_flags |= OPf_STACKED; /* make it a filehandle */
11937             scalar(kid);
11938             /* replace old const op with new OP_RV2GV parent */
11939             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
11940                                         OP_RV2GV, OPf_REF);
11941             kid = OpSIBLING(kid);
11942         }
11943     }
11944
11945     if (!kid)
11946         op_append_elem(o->op_type, o, newDEFSVOP());
11947
11948     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
11949     return listkids(o);
11950 }
11951
11952 OP *
11953 Perl_ck_smartmatch(pTHX_ OP *o)
11954 {
11955     dVAR;
11956     PERL_ARGS_ASSERT_CK_SMARTMATCH;
11957     if (0 == (o->op_flags & OPf_SPECIAL)) {
11958         OP *first  = cBINOPo->op_first;
11959         OP *second = OpSIBLING(first);
11960
11961         /* Implicitly take a reference to an array or hash */
11962
11963         /* remove the original two siblings, then add back the
11964          * (possibly different) first and second sibs.
11965          */
11966         op_sibling_splice(o, NULL, 1, NULL);
11967         op_sibling_splice(o, NULL, 1, NULL);
11968         first  = ref_array_or_hash(first);
11969         second = ref_array_or_hash(second);
11970         op_sibling_splice(o, NULL, 0, second);
11971         op_sibling_splice(o, NULL, 0, first);
11972
11973         /* Implicitly take a reference to a regular expression */
11974         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
11975             OpTYPE_set(first, OP_QR);
11976         }
11977         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
11978             OpTYPE_set(second, OP_QR);
11979         }
11980     }
11981
11982     return o;
11983 }
11984
11985
11986 static OP *
11987 S_maybe_targlex(pTHX_ OP *o)
11988 {
11989     OP * const kid = cLISTOPo->op_first;
11990     /* has a disposable target? */
11991     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
11992         && !(kid->op_flags & OPf_STACKED)
11993         /* Cannot steal the second time! */
11994         && !(kid->op_private & OPpTARGET_MY)
11995         )
11996     {
11997         OP * const kkid = OpSIBLING(kid);
11998
11999         /* Can just relocate the target. */
12000         if (kkid && kkid->op_type == OP_PADSV
12001             && (!(kkid->op_private & OPpLVAL_INTRO)
12002                || kkid->op_private & OPpPAD_STATE))
12003         {
12004             kid->op_targ = kkid->op_targ;
12005             kkid->op_targ = 0;
12006             /* Now we do not need PADSV and SASSIGN.
12007              * Detach kid and free the rest. */
12008             op_sibling_splice(o, NULL, 1, NULL);
12009             op_free(o);
12010             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12011             return kid;
12012         }
12013     }
12014     return o;
12015 }
12016
12017 OP *
12018 Perl_ck_sassign(pTHX_ OP *o)
12019 {
12020     dVAR;
12021     OP * const kid = cBINOPo->op_first;
12022
12023     PERL_ARGS_ASSERT_CK_SASSIGN;
12024
12025     if (OpHAS_SIBLING(kid)) {
12026         OP *kkid = OpSIBLING(kid);
12027         /* For state variable assignment with attributes, kkid is a list op
12028            whose op_last is a padsv. */
12029         if ((kkid->op_type == OP_PADSV ||
12030              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12031               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12032              )
12033             )
12034                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12035                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12036             return S_newONCEOP(aTHX_ o, kkid);
12037         }
12038     }
12039     return S_maybe_targlex(aTHX_ o);
12040 }
12041
12042
12043 OP *
12044 Perl_ck_match(pTHX_ OP *o)
12045 {
12046     PERL_UNUSED_CONTEXT;
12047     PERL_ARGS_ASSERT_CK_MATCH;
12048
12049     return o;
12050 }
12051
12052 OP *
12053 Perl_ck_method(pTHX_ OP *o)
12054 {
12055     SV *sv, *methsv, *rclass;
12056     const char* method;
12057     char* compatptr;
12058     int utf8;
12059     STRLEN len, nsplit = 0, i;
12060     OP* new_op;
12061     OP * const kid = cUNOPo->op_first;
12062
12063     PERL_ARGS_ASSERT_CK_METHOD;
12064     if (kid->op_type != OP_CONST) return o;
12065
12066     sv = kSVOP->op_sv;
12067
12068     /* replace ' with :: */
12069     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12070                                         SvEND(sv) - SvPVX(sv) )))
12071     {
12072         *compatptr = ':';
12073         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12074     }
12075
12076     method = SvPVX_const(sv);
12077     len = SvCUR(sv);
12078     utf8 = SvUTF8(sv) ? -1 : 1;
12079
12080     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12081         nsplit = i+1;
12082         break;
12083     }
12084
12085     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12086
12087     if (!nsplit) { /* $proto->method() */
12088         op_free(o);
12089         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12090     }
12091
12092     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12093         op_free(o);
12094         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12095     }
12096
12097     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12098     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12099         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12100         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12101     } else {
12102         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12103         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12104     }
12105 #ifdef USE_ITHREADS
12106     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12107 #else
12108     cMETHOPx(new_op)->op_rclass_sv = rclass;
12109 #endif
12110     op_free(o);
12111     return new_op;
12112 }
12113
12114 OP *
12115 Perl_ck_null(pTHX_ OP *o)
12116 {
12117     PERL_ARGS_ASSERT_CK_NULL;
12118     PERL_UNUSED_CONTEXT;
12119     return o;
12120 }
12121
12122 OP *
12123 Perl_ck_open(pTHX_ OP *o)
12124 {
12125     PERL_ARGS_ASSERT_CK_OPEN;
12126
12127     S_io_hints(aTHX_ o);
12128     {
12129          /* In case of three-arg dup open remove strictness
12130           * from the last arg if it is a bareword. */
12131          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12132          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12133          OP *oa;
12134          const char *mode;
12135
12136          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12137              (last->op_private & OPpCONST_BARE) &&
12138              (last->op_private & OPpCONST_STRICT) &&
12139              (oa = OpSIBLING(first)) &&         /* The fh. */
12140              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12141              (oa->op_type == OP_CONST) &&
12142              SvPOK(((SVOP*)oa)->op_sv) &&
12143              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12144              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12145              (last == OpSIBLING(oa)))                   /* The bareword. */
12146               last->op_private &= ~OPpCONST_STRICT;
12147     }
12148     return ck_fun(o);
12149 }
12150
12151 OP *
12152 Perl_ck_prototype(pTHX_ OP *o)
12153 {
12154     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12155     if (!(o->op_flags & OPf_KIDS)) {
12156         op_free(o);
12157         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12158     }
12159     return o;
12160 }
12161
12162 OP *
12163 Perl_ck_refassign(pTHX_ OP *o)
12164 {
12165     OP * const right = cLISTOPo->op_first;
12166     OP * const left = OpSIBLING(right);
12167     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12168     bool stacked = 0;
12169
12170     PERL_ARGS_ASSERT_CK_REFASSIGN;
12171     assert (left);
12172     assert (left->op_type == OP_SREFGEN);
12173
12174     o->op_private = 0;
12175     /* we use OPpPAD_STATE in refassign to mean either of those things,
12176      * and the code assumes the two flags occupy the same bit position
12177      * in the various ops below */
12178     assert(OPpPAD_STATE == OPpOUR_INTRO);
12179
12180     switch (varop->op_type) {
12181     case OP_PADAV:
12182         o->op_private |= OPpLVREF_AV;
12183         goto settarg;
12184     case OP_PADHV:
12185         o->op_private |= OPpLVREF_HV;
12186         /* FALLTHROUGH */
12187     case OP_PADSV:
12188       settarg:
12189         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12190         o->op_targ = varop->op_targ;
12191         varop->op_targ = 0;
12192         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12193         break;
12194
12195     case OP_RV2AV:
12196         o->op_private |= OPpLVREF_AV;
12197         goto checkgv;
12198         NOT_REACHED; /* NOTREACHED */
12199     case OP_RV2HV:
12200         o->op_private |= OPpLVREF_HV;
12201         /* FALLTHROUGH */
12202     case OP_RV2SV:
12203       checkgv:
12204         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12205         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12206       detach_and_stack:
12207         /* Point varop to its GV kid, detached.  */
12208         varop = op_sibling_splice(varop, NULL, -1, NULL);
12209         stacked = TRUE;
12210         break;
12211     case OP_RV2CV: {
12212         OP * const kidparent =
12213             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12214         OP * const kid = cUNOPx(kidparent)->op_first;
12215         o->op_private |= OPpLVREF_CV;
12216         if (kid->op_type == OP_GV) {
12217             varop = kidparent;
12218             goto detach_and_stack;
12219         }
12220         if (kid->op_type != OP_PADCV)   goto bad;
12221         o->op_targ = kid->op_targ;
12222         kid->op_targ = 0;
12223         break;
12224     }
12225     case OP_AELEM:
12226     case OP_HELEM:
12227         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12228         o->op_private |= OPpLVREF_ELEM;
12229         op_null(varop);
12230         stacked = TRUE;
12231         /* Detach varop.  */
12232         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12233         break;
12234     default:
12235       bad:
12236         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12237         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12238                                 "assignment",
12239                                  OP_DESC(varop)));
12240         return o;
12241     }
12242     if (!FEATURE_REFALIASING_IS_ENABLED)
12243         Perl_croak(aTHX_
12244                   "Experimental aliasing via reference not enabled");
12245     Perl_ck_warner_d(aTHX_
12246                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12247                     "Aliasing via reference is experimental");
12248     if (stacked) {
12249         o->op_flags |= OPf_STACKED;
12250         op_sibling_splice(o, right, 1, varop);
12251     }
12252     else {
12253         o->op_flags &=~ OPf_STACKED;
12254         op_sibling_splice(o, right, 1, NULL);
12255     }
12256     op_free(left);
12257     return o;
12258 }
12259
12260 OP *
12261 Perl_ck_repeat(pTHX_ OP *o)
12262 {
12263     PERL_ARGS_ASSERT_CK_REPEAT;
12264
12265     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12266         OP* kids;
12267         o->op_private |= OPpREPEAT_DOLIST;
12268         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12269         kids = force_list(kids, 1); /* promote it to a list */
12270         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12271     }
12272     else
12273         scalar(o);
12274     return o;
12275 }
12276
12277 OP *
12278 Perl_ck_require(pTHX_ OP *o)
12279 {
12280     GV* gv;
12281
12282     PERL_ARGS_ASSERT_CK_REQUIRE;
12283
12284     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12285         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12286         U32 hash;
12287         char *s;
12288         STRLEN len;
12289         if (kid->op_type == OP_CONST) {
12290           SV * const sv = kid->op_sv;
12291           U32 const was_readonly = SvREADONLY(sv);
12292           if (kid->op_private & OPpCONST_BARE) {
12293             dVAR;
12294             const char *end;
12295             HEK *hek;
12296
12297             if (was_readonly) {
12298                     SvREADONLY_off(sv);
12299             }
12300             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12301
12302             s = SvPVX(sv);
12303             len = SvCUR(sv);
12304             end = s + len;
12305             /* treat ::foo::bar as foo::bar */
12306             if (len >= 2 && s[0] == ':' && s[1] == ':')
12307                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12308             if (s == end)
12309                 DIE(aTHX_ "Bareword in require maps to empty filename");
12310
12311             for (; s < end; s++) {
12312                 if (*s == ':' && s[1] == ':') {
12313                     *s = '/';
12314                     Move(s+2, s+1, end - s - 1, char);
12315                     --end;
12316                 }
12317             }
12318             SvEND_set(sv, end);
12319             sv_catpvs(sv, ".pm");
12320             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12321             hek = share_hek(SvPVX(sv),
12322                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12323                             hash);
12324             sv_sethek(sv, hek);
12325             unshare_hek(hek);
12326             SvFLAGS(sv) |= was_readonly;
12327           }
12328           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12329                 && !SvVOK(sv)) {
12330             s = SvPV(sv, len);
12331             if (SvREFCNT(sv) > 1) {
12332                 kid->op_sv = newSVpvn_share(
12333                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12334                 SvREFCNT_dec_NN(sv);
12335             }
12336             else {
12337                 dVAR;
12338                 HEK *hek;
12339                 if (was_readonly) SvREADONLY_off(sv);
12340                 PERL_HASH(hash, s, len);
12341                 hek = share_hek(s,
12342                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12343                                 hash);
12344                 sv_sethek(sv, hek);
12345                 unshare_hek(hek);
12346                 SvFLAGS(sv) |= was_readonly;
12347             }
12348           }
12349         }
12350     }
12351
12352     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12353         /* handle override, if any */
12354      && (gv = gv_override("require", 7))) {
12355         OP *kid, *newop;
12356         if (o->op_flags & OPf_KIDS) {
12357             kid = cUNOPo->op_first;
12358             op_sibling_splice(o, NULL, -1, NULL);
12359         }
12360         else {
12361             kid = newDEFSVOP();
12362         }
12363         op_free(o);
12364         newop = S_new_entersubop(aTHX_ gv, kid);
12365         return newop;
12366     }
12367
12368     return ck_fun(o);
12369 }
12370
12371 OP *
12372 Perl_ck_return(pTHX_ OP *o)
12373 {
12374     OP *kid;
12375
12376     PERL_ARGS_ASSERT_CK_RETURN;
12377
12378     kid = OpSIBLING(cLISTOPo->op_first);
12379     if (PL_compcv && CvLVALUE(PL_compcv)) {
12380         for (; kid; kid = OpSIBLING(kid))
12381             op_lvalue(kid, OP_LEAVESUBLV);
12382     }
12383
12384     return o;
12385 }
12386
12387 OP *
12388 Perl_ck_select(pTHX_ OP *o)
12389 {
12390     dVAR;
12391     OP* kid;
12392
12393     PERL_ARGS_ASSERT_CK_SELECT;
12394
12395     if (o->op_flags & OPf_KIDS) {
12396         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12397         if (kid && OpHAS_SIBLING(kid)) {
12398             OpTYPE_set(o, OP_SSELECT);
12399             o = ck_fun(o);
12400             return fold_constants(op_integerize(op_std_init(o)));
12401         }
12402     }
12403     o = ck_fun(o);
12404     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12405     if (kid && kid->op_type == OP_RV2GV)
12406         kid->op_private &= ~HINT_STRICT_REFS;
12407     return o;
12408 }
12409
12410 OP *
12411 Perl_ck_shift(pTHX_ OP *o)
12412 {
12413     const I32 type = o->op_type;
12414
12415     PERL_ARGS_ASSERT_CK_SHIFT;
12416
12417     if (!(o->op_flags & OPf_KIDS)) {
12418         OP *argop;
12419
12420         if (!CvUNIQUE(PL_compcv)) {
12421             o->op_flags |= OPf_SPECIAL;
12422             return o;
12423         }
12424
12425         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12426         op_free(o);
12427         return newUNOP(type, 0, scalar(argop));
12428     }
12429     return scalar(ck_fun(o));
12430 }
12431
12432 OP *
12433 Perl_ck_sort(pTHX_ OP *o)
12434 {
12435     OP *firstkid;
12436     OP *kid;
12437     HV * const hinthv =
12438         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12439     U8 stacked;
12440
12441     PERL_ARGS_ASSERT_CK_SORT;
12442
12443     if (hinthv) {
12444             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12445             if (svp) {
12446                 const I32 sorthints = (I32)SvIV(*svp);
12447                 if ((sorthints & HINT_SORT_STABLE) != 0)
12448                     o->op_private |= OPpSORT_STABLE;
12449                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12450                     o->op_private |= OPpSORT_UNSTABLE;
12451             }
12452     }
12453
12454     if (o->op_flags & OPf_STACKED)
12455         simplify_sort(o);
12456     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12457
12458     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12459         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12460
12461         /* if the first arg is a code block, process it and mark sort as
12462          * OPf_SPECIAL */
12463         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12464             LINKLIST(kid);
12465             if (kid->op_type == OP_LEAVE)
12466                     op_null(kid);                       /* wipe out leave */
12467             /* Prevent execution from escaping out of the sort block. */
12468             kid->op_next = 0;
12469
12470             /* provide scalar context for comparison function/block */
12471             kid = scalar(firstkid);
12472             kid->op_next = kid;
12473             o->op_flags |= OPf_SPECIAL;
12474         }
12475         else if (kid->op_type == OP_CONST
12476               && kid->op_private & OPpCONST_BARE) {
12477             char tmpbuf[256];
12478             STRLEN len;
12479             PADOFFSET off;
12480             const char * const name = SvPV(kSVOP_sv, len);
12481             *tmpbuf = '&';
12482             assert (len < 256);
12483             Copy(name, tmpbuf+1, len, char);
12484             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12485             if (off != NOT_IN_PAD) {
12486                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12487                     SV * const fq =
12488                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12489                     sv_catpvs(fq, "::");
12490                     sv_catsv(fq, kSVOP_sv);
12491                     SvREFCNT_dec_NN(kSVOP_sv);
12492                     kSVOP->op_sv = fq;
12493                 }
12494                 else {
12495                     OP * const padop = newOP(OP_PADCV, 0);
12496                     padop->op_targ = off;
12497                     /* replace the const op with the pad op */
12498                     op_sibling_splice(firstkid, NULL, 1, padop);
12499                     op_free(kid);
12500                 }
12501             }
12502         }
12503
12504         firstkid = OpSIBLING(firstkid);
12505     }
12506
12507     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12508         /* provide list context for arguments */
12509         list(kid);
12510         if (stacked)
12511             op_lvalue(kid, OP_GREPSTART);
12512     }
12513
12514     return o;
12515 }
12516
12517 /* for sort { X } ..., where X is one of
12518  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12519  * elide the second child of the sort (the one containing X),
12520  * and set these flags as appropriate
12521         OPpSORT_NUMERIC;
12522         OPpSORT_INTEGER;
12523         OPpSORT_DESCEND;
12524  * Also, check and warn on lexical $a, $b.
12525  */
12526
12527 STATIC void
12528 S_simplify_sort(pTHX_ OP *o)
12529 {
12530     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12531     OP *k;
12532     int descending;
12533     GV *gv;
12534     const char *gvname;
12535     bool have_scopeop;
12536
12537     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12538
12539     kid = kUNOP->op_first;                              /* get past null */
12540     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12541      && kid->op_type != OP_LEAVE)
12542         return;
12543     kid = kLISTOP->op_last;                             /* get past scope */
12544     switch(kid->op_type) {
12545         case OP_NCMP:
12546         case OP_I_NCMP:
12547         case OP_SCMP:
12548             if (!have_scopeop) goto padkids;
12549             break;
12550         default:
12551             return;
12552     }
12553     k = kid;                                            /* remember this node*/
12554     if (kBINOP->op_first->op_type != OP_RV2SV
12555      || kBINOP->op_last ->op_type != OP_RV2SV)
12556     {
12557         /*
12558            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12559            then used in a comparison.  This catches most, but not
12560            all cases.  For instance, it catches
12561                sort { my($a); $a <=> $b }
12562            but not
12563                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12564            (although why you'd do that is anyone's guess).
12565         */
12566
12567        padkids:
12568         if (!ckWARN(WARN_SYNTAX)) return;
12569         kid = kBINOP->op_first;
12570         do {
12571             if (kid->op_type == OP_PADSV) {
12572                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12573                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12574                  && (  PadnamePV(name)[1] == 'a'
12575                     || PadnamePV(name)[1] == 'b'  ))
12576                     /* diag_listed_as: "my %s" used in sort comparison */
12577                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12578                                      "\"%s %s\" used in sort comparison",
12579                                       PadnameIsSTATE(name)
12580                                         ? "state"
12581                                         : "my",
12582                                       PadnamePV(name));
12583             }
12584         } while ((kid = OpSIBLING(kid)));
12585         return;
12586     }
12587     kid = kBINOP->op_first;                             /* get past cmp */
12588     if (kUNOP->op_first->op_type != OP_GV)
12589         return;
12590     kid = kUNOP->op_first;                              /* get past rv2sv */
12591     gv = kGVOP_gv;
12592     if (GvSTASH(gv) != PL_curstash)
12593         return;
12594     gvname = GvNAME(gv);
12595     if (*gvname == 'a' && gvname[1] == '\0')
12596         descending = 0;
12597     else if (*gvname == 'b' && gvname[1] == '\0')
12598         descending = 1;
12599     else
12600         return;
12601
12602     kid = k;                                            /* back to cmp */
12603     /* already checked above that it is rv2sv */
12604     kid = kBINOP->op_last;                              /* down to 2nd arg */
12605     if (kUNOP->op_first->op_type != OP_GV)
12606         return;
12607     kid = kUNOP->op_first;                              /* get past rv2sv */
12608     gv = kGVOP_gv;
12609     if (GvSTASH(gv) != PL_curstash)
12610         return;
12611     gvname = GvNAME(gv);
12612     if ( descending
12613          ? !(*gvname == 'a' && gvname[1] == '\0')
12614          : !(*gvname == 'b' && gvname[1] == '\0'))
12615         return;
12616     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12617     if (descending)
12618         o->op_private |= OPpSORT_DESCEND;
12619     if (k->op_type == OP_NCMP)
12620         o->op_private |= OPpSORT_NUMERIC;
12621     if (k->op_type == OP_I_NCMP)
12622         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12623     kid = OpSIBLING(cLISTOPo->op_first);
12624     /* cut out and delete old block (second sibling) */
12625     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12626     op_free(kid);
12627 }
12628
12629 OP *
12630 Perl_ck_split(pTHX_ OP *o)
12631 {
12632     dVAR;
12633     OP *kid;
12634     OP *sibs;
12635
12636     PERL_ARGS_ASSERT_CK_SPLIT;
12637
12638     assert(o->op_type == OP_LIST);
12639
12640     if (o->op_flags & OPf_STACKED)
12641         return no_fh_allowed(o);
12642
12643     kid = cLISTOPo->op_first;
12644     /* delete leading NULL node, then add a CONST if no other nodes */
12645     assert(kid->op_type == OP_NULL);
12646     op_sibling_splice(o, NULL, 1,
12647         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12648     op_free(kid);
12649     kid = cLISTOPo->op_first;
12650
12651     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12652         /* remove match expression, and replace with new optree with
12653          * a match op at its head */
12654         op_sibling_splice(o, NULL, 1, NULL);
12655         /* pmruntime will handle split " " behavior with flag==2 */
12656         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12657         op_sibling_splice(o, NULL, 0, kid);
12658     }
12659
12660     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12661
12662     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12663       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12664                      "Use of /g modifier is meaningless in split");
12665     }
12666
12667     /* eliminate the split op, and move the match op (plus any children)
12668      * into its place, then convert the match op into a split op. i.e.
12669      *
12670      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12671      *    |                        |                     |
12672      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12673      *    |                        |                     |
12674      *    R                        X - Y                 X - Y
12675      *    |
12676      *    X - Y
12677      *
12678      * (R, if it exists, will be a regcomp op)
12679      */
12680
12681     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12682     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12683     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12684     OpTYPE_set(kid, OP_SPLIT);
12685     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12686     kid->op_private = o->op_private;
12687     op_free(o);
12688     o = kid;
12689     kid = sibs; /* kid is now the string arg of the split */
12690
12691     if (!kid) {
12692         kid = newDEFSVOP();
12693         op_append_elem(OP_SPLIT, o, kid);
12694     }
12695     scalar(kid);
12696
12697     kid = OpSIBLING(kid);
12698     if (!kid) {
12699         kid = newSVOP(OP_CONST, 0, newSViv(0));
12700         op_append_elem(OP_SPLIT, o, kid);
12701         o->op_private |= OPpSPLIT_IMPLIM;
12702     }
12703     scalar(kid);
12704
12705     if (OpHAS_SIBLING(kid))
12706         return too_many_arguments_pv(o,OP_DESC(o), 0);
12707
12708     return o;
12709 }
12710
12711 OP *
12712 Perl_ck_stringify(pTHX_ OP *o)
12713 {
12714     OP * const kid = OpSIBLING(cUNOPo->op_first);
12715     PERL_ARGS_ASSERT_CK_STRINGIFY;
12716     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12717          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12718          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12719         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12720     {
12721         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12722         op_free(o);
12723         return kid;
12724     }
12725     return ck_fun(o);
12726 }
12727
12728 OP *
12729 Perl_ck_join(pTHX_ OP *o)
12730 {
12731     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12732
12733     PERL_ARGS_ASSERT_CK_JOIN;
12734
12735     if (kid && kid->op_type == OP_MATCH) {
12736         if (ckWARN(WARN_SYNTAX)) {
12737             const REGEXP *re = PM_GETRE(kPMOP);
12738             const SV *msg = re
12739                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12740                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12741                     : newSVpvs_flags( "STRING", SVs_TEMP );
12742             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12743                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12744                         SVfARG(msg), SVfARG(msg));
12745         }
12746     }
12747     if (kid
12748      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12749         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12750         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12751            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12752     {
12753         const OP * const bairn = OpSIBLING(kid); /* the list */
12754         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12755          && OP_GIMME(bairn,0) == G_SCALAR)
12756         {
12757             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12758                                      op_sibling_splice(o, kid, 1, NULL));
12759             op_free(o);
12760             return ret;
12761         }
12762     }
12763
12764     return ck_fun(o);
12765 }
12766
12767 /*
12768 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12769
12770 Examines an op, which is expected to identify a subroutine at runtime,
12771 and attempts to determine at compile time which subroutine it identifies.
12772 This is normally used during Perl compilation to determine whether
12773 a prototype can be applied to a function call.  C<cvop> is the op
12774 being considered, normally an C<rv2cv> op.  A pointer to the identified
12775 subroutine is returned, if it could be determined statically, and a null
12776 pointer is returned if it was not possible to determine statically.
12777
12778 Currently, the subroutine can be identified statically if the RV that the
12779 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12780 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12781 suitable if the constant value must be an RV pointing to a CV.  Details of
12782 this process may change in future versions of Perl.  If the C<rv2cv> op
12783 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12784 the subroutine statically: this flag is used to suppress compile-time
12785 magic on a subroutine call, forcing it to use default runtime behaviour.
12786
12787 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12788 of a GV reference is modified.  If a GV was examined and its CV slot was
12789 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12790 If the op is not optimised away, and the CV slot is later populated with
12791 a subroutine having a prototype, that flag eventually triggers the warning
12792 "called too early to check prototype".
12793
12794 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12795 of returning a pointer to the subroutine it returns a pointer to the
12796 GV giving the most appropriate name for the subroutine in this context.
12797 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12798 (C<CvANON>) subroutine that is referenced through a GV it will be the
12799 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12800 A null pointer is returned as usual if there is no statically-determinable
12801 subroutine.
12802
12803 =cut
12804 */
12805
12806 /* shared by toke.c:yylex */
12807 CV *
12808 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12809 {
12810     PADNAME *name = PAD_COMPNAME(off);
12811     CV *compcv = PL_compcv;
12812     while (PadnameOUTER(name)) {
12813         assert(PARENT_PAD_INDEX(name));
12814         compcv = CvOUTSIDE(compcv);
12815         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12816                 [off = PARENT_PAD_INDEX(name)];
12817     }
12818     assert(!PadnameIsOUR(name));
12819     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12820         return PadnamePROTOCV(name);
12821     }
12822     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12823 }
12824
12825 CV *
12826 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12827 {
12828     OP *rvop;
12829     CV *cv;
12830     GV *gv;
12831     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12832     if (flags & ~RV2CVOPCV_FLAG_MASK)
12833         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12834     if (cvop->op_type != OP_RV2CV)
12835         return NULL;
12836     if (cvop->op_private & OPpENTERSUB_AMPER)
12837         return NULL;
12838     if (!(cvop->op_flags & OPf_KIDS))
12839         return NULL;
12840     rvop = cUNOPx(cvop)->op_first;
12841     switch (rvop->op_type) {
12842         case OP_GV: {
12843             gv = cGVOPx_gv(rvop);
12844             if (!isGV(gv)) {
12845                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12846                     cv = MUTABLE_CV(SvRV(gv));
12847                     gv = NULL;
12848                     break;
12849                 }
12850                 if (flags & RV2CVOPCV_RETURN_STUB)
12851                     return (CV *)gv;
12852                 else return NULL;
12853             }
12854             cv = GvCVu(gv);
12855             if (!cv) {
12856                 if (flags & RV2CVOPCV_MARK_EARLY)
12857                     rvop->op_private |= OPpEARLY_CV;
12858                 return NULL;
12859             }
12860         } break;
12861         case OP_CONST: {
12862             SV *rv = cSVOPx_sv(rvop);
12863             if (!SvROK(rv))
12864                 return NULL;
12865             cv = (CV*)SvRV(rv);
12866             gv = NULL;
12867         } break;
12868         case OP_PADCV: {
12869             cv = find_lexical_cv(rvop->op_targ);
12870             gv = NULL;
12871         } break;
12872         default: {
12873             return NULL;
12874         } NOT_REACHED; /* NOTREACHED */
12875     }
12876     if (SvTYPE((SV*)cv) != SVt_PVCV)
12877         return NULL;
12878     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12879         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12880             gv = CvGV(cv);
12881         return (CV*)gv;
12882     }
12883     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
12884         if (CvLEXICAL(cv) || CvNAMED(cv))
12885             return NULL;
12886         if (!CvANON(cv) || !gv)
12887             gv = CvGV(cv);
12888         return (CV*)gv;
12889
12890     } else {
12891         return cv;
12892     }
12893 }
12894
12895 /*
12896 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
12897
12898 Performs the default fixup of the arguments part of an C<entersub>
12899 op tree.  This consists of applying list context to each of the
12900 argument ops.  This is the standard treatment used on a call marked
12901 with C<&>, or a method call, or a call through a subroutine reference,
12902 or any other call where the callee can't be identified at compile time,
12903 or a call where the callee has no prototype.
12904
12905 =cut
12906 */
12907
12908 OP *
12909 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
12910 {
12911     OP *aop;
12912
12913     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
12914
12915     aop = cUNOPx(entersubop)->op_first;
12916     if (!OpHAS_SIBLING(aop))
12917         aop = cUNOPx(aop)->op_first;
12918     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
12919         /* skip the extra attributes->import() call implicitly added in
12920          * something like foo(my $x : bar)
12921          */
12922         if (   aop->op_type == OP_ENTERSUB
12923             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
12924         )
12925             continue;
12926         list(aop);
12927         op_lvalue(aop, OP_ENTERSUB);
12928     }
12929     return entersubop;
12930 }
12931
12932 /*
12933 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
12934
12935 Performs the fixup of the arguments part of an C<entersub> op tree
12936 based on a subroutine prototype.  This makes various modifications to
12937 the argument ops, from applying context up to inserting C<refgen> ops,
12938 and checking the number and syntactic types of arguments, as directed by
12939 the prototype.  This is the standard treatment used on a subroutine call,
12940 not marked with C<&>, where the callee can be identified at compile time
12941 and has a prototype.
12942
12943 C<protosv> supplies the subroutine prototype to be applied to the call.
12944 It may be a normal defined scalar, of which the string value will be used.
12945 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
12946 that has been cast to C<SV*>) which has a prototype.  The prototype
12947 supplied, in whichever form, does not need to match the actual callee
12948 referenced by the op tree.
12949
12950 If the argument ops disagree with the prototype, for example by having
12951 an unacceptable number of arguments, a valid op tree is returned anyway.
12952 The error is reflected in the parser state, normally resulting in a single
12953 exception at the top level of parsing which covers all the compilation
12954 errors that occurred.  In the error message, the callee is referred to
12955 by the name defined by the C<namegv> parameter.
12956
12957 =cut
12958 */
12959
12960 OP *
12961 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
12962 {
12963     STRLEN proto_len;
12964     const char *proto, *proto_end;
12965     OP *aop, *prev, *cvop, *parent;
12966     int optional = 0;
12967     I32 arg = 0;
12968     I32 contextclass = 0;
12969     const char *e = NULL;
12970     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
12971     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
12972         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
12973                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
12974     if (SvTYPE(protosv) == SVt_PVCV)
12975          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
12976     else proto = SvPV(protosv, proto_len);
12977     proto = S_strip_spaces(aTHX_ proto, &proto_len);
12978     proto_end = proto + proto_len;
12979     parent = entersubop;
12980     aop = cUNOPx(entersubop)->op_first;
12981     if (!OpHAS_SIBLING(aop)) {
12982         parent = aop;
12983         aop = cUNOPx(aop)->op_first;
12984     }
12985     prev = aop;
12986     aop = OpSIBLING(aop);
12987     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12988     while (aop != cvop) {
12989         OP* o3 = aop;
12990
12991         if (proto >= proto_end)
12992         {
12993             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
12994             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
12995                                         SVfARG(namesv)), SvUTF8(namesv));
12996             return entersubop;
12997         }
12998
12999         switch (*proto) {
13000             case ';':
13001                 optional = 1;
13002                 proto++;
13003                 continue;
13004             case '_':
13005                 /* _ must be at the end */
13006                 if (proto[1] && !strchr(";@%", proto[1]))
13007                     goto oops;
13008                 /* FALLTHROUGH */
13009             case '$':
13010                 proto++;
13011                 arg++;
13012                 scalar(aop);
13013                 break;
13014             case '%':
13015             case '@':
13016                 list(aop);
13017                 arg++;
13018                 break;
13019             case '&':
13020                 proto++;
13021                 arg++;
13022                 if (    o3->op_type != OP_UNDEF
13023                     && (o3->op_type != OP_SREFGEN
13024                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13025                                 != OP_ANONCODE
13026                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13027                                 != OP_RV2CV)))
13028                     bad_type_gv(arg, namegv, o3,
13029                             arg == 1 ? "block or sub {}" : "sub {}");
13030                 break;
13031             case '*':
13032                 /* '*' allows any scalar type, including bareword */
13033                 proto++;
13034                 arg++;
13035                 if (o3->op_type == OP_RV2GV)
13036                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13037                 else if (o3->op_type == OP_CONST)
13038                     o3->op_private &= ~OPpCONST_STRICT;
13039                 scalar(aop);
13040                 break;
13041             case '+':
13042                 proto++;
13043                 arg++;
13044                 if (o3->op_type == OP_RV2AV ||
13045                     o3->op_type == OP_PADAV ||
13046                     o3->op_type == OP_RV2HV ||
13047                     o3->op_type == OP_PADHV
13048                 ) {
13049                     goto wrapref;
13050                 }
13051                 scalar(aop);
13052                 break;
13053             case '[': case ']':
13054                 goto oops;
13055
13056             case '\\':
13057                 proto++;
13058                 arg++;
13059             again:
13060                 switch (*proto++) {
13061                     case '[':
13062                         if (contextclass++ == 0) {
13063                             e = (char *) memchr(proto, ']', proto_end - proto);
13064                             if (!e || e == proto)
13065                                 goto oops;
13066                         }
13067                         else
13068                             goto oops;
13069                         goto again;
13070
13071                     case ']':
13072                         if (contextclass) {
13073                             const char *p = proto;
13074                             const char *const end = proto;
13075                             contextclass = 0;
13076                             while (*--p != '[')
13077                                 /* \[$] accepts any scalar lvalue */
13078                                 if (*p == '$'
13079                                  && Perl_op_lvalue_flags(aTHX_
13080                                      scalar(o3),
13081                                      OP_READ, /* not entersub */
13082                                      OP_LVALUE_NO_CROAK
13083                                     )) goto wrapref;
13084                             bad_type_gv(arg, namegv, o3,
13085                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13086                         } else
13087                             goto oops;
13088                         break;
13089                     case '*':
13090                         if (o3->op_type == OP_RV2GV)
13091                             goto wrapref;
13092                         if (!contextclass)
13093                             bad_type_gv(arg, namegv, o3, "symbol");
13094                         break;
13095                     case '&':
13096                         if (o3->op_type == OP_ENTERSUB
13097                          && !(o3->op_flags & OPf_STACKED))
13098                             goto wrapref;
13099                         if (!contextclass)
13100                             bad_type_gv(arg, namegv, o3, "subroutine");
13101                         break;
13102                     case '$':
13103                         if (o3->op_type == OP_RV2SV ||
13104                                 o3->op_type == OP_PADSV ||
13105                                 o3->op_type == OP_HELEM ||
13106                                 o3->op_type == OP_AELEM)
13107                             goto wrapref;
13108                         if (!contextclass) {
13109                             /* \$ accepts any scalar lvalue */
13110                             if (Perl_op_lvalue_flags(aTHX_
13111                                     scalar(o3),
13112                                     OP_READ,  /* not entersub */
13113                                     OP_LVALUE_NO_CROAK
13114                                )) goto wrapref;
13115                             bad_type_gv(arg, namegv, o3, "scalar");
13116                         }
13117                         break;
13118                     case '@':
13119                         if (o3->op_type == OP_RV2AV ||
13120                                 o3->op_type == OP_PADAV)
13121                         {
13122                             o3->op_flags &=~ OPf_PARENS;
13123                             goto wrapref;
13124                         }
13125                         if (!contextclass)
13126                             bad_type_gv(arg, namegv, o3, "array");
13127                         break;
13128                     case '%':
13129                         if (o3->op_type == OP_RV2HV ||
13130                                 o3->op_type == OP_PADHV)
13131                         {
13132                             o3->op_flags &=~ OPf_PARENS;
13133                             goto wrapref;
13134                         }
13135                         if (!contextclass)
13136                             bad_type_gv(arg, namegv, o3, "hash");
13137                         break;
13138                     wrapref:
13139                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13140                                                 OP_REFGEN, 0);
13141                         if (contextclass && e) {
13142                             proto = e + 1;
13143                             contextclass = 0;
13144                         }
13145                         break;
13146                     default: goto oops;
13147                 }
13148                 if (contextclass)
13149                     goto again;
13150                 break;
13151             case ' ':
13152                 proto++;
13153                 continue;
13154             default:
13155             oops: {
13156                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13157                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13158                                   SVfARG(protosv));
13159             }
13160         }
13161
13162         op_lvalue(aop, OP_ENTERSUB);
13163         prev = aop;
13164         aop = OpSIBLING(aop);
13165     }
13166     if (aop == cvop && *proto == '_') {
13167         /* generate an access to $_ */
13168         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13169     }
13170     if (!optional && proto_end > proto &&
13171         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13172     {
13173         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13174         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13175                                     SVfARG(namesv)), SvUTF8(namesv));
13176     }
13177     return entersubop;
13178 }
13179
13180 /*
13181 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13182
13183 Performs the fixup of the arguments part of an C<entersub> op tree either
13184 based on a subroutine prototype or using default list-context processing.
13185 This is the standard treatment used on a subroutine call, not marked
13186 with C<&>, where the callee can be identified at compile time.
13187
13188 C<protosv> supplies the subroutine prototype to be applied to the call,
13189 or indicates that there is no prototype.  It may be a normal scalar,
13190 in which case if it is defined then the string value will be used
13191 as a prototype, and if it is undefined then there is no prototype.
13192 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13193 that has been cast to C<SV*>), of which the prototype will be used if it
13194 has one.  The prototype (or lack thereof) supplied, in whichever form,
13195 does not need to match the actual callee referenced by the op tree.
13196
13197 If the argument ops disagree with the prototype, for example by having
13198 an unacceptable number of arguments, a valid op tree is returned anyway.
13199 The error is reflected in the parser state, normally resulting in a single
13200 exception at the top level of parsing which covers all the compilation
13201 errors that occurred.  In the error message, the callee is referred to
13202 by the name defined by the C<namegv> parameter.
13203
13204 =cut
13205 */
13206
13207 OP *
13208 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13209         GV *namegv, SV *protosv)
13210 {
13211     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13212     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13213         return ck_entersub_args_proto(entersubop, namegv, protosv);
13214     else
13215         return ck_entersub_args_list(entersubop);
13216 }
13217
13218 OP *
13219 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13220 {
13221     IV cvflags = SvIVX(protosv);
13222     int opnum = cvflags & 0xffff;
13223     OP *aop = cUNOPx(entersubop)->op_first;
13224
13225     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13226
13227     if (!opnum) {
13228         OP *cvop;
13229         if (!OpHAS_SIBLING(aop))
13230             aop = cUNOPx(aop)->op_first;
13231         aop = OpSIBLING(aop);
13232         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13233         if (aop != cvop) {
13234             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13235             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13236                 SVfARG(namesv)), SvUTF8(namesv));
13237         }
13238
13239         op_free(entersubop);
13240         switch(cvflags >> 16) {
13241         case 'F': return newSVOP(OP_CONST, 0,
13242                                         newSVpv(CopFILE(PL_curcop),0));
13243         case 'L': return newSVOP(
13244                            OP_CONST, 0,
13245                            Perl_newSVpvf(aTHX_
13246                              "%" IVdf, (IV)CopLINE(PL_curcop)
13247                            )
13248                          );
13249         case 'P': return newSVOP(OP_CONST, 0,
13250                                    (PL_curstash
13251                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13252                                      : &PL_sv_undef
13253                                    )
13254                                 );
13255         }
13256         NOT_REACHED; /* NOTREACHED */
13257     }
13258     else {
13259         OP *prev, *cvop, *first, *parent;
13260         U32 flags = 0;
13261
13262         parent = entersubop;
13263         if (!OpHAS_SIBLING(aop)) {
13264             parent = aop;
13265             aop = cUNOPx(aop)->op_first;
13266         }
13267
13268         first = prev = aop;
13269         aop = OpSIBLING(aop);
13270         /* find last sibling */
13271         for (cvop = aop;
13272              OpHAS_SIBLING(cvop);
13273              prev = cvop, cvop = OpSIBLING(cvop))
13274             ;
13275         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13276             /* Usually, OPf_SPECIAL on an op with no args means that it had
13277              * parens, but these have their own meaning for that flag: */
13278             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13279             && opnum != OP_DELETE && opnum != OP_EXISTS)
13280                 flags |= OPf_SPECIAL;
13281         /* excise cvop from end of sibling chain */
13282         op_sibling_splice(parent, prev, 1, NULL);
13283         op_free(cvop);
13284         if (aop == cvop) aop = NULL;
13285
13286         /* detach remaining siblings from the first sibling, then
13287          * dispose of original optree */
13288
13289         if (aop)
13290             op_sibling_splice(parent, first, -1, NULL);
13291         op_free(entersubop);
13292
13293         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13294             flags |= OPpEVAL_BYTES <<8;
13295
13296         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13297         case OA_UNOP:
13298         case OA_BASEOP_OR_UNOP:
13299         case OA_FILESTATOP:
13300             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13301         case OA_BASEOP:
13302             if (aop) {
13303                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13304                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13305                     SVfARG(namesv)), SvUTF8(namesv));
13306                 op_free(aop);
13307             }
13308             return opnum == OP_RUNCV
13309                 ? newPVOP(OP_RUNCV,0,NULL)
13310                 : newOP(opnum,0);
13311         default:
13312             return op_convert_list(opnum,0,aop);
13313         }
13314     }
13315     NOT_REACHED; /* NOTREACHED */
13316     return entersubop;
13317 }
13318
13319 /*
13320 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13321
13322 Retrieves the function that will be used to fix up a call to C<cv>.
13323 Specifically, the function is applied to an C<entersub> op tree for a
13324 subroutine call, not marked with C<&>, where the callee can be identified
13325 at compile time as C<cv>.
13326
13327 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13328 for it is returned in C<*ckobj_p>, and control flags are returned in
13329 C<*ckflags_p>.  The function is intended to be called in this manner:
13330
13331  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13332
13333 In this call, C<entersubop> is a pointer to the C<entersub> op,
13334 which may be replaced by the check function, and C<namegv> supplies
13335 the name that should be used by the check function to refer
13336 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13337 It is permitted to apply the check function in non-standard situations,
13338 such as to a call to a different subroutine or to a method call.
13339
13340 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13341 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13342 instead, anything that can be used as the first argument to L</cv_name>.
13343 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13344 check function requires C<namegv> to be a genuine GV.
13345
13346 By default, the check function is
13347 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13348 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13349 flag is clear.  This implements standard prototype processing.  It can
13350 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13351
13352 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13353 indicates that the caller only knows about the genuine GV version of
13354 C<namegv>, and accordingly the corresponding bit will always be set in
13355 C<*ckflags_p>, regardless of the check function's recorded requirements.
13356 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13357 indicates the caller knows about the possibility of passing something
13358 other than a GV as C<namegv>, and accordingly the corresponding bit may
13359 be either set or clear in C<*ckflags_p>, indicating the check function's
13360 recorded requirements.
13361
13362 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13363 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13364 (for which see above).  All other bits should be clear.
13365
13366 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13367
13368 The original form of L</cv_get_call_checker_flags>, which does not return
13369 checker flags.  When using a checker function returned by this function,
13370 it is only safe to call it with a genuine GV as its C<namegv> argument.
13371
13372 =cut
13373 */
13374
13375 void
13376 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13377         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13378 {
13379     MAGIC *callmg;
13380     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13381     PERL_UNUSED_CONTEXT;
13382     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13383     if (callmg) {
13384         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13385         *ckobj_p = callmg->mg_obj;
13386         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13387     } else {
13388         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13389         *ckobj_p = (SV*)cv;
13390         *ckflags_p = gflags & MGf_REQUIRE_GV;
13391     }
13392 }
13393
13394 void
13395 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13396 {
13397     U32 ckflags;
13398     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13399     PERL_UNUSED_CONTEXT;
13400     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13401         &ckflags);
13402 }
13403
13404 /*
13405 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13406
13407 Sets the function that will be used to fix up a call to C<cv>.
13408 Specifically, the function is applied to an C<entersub> op tree for a
13409 subroutine call, not marked with C<&>, where the callee can be identified
13410 at compile time as C<cv>.
13411
13412 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13413 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13414 The function should be defined like this:
13415
13416     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13417
13418 It is intended to be called in this manner:
13419
13420     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13421
13422 In this call, C<entersubop> is a pointer to the C<entersub> op,
13423 which may be replaced by the check function, and C<namegv> supplies
13424 the name that should be used by the check function to refer
13425 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13426 It is permitted to apply the check function in non-standard situations,
13427 such as to a call to a different subroutine or to a method call.
13428
13429 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13430 CV or other SV instead.  Whatever is passed can be used as the first
13431 argument to L</cv_name>.  You can force perl to pass a GV by including
13432 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13433
13434 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13435 bit currently has a defined meaning (for which see above).  All other
13436 bits should be clear.
13437
13438 The current setting for a particular CV can be retrieved by
13439 L</cv_get_call_checker_flags>.
13440
13441 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13442
13443 The original form of L</cv_set_call_checker_flags>, which passes it the
13444 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13445 of that flag setting is that the check function is guaranteed to get a
13446 genuine GV as its C<namegv> argument.
13447
13448 =cut
13449 */
13450
13451 void
13452 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13453 {
13454     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13455     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13456 }
13457
13458 void
13459 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13460                                      SV *ckobj, U32 ckflags)
13461 {
13462     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13463     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13464         if (SvMAGICAL((SV*)cv))
13465             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13466     } else {
13467         MAGIC *callmg;
13468         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13469         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13470         assert(callmg);
13471         if (callmg->mg_flags & MGf_REFCOUNTED) {
13472             SvREFCNT_dec(callmg->mg_obj);
13473             callmg->mg_flags &= ~MGf_REFCOUNTED;
13474         }
13475         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13476         callmg->mg_obj = ckobj;
13477         if (ckobj != (SV*)cv) {
13478             SvREFCNT_inc_simple_void_NN(ckobj);
13479             callmg->mg_flags |= MGf_REFCOUNTED;
13480         }
13481         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13482                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13483     }
13484 }
13485
13486 static void
13487 S_entersub_alloc_targ(pTHX_ OP * const o)
13488 {
13489     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13490     o->op_private |= OPpENTERSUB_HASTARG;
13491 }
13492
13493 OP *
13494 Perl_ck_subr(pTHX_ OP *o)
13495 {
13496     OP *aop, *cvop;
13497     CV *cv;
13498     GV *namegv;
13499     SV **const_class = NULL;
13500
13501     PERL_ARGS_ASSERT_CK_SUBR;
13502
13503     aop = cUNOPx(o)->op_first;
13504     if (!OpHAS_SIBLING(aop))
13505         aop = cUNOPx(aop)->op_first;
13506     aop = OpSIBLING(aop);
13507     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13508     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13509     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13510
13511     o->op_private &= ~1;
13512     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13513     if (PERLDB_SUB && PL_curstash != PL_debstash)
13514         o->op_private |= OPpENTERSUB_DB;
13515     switch (cvop->op_type) {
13516         case OP_RV2CV:
13517             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13518             op_null(cvop);
13519             break;
13520         case OP_METHOD:
13521         case OP_METHOD_NAMED:
13522         case OP_METHOD_SUPER:
13523         case OP_METHOD_REDIR:
13524         case OP_METHOD_REDIR_SUPER:
13525             o->op_flags |= OPf_REF;
13526             if (aop->op_type == OP_CONST) {
13527                 aop->op_private &= ~OPpCONST_STRICT;
13528                 const_class = &cSVOPx(aop)->op_sv;
13529             }
13530             else if (aop->op_type == OP_LIST) {
13531                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13532                 if (sib && sib->op_type == OP_CONST) {
13533                     sib->op_private &= ~OPpCONST_STRICT;
13534                     const_class = &cSVOPx(sib)->op_sv;
13535                 }
13536             }
13537             /* make class name a shared cow string to speedup method calls */
13538             /* constant string might be replaced with object, f.e. bigint */
13539             if (const_class && SvPOK(*const_class)) {
13540                 STRLEN len;
13541                 const char* str = SvPV(*const_class, len);
13542                 if (len) {
13543                     SV* const shared = newSVpvn_share(
13544                         str, SvUTF8(*const_class)
13545                                     ? -(SSize_t)len : (SSize_t)len,
13546                         0
13547                     );
13548                     if (SvREADONLY(*const_class))
13549                         SvREADONLY_on(shared);
13550                     SvREFCNT_dec(*const_class);
13551                     *const_class = shared;
13552                 }
13553             }
13554             break;
13555     }
13556
13557     if (!cv) {
13558         S_entersub_alloc_targ(aTHX_ o);
13559         return ck_entersub_args_list(o);
13560     } else {
13561         Perl_call_checker ckfun;
13562         SV *ckobj;
13563         U32 ckflags;
13564         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13565         if (CvISXSUB(cv) || !CvROOT(cv))
13566             S_entersub_alloc_targ(aTHX_ o);
13567         if (!namegv) {
13568             /* The original call checker API guarantees that a GV will be
13569                be provided with the right name.  So, if the old API was
13570                used (or the REQUIRE_GV flag was passed), we have to reify
13571                the CV’s GV, unless this is an anonymous sub.  This is not
13572                ideal for lexical subs, as its stringification will include
13573                the package.  But it is the best we can do.  */
13574             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13575                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13576                     namegv = CvGV(cv);
13577             }
13578             else namegv = MUTABLE_GV(cv);
13579             /* After a syntax error in a lexical sub, the cv that
13580                rv2cv_op_cv returns may be a nameless stub. */
13581             if (!namegv) return ck_entersub_args_list(o);
13582
13583         }
13584         return ckfun(aTHX_ o, namegv, ckobj);
13585     }
13586 }
13587
13588 OP *
13589 Perl_ck_svconst(pTHX_ OP *o)
13590 {
13591     SV * const sv = cSVOPo->op_sv;
13592     PERL_ARGS_ASSERT_CK_SVCONST;
13593     PERL_UNUSED_CONTEXT;
13594 #ifdef PERL_COPY_ON_WRITE
13595     /* Since the read-only flag may be used to protect a string buffer, we
13596        cannot do copy-on-write with existing read-only scalars that are not
13597        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13598        that constant, mark the constant as COWable here, if it is not
13599        already read-only. */
13600     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13601         SvIsCOW_on(sv);
13602         CowREFCNT(sv) = 0;
13603 # ifdef PERL_DEBUG_READONLY_COW
13604         sv_buf_to_ro(sv);
13605 # endif
13606     }
13607 #endif
13608     SvREADONLY_on(sv);
13609     return o;
13610 }
13611
13612 OP *
13613 Perl_ck_trunc(pTHX_ OP *o)
13614 {
13615     PERL_ARGS_ASSERT_CK_TRUNC;
13616
13617     if (o->op_flags & OPf_KIDS) {
13618         SVOP *kid = (SVOP*)cUNOPo->op_first;
13619
13620         if (kid->op_type == OP_NULL)
13621             kid = (SVOP*)OpSIBLING(kid);
13622         if (kid && kid->op_type == OP_CONST &&
13623             (kid->op_private & OPpCONST_BARE) &&
13624             !kid->op_folded)
13625         {
13626             o->op_flags |= OPf_SPECIAL;
13627             kid->op_private &= ~OPpCONST_STRICT;
13628         }
13629     }
13630     return ck_fun(o);
13631 }
13632
13633 OP *
13634 Perl_ck_substr(pTHX_ OP *o)
13635 {
13636     PERL_ARGS_ASSERT_CK_SUBSTR;
13637
13638     o = ck_fun(o);
13639     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13640         OP *kid = cLISTOPo->op_first;
13641
13642         if (kid->op_type == OP_NULL)
13643             kid = OpSIBLING(kid);
13644         if (kid)
13645             /* Historically, substr(delete $foo{bar},...) has been allowed
13646                with 4-arg substr.  Keep it working by applying entersub
13647                lvalue context.  */
13648             op_lvalue(kid, OP_ENTERSUB);
13649
13650     }
13651     return o;
13652 }
13653
13654 OP *
13655 Perl_ck_tell(pTHX_ OP *o)
13656 {
13657     PERL_ARGS_ASSERT_CK_TELL;
13658     o = ck_fun(o);
13659     if (o->op_flags & OPf_KIDS) {
13660      OP *kid = cLISTOPo->op_first;
13661      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13662      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13663     }
13664     return o;
13665 }
13666
13667 OP *
13668 Perl_ck_each(pTHX_ OP *o)
13669 {
13670     dVAR;
13671     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13672     const unsigned orig_type  = o->op_type;
13673
13674     PERL_ARGS_ASSERT_CK_EACH;
13675
13676     if (kid) {
13677         switch (kid->op_type) {
13678             case OP_PADHV:
13679             case OP_RV2HV:
13680                 break;
13681             case OP_PADAV:
13682             case OP_RV2AV:
13683                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13684                             : orig_type == OP_KEYS ? OP_AKEYS
13685                             :                        OP_AVALUES);
13686                 break;
13687             case OP_CONST:
13688                 if (kid->op_private == OPpCONST_BARE
13689                  || !SvROK(cSVOPx_sv(kid))
13690                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13691                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13692                    )
13693                     goto bad;
13694                 /* FALLTHROUGH */
13695             default:
13696                 qerror(Perl_mess(aTHX_
13697                     "Experimental %s on scalar is now forbidden",
13698                      PL_op_desc[orig_type]));
13699                bad:
13700                 bad_type_pv(1, "hash or array", o, kid);
13701                 return o;
13702         }
13703     }
13704     return ck_fun(o);
13705 }
13706
13707 OP *
13708 Perl_ck_length(pTHX_ OP *o)
13709 {
13710     PERL_ARGS_ASSERT_CK_LENGTH;
13711
13712     o = ck_fun(o);
13713
13714     if (ckWARN(WARN_SYNTAX)) {
13715         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13716
13717         if (kid) {
13718             SV *name = NULL;
13719             const bool hash = kid->op_type == OP_PADHV
13720                            || kid->op_type == OP_RV2HV;
13721             switch (kid->op_type) {
13722                 case OP_PADHV:
13723                 case OP_PADAV:
13724                 case OP_RV2HV:
13725                 case OP_RV2AV:
13726                     name = S_op_varname(aTHX_ kid);
13727                     break;
13728                 default:
13729                     return o;
13730             }
13731             if (name)
13732                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13733                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13734                     ")\"?)",
13735                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13736                 );
13737             else if (hash)
13738      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13739                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13740                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13741             else
13742      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13743                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13744                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13745         }
13746     }
13747
13748     return o;
13749 }
13750
13751
13752
13753 /*
13754    ---------------------------------------------------------
13755
13756    Common vars in list assignment
13757
13758    There now follows some enums and static functions for detecting
13759    common variables in list assignments. Here is a little essay I wrote
13760    for myself when trying to get my head around this. DAPM.
13761
13762    ----
13763
13764    First some random observations:
13765
13766    * If a lexical var is an alias of something else, e.g.
13767        for my $x ($lex, $pkg, $a[0]) {...}
13768      then the act of aliasing will increase the reference count of the SV
13769
13770    * If a package var is an alias of something else, it may still have a
13771      reference count of 1, depending on how the alias was created, e.g.
13772      in *a = *b, $a may have a refcount of 1 since the GP is shared
13773      with a single GvSV pointer to the SV. So If it's an alias of another
13774      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13775      a lexical var or an array element, then it will have RC > 1.
13776
13777    * There are many ways to create a package alias; ultimately, XS code
13778      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13779      run-time tracing mechanisms are unlikely to be able to catch all cases.
13780
13781    * When the LHS is all my declarations, the same vars can't appear directly
13782      on the RHS, but they can indirectly via closures, aliasing and lvalue
13783      subs. But those techniques all involve an increase in the lexical
13784      scalar's ref count.
13785
13786    * When the LHS is all lexical vars (but not necessarily my declarations),
13787      it is possible for the same lexicals to appear directly on the RHS, and
13788      without an increased ref count, since the stack isn't refcounted.
13789      This case can be detected at compile time by scanning for common lex
13790      vars with PL_generation.
13791
13792    * lvalue subs defeat common var detection, but they do at least
13793      return vars with a temporary ref count increment. Also, you can't
13794      tell at compile time whether a sub call is lvalue.
13795
13796
13797    So...
13798
13799    A: There are a few circumstances where there definitely can't be any
13800      commonality:
13801
13802        LHS empty:  () = (...);
13803        RHS empty:  (....) = ();
13804        RHS contains only constants or other 'can't possibly be shared'
13805            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13806            i.e. they only contain ops not marked as dangerous, whose children
13807            are also not dangerous;
13808        LHS ditto;
13809        LHS contains a single scalar element: e.g. ($x) = (....); because
13810            after $x has been modified, it won't be used again on the RHS;
13811        RHS contains a single element with no aggregate on LHS: e.g.
13812            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13813            won't be used again.
13814
13815    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13816      we can ignore):
13817
13818        my ($a, $b, @c) = ...;
13819
13820        Due to closure and goto tricks, these vars may already have content.
13821        For the same reason, an element on the RHS may be a lexical or package
13822        alias of one of the vars on the left, or share common elements, for
13823        example:
13824
13825            my ($x,$y) = f(); # $x and $y on both sides
13826            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13827
13828        and
13829
13830            my $ra = f();
13831            my @a = @$ra;  # elements of @a on both sides
13832            sub f { @a = 1..4; \@a }
13833
13834
13835        First, just consider scalar vars on LHS:
13836
13837            RHS is safe only if (A), or in addition,
13838                * contains only lexical *scalar* vars, where neither side's
13839                  lexicals have been flagged as aliases
13840
13841            If RHS is not safe, then it's always legal to check LHS vars for
13842            RC==1, since the only RHS aliases will always be associated
13843            with an RC bump.
13844
13845            Note that in particular, RHS is not safe if:
13846
13847                * it contains package scalar vars; e.g.:
13848
13849                    f();
13850                    my ($x, $y) = (2, $x_alias);
13851                    sub f { $x = 1; *x_alias = \$x; }
13852
13853                * It contains other general elements, such as flattened or
13854                * spliced or single array or hash elements, e.g.
13855
13856                    f();
13857                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13858
13859                    sub f {
13860                        ($x, $y) = (1,2);
13861                        use feature 'refaliasing';
13862                        \($a[0], $a[1]) = \($y,$x);
13863                    }
13864
13865                  It doesn't matter if the array/hash is lexical or package.
13866
13867                * it contains a function call that happens to be an lvalue
13868                  sub which returns one or more of the above, e.g.
13869
13870                    f();
13871                    my ($x,$y) = f();
13872
13873                    sub f : lvalue {
13874                        ($x, $y) = (1,2);
13875                        *x1 = \$x;
13876                        $y, $x1;
13877                    }
13878
13879                    (so a sub call on the RHS should be treated the same
13880                    as having a package var on the RHS).
13881
13882                * any other "dangerous" thing, such an op or built-in that
13883                  returns one of the above, e.g. pp_preinc
13884
13885
13886            If RHS is not safe, what we can do however is at compile time flag
13887            that the LHS are all my declarations, and at run time check whether
13888            all the LHS have RC == 1, and if so skip the full scan.
13889
13890        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
13891
13892            Here the issue is whether there can be elements of @a on the RHS
13893            which will get prematurely freed when @a is cleared prior to
13894            assignment. This is only a problem if the aliasing mechanism
13895            is one which doesn't increase the refcount - only if RC == 1
13896            will the RHS element be prematurely freed.
13897
13898            Because the array/hash is being INTROed, it or its elements
13899            can't directly appear on the RHS:
13900
13901                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
13902
13903            but can indirectly, e.g.:
13904
13905                my $r = f();
13906                my (@a) = @$r;
13907                sub f { @a = 1..3; \@a }
13908
13909            So if the RHS isn't safe as defined by (A), we must always
13910            mortalise and bump the ref count of any remaining RHS elements
13911            when assigning to a non-empty LHS aggregate.
13912
13913            Lexical scalars on the RHS aren't safe if they've been involved in
13914            aliasing, e.g.
13915
13916                use feature 'refaliasing';
13917
13918                f();
13919                \(my $lex) = \$pkg;
13920                my @a = ($lex,3); # equivalent to ($a[0],3)
13921
13922                sub f {
13923                    @a = (1,2);
13924                    \$pkg = \$a[0];
13925                }
13926
13927            Similarly with lexical arrays and hashes on the RHS:
13928
13929                f();
13930                my @b;
13931                my @a = (@b);
13932
13933                sub f {
13934                    @a = (1,2);
13935                    \$b[0] = \$a[1];
13936                    \$b[1] = \$a[0];
13937                }
13938
13939
13940
13941    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
13942        my $a; ($a, my $b) = (....);
13943
13944        The difference between (B) and (C) is that it is now physically
13945        possible for the LHS vars to appear on the RHS too, where they
13946        are not reference counted; but in this case, the compile-time
13947        PL_generation sweep will detect such common vars.
13948
13949        So the rules for (C) differ from (B) in that if common vars are
13950        detected, the runtime "test RC==1" optimisation can no longer be used,
13951        and a full mark and sweep is required
13952
13953    D: As (C), but in addition the LHS may contain package vars.
13954
13955        Since package vars can be aliased without a corresponding refcount
13956        increase, all bets are off. It's only safe if (A). E.g.
13957
13958            my ($x, $y) = (1,2);
13959
13960            for $x_alias ($x) {
13961                ($x_alias, $y) = (3, $x); # whoops
13962            }
13963
13964        Ditto for LHS aggregate package vars.
13965
13966    E: Any other dangerous ops on LHS, e.g.
13967            (f(), $a[0], @$r) = (...);
13968
13969        this is similar to (E) in that all bets are off. In addition, it's
13970        impossible to determine at compile time whether the LHS
13971        contains a scalar or an aggregate, e.g.
13972
13973            sub f : lvalue { @a }
13974            (f()) = 1..3;
13975
13976 * ---------------------------------------------------------
13977 */
13978
13979
13980 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
13981  * that at least one of the things flagged was seen.
13982  */
13983
13984 enum {
13985     AAS_MY_SCALAR       = 0x001, /* my $scalar */
13986     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
13987     AAS_LEX_SCALAR      = 0x004, /* $lexical */
13988     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
13989     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
13990     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
13991     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
13992     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
13993                                          that's flagged OA_DANGEROUS */
13994     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
13995                                         not in any of the categories above */
13996     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
13997 };
13998
13999
14000
14001 /* helper function for S_aassign_scan().
14002  * check a PAD-related op for commonality and/or set its generation number.
14003  * Returns a boolean indicating whether its shared */
14004
14005 static bool
14006 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14007 {
14008     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14009         /* lexical used in aliasing */
14010         return TRUE;
14011
14012     if (rhs)
14013         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14014     else
14015         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14016
14017     return FALSE;
14018 }
14019
14020
14021 /*
14022   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14023   It scans the left or right hand subtree of the aassign op, and returns a
14024   set of flags indicating what sorts of things it found there.
14025   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14026   set PL_generation on lexical vars; if the latter, we see if
14027   PL_generation matches.
14028   'top' indicates whether we're recursing or at the top level.
14029   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14030   This fn will increment it by the number seen. It's not intended to
14031   be an accurate count (especially as many ops can push a variable
14032   number of SVs onto the stack); rather it's used as to test whether there
14033   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14034 */
14035
14036 static int
14037 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14038 {
14039     int flags = 0;
14040     bool kid_top = FALSE;
14041
14042     /* first, look for a solitary @_ on the RHS */
14043     if (   rhs
14044         && top
14045         && (o->op_flags & OPf_KIDS)
14046         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14047     ) {
14048         OP *kid = cUNOPo->op_first;
14049         if (   (   kid->op_type == OP_PUSHMARK
14050                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14051             && ((kid = OpSIBLING(kid)))
14052             && !OpHAS_SIBLING(kid)
14053             && kid->op_type == OP_RV2AV
14054             && !(kid->op_flags & OPf_REF)
14055             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14056             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14057             && ((kid = cUNOPx(kid)->op_first))
14058             && kid->op_type == OP_GV
14059             && cGVOPx_gv(kid) == PL_defgv
14060         )
14061             flags |= AAS_DEFAV;
14062     }
14063
14064     switch (o->op_type) {
14065     case OP_GVSV:
14066         (*scalars_p)++;
14067         return AAS_PKG_SCALAR;
14068
14069     case OP_PADAV:
14070     case OP_PADHV:
14071         (*scalars_p) += 2;
14072         /* if !top, could be e.g. @a[0,1] */
14073         if (top && (o->op_flags & OPf_REF))
14074             return (o->op_private & OPpLVAL_INTRO)
14075                 ? AAS_MY_AGG : AAS_LEX_AGG;
14076         return AAS_DANGEROUS;
14077
14078     case OP_PADSV:
14079         {
14080             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14081                         ?  AAS_LEX_SCALAR_COMM : 0;
14082             (*scalars_p)++;
14083             return (o->op_private & OPpLVAL_INTRO)
14084                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14085         }
14086
14087     case OP_RV2AV:
14088     case OP_RV2HV:
14089         (*scalars_p) += 2;
14090         if (cUNOPx(o)->op_first->op_type != OP_GV)
14091             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14092         /* @pkg, %pkg */
14093         /* if !top, could be e.g. @a[0,1] */
14094         if (top && (o->op_flags & OPf_REF))
14095             return AAS_PKG_AGG;
14096         return AAS_DANGEROUS;
14097
14098     case OP_RV2SV:
14099         (*scalars_p)++;
14100         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14101             (*scalars_p) += 2;
14102             return AAS_DANGEROUS; /* ${expr} */
14103         }
14104         return AAS_PKG_SCALAR; /* $pkg */
14105
14106     case OP_SPLIT:
14107         if (o->op_private & OPpSPLIT_ASSIGN) {
14108             /* the assign in @a = split() has been optimised away
14109              * and the @a attached directly to the split op
14110              * Treat the array as appearing on the RHS, i.e.
14111              *    ... = (@a = split)
14112              * is treated like
14113              *    ... = @a;
14114              */
14115
14116             if (o->op_flags & OPf_STACKED)
14117                 /* @{expr} = split() - the array expression is tacked
14118                  * on as an extra child to split - process kid */
14119                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14120                                         top, scalars_p);
14121
14122             /* ... else array is directly attached to split op */
14123             (*scalars_p) += 2;
14124             if (PL_op->op_private & OPpSPLIT_LEX)
14125                 return (o->op_private & OPpLVAL_INTRO)
14126                     ? AAS_MY_AGG : AAS_LEX_AGG;
14127             else
14128                 return AAS_PKG_AGG;
14129         }
14130         (*scalars_p)++;
14131         /* other args of split can't be returned */
14132         return AAS_SAFE_SCALAR;
14133
14134     case OP_UNDEF:
14135         /* undef counts as a scalar on the RHS:
14136          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14137          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14138          */
14139         if (rhs)
14140             (*scalars_p)++;
14141         flags = AAS_SAFE_SCALAR;
14142         break;
14143
14144     case OP_PUSHMARK:
14145     case OP_STUB:
14146         /* these are all no-ops; they don't push a potentially common SV
14147          * onto the stack, so they are neither AAS_DANGEROUS nor
14148          * AAS_SAFE_SCALAR */
14149         return 0;
14150
14151     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14152         break;
14153
14154     case OP_NULL:
14155     case OP_LIST:
14156         /* these do nothing but may have children; but their children
14157          * should also be treated as top-level */
14158         kid_top = top;
14159         break;
14160
14161     default:
14162         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14163             (*scalars_p) += 2;
14164             flags = AAS_DANGEROUS;
14165             break;
14166         }
14167
14168         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14169             && (o->op_private & OPpTARGET_MY))
14170         {
14171             (*scalars_p)++;
14172             return S_aassign_padcheck(aTHX_ o, rhs)
14173                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14174         }
14175
14176         /* if its an unrecognised, non-dangerous op, assume that it
14177          * it the cause of at least one safe scalar */
14178         (*scalars_p)++;
14179         flags = AAS_SAFE_SCALAR;
14180         break;
14181     }
14182
14183     /* XXX this assumes that all other ops are "transparent" - i.e. that
14184      * they can return some of their children. While this true for e.g.
14185      * sort and grep, it's not true for e.g. map. We really need a
14186      * 'transparent' flag added to regen/opcodes
14187      */
14188     if (o->op_flags & OPf_KIDS) {
14189         OP *kid;
14190         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14191             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14192     }
14193     return flags;
14194 }
14195
14196
14197 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14198    and modify the optree to make them work inplace */
14199
14200 STATIC void
14201 S_inplace_aassign(pTHX_ OP *o) {
14202
14203     OP *modop, *modop_pushmark;
14204     OP *oright;
14205     OP *oleft, *oleft_pushmark;
14206
14207     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14208
14209     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14210
14211     assert(cUNOPo->op_first->op_type == OP_NULL);
14212     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14213     assert(modop_pushmark->op_type == OP_PUSHMARK);
14214     modop = OpSIBLING(modop_pushmark);
14215
14216     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14217         return;
14218
14219     /* no other operation except sort/reverse */
14220     if (OpHAS_SIBLING(modop))
14221         return;
14222
14223     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14224     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14225
14226     if (modop->op_flags & OPf_STACKED) {
14227         /* skip sort subroutine/block */
14228         assert(oright->op_type == OP_NULL);
14229         oright = OpSIBLING(oright);
14230     }
14231
14232     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14233     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14234     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14235     oleft = OpSIBLING(oleft_pushmark);
14236
14237     /* Check the lhs is an array */
14238     if (!oleft ||
14239         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14240         || OpHAS_SIBLING(oleft)
14241         || (oleft->op_private & OPpLVAL_INTRO)
14242     )
14243         return;
14244
14245     /* Only one thing on the rhs */
14246     if (OpHAS_SIBLING(oright))
14247         return;
14248
14249     /* check the array is the same on both sides */
14250     if (oleft->op_type == OP_RV2AV) {
14251         if (oright->op_type != OP_RV2AV
14252             || !cUNOPx(oright)->op_first
14253             || cUNOPx(oright)->op_first->op_type != OP_GV
14254             || cUNOPx(oleft )->op_first->op_type != OP_GV
14255             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14256                cGVOPx_gv(cUNOPx(oright)->op_first)
14257         )
14258             return;
14259     }
14260     else if (oright->op_type != OP_PADAV
14261         || oright->op_targ != oleft->op_targ
14262     )
14263         return;
14264
14265     /* This actually is an inplace assignment */
14266
14267     modop->op_private |= OPpSORT_INPLACE;
14268
14269     /* transfer MODishness etc from LHS arg to RHS arg */
14270     oright->op_flags = oleft->op_flags;
14271
14272     /* remove the aassign op and the lhs */
14273     op_null(o);
14274     op_null(oleft_pushmark);
14275     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14276         op_null(cUNOPx(oleft)->op_first);
14277     op_null(oleft);
14278 }
14279
14280
14281
14282 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14283  * that potentially represent a series of one or more aggregate derefs
14284  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14285  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14286  * additional ops left in too).
14287  *
14288  * The caller will have already verified that the first few ops in the
14289  * chain following 'start' indicate a multideref candidate, and will have
14290  * set 'orig_o' to the point further on in the chain where the first index
14291  * expression (if any) begins.  'orig_action' specifies what type of
14292  * beginning has already been determined by the ops between start..orig_o
14293  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14294  *
14295  * 'hints' contains any hints flags that need adding (currently just
14296  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14297  */
14298
14299 STATIC void
14300 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14301 {
14302     dVAR;
14303     int pass;
14304     UNOP_AUX_item *arg_buf = NULL;
14305     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14306     int index_skip         = -1;    /* don't output index arg on this action */
14307
14308     /* similar to regex compiling, do two passes; the first pass
14309      * determines whether the op chain is convertible and calculates the
14310      * buffer size; the second pass populates the buffer and makes any
14311      * changes necessary to ops (such as moving consts to the pad on
14312      * threaded builds).
14313      *
14314      * NB: for things like Coverity, note that both passes take the same
14315      * path through the logic tree (except for 'if (pass)' bits), since
14316      * both passes are following the same op_next chain; and in
14317      * particular, if it would return early on the second pass, it would
14318      * already have returned early on the first pass.
14319      */
14320     for (pass = 0; pass < 2; pass++) {
14321         OP *o                = orig_o;
14322         UV action            = orig_action;
14323         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14324         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14325         int action_count     = 0;     /* number of actions seen so far */
14326         int action_ix        = 0;     /* action_count % (actions per IV) */
14327         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14328         bool is_last         = FALSE; /* no more derefs to follow */
14329         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14330         UNOP_AUX_item *arg     = arg_buf;
14331         UNOP_AUX_item *action_ptr = arg_buf;
14332
14333         if (pass)
14334             action_ptr->uv = 0;
14335         arg++;
14336
14337         switch (action) {
14338         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14339         case MDEREF_HV_gvhv_helem:
14340             next_is_hash = TRUE;
14341             /* FALLTHROUGH */
14342         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14343         case MDEREF_AV_gvav_aelem:
14344             if (pass) {
14345 #ifdef USE_ITHREADS
14346                 arg->pad_offset = cPADOPx(start)->op_padix;
14347                 /* stop it being swiped when nulled */
14348                 cPADOPx(start)->op_padix = 0;
14349 #else
14350                 arg->sv = cSVOPx(start)->op_sv;
14351                 cSVOPx(start)->op_sv = NULL;
14352 #endif
14353             }
14354             arg++;
14355             break;
14356
14357         case MDEREF_HV_padhv_helem:
14358         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14359             next_is_hash = TRUE;
14360             /* FALLTHROUGH */
14361         case MDEREF_AV_padav_aelem:
14362         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14363             if (pass) {
14364                 arg->pad_offset = start->op_targ;
14365                 /* we skip setting op_targ = 0 for now, since the intact
14366                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14367                 reset_start_targ = TRUE;
14368             }
14369             arg++;
14370             break;
14371
14372         case MDEREF_HV_pop_rv2hv_helem:
14373             next_is_hash = TRUE;
14374             /* FALLTHROUGH */
14375         case MDEREF_AV_pop_rv2av_aelem:
14376             break;
14377
14378         default:
14379             NOT_REACHED; /* NOTREACHED */
14380             return;
14381         }
14382
14383         while (!is_last) {
14384             /* look for another (rv2av/hv; get index;
14385              * aelem/helem/exists/delele) sequence */
14386
14387             OP *kid;
14388             bool is_deref;
14389             bool ok;
14390             UV index_type = MDEREF_INDEX_none;
14391
14392             if (action_count) {
14393                 /* if this is not the first lookup, consume the rv2av/hv  */
14394
14395                 /* for N levels of aggregate lookup, we normally expect
14396                  * that the first N-1 [ah]elem ops will be flagged as
14397                  * /DEREF (so they autovivifiy if necessary), and the last
14398                  * lookup op not to be.
14399                  * For other things (like @{$h{k1}{k2}}) extra scope or
14400                  * leave ops can appear, so abandon the effort in that
14401                  * case */
14402                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14403                     return;
14404
14405                 /* rv2av or rv2hv sKR/1 */
14406
14407                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14408                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14409                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14410                     return;
14411
14412                 /* at this point, we wouldn't expect any of these
14413                  * possible private flags:
14414                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14415                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14416                  */
14417                 ASSUME(!(o->op_private &
14418                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14419
14420                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14421
14422                 /* make sure the type of the previous /DEREF matches the
14423                  * type of the next lookup */
14424                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14425                 top_op = o;
14426
14427                 action = next_is_hash
14428                             ? MDEREF_HV_vivify_rv2hv_helem
14429                             : MDEREF_AV_vivify_rv2av_aelem;
14430                 o = o->op_next;
14431             }
14432
14433             /* if this is the second pass, and we're at the depth where
14434              * previously we encountered a non-simple index expression,
14435              * stop processing the index at this point */
14436             if (action_count != index_skip) {
14437
14438                 /* look for one or more simple ops that return an array
14439                  * index or hash key */
14440
14441                 switch (o->op_type) {
14442                 case OP_PADSV:
14443                     /* it may be a lexical var index */
14444                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14445                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14446                     ASSUME(!(o->op_private &
14447                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14448
14449                     if (   OP_GIMME(o,0) == G_SCALAR
14450                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14451                         && o->op_private == 0)
14452                     {
14453                         if (pass)
14454                             arg->pad_offset = o->op_targ;
14455                         arg++;
14456                         index_type = MDEREF_INDEX_padsv;
14457                         o = o->op_next;
14458                     }
14459                     break;
14460
14461                 case OP_CONST:
14462                     if (next_is_hash) {
14463                         /* it's a constant hash index */
14464                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14465                             /* "use constant foo => FOO; $h{+foo}" for
14466                              * some weird FOO, can leave you with constants
14467                              * that aren't simple strings. It's not worth
14468                              * the extra hassle for those edge cases */
14469                             break;
14470
14471                         if (pass) {
14472                             UNOP *rop = NULL;
14473                             OP * helem_op = o->op_next;
14474
14475                             ASSUME(   helem_op->op_type == OP_HELEM
14476                                    || helem_op->op_type == OP_NULL);
14477                             if (helem_op->op_type == OP_HELEM) {
14478                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14479                                 if (   helem_op->op_private & OPpLVAL_INTRO
14480                                     || rop->op_type != OP_RV2HV
14481                                 )
14482                                     rop = NULL;
14483                             }
14484                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14485
14486 #ifdef USE_ITHREADS
14487                             /* Relocate sv to the pad for thread safety */
14488                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14489                             arg->pad_offset = o->op_targ;
14490                             o->op_targ = 0;
14491 #else
14492                             arg->sv = cSVOPx_sv(o);
14493 #endif
14494                         }
14495                     }
14496                     else {
14497                         /* it's a constant array index */
14498                         IV iv;
14499                         SV *ix_sv = cSVOPo->op_sv;
14500                         if (!SvIOK(ix_sv))
14501                             break;
14502                         iv = SvIV(ix_sv);
14503
14504                         if (   action_count == 0
14505                             && iv >= -128
14506                             && iv <= 127
14507                             && (   action == MDEREF_AV_padav_aelem
14508                                 || action == MDEREF_AV_gvav_aelem)
14509                         )
14510                             maybe_aelemfast = TRUE;
14511
14512                         if (pass) {
14513                             arg->iv = iv;
14514                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14515                         }
14516                     }
14517                     if (pass)
14518                         /* we've taken ownership of the SV */
14519                         cSVOPo->op_sv = NULL;
14520                     arg++;
14521                     index_type = MDEREF_INDEX_const;
14522                     o = o->op_next;
14523                     break;
14524
14525                 case OP_GV:
14526                     /* it may be a package var index */
14527
14528                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14529                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14530                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14531                         || o->op_private != 0
14532                     )
14533                         break;
14534
14535                     kid = o->op_next;
14536                     if (kid->op_type != OP_RV2SV)
14537                         break;
14538
14539                     ASSUME(!(kid->op_flags &
14540                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14541                              |OPf_SPECIAL|OPf_PARENS)));
14542                     ASSUME(!(kid->op_private &
14543                                     ~(OPpARG1_MASK
14544                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14545                                      |OPpDEREF|OPpLVAL_INTRO)));
14546                     if(   (kid->op_flags &~ OPf_PARENS)
14547                             != (OPf_WANT_SCALAR|OPf_KIDS)
14548                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14549                     )
14550                         break;
14551
14552                     if (pass) {
14553 #ifdef USE_ITHREADS
14554                         arg->pad_offset = cPADOPx(o)->op_padix;
14555                         /* stop it being swiped when nulled */
14556                         cPADOPx(o)->op_padix = 0;
14557 #else
14558                         arg->sv = cSVOPx(o)->op_sv;
14559                         cSVOPo->op_sv = NULL;
14560 #endif
14561                     }
14562                     arg++;
14563                     index_type = MDEREF_INDEX_gvsv;
14564                     o = kid->op_next;
14565                     break;
14566
14567                 } /* switch */
14568             } /* action_count != index_skip */
14569
14570             action |= index_type;
14571
14572
14573             /* at this point we have either:
14574              *   * detected what looks like a simple index expression,
14575              *     and expect the next op to be an [ah]elem, or
14576              *     an nulled  [ah]elem followed by a delete or exists;
14577              *  * found a more complex expression, so something other
14578              *    than the above follows.
14579              */
14580
14581             /* possibly an optimised away [ah]elem (where op_next is
14582              * exists or delete) */
14583             if (o->op_type == OP_NULL)
14584                 o = o->op_next;
14585
14586             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14587              * OP_EXISTS or OP_DELETE */
14588
14589             /* if something like arybase (a.k.a $[ ) is in scope,
14590              * abandon optimisation attempt */
14591             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14592                && PL_check[o->op_type] != Perl_ck_null)
14593                 return;
14594             /* similarly for customised exists and delete */
14595             if (  (o->op_type == OP_EXISTS)
14596                && PL_check[o->op_type] != Perl_ck_exists)
14597                 return;
14598             if (  (o->op_type == OP_DELETE)
14599                && PL_check[o->op_type] != Perl_ck_delete)
14600                 return;
14601
14602             if (   o->op_type != OP_AELEM
14603                 || (o->op_private &
14604                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14605                 )
14606                 maybe_aelemfast = FALSE;
14607
14608             /* look for aelem/helem/exists/delete. If it's not the last elem
14609              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14610              * flags; if it's the last, then it mustn't have
14611              * OPpDEREF_AV/HV, but may have lots of other flags, like
14612              * OPpLVAL_INTRO etc
14613              */
14614
14615             if (   index_type == MDEREF_INDEX_none
14616                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14617                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14618             )
14619                 ok = FALSE;
14620             else {
14621                 /* we have aelem/helem/exists/delete with valid simple index */
14622
14623                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14624                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14625                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14626
14627                 /* This doesn't make much sense but is legal:
14628                  *    @{ local $x[0][0] } = 1
14629                  * Since scope exit will undo the autovivification,
14630                  * don't bother in the first place. The OP_LEAVE
14631                  * assertion is in case there are other cases of both
14632                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14633                  * exit that would undo the local - in which case this
14634                  * block of code would need rethinking.
14635                  */
14636                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14637 #ifdef DEBUGGING
14638                     OP *n = o->op_next;
14639                     while (n && (  n->op_type == OP_NULL
14640                                 || n->op_type == OP_LIST))
14641                         n = n->op_next;
14642                     assert(n && n->op_type == OP_LEAVE);
14643 #endif
14644                     o->op_private &= ~OPpDEREF;
14645                     is_deref = FALSE;
14646                 }
14647
14648                 if (is_deref) {
14649                     ASSUME(!(o->op_flags &
14650                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14651                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14652
14653                     ok =    (o->op_flags &~ OPf_PARENS)
14654                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14655                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14656                 }
14657                 else if (o->op_type == OP_EXISTS) {
14658                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14659                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14660                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14661                     ok =  !(o->op_private & ~OPpARG1_MASK);
14662                 }
14663                 else if (o->op_type == OP_DELETE) {
14664                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14665                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14666                     ASSUME(!(o->op_private &
14667                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14668                     /* don't handle slices or 'local delete'; the latter
14669                      * is fairly rare, and has a complex runtime */
14670                     ok =  !(o->op_private & ~OPpARG1_MASK);
14671                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14672                         /* skip handling run-tome error */
14673                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14674                 }
14675                 else {
14676                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14677                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14678                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14679                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14680                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14681                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14682                 }
14683             }
14684
14685             if (ok) {
14686                 if (!first_elem_op)
14687                     first_elem_op = o;
14688                 top_op = o;
14689                 if (is_deref) {
14690                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14691                     o = o->op_next;
14692                 }
14693                 else {
14694                     is_last = TRUE;
14695                     action |= MDEREF_FLAG_last;
14696                 }
14697             }
14698             else {
14699                 /* at this point we have something that started
14700                  * promisingly enough (with rv2av or whatever), but failed
14701                  * to find a simple index followed by an
14702                  * aelem/helem/exists/delete. If this is the first action,
14703                  * give up; but if we've already seen at least one
14704                  * aelem/helem, then keep them and add a new action with
14705                  * MDEREF_INDEX_none, which causes it to do the vivify
14706                  * from the end of the previous lookup, and do the deref,
14707                  * but stop at that point. So $a[0][expr] will do one
14708                  * av_fetch, vivify and deref, then continue executing at
14709                  * expr */
14710                 if (!action_count)
14711                     return;
14712                 is_last = TRUE;
14713                 index_skip = action_count;
14714                 action |= MDEREF_FLAG_last;
14715                 if (index_type != MDEREF_INDEX_none)
14716                     arg--;
14717             }
14718
14719             if (pass)
14720                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14721             action_ix++;
14722             action_count++;
14723             /* if there's no space for the next action, create a new slot
14724              * for it *before* we start adding args for that action */
14725             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14726                 action_ptr = arg;
14727                 if (pass)
14728                     arg->uv = 0;
14729                 arg++;
14730                 action_ix = 0;
14731             }
14732         } /* while !is_last */
14733
14734         /* success! */
14735
14736         if (pass) {
14737             OP *mderef;
14738             OP *p, *q;
14739
14740             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14741             if (index_skip == -1) {
14742                 mderef->op_flags = o->op_flags
14743                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14744                 if (o->op_type == OP_EXISTS)
14745                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14746                 else if (o->op_type == OP_DELETE)
14747                     mderef->op_private = OPpMULTIDEREF_DELETE;
14748                 else
14749                     mderef->op_private = o->op_private
14750                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14751             }
14752             /* accumulate strictness from every level (although I don't think
14753              * they can actually vary) */
14754             mderef->op_private |= hints;
14755
14756             /* integrate the new multideref op into the optree and the
14757              * op_next chain.
14758              *
14759              * In general an op like aelem or helem has two child
14760              * sub-trees: the aggregate expression (a_expr) and the
14761              * index expression (i_expr):
14762              *
14763              *     aelem
14764              *       |
14765              *     a_expr - i_expr
14766              *
14767              * The a_expr returns an AV or HV, while the i-expr returns an
14768              * index. In general a multideref replaces most or all of a
14769              * multi-level tree, e.g.
14770              *
14771              *     exists
14772              *       |
14773              *     ex-aelem
14774              *       |
14775              *     rv2av  - i_expr1
14776              *       |
14777              *     helem
14778              *       |
14779              *     rv2hv  - i_expr2
14780              *       |
14781              *     aelem
14782              *       |
14783              *     a_expr - i_expr3
14784              *
14785              * With multideref, all the i_exprs will be simple vars or
14786              * constants, except that i_expr1 may be arbitrary in the case
14787              * of MDEREF_INDEX_none.
14788              *
14789              * The bottom-most a_expr will be either:
14790              *   1) a simple var (so padXv or gv+rv2Xv);
14791              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14792              *      so a simple var with an extra rv2Xv;
14793              *   3) or an arbitrary expression.
14794              *
14795              * 'start', the first op in the execution chain, will point to
14796              *   1),2): the padXv or gv op;
14797              *   3):    the rv2Xv which forms the last op in the a_expr
14798              *          execution chain, and the top-most op in the a_expr
14799              *          subtree.
14800              *
14801              * For all cases, the 'start' node is no longer required,
14802              * but we can't free it since one or more external nodes
14803              * may point to it. E.g. consider
14804              *     $h{foo} = $a ? $b : $c
14805              * Here, both the op_next and op_other branches of the
14806              * cond_expr point to the gv[*h] of the hash expression, so
14807              * we can't free the 'start' op.
14808              *
14809              * For expr->[...], we need to save the subtree containing the
14810              * expression; for the other cases, we just need to save the
14811              * start node.
14812              * So in all cases, we null the start op and keep it around by
14813              * making it the child of the multideref op; for the expr->
14814              * case, the expr will be a subtree of the start node.
14815              *
14816              * So in the simple 1,2 case the  optree above changes to
14817              *
14818              *     ex-exists
14819              *       |
14820              *     multideref
14821              *       |
14822              *     ex-gv (or ex-padxv)
14823              *
14824              *  with the op_next chain being
14825              *
14826              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14827              *
14828              *  In the 3 case, we have
14829              *
14830              *     ex-exists
14831              *       |
14832              *     multideref
14833              *       |
14834              *     ex-rv2xv
14835              *       |
14836              *    rest-of-a_expr
14837              *      subtree
14838              *
14839              *  and
14840              *
14841              *  -> rest-of-a_expr subtree ->
14842              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
14843              *
14844              *
14845              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14846              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14847              * multideref attached as the child, e.g.
14848              *
14849              *     exists
14850              *       |
14851              *     ex-aelem
14852              *       |
14853              *     ex-rv2av  - i_expr1
14854              *       |
14855              *     multideref
14856              *       |
14857              *     ex-whatever
14858              *
14859              */
14860
14861             /* if we free this op, don't free the pad entry */
14862             if (reset_start_targ)
14863                 start->op_targ = 0;
14864
14865
14866             /* Cut the bit we need to save out of the tree and attach to
14867              * the multideref op, then free the rest of the tree */
14868
14869             /* find parent of node to be detached (for use by splice) */
14870             p = first_elem_op;
14871             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
14872                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14873             {
14874                 /* there is an arbitrary expression preceding us, e.g.
14875                  * expr->[..]? so we need to save the 'expr' subtree */
14876                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14877                     p = cUNOPx(p)->op_first;
14878                 ASSUME(   start->op_type == OP_RV2AV
14879                        || start->op_type == OP_RV2HV);
14880             }
14881             else {
14882                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
14883                  * above for exists/delete. */
14884                 while (   (p->op_flags & OPf_KIDS)
14885                        && cUNOPx(p)->op_first != start
14886                 )
14887                     p = cUNOPx(p)->op_first;
14888             }
14889             ASSUME(cUNOPx(p)->op_first == start);
14890
14891             /* detach from main tree, and re-attach under the multideref */
14892             op_sibling_splice(mderef, NULL, 0,
14893                     op_sibling_splice(p, NULL, 1, NULL));
14894             op_null(start);
14895
14896             start->op_next = mderef;
14897
14898             mderef->op_next = index_skip == -1 ? o->op_next : o;
14899
14900             /* excise and free the original tree, and replace with
14901              * the multideref op */
14902             p = op_sibling_splice(top_op, NULL, -1, mderef);
14903             while (p) {
14904                 q = OpSIBLING(p);
14905                 op_free(p);
14906                 p = q;
14907             }
14908             op_null(top_op);
14909         }
14910         else {
14911             Size_t size = arg - arg_buf;
14912
14913             if (maybe_aelemfast && action_count == 1)
14914                 return;
14915
14916             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
14917                                 sizeof(UNOP_AUX_item) * (size + 1));
14918             /* for dumping etc: store the length in a hidden first slot;
14919              * we set the op_aux pointer to the second slot */
14920             arg_buf->uv = size;
14921             arg_buf++;
14922         }
14923     } /* for (pass = ...) */
14924 }
14925
14926 /* See if the ops following o are such that o will always be executed in
14927  * boolean context: that is, the SV which o pushes onto the stack will
14928  * only ever be consumed by later ops via SvTRUE(sv) or similar.
14929  * If so, set a suitable private flag on o. Normally this will be
14930  * bool_flag; but see below why maybe_flag is needed too.
14931  *
14932  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
14933  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
14934  * already be taken, so you'll have to give that op two different flags.
14935  *
14936  * More explanation of 'maybe_flag' and 'safe_and' parameters.
14937  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
14938  * those underlying ops) short-circuit, which means that rather than
14939  * necessarily returning a truth value, they may return the LH argument,
14940  * which may not be boolean. For example in $x = (keys %h || -1), keys
14941  * should return a key count rather than a boolean, even though its
14942  * sort-of being used in boolean context.
14943  *
14944  * So we only consider such logical ops to provide boolean context to
14945  * their LH argument if they themselves are in void or boolean context.
14946  * However, sometimes the context isn't known until run-time. In this
14947  * case the op is marked with the maybe_flag flag it.
14948  *
14949  * Consider the following.
14950  *
14951  *     sub f { ....;  if (%h) { .... } }
14952  *
14953  * This is actually compiled as
14954  *
14955  *     sub f { ....;  %h && do { .... } }
14956  *
14957  * Here we won't know until runtime whether the final statement (and hence
14958  * the &&) is in void context and so is safe to return a boolean value.
14959  * So mark o with maybe_flag rather than the bool_flag.
14960  * Note that there is cost associated with determining context at runtime
14961  * (e.g. a call to block_gimme()), so it may not be worth setting (at
14962  * compile time) and testing (at runtime) maybe_flag if the scalar verses
14963  * boolean costs savings are marginal.
14964  *
14965  * However, we can do slightly better with && (compared to || and //):
14966  * this op only returns its LH argument when that argument is false. In
14967  * this case, as long as the op promises to return a false value which is
14968  * valid in both boolean and scalar contexts, we can mark an op consumed
14969  * by && with bool_flag rather than maybe_flag.
14970  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
14971  * than &PL_sv_no for a false result in boolean context, then it's safe. An
14972  * op which promises to handle this case is indicated by setting safe_and
14973  * to true.
14974  */
14975
14976 static void
14977 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
14978 {
14979     OP *lop;
14980     U8 flag = 0;
14981
14982     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
14983
14984     /* OPpTARGET_MY and boolean context probably don't mix well.
14985      * If someone finds a valid use case, maybe add an extra flag to this
14986      * function which indicates its safe to do so for this op? */
14987     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
14988              && (o->op_private & OPpTARGET_MY)));
14989
14990     lop = o->op_next;
14991
14992     while (lop) {
14993         switch (lop->op_type) {
14994         case OP_NULL:
14995         case OP_SCALAR:
14996             break;
14997
14998         /* these two consume the stack argument in the scalar case,
14999          * and treat it as a boolean in the non linenumber case */
15000         case OP_FLIP:
15001         case OP_FLOP:
15002             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15003                 || (lop->op_private & OPpFLIP_LINENUM))
15004             {
15005                 lop = NULL;
15006                 break;
15007             }
15008             /* FALLTHROUGH */
15009         /* these never leave the original value on the stack */
15010         case OP_NOT:
15011         case OP_XOR:
15012         case OP_COND_EXPR:
15013         case OP_GREPWHILE:
15014             flag = bool_flag;
15015             lop = NULL;
15016             break;
15017
15018         /* OR DOR and AND evaluate their arg as a boolean, but then may
15019          * leave the original scalar value on the stack when following the
15020          * op_next route. If not in void context, we need to ensure
15021          * that whatever follows consumes the arg only in boolean context
15022          * too.
15023          */
15024         case OP_AND:
15025             if (safe_and) {
15026                 flag = bool_flag;
15027                 lop = NULL;
15028                 break;
15029             }
15030             /* FALLTHROUGH */
15031         case OP_OR:
15032         case OP_DOR:
15033             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15034                 flag = bool_flag;
15035                 lop = NULL;
15036             }
15037             else if (!(lop->op_flags & OPf_WANT)) {
15038                 /* unknown context - decide at runtime */
15039                 flag = maybe_flag;
15040                 lop = NULL;
15041             }
15042             break;
15043
15044         default:
15045             lop = NULL;
15046             break;
15047         }
15048
15049         if (lop)
15050             lop = lop->op_next;
15051     }
15052
15053     o->op_private |= flag;
15054 }
15055
15056
15057
15058 /* mechanism for deferring recursion in rpeep() */
15059
15060 #define MAX_DEFERRED 4
15061
15062 #define DEFER(o) \
15063   STMT_START { \
15064     if (defer_ix == (MAX_DEFERRED-1)) { \
15065         OP **defer = defer_queue[defer_base]; \
15066         CALL_RPEEP(*defer); \
15067         S_prune_chain_head(defer); \
15068         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15069         defer_ix--; \
15070     } \
15071     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15072   } STMT_END
15073
15074 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15075 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15076
15077
15078 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15079  * See the comments at the top of this file for more details about when
15080  * peep() is called */
15081
15082 void
15083 Perl_rpeep(pTHX_ OP *o)
15084 {
15085     dVAR;
15086     OP* oldop = NULL;
15087     OP* oldoldop = NULL;
15088     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15089     int defer_base = 0;
15090     int defer_ix = -1;
15091
15092     if (!o || o->op_opt)
15093         return;
15094
15095     assert(o->op_type != OP_FREED);
15096
15097     ENTER;
15098     SAVEOP();
15099     SAVEVPTR(PL_curcop);
15100     for (;; o = o->op_next) {
15101         if (o && o->op_opt)
15102             o = NULL;
15103         if (!o) {
15104             while (defer_ix >= 0) {
15105                 OP **defer =
15106                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15107                 CALL_RPEEP(*defer);
15108                 S_prune_chain_head(defer);
15109             }
15110             break;
15111         }
15112
15113       redo:
15114
15115         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15116         assert(!oldoldop || oldoldop->op_next == oldop);
15117         assert(!oldop    || oldop->op_next    == o);
15118
15119         /* By default, this op has now been optimised. A couple of cases below
15120            clear this again.  */
15121         o->op_opt = 1;
15122         PL_op = o;
15123
15124         /* look for a series of 1 or more aggregate derefs, e.g.
15125          *   $a[1]{foo}[$i]{$k}
15126          * and replace with a single OP_MULTIDEREF op.
15127          * Each index must be either a const, or a simple variable,
15128          *
15129          * First, look for likely combinations of starting ops,
15130          * corresponding to (global and lexical variants of)
15131          *     $a[...]   $h{...}
15132          *     $r->[...] $r->{...}
15133          *     (preceding expression)->[...]
15134          *     (preceding expression)->{...}
15135          * and if so, call maybe_multideref() to do a full inspection
15136          * of the op chain and if appropriate, replace with an
15137          * OP_MULTIDEREF
15138          */
15139         {
15140             UV action;
15141             OP *o2 = o;
15142             U8 hints = 0;
15143
15144             switch (o2->op_type) {
15145             case OP_GV:
15146                 /* $pkg[..]   :   gv[*pkg]
15147                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15148
15149                 /* Fail if there are new op flag combinations that we're
15150                  * not aware of, rather than:
15151                  *  * silently failing to optimise, or
15152                  *  * silently optimising the flag away.
15153                  * If this ASSUME starts failing, examine what new flag
15154                  * has been added to the op, and decide whether the
15155                  * optimisation should still occur with that flag, then
15156                  * update the code accordingly. This applies to all the
15157                  * other ASSUMEs in the block of code too.
15158                  */
15159                 ASSUME(!(o2->op_flags &
15160                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15161                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15162
15163                 o2 = o2->op_next;
15164
15165                 if (o2->op_type == OP_RV2AV) {
15166                     action = MDEREF_AV_gvav_aelem;
15167                     goto do_deref;
15168                 }
15169
15170                 if (o2->op_type == OP_RV2HV) {
15171                     action = MDEREF_HV_gvhv_helem;
15172                     goto do_deref;
15173                 }
15174
15175                 if (o2->op_type != OP_RV2SV)
15176                     break;
15177
15178                 /* at this point we've seen gv,rv2sv, so the only valid
15179                  * construct left is $pkg->[] or $pkg->{} */
15180
15181                 ASSUME(!(o2->op_flags & OPf_STACKED));
15182                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15183                             != (OPf_WANT_SCALAR|OPf_MOD))
15184                     break;
15185
15186                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15187                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15188                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15189                     break;
15190                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15191                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15192                     break;
15193
15194                 o2 = o2->op_next;
15195                 if (o2->op_type == OP_RV2AV) {
15196                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15197                     goto do_deref;
15198                 }
15199                 if (o2->op_type == OP_RV2HV) {
15200                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15201                     goto do_deref;
15202                 }
15203                 break;
15204
15205             case OP_PADSV:
15206                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15207
15208                 ASSUME(!(o2->op_flags &
15209                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15210                 if ((o2->op_flags &
15211                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15212                      != (OPf_WANT_SCALAR|OPf_MOD))
15213                     break;
15214
15215                 ASSUME(!(o2->op_private &
15216                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15217                 /* skip if state or intro, or not a deref */
15218                 if (      o2->op_private != OPpDEREF_AV
15219                        && o2->op_private != OPpDEREF_HV)
15220                     break;
15221
15222                 o2 = o2->op_next;
15223                 if (o2->op_type == OP_RV2AV) {
15224                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15225                     goto do_deref;
15226                 }
15227                 if (o2->op_type == OP_RV2HV) {
15228                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15229                     goto do_deref;
15230                 }
15231                 break;
15232
15233             case OP_PADAV:
15234             case OP_PADHV:
15235                 /*    $lex[..]:  padav[@lex:1,2] sR *
15236                  * or $lex{..}:  padhv[%lex:1,2] sR */
15237                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15238                                             OPf_REF|OPf_SPECIAL)));
15239                 if ((o2->op_flags &
15240                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15241                      != (OPf_WANT_SCALAR|OPf_REF))
15242                     break;
15243                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15244                     break;
15245                 /* OPf_PARENS isn't currently used in this case;
15246                  * if that changes, let us know! */
15247                 ASSUME(!(o2->op_flags & OPf_PARENS));
15248
15249                 /* at this point, we wouldn't expect any of the remaining
15250                  * possible private flags:
15251                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15252                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15253                  *
15254                  * OPpSLICEWARNING shouldn't affect runtime
15255                  */
15256                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15257
15258                 action = o2->op_type == OP_PADAV
15259                             ? MDEREF_AV_padav_aelem
15260                             : MDEREF_HV_padhv_helem;
15261                 o2 = o2->op_next;
15262                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15263                 break;
15264
15265
15266             case OP_RV2AV:
15267             case OP_RV2HV:
15268                 action = o2->op_type == OP_RV2AV
15269                             ? MDEREF_AV_pop_rv2av_aelem
15270                             : MDEREF_HV_pop_rv2hv_helem;
15271                 /* FALLTHROUGH */
15272             do_deref:
15273                 /* (expr)->[...]:  rv2av sKR/1;
15274                  * (expr)->{...}:  rv2hv sKR/1; */
15275
15276                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15277
15278                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15279                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15280                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15281                     break;
15282
15283                 /* at this point, we wouldn't expect any of these
15284                  * possible private flags:
15285                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15286                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15287                  */
15288                 ASSUME(!(o2->op_private &
15289                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15290                      |OPpOUR_INTRO)));
15291                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15292
15293                 o2 = o2->op_next;
15294
15295                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15296                 break;
15297
15298             default:
15299                 break;
15300             }
15301         }
15302
15303
15304         switch (o->op_type) {
15305         case OP_DBSTATE:
15306             PL_curcop = ((COP*)o);              /* for warnings */
15307             break;
15308         case OP_NEXTSTATE:
15309             PL_curcop = ((COP*)o);              /* for warnings */
15310
15311             /* Optimise a "return ..." at the end of a sub to just be "...".
15312              * This saves 2 ops. Before:
15313              * 1  <;> nextstate(main 1 -e:1) v ->2
15314              * 4  <@> return K ->5
15315              * 2    <0> pushmark s ->3
15316              * -    <1> ex-rv2sv sK/1 ->4
15317              * 3      <#> gvsv[*cat] s ->4
15318              *
15319              * After:
15320              * -  <@> return K ->-
15321              * -    <0> pushmark s ->2
15322              * -    <1> ex-rv2sv sK/1 ->-
15323              * 2      <$> gvsv(*cat) s ->3
15324              */
15325             {
15326                 OP *next = o->op_next;
15327                 OP *sibling = OpSIBLING(o);
15328                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15329                     && OP_TYPE_IS(sibling, OP_RETURN)
15330                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15331                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15332                        ||OP_TYPE_IS(sibling->op_next->op_next,
15333                                     OP_LEAVESUBLV))
15334                     && cUNOPx(sibling)->op_first == next
15335                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15336                     && next->op_next
15337                 ) {
15338                     /* Look through the PUSHMARK's siblings for one that
15339                      * points to the RETURN */
15340                     OP *top = OpSIBLING(next);
15341                     while (top && top->op_next) {
15342                         if (top->op_next == sibling) {
15343                             top->op_next = sibling->op_next;
15344                             o->op_next = next->op_next;
15345                             break;
15346                         }
15347                         top = OpSIBLING(top);
15348                     }
15349                 }
15350             }
15351
15352             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15353              *
15354              * This latter form is then suitable for conversion into padrange
15355              * later on. Convert:
15356              *
15357              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15358              *
15359              * into:
15360              *
15361              *   nextstate1 ->     listop     -> nextstate3
15362              *                 /            \
15363              *         pushmark -> padop1 -> padop2
15364              */
15365             if (o->op_next && (
15366                     o->op_next->op_type == OP_PADSV
15367                  || o->op_next->op_type == OP_PADAV
15368                  || o->op_next->op_type == OP_PADHV
15369                 )
15370                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15371                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15372                 && o->op_next->op_next->op_next && (
15373                     o->op_next->op_next->op_next->op_type == OP_PADSV
15374                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15375                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15376                 )
15377                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15378                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15379                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15380                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15381             ) {
15382                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15383
15384                 pad1 =    o->op_next;
15385                 ns2  = pad1->op_next;
15386                 pad2 =  ns2->op_next;
15387                 ns3  = pad2->op_next;
15388
15389                 /* we assume here that the op_next chain is the same as
15390                  * the op_sibling chain */
15391                 assert(OpSIBLING(o)    == pad1);
15392                 assert(OpSIBLING(pad1) == ns2);
15393                 assert(OpSIBLING(ns2)  == pad2);
15394                 assert(OpSIBLING(pad2) == ns3);
15395
15396                 /* excise and delete ns2 */
15397                 op_sibling_splice(NULL, pad1, 1, NULL);
15398                 op_free(ns2);
15399
15400                 /* excise pad1 and pad2 */
15401                 op_sibling_splice(NULL, o, 2, NULL);
15402
15403                 /* create new listop, with children consisting of:
15404                  * a new pushmark, pad1, pad2. */
15405                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15406                 newop->op_flags |= OPf_PARENS;
15407                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15408
15409                 /* insert newop between o and ns3 */
15410                 op_sibling_splice(NULL, o, 0, newop);
15411
15412                 /*fixup op_next chain */
15413                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15414                 o    ->op_next = newpm;
15415                 newpm->op_next = pad1;
15416                 pad1 ->op_next = pad2;
15417                 pad2 ->op_next = newop; /* listop */
15418                 newop->op_next = ns3;
15419
15420                 /* Ensure pushmark has this flag if padops do */
15421                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15422                     newpm->op_flags |= OPf_MOD;
15423                 }
15424
15425                 break;
15426             }
15427
15428             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15429                to carry two labels. For now, take the easier option, and skip
15430                this optimisation if the first NEXTSTATE has a label.  */
15431             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15432                 OP *nextop = o->op_next;
15433                 while (nextop && nextop->op_type == OP_NULL)
15434                     nextop = nextop->op_next;
15435
15436                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15437                     op_null(o);
15438                     if (oldop)
15439                         oldop->op_next = nextop;
15440                     o = nextop;
15441                     /* Skip (old)oldop assignment since the current oldop's
15442                        op_next already points to the next op.  */
15443                     goto redo;
15444                 }
15445             }
15446             break;
15447
15448         case OP_CONCAT:
15449             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15450                 if (o->op_next->op_private & OPpTARGET_MY) {
15451                     if (o->op_flags & OPf_STACKED) /* chained concats */
15452                         break; /* ignore_optimization */
15453                     else {
15454                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15455                         o->op_targ = o->op_next->op_targ;
15456                         o->op_next->op_targ = 0;
15457                         o->op_private |= OPpTARGET_MY;
15458                     }
15459                 }
15460                 op_null(o->op_next);
15461             }
15462             break;
15463         case OP_STUB:
15464             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15465                 break; /* Scalar stub must produce undef.  List stub is noop */
15466             }
15467             goto nothin;
15468         case OP_NULL:
15469             if (o->op_targ == OP_NEXTSTATE
15470                 || o->op_targ == OP_DBSTATE)
15471             {
15472                 PL_curcop = ((COP*)o);
15473             }
15474             /* XXX: We avoid setting op_seq here to prevent later calls
15475                to rpeep() from mistakenly concluding that optimisation
15476                has already occurred. This doesn't fix the real problem,
15477                though (See 20010220.007 (#5874)). AMS 20010719 */
15478             /* op_seq functionality is now replaced by op_opt */
15479             o->op_opt = 0;
15480             /* FALLTHROUGH */
15481         case OP_SCALAR:
15482         case OP_LINESEQ:
15483         case OP_SCOPE:
15484         nothin:
15485             if (oldop) {
15486                 oldop->op_next = o->op_next;
15487                 o->op_opt = 0;
15488                 continue;
15489             }
15490             break;
15491
15492         case OP_PUSHMARK:
15493
15494             /* Given
15495                  5 repeat/DOLIST
15496                  3   ex-list
15497                  1     pushmark
15498                  2     scalar or const
15499                  4   const[0]
15500                convert repeat into a stub with no kids.
15501              */
15502             if (o->op_next->op_type == OP_CONST
15503              || (  o->op_next->op_type == OP_PADSV
15504                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15505              || (  o->op_next->op_type == OP_GV
15506                 && o->op_next->op_next->op_type == OP_RV2SV
15507                 && !(o->op_next->op_next->op_private
15508                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15509             {
15510                 const OP *kid = o->op_next->op_next;
15511                 if (o->op_next->op_type == OP_GV)
15512                    kid = kid->op_next;
15513                 /* kid is now the ex-list.  */
15514                 if (kid->op_type == OP_NULL
15515                  && (kid = kid->op_next)->op_type == OP_CONST
15516                     /* kid is now the repeat count.  */
15517                  && kid->op_next->op_type == OP_REPEAT
15518                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15519                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15520                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15521                  && oldop)
15522                 {
15523                     o = kid->op_next; /* repeat */
15524                     oldop->op_next = o;
15525                     op_free(cBINOPo->op_first);
15526                     op_free(cBINOPo->op_last );
15527                     o->op_flags &=~ OPf_KIDS;
15528                     /* stub is a baseop; repeat is a binop */
15529                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15530                     OpTYPE_set(o, OP_STUB);
15531                     o->op_private = 0;
15532                     break;
15533                 }
15534             }
15535
15536             /* Convert a series of PAD ops for my vars plus support into a
15537              * single padrange op. Basically
15538              *
15539              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15540              *
15541              * becomes, depending on circumstances, one of
15542              *
15543              *    padrange  ----------------------------------> (list) -> rest
15544              *    padrange  --------------------------------------------> rest
15545              *
15546              * where all the pad indexes are sequential and of the same type
15547              * (INTRO or not).
15548              * We convert the pushmark into a padrange op, then skip
15549              * any other pad ops, and possibly some trailing ops.
15550              * Note that we don't null() the skipped ops, to make it
15551              * easier for Deparse to undo this optimisation (and none of
15552              * the skipped ops are holding any resourses). It also makes
15553              * it easier for find_uninit_var(), as it can just ignore
15554              * padrange, and examine the original pad ops.
15555              */
15556         {
15557             OP *p;
15558             OP *followop = NULL; /* the op that will follow the padrange op */
15559             U8 count = 0;
15560             U8 intro = 0;
15561             PADOFFSET base = 0; /* init only to stop compiler whining */
15562             bool gvoid = 0;     /* init only to stop compiler whining */
15563             bool defav = 0;  /* seen (...) = @_ */
15564             bool reuse = 0;  /* reuse an existing padrange op */
15565
15566             /* look for a pushmark -> gv[_] -> rv2av */
15567
15568             {
15569                 OP *rv2av, *q;
15570                 p = o->op_next;
15571                 if (   p->op_type == OP_GV
15572                     && cGVOPx_gv(p) == PL_defgv
15573                     && (rv2av = p->op_next)
15574                     && rv2av->op_type == OP_RV2AV
15575                     && !(rv2av->op_flags & OPf_REF)
15576                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15577                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15578                 ) {
15579                     q = rv2av->op_next;
15580                     if (q->op_type == OP_NULL)
15581                         q = q->op_next;
15582                     if (q->op_type == OP_PUSHMARK) {
15583                         defav = 1;
15584                         p = q;
15585                     }
15586                 }
15587             }
15588             if (!defav) {
15589                 p = o;
15590             }
15591
15592             /* scan for PAD ops */
15593
15594             for (p = p->op_next; p; p = p->op_next) {
15595                 if (p->op_type == OP_NULL)
15596                     continue;
15597
15598                 if ((     p->op_type != OP_PADSV
15599                        && p->op_type != OP_PADAV
15600                        && p->op_type != OP_PADHV
15601                     )
15602                       /* any private flag other than INTRO? e.g. STATE */
15603                    || (p->op_private & ~OPpLVAL_INTRO)
15604                 )
15605                     break;
15606
15607                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15608                  * instead */
15609                 if (   p->op_type == OP_PADAV
15610                     && p->op_next
15611                     && p->op_next->op_type == OP_CONST
15612                     && p->op_next->op_next
15613                     && p->op_next->op_next->op_type == OP_AELEM
15614                 )
15615                     break;
15616
15617                 /* for 1st padop, note what type it is and the range
15618                  * start; for the others, check that it's the same type
15619                  * and that the targs are contiguous */
15620                 if (count == 0) {
15621                     intro = (p->op_private & OPpLVAL_INTRO);
15622                     base = p->op_targ;
15623                     gvoid = OP_GIMME(p,0) == G_VOID;
15624                 }
15625                 else {
15626                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15627                         break;
15628                     /* Note that you'd normally  expect targs to be
15629                      * contiguous in my($a,$b,$c), but that's not the case
15630                      * when external modules start doing things, e.g.
15631                      * Function::Parameters */
15632                     if (p->op_targ != base + count)
15633                         break;
15634                     assert(p->op_targ == base + count);
15635                     /* Either all the padops or none of the padops should
15636                        be in void context.  Since we only do the optimisa-
15637                        tion for av/hv when the aggregate itself is pushed
15638                        on to the stack (one item), there is no need to dis-
15639                        tinguish list from scalar context.  */
15640                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15641                         break;
15642                 }
15643
15644                 /* for AV, HV, only when we're not flattening */
15645                 if (   p->op_type != OP_PADSV
15646                     && !gvoid
15647                     && !(p->op_flags & OPf_REF)
15648                 )
15649                     break;
15650
15651                 if (count >= OPpPADRANGE_COUNTMASK)
15652                     break;
15653
15654                 /* there's a biggest base we can fit into a
15655                  * SAVEt_CLEARPADRANGE in pp_padrange.
15656                  * (The sizeof() stuff will be constant-folded, and is
15657                  * intended to avoid getting "comparison is always false"
15658                  * compiler warnings. See the comments above
15659                  * MEM_WRAP_CHECK for more explanation on why we do this
15660                  * in a weird way to avoid compiler warnings.)
15661                  */
15662                 if (   intro
15663                     && (8*sizeof(base) >
15664                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15665                         ? (Size_t)base
15666                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15667                         ) >
15668                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15669                 )
15670                     break;
15671
15672                 /* Success! We've got another valid pad op to optimise away */
15673                 count++;
15674                 followop = p->op_next;
15675             }
15676
15677             if (count < 1 || (count == 1 && !defav))
15678                 break;
15679
15680             /* pp_padrange in specifically compile-time void context
15681              * skips pushing a mark and lexicals; in all other contexts
15682              * (including unknown till runtime) it pushes a mark and the
15683              * lexicals. We must be very careful then, that the ops we
15684              * optimise away would have exactly the same effect as the
15685              * padrange.
15686              * In particular in void context, we can only optimise to
15687              * a padrange if we see the complete sequence
15688              *     pushmark, pad*v, ...., list
15689              * which has the net effect of leaving the markstack as it
15690              * was.  Not pushing onto the stack (whereas padsv does touch
15691              * the stack) makes no difference in void context.
15692              */
15693             assert(followop);
15694             if (gvoid) {
15695                 if (followop->op_type == OP_LIST
15696                         && OP_GIMME(followop,0) == G_VOID
15697                    )
15698                 {
15699                     followop = followop->op_next; /* skip OP_LIST */
15700
15701                     /* consolidate two successive my(...);'s */
15702
15703                     if (   oldoldop
15704                         && oldoldop->op_type == OP_PADRANGE
15705                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15706                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15707                         && !(oldoldop->op_flags & OPf_SPECIAL)
15708                     ) {
15709                         U8 old_count;
15710                         assert(oldoldop->op_next == oldop);
15711                         assert(   oldop->op_type == OP_NEXTSTATE
15712                                || oldop->op_type == OP_DBSTATE);
15713                         assert(oldop->op_next == o);
15714
15715                         old_count
15716                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15717
15718                        /* Do not assume pad offsets for $c and $d are con-
15719                           tiguous in
15720                             my ($a,$b,$c);
15721                             my ($d,$e,$f);
15722                         */
15723                         if (  oldoldop->op_targ + old_count == base
15724                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15725                             base = oldoldop->op_targ;
15726                             count += old_count;
15727                             reuse = 1;
15728                         }
15729                     }
15730
15731                     /* if there's any immediately following singleton
15732                      * my var's; then swallow them and the associated
15733                      * nextstates; i.e.
15734                      *    my ($a,$b); my $c; my $d;
15735                      * is treated as
15736                      *    my ($a,$b,$c,$d);
15737                      */
15738
15739                     while (    ((p = followop->op_next))
15740                             && (  p->op_type == OP_PADSV
15741                                || p->op_type == OP_PADAV
15742                                || p->op_type == OP_PADHV)
15743                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15744                             && (p->op_private & OPpLVAL_INTRO) == intro
15745                             && !(p->op_private & ~OPpLVAL_INTRO)
15746                             && p->op_next
15747                             && (   p->op_next->op_type == OP_NEXTSTATE
15748                                 || p->op_next->op_type == OP_DBSTATE)
15749                             && count < OPpPADRANGE_COUNTMASK
15750                             && base + count == p->op_targ
15751                     ) {
15752                         count++;
15753                         followop = p->op_next;
15754                     }
15755                 }
15756                 else
15757                     break;
15758             }
15759
15760             if (reuse) {
15761                 assert(oldoldop->op_type == OP_PADRANGE);
15762                 oldoldop->op_next = followop;
15763                 oldoldop->op_private = (intro | count);
15764                 o = oldoldop;
15765                 oldop = NULL;
15766                 oldoldop = NULL;
15767             }
15768             else {
15769                 /* Convert the pushmark into a padrange.
15770                  * To make Deparse easier, we guarantee that a padrange was
15771                  * *always* formerly a pushmark */
15772                 assert(o->op_type == OP_PUSHMARK);
15773                 o->op_next = followop;
15774                 OpTYPE_set(o, OP_PADRANGE);
15775                 o->op_targ = base;
15776                 /* bit 7: INTRO; bit 6..0: count */
15777                 o->op_private = (intro | count);
15778                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15779                               | gvoid * OPf_WANT_VOID
15780                               | (defav ? OPf_SPECIAL : 0));
15781             }
15782             break;
15783         }
15784
15785         case OP_RV2AV:
15786             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15787                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15788             break;
15789
15790         case OP_RV2HV:
15791         case OP_PADHV:
15792             /*'keys %h' in void or scalar context: skip the OP_KEYS
15793              * and perform the functionality directly in the RV2HV/PADHV
15794              * op
15795              */
15796             if (o->op_flags & OPf_REF) {
15797                 OP *k = o->op_next;
15798                 U8 want = (k->op_flags & OPf_WANT);
15799                 if (   k
15800                     && k->op_type == OP_KEYS
15801                     && (   want == OPf_WANT_VOID
15802                         || want == OPf_WANT_SCALAR)
15803                     && !(k->op_private & OPpMAYBE_LVSUB)
15804                     && !(k->op_flags & OPf_MOD)
15805                 ) {
15806                     o->op_next     = k->op_next;
15807                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15808                     o->op_flags   |= want;
15809                     o->op_private |= (o->op_type == OP_PADHV ?
15810                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15811                     /* for keys(%lex), hold onto the OP_KEYS's targ
15812                      * since padhv doesn't have its own targ to return
15813                      * an int with */
15814                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15815                         op_null(k);
15816                 }
15817             }
15818
15819             /* see if %h is used in boolean context */
15820             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15821                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15822
15823
15824             if (o->op_type != OP_PADHV)
15825                 break;
15826             /* FALLTHROUGH */
15827         case OP_PADAV:
15828             if (   o->op_type == OP_PADAV
15829                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15830             )
15831                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15832             /* FALLTHROUGH */
15833         case OP_PADSV:
15834             /* Skip over state($x) in void context.  */
15835             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15836              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15837             {
15838                 oldop->op_next = o->op_next;
15839                 goto redo_nextstate;
15840             }
15841             if (o->op_type != OP_PADAV)
15842                 break;
15843             /* FALLTHROUGH */
15844         case OP_GV:
15845             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15846                 OP* const pop = (o->op_type == OP_PADAV) ?
15847                             o->op_next : o->op_next->op_next;
15848                 IV i;
15849                 if (pop && pop->op_type == OP_CONST &&
15850                     ((PL_op = pop->op_next)) &&
15851                     pop->op_next->op_type == OP_AELEM &&
15852                     !(pop->op_next->op_private &
15853                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15854                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15855                 {
15856                     GV *gv;
15857                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15858                         no_bareword_allowed(pop);
15859                     if (o->op_type == OP_GV)
15860                         op_null(o->op_next);
15861                     op_null(pop->op_next);
15862                     op_null(pop);
15863                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15864                     o->op_next = pop->op_next->op_next;
15865                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15866                     o->op_private = (U8)i;
15867                     if (o->op_type == OP_GV) {
15868                         gv = cGVOPo_gv;
15869                         GvAVn(gv);
15870                         o->op_type = OP_AELEMFAST;
15871                     }
15872                     else
15873                         o->op_type = OP_AELEMFAST_LEX;
15874                 }
15875                 if (o->op_type != OP_GV)
15876                     break;
15877             }
15878
15879             /* Remove $foo from the op_next chain in void context.  */
15880             if (oldop
15881              && (  o->op_next->op_type == OP_RV2SV
15882                 || o->op_next->op_type == OP_RV2AV
15883                 || o->op_next->op_type == OP_RV2HV  )
15884              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15885              && !(o->op_next->op_private & OPpLVAL_INTRO))
15886             {
15887                 oldop->op_next = o->op_next->op_next;
15888                 /* Reprocess the previous op if it is a nextstate, to
15889                    allow double-nextstate optimisation.  */
15890               redo_nextstate:
15891                 if (oldop->op_type == OP_NEXTSTATE) {
15892                     oldop->op_opt = 0;
15893                     o = oldop;
15894                     oldop = oldoldop;
15895                     oldoldop = NULL;
15896                     goto redo;
15897                 }
15898                 o = oldop->op_next;
15899                 goto redo;
15900             }
15901             else if (o->op_next->op_type == OP_RV2SV) {
15902                 if (!(o->op_next->op_private & OPpDEREF)) {
15903                     op_null(o->op_next);
15904                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
15905                                                                | OPpOUR_INTRO);
15906                     o->op_next = o->op_next->op_next;
15907                     OpTYPE_set(o, OP_GVSV);
15908                 }
15909             }
15910             else if (o->op_next->op_type == OP_READLINE
15911                     && o->op_next->op_next->op_type == OP_CONCAT
15912                     && (o->op_next->op_next->op_flags & OPf_STACKED))
15913             {
15914                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
15915                 OpTYPE_set(o, OP_RCATLINE);
15916                 o->op_flags |= OPf_STACKED;
15917                 op_null(o->op_next->op_next);
15918                 op_null(o->op_next);
15919             }
15920
15921             break;
15922
15923         case OP_NOT:
15924             break;
15925
15926         case OP_AND:
15927         case OP_OR:
15928         case OP_DOR:
15929             while (cLOGOP->op_other->op_type == OP_NULL)
15930                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15931             while (o->op_next && (   o->op_type == o->op_next->op_type
15932                                   || o->op_next->op_type == OP_NULL))
15933                 o->op_next = o->op_next->op_next;
15934
15935             /* If we're an OR and our next is an AND in void context, we'll
15936                follow its op_other on short circuit, same for reverse.
15937                We can't do this with OP_DOR since if it's true, its return
15938                value is the underlying value which must be evaluated
15939                by the next op. */
15940             if (o->op_next &&
15941                 (
15942                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
15943                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
15944                 )
15945                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
15946             ) {
15947                 o->op_next = ((LOGOP*)o->op_next)->op_other;
15948             }
15949             DEFER(cLOGOP->op_other);
15950             o->op_opt = 1;
15951             break;
15952
15953         case OP_GREPWHILE:
15954             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15955                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15956             /* FALLTHROUGH */
15957         case OP_COND_EXPR:
15958         case OP_MAPWHILE:
15959         case OP_ANDASSIGN:
15960         case OP_ORASSIGN:
15961         case OP_DORASSIGN:
15962         case OP_RANGE:
15963         case OP_ONCE:
15964         case OP_ARGDEFELEM:
15965             while (cLOGOP->op_other->op_type == OP_NULL)
15966                 cLOGOP->op_other = cLOGOP->op_other->op_next;
15967             DEFER(cLOGOP->op_other);
15968             break;
15969
15970         case OP_ENTERLOOP:
15971         case OP_ENTERITER:
15972             while (cLOOP->op_redoop->op_type == OP_NULL)
15973                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
15974             while (cLOOP->op_nextop->op_type == OP_NULL)
15975                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
15976             while (cLOOP->op_lastop->op_type == OP_NULL)
15977                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
15978             /* a while(1) loop doesn't have an op_next that escapes the
15979              * loop, so we have to explicitly follow the op_lastop to
15980              * process the rest of the code */
15981             DEFER(cLOOP->op_lastop);
15982             break;
15983
15984         case OP_ENTERTRY:
15985             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
15986             DEFER(cLOGOPo->op_other);
15987             break;
15988
15989         case OP_SUBST:
15990             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15991                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15992             assert(!(cPMOP->op_pmflags & PMf_ONCE));
15993             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
15994                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
15995                 cPMOP->op_pmstashstartu.op_pmreplstart
15996                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
15997             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
15998             break;
15999
16000         case OP_SORT: {
16001             OP *oright;
16002
16003             if (o->op_flags & OPf_SPECIAL) {
16004                 /* first arg is a code block */
16005                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16006                 OP * kid          = cUNOPx(nullop)->op_first;
16007
16008                 assert(nullop->op_type == OP_NULL);
16009                 assert(kid->op_type == OP_SCOPE
16010                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16011                 /* since OP_SORT doesn't have a handy op_other-style
16012                  * field that can point directly to the start of the code
16013                  * block, store it in the otherwise-unused op_next field
16014                  * of the top-level OP_NULL. This will be quicker at
16015                  * run-time, and it will also allow us to remove leading
16016                  * OP_NULLs by just messing with op_nexts without
16017                  * altering the basic op_first/op_sibling layout. */
16018                 kid = kLISTOP->op_first;
16019                 assert(
16020                       (kid->op_type == OP_NULL
16021                       && (  kid->op_targ == OP_NEXTSTATE
16022                          || kid->op_targ == OP_DBSTATE  ))
16023                     || kid->op_type == OP_STUB
16024                     || kid->op_type == OP_ENTER
16025                     || (PL_parser && PL_parser->error_count));
16026                 nullop->op_next = kid->op_next;
16027                 DEFER(nullop->op_next);
16028             }
16029
16030             /* check that RHS of sort is a single plain array */
16031             oright = cUNOPo->op_first;
16032             if (!oright || oright->op_type != OP_PUSHMARK)
16033                 break;
16034
16035             if (o->op_private & OPpSORT_INPLACE)
16036                 break;
16037
16038             /* reverse sort ... can be optimised.  */
16039             if (!OpHAS_SIBLING(cUNOPo)) {
16040                 /* Nothing follows us on the list. */
16041                 OP * const reverse = o->op_next;
16042
16043                 if (reverse->op_type == OP_REVERSE &&
16044                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16045                     OP * const pushmark = cUNOPx(reverse)->op_first;
16046                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16047                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16048                         /* reverse -> pushmark -> sort */
16049                         o->op_private |= OPpSORT_REVERSE;
16050                         op_null(reverse);
16051                         pushmark->op_next = oright->op_next;
16052                         op_null(oright);
16053                     }
16054                 }
16055             }
16056
16057             break;
16058         }
16059
16060         case OP_REVERSE: {
16061             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16062             OP *gvop = NULL;
16063             LISTOP *enter, *exlist;
16064
16065             if (o->op_private & OPpSORT_INPLACE)
16066                 break;
16067
16068             enter = (LISTOP *) o->op_next;
16069             if (!enter)
16070                 break;
16071             if (enter->op_type == OP_NULL) {
16072                 enter = (LISTOP *) enter->op_next;
16073                 if (!enter)
16074                     break;
16075             }
16076             /* for $a (...) will have OP_GV then OP_RV2GV here.
16077                for (...) just has an OP_GV.  */
16078             if (enter->op_type == OP_GV) {
16079                 gvop = (OP *) enter;
16080                 enter = (LISTOP *) enter->op_next;
16081                 if (!enter)
16082                     break;
16083                 if (enter->op_type == OP_RV2GV) {
16084                   enter = (LISTOP *) enter->op_next;
16085                   if (!enter)
16086                     break;
16087                 }
16088             }
16089
16090             if (enter->op_type != OP_ENTERITER)
16091                 break;
16092
16093             iter = enter->op_next;
16094             if (!iter || iter->op_type != OP_ITER)
16095                 break;
16096
16097             expushmark = enter->op_first;
16098             if (!expushmark || expushmark->op_type != OP_NULL
16099                 || expushmark->op_targ != OP_PUSHMARK)
16100                 break;
16101
16102             exlist = (LISTOP *) OpSIBLING(expushmark);
16103             if (!exlist || exlist->op_type != OP_NULL
16104                 || exlist->op_targ != OP_LIST)
16105                 break;
16106
16107             if (exlist->op_last != o) {
16108                 /* Mmm. Was expecting to point back to this op.  */
16109                 break;
16110             }
16111             theirmark = exlist->op_first;
16112             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16113                 break;
16114
16115             if (OpSIBLING(theirmark) != o) {
16116                 /* There's something between the mark and the reverse, eg
16117                    for (1, reverse (...))
16118                    so no go.  */
16119                 break;
16120             }
16121
16122             ourmark = ((LISTOP *)o)->op_first;
16123             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16124                 break;
16125
16126             ourlast = ((LISTOP *)o)->op_last;
16127             if (!ourlast || ourlast->op_next != o)
16128                 break;
16129
16130             rv2av = OpSIBLING(ourmark);
16131             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16132                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16133                 /* We're just reversing a single array.  */
16134                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16135                 enter->op_flags |= OPf_STACKED;
16136             }
16137
16138             /* We don't have control over who points to theirmark, so sacrifice
16139                ours.  */
16140             theirmark->op_next = ourmark->op_next;
16141             theirmark->op_flags = ourmark->op_flags;
16142             ourlast->op_next = gvop ? gvop : (OP *) enter;
16143             op_null(ourmark);
16144             op_null(o);
16145             enter->op_private |= OPpITER_REVERSED;
16146             iter->op_private |= OPpITER_REVERSED;
16147
16148             oldoldop = NULL;
16149             oldop    = ourlast;
16150             o        = oldop->op_next;
16151             goto redo;
16152             NOT_REACHED; /* NOTREACHED */
16153             break;
16154         }
16155
16156         case OP_QR:
16157         case OP_MATCH:
16158             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16159                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16160             }
16161             break;
16162
16163         case OP_RUNCV:
16164             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16165              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16166             {
16167                 SV *sv;
16168                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16169                 else {
16170                     sv = newRV((SV *)PL_compcv);
16171                     sv_rvweaken(sv);
16172                     SvREADONLY_on(sv);
16173                 }
16174                 OpTYPE_set(o, OP_CONST);
16175                 o->op_flags |= OPf_SPECIAL;
16176                 cSVOPo->op_sv = sv;
16177             }
16178             break;
16179
16180         case OP_SASSIGN:
16181             if (OP_GIMME(o,0) == G_VOID
16182              || (  o->op_next->op_type == OP_LINESEQ
16183                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16184                    || (  o->op_next->op_next->op_type == OP_RETURN
16185                       && !CvLVALUE(PL_compcv)))))
16186             {
16187                 OP *right = cBINOP->op_first;
16188                 if (right) {
16189                     /*   sassign
16190                     *      RIGHT
16191                     *      substr
16192                     *         pushmark
16193                     *         arg1
16194                     *         arg2
16195                     *         ...
16196                     * becomes
16197                     *
16198                     *  ex-sassign
16199                     *     substr
16200                     *        pushmark
16201                     *        RIGHT
16202                     *        arg1
16203                     *        arg2
16204                     *        ...
16205                     */
16206                     OP *left = OpSIBLING(right);
16207                     if (left->op_type == OP_SUBSTR
16208                          && (left->op_private & 7) < 4) {
16209                         op_null(o);
16210                         /* cut out right */
16211                         op_sibling_splice(o, NULL, 1, NULL);
16212                         /* and insert it as second child of OP_SUBSTR */
16213                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16214                                     right);
16215                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16216                         left->op_flags =
16217                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16218                     }
16219                 }
16220             }
16221             break;
16222
16223         case OP_AASSIGN: {
16224             int l, r, lr, lscalars, rscalars;
16225
16226             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16227                Note that we do this now rather than in newASSIGNOP(),
16228                since only by now are aliased lexicals flagged as such
16229
16230                See the essay "Common vars in list assignment" above for
16231                the full details of the rationale behind all the conditions
16232                below.
16233
16234                PL_generation sorcery:
16235                To detect whether there are common vars, the global var
16236                PL_generation is incremented for each assign op we scan.
16237                Then we run through all the lexical variables on the LHS,
16238                of the assignment, setting a spare slot in each of them to
16239                PL_generation.  Then we scan the RHS, and if any lexicals
16240                already have that value, we know we've got commonality.
16241                Also, if the generation number is already set to
16242                PERL_INT_MAX, then the variable is involved in aliasing, so
16243                we also have potential commonality in that case.
16244              */
16245
16246             PL_generation++;
16247             /* scan LHS */
16248             lscalars = 0;
16249             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16250             /* scan RHS */
16251             rscalars = 0;
16252             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16253             lr = (l|r);
16254
16255
16256             /* After looking for things which are *always* safe, this main
16257              * if/else chain selects primarily based on the type of the
16258              * LHS, gradually working its way down from the more dangerous
16259              * to the more restrictive and thus safer cases */
16260
16261             if (   !l                      /* () = ....; */
16262                 || !r                      /* .... = (); */
16263                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16264                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16265                 || (lscalars < 2)          /* ($x, undef) = ... */
16266             ) {
16267                 NOOP; /* always safe */
16268             }
16269             else if (l & AAS_DANGEROUS) {
16270                 /* always dangerous */
16271                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16272                 o->op_private |= OPpASSIGN_COMMON_AGG;
16273             }
16274             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16275                 /* package vars are always dangerous - too many
16276                  * aliasing possibilities */
16277                 if (l & AAS_PKG_SCALAR)
16278                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16279                 if (l & AAS_PKG_AGG)
16280                     o->op_private |= OPpASSIGN_COMMON_AGG;
16281             }
16282             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16283                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16284             {
16285                 /* LHS contains only lexicals and safe ops */
16286
16287                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16288                     o->op_private |= OPpASSIGN_COMMON_AGG;
16289
16290                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16291                     if (lr & AAS_LEX_SCALAR_COMM)
16292                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16293                     else if (   !(l & AAS_LEX_SCALAR)
16294                              && (r & AAS_DEFAV))
16295                     {
16296                         /* falsely mark
16297                          *    my (...) = @_
16298                          * as scalar-safe for performance reasons.
16299                          * (it will still have been marked _AGG if necessary */
16300                         NOOP;
16301                     }
16302                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16303                         /* if there are only lexicals on the LHS and no
16304                          * common ones on the RHS, then we assume that the
16305                          * only way those lexicals could also get
16306                          * on the RHS is via some sort of dereffing or
16307                          * closure, e.g.
16308                          *    $r = \$lex;
16309                          *    ($lex, $x) = (1, $$r)
16310                          * and in this case we assume the var must have
16311                          *  a bumped ref count. So if its ref count is 1,
16312                          *  it must only be on the LHS.
16313                          */
16314                         o->op_private |= OPpASSIGN_COMMON_RC1;
16315                 }
16316             }
16317
16318             /* ... = ($x)
16319              * may have to handle aggregate on LHS, but we can't
16320              * have common scalars. */
16321             if (rscalars < 2)
16322                 o->op_private &=
16323                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16324
16325             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16326                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16327             break;
16328         }
16329
16330         case OP_REF:
16331             /* see if ref() is used in boolean context */
16332             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16333                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16334             break;
16335
16336         case OP_LENGTH:
16337             /* see if the op is used in known boolean context,
16338              * but not if OA_TARGLEX optimisation is enabled */
16339             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16340                 && !(o->op_private & OPpTARGET_MY)
16341             )
16342                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16343             break;
16344
16345         case OP_POS:
16346             /* see if the op is used in known boolean context */
16347             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16348                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16349             break;
16350
16351         case OP_CUSTOM: {
16352             Perl_cpeep_t cpeep =
16353                 XopENTRYCUSTOM(o, xop_peep);
16354             if (cpeep)
16355                 cpeep(aTHX_ o, oldop);
16356             break;
16357         }
16358
16359         }
16360         /* did we just null the current op? If so, re-process it to handle
16361          * eliding "empty" ops from the chain */
16362         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16363             o->op_opt = 0;
16364             o = oldop;
16365         }
16366         else {
16367             oldoldop = oldop;
16368             oldop = o;
16369         }
16370     }
16371     LEAVE;
16372 }
16373
16374 void
16375 Perl_peep(pTHX_ OP *o)
16376 {
16377     CALL_RPEEP(o);
16378 }
16379
16380 /*
16381 =head1 Custom Operators
16382
16383 =for apidoc Ao||custom_op_xop
16384 Return the XOP structure for a given custom op.  This macro should be
16385 considered internal to C<OP_NAME> and the other access macros: use them instead.
16386 This macro does call a function.  Prior
16387 to 5.19.6, this was implemented as a
16388 function.
16389
16390 =cut
16391 */
16392
16393 XOPRETANY
16394 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16395 {
16396     SV *keysv;
16397     HE *he = NULL;
16398     XOP *xop;
16399
16400     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16401
16402     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16403     assert(o->op_type == OP_CUSTOM);
16404
16405     /* This is wrong. It assumes a function pointer can be cast to IV,
16406      * which isn't guaranteed, but this is what the old custom OP code
16407      * did. In principle it should be safer to Copy the bytes of the
16408      * pointer into a PV: since the new interface is hidden behind
16409      * functions, this can be changed later if necessary.  */
16410     /* Change custom_op_xop if this ever happens */
16411     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16412
16413     if (PL_custom_ops)
16414         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16415
16416     /* assume noone will have just registered a desc */
16417     if (!he && PL_custom_op_names &&
16418         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16419     ) {
16420         const char *pv;
16421         STRLEN l;
16422
16423         /* XXX does all this need to be shared mem? */
16424         Newxz(xop, 1, XOP);
16425         pv = SvPV(HeVAL(he), l);
16426         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16427         if (PL_custom_op_descs &&
16428             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16429         ) {
16430             pv = SvPV(HeVAL(he), l);
16431             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16432         }
16433         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16434     }
16435     else {
16436         if (!he)
16437             xop = (XOP *)&xop_null;
16438         else
16439             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16440     }
16441     {
16442         XOPRETANY any;
16443         if(field == XOPe_xop_ptr) {
16444             any.xop_ptr = xop;
16445         } else {
16446             const U32 flags = XopFLAGS(xop);
16447             if(flags & field) {
16448                 switch(field) {
16449                 case XOPe_xop_name:
16450                     any.xop_name = xop->xop_name;
16451                     break;
16452                 case XOPe_xop_desc:
16453                     any.xop_desc = xop->xop_desc;
16454                     break;
16455                 case XOPe_xop_class:
16456                     any.xop_class = xop->xop_class;
16457                     break;
16458                 case XOPe_xop_peep:
16459                     any.xop_peep = xop->xop_peep;
16460                     break;
16461                 default:
16462                     NOT_REACHED; /* NOTREACHED */
16463                     break;
16464                 }
16465             } else {
16466                 switch(field) {
16467                 case XOPe_xop_name:
16468                     any.xop_name = XOPd_xop_name;
16469                     break;
16470                 case XOPe_xop_desc:
16471                     any.xop_desc = XOPd_xop_desc;
16472                     break;
16473                 case XOPe_xop_class:
16474                     any.xop_class = XOPd_xop_class;
16475                     break;
16476                 case XOPe_xop_peep:
16477                     any.xop_peep = XOPd_xop_peep;
16478                     break;
16479                 default:
16480                     NOT_REACHED; /* NOTREACHED */
16481                     break;
16482                 }
16483             }
16484         }
16485         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16486          * op.c: In function 'Perl_custom_op_get_field':
16487          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16488          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16489          * expands to assert(0), which expands to ((0) ? (void)0 :
16490          * __assert(...)), and gcc doesn't know that __assert can never return. */
16491         return any;
16492     }
16493 }
16494
16495 /*
16496 =for apidoc Ao||custom_op_register
16497 Register a custom op.  See L<perlguts/"Custom Operators">.
16498
16499 =cut
16500 */
16501
16502 void
16503 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16504 {
16505     SV *keysv;
16506
16507     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16508
16509     /* see the comment in custom_op_xop */
16510     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16511
16512     if (!PL_custom_ops)
16513         PL_custom_ops = newHV();
16514
16515     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16516         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16517 }
16518
16519 /*
16520
16521 =for apidoc core_prototype
16522
16523 This function assigns the prototype of the named core function to C<sv>, or
16524 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16525 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16526 by C<keyword()>.  It must not be equal to 0.
16527
16528 =cut
16529 */
16530
16531 SV *
16532 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16533                           int * const opnum)
16534 {
16535     int i = 0, n = 0, seen_question = 0, defgv = 0;
16536     I32 oa;
16537 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16538     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16539     bool nullret = FALSE;
16540
16541     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16542
16543     assert (code);
16544
16545     if (!sv) sv = sv_newmortal();
16546
16547 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16548
16549     switch (code < 0 ? -code : code) {
16550     case KEY_and   : case KEY_chop: case KEY_chomp:
16551     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16552     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16553     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16554     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16555     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16556     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16557     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16558     case KEY_x     : case KEY_xor    :
16559         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16560     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16561     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16562     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16563     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16564     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16565     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16566         retsetpvs("", 0);
16567     case KEY_evalbytes:
16568         name = "entereval"; break;
16569     case KEY_readpipe:
16570         name = "backtick";
16571     }
16572
16573 #undef retsetpvs
16574
16575   findopnum:
16576     while (i < MAXO) {  /* The slow way. */
16577         if (strEQ(name, PL_op_name[i])
16578             || strEQ(name, PL_op_desc[i]))
16579         {
16580             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16581             goto found;
16582         }
16583         i++;
16584     }
16585     return NULL;
16586   found:
16587     defgv = PL_opargs[i] & OA_DEFGV;
16588     oa = PL_opargs[i] >> OASHIFT;
16589     while (oa) {
16590         if (oa & OA_OPTIONAL && !seen_question && (
16591               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16592         )) {
16593             seen_question = 1;
16594             str[n++] = ';';
16595         }
16596         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16597             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16598             /* But globs are already references (kinda) */
16599             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16600         ) {
16601             str[n++] = '\\';
16602         }
16603         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16604          && !scalar_mod_type(NULL, i)) {
16605             str[n++] = '[';
16606             str[n++] = '$';
16607             str[n++] = '@';
16608             str[n++] = '%';
16609             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16610             str[n++] = '*';
16611             str[n++] = ']';
16612         }
16613         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16614         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16615             str[n-1] = '_'; defgv = 0;
16616         }
16617         oa = oa >> 4;
16618     }
16619     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16620     str[n++] = '\0';
16621     sv_setpvn(sv, str, n - 1);
16622     if (opnum) *opnum = i;
16623     return sv;
16624 }
16625
16626 OP *
16627 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16628                       const int opnum)
16629 {
16630     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16631     OP *o;
16632
16633     PERL_ARGS_ASSERT_CORESUB_OP;
16634
16635     switch(opnum) {
16636     case 0:
16637         return op_append_elem(OP_LINESEQ,
16638                        argop,
16639                        newSLICEOP(0,
16640                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16641                                   newOP(OP_CALLER,0)
16642                        )
16643                );
16644     case OP_EACH:
16645     case OP_KEYS:
16646     case OP_VALUES:
16647         o = newUNOP(OP_AVHVSWITCH,0,argop);
16648         o->op_private = opnum-OP_EACH;
16649         return o;
16650     case OP_SELECT: /* which represents OP_SSELECT as well */
16651         if (code)
16652             return newCONDOP(
16653                          0,
16654                          newBINOP(OP_GT, 0,
16655                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16656                                   newSVOP(OP_CONST, 0, newSVuv(1))
16657                                  ),
16658                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16659                                     OP_SSELECT),
16660                          coresub_op(coreargssv, 0, OP_SELECT)
16661                    );
16662         /* FALLTHROUGH */
16663     default:
16664         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16665         case OA_BASEOP:
16666             return op_append_elem(
16667                         OP_LINESEQ, argop,
16668                         newOP(opnum,
16669                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16670                                 ? OPpOFFBYONE << 8 : 0)
16671                    );
16672         case OA_BASEOP_OR_UNOP:
16673             if (opnum == OP_ENTEREVAL) {
16674                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16675                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16676             }
16677             else o = newUNOP(opnum,0,argop);
16678             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16679             else {
16680           onearg:
16681               if (is_handle_constructor(o, 1))
16682                 argop->op_private |= OPpCOREARGS_DEREF1;
16683               if (scalar_mod_type(NULL, opnum))
16684                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16685             }
16686             return o;
16687         default:
16688             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16689             if (is_handle_constructor(o, 2))
16690                 argop->op_private |= OPpCOREARGS_DEREF2;
16691             if (opnum == OP_SUBSTR) {
16692                 o->op_private |= OPpMAYBE_LVSUB;
16693                 return o;
16694             }
16695             else goto onearg;
16696         }
16697     }
16698 }
16699
16700 void
16701 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16702                                SV * const *new_const_svp)
16703 {
16704     const char *hvname;
16705     bool is_const = !!CvCONST(old_cv);
16706     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16707
16708     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16709
16710     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16711         return;
16712         /* They are 2 constant subroutines generated from
16713            the same constant. This probably means that
16714            they are really the "same" proxy subroutine
16715            instantiated in 2 places. Most likely this is
16716            when a constant is exported twice.  Don't warn.
16717         */
16718     if (
16719         (ckWARN(WARN_REDEFINE)
16720          && !(
16721                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16722              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16723              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16724                  strEQ(hvname, "autouse"))
16725              )
16726         )
16727      || (is_const
16728          && ckWARN_d(WARN_REDEFINE)
16729          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16730         )
16731     )
16732         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16733                           is_const
16734                             ? "Constant subroutine %" SVf " redefined"
16735                             : "Subroutine %" SVf " redefined",
16736                           SVfARG(name));
16737 }
16738
16739 /*
16740 =head1 Hook manipulation
16741
16742 These functions provide convenient and thread-safe means of manipulating
16743 hook variables.
16744
16745 =cut
16746 */
16747
16748 /*
16749 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16750
16751 Puts a C function into the chain of check functions for a specified op
16752 type.  This is the preferred way to manipulate the L</PL_check> array.
16753 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16754 is a pointer to the C function that is to be added to that opcode's
16755 check chain, and C<old_checker_p> points to the storage location where a
16756 pointer to the next function in the chain will be stored.  The value of
16757 C<new_checker> is written into the L</PL_check> array, while the value
16758 previously stored there is written to C<*old_checker_p>.
16759
16760 L</PL_check> is global to an entire process, and a module wishing to
16761 hook op checking may find itself invoked more than once per process,
16762 typically in different threads.  To handle that situation, this function
16763 is idempotent.  The location C<*old_checker_p> must initially (once
16764 per process) contain a null pointer.  A C variable of static duration
16765 (declared at file scope, typically also marked C<static> to give
16766 it internal linkage) will be implicitly initialised appropriately,
16767 if it does not have an explicit initialiser.  This function will only
16768 actually modify the check chain if it finds C<*old_checker_p> to be null.
16769 This function is also thread safe on the small scale.  It uses appropriate
16770 locking to avoid race conditions in accessing L</PL_check>.
16771
16772 When this function is called, the function referenced by C<new_checker>
16773 must be ready to be called, except for C<*old_checker_p> being unfilled.
16774 In a threading situation, C<new_checker> may be called immediately,
16775 even before this function has returned.  C<*old_checker_p> will always
16776 be appropriately set before C<new_checker> is called.  If C<new_checker>
16777 decides not to do anything special with an op that it is given (which
16778 is the usual case for most uses of op check hooking), it must chain the
16779 check function referenced by C<*old_checker_p>.
16780
16781 Taken all together, XS code to hook an op checker should typically look
16782 something like this:
16783
16784     static Perl_check_t nxck_frob;
16785     static OP *myck_frob(pTHX_ OP *op) {
16786         ...
16787         op = nxck_frob(aTHX_ op);
16788         ...
16789         return op;
16790     }
16791     BOOT:
16792         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16793
16794 If you want to influence compilation of calls to a specific subroutine,
16795 then use L</cv_set_call_checker_flags> rather than hooking checking of
16796 all C<entersub> ops.
16797
16798 =cut
16799 */
16800
16801 void
16802 Perl_wrap_op_checker(pTHX_ Optype opcode,
16803     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16804 {
16805     dVAR;
16806
16807     PERL_UNUSED_CONTEXT;
16808     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16809     if (*old_checker_p) return;
16810     OP_CHECK_MUTEX_LOCK;
16811     if (!*old_checker_p) {
16812         *old_checker_p = PL_check[opcode];
16813         PL_check[opcode] = new_checker;
16814     }
16815     OP_CHECK_MUTEX_UNLOCK;
16816 }
16817
16818 #include "XSUB.h"
16819
16820 /* Efficient sub that returns a constant scalar value. */
16821 static void
16822 const_sv_xsub(pTHX_ CV* cv)
16823 {
16824     dXSARGS;
16825     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16826     PERL_UNUSED_ARG(items);
16827     if (!sv) {
16828         XSRETURN(0);
16829     }
16830     EXTEND(sp, 1);
16831     ST(0) = sv;
16832     XSRETURN(1);
16833 }
16834
16835 static void
16836 const_av_xsub(pTHX_ CV* cv)
16837 {
16838     dXSARGS;
16839     AV * const av = MUTABLE_AV(XSANY.any_ptr);
16840     SP -= items;
16841     assert(av);
16842 #ifndef DEBUGGING
16843     if (!av) {
16844         XSRETURN(0);
16845     }
16846 #endif
16847     if (SvRMAGICAL(av))
16848         Perl_croak(aTHX_ "Magical list constants are not supported");
16849     if (GIMME_V != G_ARRAY) {
16850         EXTEND(SP, 1);
16851         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16852         XSRETURN(1);
16853     }
16854     EXTEND(SP, AvFILLp(av)+1);
16855     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16856     XSRETURN(AvFILLp(av)+1);
16857 }
16858
16859
16860 /*
16861  * ex: set ts=8 sts=4 sw=4 et:
16862  */