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     HV * const pmstash = PmopSTASH(o);
1229
1230     PERL_ARGS_ASSERT_FORGET_PMOP;
1231
1232     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1233         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1234         if (mg) {
1235             PMOP **const array = (PMOP**) mg->mg_ptr;
1236             U32 count = mg->mg_len / sizeof(PMOP**);
1237             U32 i = count;
1238
1239             while (i--) {
1240                 if (array[i] == o) {
1241                     /* Found it. Move the entry at the end to overwrite it.  */
1242                     array[i] = array[--count];
1243                     mg->mg_len = count * sizeof(PMOP**);
1244                     /* Could realloc smaller at this point always, but probably
1245                        not worth it. Probably worth free()ing if we're the
1246                        last.  */
1247                     if(!count) {
1248                         Safefree(mg->mg_ptr);
1249                         mg->mg_ptr = NULL;
1250                     }
1251                     break;
1252                 }
1253             }
1254         }
1255     }
1256     if (PL_curpm == o)
1257         PL_curpm = NULL;
1258 }
1259
1260 STATIC void
1261 S_find_and_forget_pmops(pTHX_ OP *o)
1262 {
1263     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1264
1265     if (o->op_flags & OPf_KIDS) {
1266         OP *kid = cUNOPo->op_first;
1267         while (kid) {
1268             switch (kid->op_type) {
1269             case OP_SUBST:
1270             case OP_SPLIT:
1271             case OP_MATCH:
1272             case OP_QR:
1273                 forget_pmop((PMOP*)kid);
1274             }
1275             find_and_forget_pmops(kid);
1276             kid = OpSIBLING(kid);
1277         }
1278     }
1279 }
1280
1281 /*
1282 =for apidoc Am|void|op_null|OP *o
1283
1284 Neutralizes an op when it is no longer needed, but is still linked to from
1285 other ops.
1286
1287 =cut
1288 */
1289
1290 void
1291 Perl_op_null(pTHX_ OP *o)
1292 {
1293     dVAR;
1294
1295     PERL_ARGS_ASSERT_OP_NULL;
1296
1297     if (o->op_type == OP_NULL)
1298         return;
1299     op_clear(o);
1300     o->op_targ = o->op_type;
1301     OpTYPE_set(o, OP_NULL);
1302 }
1303
1304 void
1305 Perl_op_refcnt_lock(pTHX)
1306   PERL_TSA_ACQUIRE(PL_op_mutex)
1307 {
1308 #ifdef USE_ITHREADS
1309     dVAR;
1310 #endif
1311     PERL_UNUSED_CONTEXT;
1312     OP_REFCNT_LOCK;
1313 }
1314
1315 void
1316 Perl_op_refcnt_unlock(pTHX)
1317   PERL_TSA_RELEASE(PL_op_mutex)
1318 {
1319 #ifdef USE_ITHREADS
1320     dVAR;
1321 #endif
1322     PERL_UNUSED_CONTEXT;
1323     OP_REFCNT_UNLOCK;
1324 }
1325
1326
1327 /*
1328 =for apidoc op_sibling_splice
1329
1330 A general function for editing the structure of an existing chain of
1331 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1332 you to delete zero or more sequential nodes, replacing them with zero or
1333 more different nodes.  Performs the necessary op_first/op_last
1334 housekeeping on the parent node and op_sibling manipulation on the
1335 children.  The last deleted node will be marked as as the last node by
1336 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1337
1338 Note that op_next is not manipulated, and nodes are not freed; that is the
1339 responsibility of the caller.  It also won't create a new list op for an
1340 empty list etc; use higher-level functions like op_append_elem() for that.
1341
1342 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1343 the splicing doesn't affect the first or last op in the chain.
1344
1345 C<start> is the node preceding the first node to be spliced.  Node(s)
1346 following it will be deleted, and ops will be inserted after it.  If it is
1347 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1348 beginning.
1349
1350 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1351 If -1 or greater than or equal to the number of remaining kids, all
1352 remaining kids are deleted.
1353
1354 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1355 If C<NULL>, no nodes are inserted.
1356
1357 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1358 deleted.
1359
1360 For example:
1361
1362     action                    before      after         returns
1363     ------                    -----       -----         -------
1364
1365                               P           P
1366     splice(P, A, 2, X-Y-Z)    |           |             B-C
1367                               A-B-C-D     A-X-Y-Z-D
1368
1369                               P           P
1370     splice(P, NULL, 1, X-Y)   |           |             A
1371                               A-B-C-D     X-Y-B-C-D
1372
1373                               P           P
1374     splice(P, NULL, 3, NULL)  |           |             A-B-C
1375                               A-B-C-D     D
1376
1377                               P           P
1378     splice(P, B, 0, X-Y)      |           |             NULL
1379                               A-B-C-D     A-B-X-Y-C-D
1380
1381
1382 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1383 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1384
1385 =cut
1386 */
1387
1388 OP *
1389 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1390 {
1391     OP *first;
1392     OP *rest;
1393     OP *last_del = NULL;
1394     OP *last_ins = NULL;
1395
1396     if (start)
1397         first = OpSIBLING(start);
1398     else if (!parent)
1399         goto no_parent;
1400     else
1401         first = cLISTOPx(parent)->op_first;
1402
1403     assert(del_count >= -1);
1404
1405     if (del_count && first) {
1406         last_del = first;
1407         while (--del_count && OpHAS_SIBLING(last_del))
1408             last_del = OpSIBLING(last_del);
1409         rest = OpSIBLING(last_del);
1410         OpLASTSIB_set(last_del, NULL);
1411     }
1412     else
1413         rest = first;
1414
1415     if (insert) {
1416         last_ins = insert;
1417         while (OpHAS_SIBLING(last_ins))
1418             last_ins = OpSIBLING(last_ins);
1419         OpMAYBESIB_set(last_ins, rest, NULL);
1420     }
1421     else
1422         insert = rest;
1423
1424     if (start) {
1425         OpMAYBESIB_set(start, insert, NULL);
1426     }
1427     else {
1428         if (!parent)
1429             goto no_parent;
1430         cLISTOPx(parent)->op_first = insert;
1431         if (insert)
1432             parent->op_flags |= OPf_KIDS;
1433         else
1434             parent->op_flags &= ~OPf_KIDS;
1435     }
1436
1437     if (!rest) {
1438         /* update op_last etc */
1439         U32 type;
1440         OP *lastop;
1441
1442         if (!parent)
1443             goto no_parent;
1444
1445         /* ought to use OP_CLASS(parent) here, but that can't handle
1446          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1447          * either */
1448         type = parent->op_type;
1449         if (type == OP_CUSTOM) {
1450             dTHX;
1451             type = XopENTRYCUSTOM(parent, xop_class);
1452         }
1453         else {
1454             if (type == OP_NULL)
1455                 type = parent->op_targ;
1456             type = PL_opargs[type] & OA_CLASS_MASK;
1457         }
1458
1459         lastop = last_ins ? last_ins : start ? start : NULL;
1460         if (   type == OA_BINOP
1461             || type == OA_LISTOP
1462             || type == OA_PMOP
1463             || type == OA_LOOP
1464         )
1465             cLISTOPx(parent)->op_last = lastop;
1466
1467         if (lastop)
1468             OpLASTSIB_set(lastop, parent);
1469     }
1470     return last_del ? first : NULL;
1471
1472   no_parent:
1473     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1474 }
1475
1476
1477 #ifdef PERL_OP_PARENT
1478
1479 /*
1480 =for apidoc op_parent
1481
1482 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1483 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1484
1485 =cut
1486 */
1487
1488 OP *
1489 Perl_op_parent(OP *o)
1490 {
1491     PERL_ARGS_ASSERT_OP_PARENT;
1492     while (OpHAS_SIBLING(o))
1493         o = OpSIBLING(o);
1494     return o->op_sibparent;
1495 }
1496
1497 #endif
1498
1499
1500 /* replace the sibling following start with a new UNOP, which becomes
1501  * the parent of the original sibling; e.g.
1502  *
1503  *  op_sibling_newUNOP(P, A, unop-args...)
1504  *
1505  *  P              P
1506  *  |      becomes |
1507  *  A-B-C          A-U-C
1508  *                   |
1509  *                   B
1510  *
1511  * where U is the new UNOP.
1512  *
1513  * parent and start args are the same as for op_sibling_splice();
1514  * type and flags args are as newUNOP().
1515  *
1516  * Returns the new UNOP.
1517  */
1518
1519 STATIC OP *
1520 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1521 {
1522     OP *kid, *newop;
1523
1524     kid = op_sibling_splice(parent, start, 1, NULL);
1525     newop = newUNOP(type, flags, kid);
1526     op_sibling_splice(parent, start, 0, newop);
1527     return newop;
1528 }
1529
1530
1531 /* lowest-level newLOGOP-style function - just allocates and populates
1532  * the struct. Higher-level stuff should be done by S_new_logop() /
1533  * newLOGOP(). This function exists mainly to avoid op_first assignment
1534  * being spread throughout this file.
1535  */
1536
1537 LOGOP *
1538 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1539 {
1540     dVAR;
1541     LOGOP *logop;
1542     OP *kid = first;
1543     NewOp(1101, logop, 1, LOGOP);
1544     OpTYPE_set(logop, type);
1545     logop->op_first = first;
1546     logop->op_other = other;
1547     if (first)
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     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2671     STRLEN variant;
2672     bool utf8 = FALSE;
2673     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2674                                  the last-processed arg will the LHS of one,
2675                                  as args are processed in reverse order */
2676     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2677     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2678     U8 flags          = 0;   /* what will become the op_flags and ... */
2679     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2680     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2681     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2682     bool prev_was_const = FALSE; /* previous arg was a const */
2683
2684     /* -----------------------------------------------------------------
2685      * Phase 1:
2686      *
2687      * Examine the optree non-destructively to determine whether it's
2688      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2689      * information about the optree in args[].
2690      */
2691
2692     argp     = args;
2693     targmyop = NULL;
2694     targetop = NULL;
2695     stringop = NULL;
2696     topop    = o;
2697     parentop = o;
2698
2699     assert(   o->op_type == OP_SASSIGN
2700            || o->op_type == OP_CONCAT
2701            || o->op_type == OP_SPRINTF
2702            || o->op_type == OP_STRINGIFY);
2703
2704     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2705
2706     /* first see if, at the top of the tree, there is an assign,
2707      * append and/or stringify */
2708
2709     if (topop->op_type == OP_SASSIGN) {
2710         /* expr = ..... */
2711         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2712             return;
2713         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2714             return;
2715         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2716
2717         parentop = topop;
2718         topop = cBINOPo->op_first;
2719         targetop = OpSIBLING(topop);
2720         if (!targetop) /* probably some sort of syntax error */
2721             return;
2722     }
2723     else if (   topop->op_type == OP_CONCAT
2724              && (topop->op_flags & OPf_STACKED)
2725              && (cUNOPo->op_first->op_flags & OPf_MOD)
2726              && (!(topop->op_private & OPpCONCAT_NESTED))
2727             )
2728     {
2729         /* expr .= ..... */
2730
2731         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2732          * decide what to do about it */
2733         assert(!(o->op_private & OPpTARGET_MY));
2734
2735         /* barf on unknown flags */
2736         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2737         private_flags |= OPpMULTICONCAT_APPEND;
2738         targetop = cBINOPo->op_first;
2739         parentop = topop;
2740         topop    = OpSIBLING(targetop);
2741
2742         /* $x .= <FOO> gets optimised to rcatline instead */
2743         if (topop->op_type == OP_READLINE)
2744             return;
2745     }
2746
2747     if (targetop) {
2748         /* Can targetop (the LHS) if it's a padsv, be be optimised
2749          * away and use OPpTARGET_MY instead?
2750          */
2751         if (    (targetop->op_type == OP_PADSV)
2752             && !(targetop->op_private & OPpDEREF)
2753             && !(targetop->op_private & OPpPAD_STATE)
2754                /* we don't support 'my $x .= ...' */
2755             && (   o->op_type == OP_SASSIGN
2756                 || !(targetop->op_private & OPpLVAL_INTRO))
2757         )
2758             is_targable = TRUE;
2759     }
2760
2761     if (topop->op_type == OP_STRINGIFY) {
2762         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2763             return;
2764         stringop = topop;
2765
2766         /* barf on unknown flags */
2767         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2768
2769         if ((topop->op_private & OPpTARGET_MY)) {
2770             if (o->op_type == OP_SASSIGN)
2771                 return; /* can't have two assigns */
2772             targmyop = topop;
2773         }
2774
2775         private_flags |= OPpMULTICONCAT_STRINGIFY;
2776         parentop = topop;
2777         topop = cBINOPx(topop)->op_first;
2778         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2779         topop = OpSIBLING(topop);
2780     }
2781
2782     if (topop->op_type == OP_SPRINTF) {
2783         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2784             return;
2785         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2786             nargs     = sprintf_info.nargs;
2787             total_len = sprintf_info.total_len;
2788             variant   = sprintf_info.variant;
2789             utf8      = sprintf_info.utf8;
2790             is_sprintf = TRUE;
2791             private_flags |= OPpMULTICONCAT_FAKE;
2792             toparg = argp;
2793             /* we have an sprintf op rather than a concat optree.
2794              * Skip most of the code below which is associated with
2795              * processing that optree. We also skip phase 2, determining
2796              * whether its cost effective to optimise, since for sprintf,
2797              * multiconcat is *always* faster */
2798             goto create_aux;
2799         }
2800         /* note that even if the sprintf itself isn't multiconcatable,
2801          * the expression as a whole may be, e.g. in
2802          *    $x .= sprintf("%d",...)
2803          * the sprintf op will be left as-is, but the concat/S op may
2804          * be upgraded to multiconcat
2805          */
2806     }
2807     else if (topop->op_type == OP_CONCAT) {
2808         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2809             return;
2810
2811         if ((topop->op_private & OPpTARGET_MY)) {
2812             if (o->op_type == OP_SASSIGN || targmyop)
2813                 return; /* can't have two assigns */
2814             targmyop = topop;
2815         }
2816     }
2817
2818     /* Is it safe to convert a sassign/stringify/concat op into
2819      * a multiconcat? */
2820     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2821     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2822     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2823     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2824     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2825                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2826     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2827                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2828
2829     /* Now scan the down the tree looking for a series of
2830      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2831      * stacked). For example this tree:
2832      *
2833      *     |
2834      *   CONCAT/STACKED
2835      *     |
2836      *   CONCAT/STACKED -- EXPR5
2837      *     |
2838      *   CONCAT/STACKED -- EXPR4
2839      *     |
2840      *   CONCAT -- EXPR3
2841      *     |
2842      *   EXPR1  -- EXPR2
2843      *
2844      * corresponds to an expression like
2845      *
2846      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2847      *
2848      * Record info about each EXPR in args[]: in particular, whether it is
2849      * a stringifiable OP_CONST and if so what the const sv is.
2850      *
2851      * The reason why the last concat can't be STACKED is the difference
2852      * between
2853      *
2854      *    ((($a .= $a) .= $a) .= $a) .= $a
2855      *
2856      * and
2857      *    $a . $a . $a . $a . $a
2858      *
2859      * The main difference between the optrees for those two constructs
2860      * is the presence of the last STACKED. As well as modifying $a,
2861      * the former sees the changed $a between each concat, so if $s is
2862      * initially 'a', the first returns 'a' x 16, while the latter returns
2863      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2864      */
2865
2866     kid = topop;
2867
2868     for (;;) {
2869         OP *argop;
2870         SV *sv;
2871         bool last = FALSE;
2872
2873         if (    kid->op_type == OP_CONCAT
2874             && !kid_is_last
2875         ) {
2876             OP *k1, *k2;
2877             k1 = cUNOPx(kid)->op_first;
2878             k2 = OpSIBLING(k1);
2879             /* shouldn't happen except maybe after compile err? */
2880             if (!k2)
2881                 return;
2882
2883             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2884             if (kid->op_private & OPpTARGET_MY)
2885                 kid_is_last = TRUE;
2886
2887             stacked_last = (kid->op_flags & OPf_STACKED);
2888             if (!stacked_last)
2889                 kid_is_last = TRUE;
2890
2891             kid   = k1;
2892             argop = k2;
2893         }
2894         else {
2895             argop = kid;
2896             last = TRUE;
2897         }
2898
2899         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2900             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2901         {
2902             /* At least two spare slots are needed to decompose both
2903              * concat args. If there are no slots left, continue to
2904              * examine the rest of the optree, but don't push new values
2905              * on args[]. If the optree as a whole is legal for conversion
2906              * (in particular that the last concat isn't STACKED), then
2907              * the first PERL_MULTICONCAT_MAXARG elements of the optree
2908              * can be converted into an OP_MULTICONCAT now, with the first
2909              * child of that op being the remainder of the optree -
2910              * which may itself later be converted to a multiconcat op
2911              * too.
2912              */
2913             if (last) {
2914                 /* the last arg is the rest of the optree */
2915                 argp++->p = NULL;
2916                 nargs++;
2917             }
2918         }
2919         else if (   argop->op_type == OP_CONST
2920             && ((sv = cSVOPx_sv(argop)))
2921             /* defer stringification until runtime of 'constant'
2922              * things that might stringify variantly, e.g. the radix
2923              * point of NVs, or overloaded RVs */
2924             && (SvPOK(sv) || SvIOK(sv))
2925             && (!SvGMAGICAL(sv))
2926         ) {
2927             argp++->p = sv;
2928             utf8   |= cBOOL(SvUTF8(sv));
2929             nconst++;
2930             if (prev_was_const)
2931                 /* this const may be demoted back to a plain arg later;
2932                  * make sure we have enough arg slots left */
2933                 nadjconst++;
2934             prev_was_const = !prev_was_const;
2935         }
2936         else {
2937             argp++->p = NULL;
2938             nargs++;
2939             prev_was_const = FALSE;
2940         }
2941
2942         if (last)
2943             break;
2944     }
2945
2946     toparg = argp - 1;
2947
2948     if (stacked_last)
2949         return; /* we don't support ((A.=B).=C)...) */
2950
2951     /* look for two adjacent consts and don't fold them together:
2952      *     $o . "a" . "b"
2953      * should do
2954      *     $o->concat("a")->concat("b")
2955      * rather than
2956      *     $o->concat("ab")
2957      * (but $o .=  "a" . "b" should still fold)
2958      */
2959     {
2960         bool seen_nonconst = FALSE;
2961         for (argp = toparg; argp >= args; argp--) {
2962             if (argp->p == NULL) {
2963                 seen_nonconst = TRUE;
2964                 continue;
2965             }
2966             if (!seen_nonconst)
2967                 continue;
2968             if (argp[1].p) {
2969                 /* both previous and current arg were constants;
2970                  * leave the current OP_CONST as-is */
2971                 argp->p = NULL;
2972                 nconst--;
2973                 nargs++;
2974             }
2975         }
2976     }
2977
2978     /* -----------------------------------------------------------------
2979      * Phase 2:
2980      *
2981      * At this point we have determined that the optree *can* be converted
2982      * into a multiconcat. Having gathered all the evidence, we now decide
2983      * whether it *should*.
2984      */
2985
2986
2987     /* we need at least one concat action, e.g.:
2988      *
2989      *  Y . Z
2990      *  X = Y . Z
2991      *  X .= Y
2992      *
2993      * otherwise we could be doing something like $x = "foo", which
2994      * if treated as as a concat, would fail to COW.
2995      */
2996     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
2997         return;
2998
2999     /* Benchmarking seems to indicate that we gain if:
3000      * * we optimise at least two actions into a single multiconcat
3001      *    (e.g concat+concat, sassign+concat);
3002      * * or if we can eliminate at least 1 OP_CONST;
3003      * * or if we can eliminate a padsv via OPpTARGET_MY
3004      */
3005
3006     if (
3007            /* eliminated at least one OP_CONST */
3008            nconst >= 1
3009            /* eliminated an OP_SASSIGN */
3010         || o->op_type == OP_SASSIGN
3011            /* eliminated an OP_PADSV */
3012         || (!targmyop && is_targable)
3013     )
3014         /* definitely a net gain to optimise */
3015         goto optimise;
3016
3017     /* ... if not, what else? */
3018
3019     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3020      * multiconcat is faster (due to not creating a temporary copy of
3021      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3022      * faster.
3023      */
3024     if (   nconst == 0
3025          && nargs == 2
3026          && targmyop
3027          && topop->op_type == OP_CONCAT
3028     ) {
3029         PADOFFSET t = targmyop->op_targ;
3030         OP *k1 = cBINOPx(topop)->op_first;
3031         OP *k2 = cBINOPx(topop)->op_last;
3032         if (   k2->op_type == OP_PADSV
3033             && k2->op_targ == t
3034             && (   k1->op_type != OP_PADSV
3035                 || k1->op_targ != t)
3036         )
3037             goto optimise;
3038     }
3039
3040     /* need at least two concats */
3041     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3042         return;
3043
3044
3045
3046     /* -----------------------------------------------------------------
3047      * Phase 3:
3048      *
3049      * At this point the optree has been verified as ok to be optimised
3050      * into an OP_MULTICONCAT. Now start changing things.
3051      */
3052
3053    optimise:
3054
3055     /* stringify all const args and determine utf8ness */
3056
3057     variant = 0;
3058     for (argp = args; argp <= toparg; argp++) {
3059         SV *sv = (SV*)argp->p;
3060         if (!sv)
3061             continue; /* not a const op */
3062         if (utf8 && !SvUTF8(sv))
3063             sv_utf8_upgrade_nomg(sv);
3064         argp->p = SvPV_nomg(sv, argp->len);
3065         total_len += argp->len;
3066
3067         /* see if any strings would grow if converted to utf8 */
3068         if (!utf8) {
3069             char *p    = (char*)argp->p;
3070             STRLEN len = argp->len;
3071             while (len--) {
3072                 U8 c = *p++;
3073                 if (!UTF8_IS_INVARIANT(c))
3074                     variant++;
3075             }
3076         }
3077     }
3078
3079     /* create and populate aux struct */
3080
3081   create_aux:
3082
3083     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3084                     sizeof(UNOP_AUX_item)
3085                     *  (
3086                            PERL_MULTICONCAT_HEADER_SIZE
3087                          + ((nargs + 1) * (variant ? 2 : 1))
3088                         )
3089                     );
3090     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3091
3092     /* Extract all the non-const expressions from the concat tree then
3093      * dispose of the old tree, e.g. convert the tree from this:
3094      *
3095      *  o => SASSIGN
3096      *         |
3097      *       STRINGIFY   -- TARGET
3098      *         |
3099      *       ex-PUSHMARK -- CONCAT
3100      *                        |
3101      *                      CONCAT -- EXPR5
3102      *                        |
3103      *                      CONCAT -- EXPR4
3104      *                        |
3105      *                      CONCAT -- EXPR3
3106      *                        |
3107      *                      EXPR1  -- EXPR2
3108      *
3109      *
3110      * to:
3111      *
3112      *  o => MULTICONCAT
3113      *         |
3114      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3115      *
3116      * except that if EXPRi is an OP_CONST, it's discarded.
3117      *
3118      * During the conversion process, EXPR ops are stripped from the tree
3119      * and unshifted onto o. Finally, any of o's remaining original
3120      * childen are discarded and o is converted into an OP_MULTICONCAT.
3121      *
3122      * In this middle of this, o may contain both: unshifted args on the
3123      * left, and some remaining original args on the right. lastkidop
3124      * is set to point to the right-most unshifted arg to delineate
3125      * between the two sets.
3126      */
3127
3128
3129     if (is_sprintf) {
3130         /* create a copy of the format with the %'s removed, and record
3131          * the sizes of the const string segments in the aux struct */
3132         char *q, *oldq;
3133         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3134
3135         p    = sprintf_info.start;
3136         q    = const_str;
3137         oldq = q;
3138         for (; p < sprintf_info.end; p++) {
3139             if (*p == '%') {
3140                 p++;
3141                 if (*p != '%') {
3142                     (lenp++)->ssize = q - oldq;
3143                     oldq = q;
3144                     continue;
3145                 }
3146             }
3147             *q++ = *p;
3148         }
3149         lenp->ssize = q - oldq;
3150         assert((STRLEN)(q - const_str) == total_len);
3151
3152         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3153          * may or may not be topop) The pushmark and const ops need to be
3154          * kept in case they're an op_next entry point.
3155          */
3156         lastkidop = cLISTOPx(topop)->op_last;
3157         kid = cUNOPx(topop)->op_first; /* pushmark */
3158         op_null(kid);
3159         op_null(OpSIBLING(kid));       /* const */
3160         if (o != topop) {
3161             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3162             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3163             lastkidop->op_next = o;
3164         }
3165     }
3166     else {
3167         p = const_str;
3168         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3169
3170         lenp->ssize = -1;
3171
3172         /* Concatenate all const strings into const_str.
3173          * Note that args[] contains the RHS args in reverse order, so
3174          * we scan args[] from top to bottom to get constant strings
3175          * in L-R order
3176          */
3177         for (argp = toparg; argp >= args; argp--) {
3178             if (!argp->p)
3179                 /* not a const op */
3180                 (++lenp)->ssize = -1;
3181             else {
3182                 STRLEN l = argp->len;
3183                 Copy(argp->p, p, l, char);
3184                 p += l;
3185                 if (lenp->ssize == -1)
3186                     lenp->ssize = l;
3187                 else
3188                     lenp->ssize += l;
3189             }
3190         }
3191
3192         kid = topop;
3193         nextop = o;
3194         lastkidop = NULL;
3195
3196         for (argp = args; argp <= toparg; argp++) {
3197             /* only keep non-const args, except keep the first-in-next-chain
3198              * arg no matter what it is (but nulled if OP_CONST), because it
3199              * may be the entry point to this subtree from the previous
3200              * op_next.
3201              */
3202             bool last = (argp == toparg);
3203             OP *prev;
3204
3205             /* set prev to the sibling *before* the arg to be cut out,
3206              * e.g. when cutting EXPR:
3207              *
3208              *         |
3209              * kid=  CONCAT
3210              *         |
3211              * prev= CONCAT -- EXPR
3212              *         |
3213              */
3214             if (argp == args && kid->op_type != OP_CONCAT) {
3215                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3216                  * so the expression to be cut isn't kid->op_last but
3217                  * kid itself */
3218                 OP *o1, *o2;
3219                 /* find the op before kid */
3220                 o1 = NULL;
3221                 o2 = cUNOPx(parentop)->op_first;
3222                 while (o2 && o2 != kid) {
3223                     o1 = o2;
3224                     o2 = OpSIBLING(o2);
3225                 }
3226                 assert(o2 == kid);
3227                 prev = o1;
3228                 kid  = parentop;
3229             }
3230             else if (kid == o && lastkidop)
3231                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3232             else
3233                 prev = last ? NULL : cUNOPx(kid)->op_first;
3234
3235             if (!argp->p || last) {
3236                 /* cut RH op */
3237                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3238                 /* and unshift to front of o */
3239                 op_sibling_splice(o, NULL, 0, aop);
3240                 /* record the right-most op added to o: later we will
3241                  * free anything to the right of it */
3242                 if (!lastkidop)
3243                     lastkidop = aop;
3244                 aop->op_next = nextop;
3245                 if (last) {
3246                     if (argp->p)
3247                         /* null the const at start of op_next chain */
3248                         op_null(aop);
3249                 }
3250                 else if (prev)
3251                     nextop = prev->op_next;
3252             }
3253
3254             /* the last two arguments are both attached to the same concat op */
3255             if (argp < toparg - 1)
3256                 kid = prev;
3257         }
3258     }
3259
3260     /* Populate the aux struct */
3261
3262     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3263     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3264     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3265     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3266     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3267
3268     /* if variant > 0, calculate a variant const string and lengths where
3269      * the utf8 version of the string will take 'variant' more bytes than
3270      * the plain one. */
3271
3272     if (variant) {
3273         char              *p = const_str;
3274         STRLEN          ulen = total_len + variant;
3275         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3276         UNOP_AUX_item *ulens = lens + (nargs + 1);
3277         char             *up = (char*)PerlMemShared_malloc(ulen);
3278         SSize_t            n;
3279
3280         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3281         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3282
3283         for (n = 0; n < (nargs + 1); n++) {
3284             SSize_t i;
3285             char * orig_up = up;
3286             for (i = (lens++)->ssize; i > 0; i--) {
3287                 U8 c = *p++;
3288                 append_utf8_from_native_byte(c, (U8**)&up);
3289             }
3290             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3291         }
3292     }
3293
3294     if (stringop) {
3295         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3296          * that op's first child - an ex-PUSHMARK - because the op_next of
3297          * the previous op may point to it (i.e. it's the entry point for
3298          * the o optree)
3299          */
3300         OP *pmop =
3301             (stringop == o)
3302                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3303                 : op_sibling_splice(stringop, NULL, 1, NULL);
3304         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3305         op_sibling_splice(o, NULL, 0, pmop);
3306         if (!lastkidop)
3307             lastkidop = pmop;
3308     }
3309
3310     /* Optimise
3311      *    target  = A.B.C...
3312      *    target .= A.B.C...
3313      */
3314
3315     if (targetop) {
3316         assert(!targmyop);
3317
3318         if (o->op_type == OP_SASSIGN) {
3319             /* Move the target subtree from being the last of o's children
3320              * to being the last of o's preserved children.
3321              * Note the difference between 'target = ...' and 'target .= ...':
3322              * for the former, target is executed last; for the latter,
3323              * first.
3324              */
3325             kid = OpSIBLING(lastkidop);
3326             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3327             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3328             lastkidop->op_next = kid->op_next;
3329             lastkidop = targetop;
3330         }
3331         else {
3332             /* Move the target subtree from being the first of o's
3333              * original children to being the first of *all* o's children.
3334              */
3335             if (lastkidop) {
3336                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3337                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3338             }
3339             else {
3340                 /* if the RHS of .= doesn't contain a concat (e.g.
3341                  * $x .= "foo"), it gets missed by the "strip ops from the
3342                  * tree and add to o" loop earlier */
3343                 assert(topop->op_type != OP_CONCAT);
3344                 if (stringop) {
3345                     /* in e.g. $x .= "$y", move the $y expression
3346                      * from being a child of OP_STRINGIFY to being the
3347                      * second child of the OP_CONCAT
3348                      */
3349                     assert(cUNOPx(stringop)->op_first == topop);
3350                     op_sibling_splice(stringop, NULL, 1, NULL);
3351                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3352                 }
3353                 assert(topop == OpSIBLING(cBINOPo->op_first));
3354                 if (toparg->p)
3355                     op_null(topop);
3356                 lastkidop = topop;
3357             }
3358         }
3359
3360         if (is_targable) {
3361             /* optimise
3362              *  my $lex  = A.B.C...
3363              *     $lex  = A.B.C...
3364              *     $lex .= A.B.C...
3365              * The original padsv op is kept but nulled in case it's the
3366              * entry point for the optree (which it will be for
3367              * '$lex .=  ... '
3368              */
3369             private_flags |= OPpTARGET_MY;
3370             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3371             o->op_targ = targetop->op_targ;
3372             targetop->op_targ = 0;
3373             op_null(targetop);
3374         }
3375         else
3376             flags |= OPf_STACKED;
3377     }
3378     else if (targmyop) {
3379         private_flags |= OPpTARGET_MY;
3380         if (o != targmyop) {
3381             o->op_targ = targmyop->op_targ;
3382             targmyop->op_targ = 0;
3383         }
3384     }
3385
3386     /* detach the emaciated husk of the sprintf/concat optree and free it */
3387     for (;;) {
3388         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3389         if (!kid)
3390             break;
3391         op_free(kid);
3392     }
3393
3394     /* and convert o into a multiconcat */
3395
3396     o->op_flags        = (flags|OPf_KIDS|stacked_last
3397                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3398     o->op_private      = private_flags;
3399     o->op_type         = OP_MULTICONCAT;
3400     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3401     cUNOP_AUXo->op_aux = aux;
3402 }
3403
3404
3405 /* do all the final processing on an optree (e.g. running the peephole
3406  * optimiser on it), then attach it to cv (if cv is non-null)
3407  */
3408
3409 static void
3410 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3411 {
3412     OP **startp;
3413
3414     /* XXX for some reason, evals, require and main optrees are
3415      * never attached to their CV; instead they just hang off
3416      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3417      * and get manually freed when appropriate */
3418     if (cv)
3419         startp = &CvSTART(cv);
3420     else
3421         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3422
3423     *startp = start;
3424     optree->op_private |= OPpREFCOUNTED;
3425     OpREFCNT_set(optree, 1);
3426     optimize_optree(optree);
3427     CALL_PEEP(*startp);
3428     finalize_optree(optree);
3429     S_prune_chain_head(startp);
3430
3431     if (cv) {
3432         /* now that optimizer has done its work, adjust pad values */
3433         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3434                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3435     }
3436 }
3437
3438
3439 /*
3440 =for apidoc optimize_optree
3441
3442 This function applies some optimisations to the optree in top-down order.
3443 It is called before the peephole optimizer, which processes ops in
3444 execution order. Note that finalize_optree() also does a top-down scan,
3445 but is called *after* the peephole optimizer.
3446
3447 =cut
3448 */
3449
3450 void
3451 Perl_optimize_optree(pTHX_ OP* o)
3452 {
3453     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3454
3455     ENTER;
3456     SAVEVPTR(PL_curcop);
3457
3458     optimize_op(o);
3459
3460     LEAVE;
3461 }
3462
3463
3464 /* helper for optimize_optree() which optimises on op then recurses
3465  * to optimise any children.
3466  */
3467
3468 STATIC void
3469 S_optimize_op(pTHX_ OP* o)
3470 {
3471     OP *kid;
3472
3473     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3474     assert(o->op_type != OP_FREED);
3475
3476     switch (o->op_type) {
3477     case OP_NEXTSTATE:
3478     case OP_DBSTATE:
3479         PL_curcop = ((COP*)o);          /* for warnings */
3480         break;
3481
3482
3483     case OP_CONCAT:
3484     case OP_SASSIGN:
3485     case OP_STRINGIFY:
3486     case OP_SPRINTF:
3487         S_maybe_multiconcat(aTHX_ o);
3488         break;
3489
3490     case OP_SUBST:
3491         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3492             optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3493         break;
3494
3495     default:
3496         break;
3497     }
3498
3499     if (!(o->op_flags & OPf_KIDS))
3500         return;
3501
3502     for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3503         optimize_op(kid);
3504 }
3505
3506
3507 /*
3508 =for apidoc finalize_optree
3509
3510 This function finalizes the optree.  Should be called directly after
3511 the complete optree is built.  It does some additional
3512 checking which can't be done in the normal C<ck_>xxx functions and makes
3513 the tree thread-safe.
3514
3515 =cut
3516 */
3517 void
3518 Perl_finalize_optree(pTHX_ OP* o)
3519 {
3520     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3521
3522     ENTER;
3523     SAVEVPTR(PL_curcop);
3524
3525     finalize_op(o);
3526
3527     LEAVE;
3528 }
3529
3530 #ifdef USE_ITHREADS
3531 /* Relocate sv to the pad for thread safety.
3532  * Despite being a "constant", the SV is written to,
3533  * for reference counts, sv_upgrade() etc. */
3534 PERL_STATIC_INLINE void
3535 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3536 {
3537     PADOFFSET ix;
3538     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3539     if (!*svp) return;
3540     ix = pad_alloc(OP_CONST, SVf_READONLY);
3541     SvREFCNT_dec(PAD_SVl(ix));
3542     PAD_SETSV(ix, *svp);
3543     /* XXX I don't know how this isn't readonly already. */
3544     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3545     *svp = NULL;
3546     *targp = ix;
3547 }
3548 #endif
3549
3550
3551 STATIC void
3552 S_finalize_op(pTHX_ OP* o)
3553 {
3554     PERL_ARGS_ASSERT_FINALIZE_OP;
3555
3556     assert(o->op_type != OP_FREED);
3557
3558     switch (o->op_type) {
3559     case OP_NEXTSTATE:
3560     case OP_DBSTATE:
3561         PL_curcop = ((COP*)o);          /* for warnings */
3562         break;
3563     case OP_EXEC:
3564         if (OpHAS_SIBLING(o)) {
3565             OP *sib = OpSIBLING(o);
3566             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3567                 && ckWARN(WARN_EXEC)
3568                 && OpHAS_SIBLING(sib))
3569             {
3570                     const OPCODE type = OpSIBLING(sib)->op_type;
3571                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3572                         const line_t oldline = CopLINE(PL_curcop);
3573                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3574                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3575                             "Statement unlikely to be reached");
3576                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3577                             "\t(Maybe you meant system() when you said exec()?)\n");
3578                         CopLINE_set(PL_curcop, oldline);
3579                     }
3580             }
3581         }
3582         break;
3583
3584     case OP_GV:
3585         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3586             GV * const gv = cGVOPo_gv;
3587             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3588                 /* XXX could check prototype here instead of just carping */
3589                 SV * const sv = sv_newmortal();
3590                 gv_efullname3(sv, gv, NULL);
3591                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3592                     "%" SVf "() called too early to check prototype",
3593                     SVfARG(sv));
3594             }
3595         }
3596         break;
3597
3598     case OP_CONST:
3599         if (cSVOPo->op_private & OPpCONST_STRICT)
3600             no_bareword_allowed(o);
3601 #ifdef USE_ITHREADS
3602         /* FALLTHROUGH */
3603     case OP_HINTSEVAL:
3604         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3605 #endif
3606         break;
3607
3608 #ifdef USE_ITHREADS
3609     /* Relocate all the METHOP's SVs to the pad for thread safety. */
3610     case OP_METHOD_NAMED:
3611     case OP_METHOD_SUPER:
3612     case OP_METHOD_REDIR:
3613     case OP_METHOD_REDIR_SUPER:
3614         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3615         break;
3616 #endif
3617
3618     case OP_HELEM: {
3619         UNOP *rop;
3620         SVOP *key_op;
3621         OP *kid;
3622
3623         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3624             break;
3625
3626         rop = (UNOP*)((BINOP*)o)->op_first;
3627
3628         goto check_keys;
3629
3630     case OP_HSLICE:
3631         S_scalar_slice_warning(aTHX_ o);
3632         /* FALLTHROUGH */
3633
3634     case OP_KVHSLICE:
3635         kid = OpSIBLING(cLISTOPo->op_first);
3636         if (/* I bet there's always a pushmark... */
3637             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3638             && OP_TYPE_ISNT_NN(kid, OP_CONST))
3639         {
3640             break;
3641         }
3642
3643         key_op = (SVOP*)(kid->op_type == OP_CONST
3644                                 ? kid
3645                                 : OpSIBLING(kLISTOP->op_first));
3646
3647         rop = (UNOP*)((LISTOP*)o)->op_last;
3648
3649       check_keys:
3650         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3651             rop = NULL;
3652         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3653         break;
3654     }
3655     case OP_NULL:
3656         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3657             break;
3658         /* FALLTHROUGH */
3659     case OP_ASLICE:
3660         S_scalar_slice_warning(aTHX_ o);
3661         break;
3662
3663     case OP_SUBST: {
3664         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3665             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3666         break;
3667     }
3668     default:
3669         break;
3670     }
3671
3672     if (o->op_flags & OPf_KIDS) {
3673         OP *kid;
3674
3675 #ifdef DEBUGGING
3676         /* check that op_last points to the last sibling, and that
3677          * the last op_sibling/op_sibparent field points back to the
3678          * parent, and that the only ops with KIDS are those which are
3679          * entitled to them */
3680         U32 type = o->op_type;
3681         U32 family;
3682         bool has_last;
3683
3684         if (type == OP_NULL) {
3685             type = o->op_targ;
3686             /* ck_glob creates a null UNOP with ex-type GLOB
3687              * (which is a list op. So pretend it wasn't a listop */
3688             if (type == OP_GLOB)
3689                 type = OP_NULL;
3690         }
3691         family = PL_opargs[type] & OA_CLASS_MASK;
3692
3693         has_last = (   family == OA_BINOP
3694                     || family == OA_LISTOP
3695                     || family == OA_PMOP
3696                     || family == OA_LOOP
3697                    );
3698         assert(  has_last /* has op_first and op_last, or ...
3699               ... has (or may have) op_first: */
3700               || family == OA_UNOP
3701               || family == OA_UNOP_AUX
3702               || family == OA_LOGOP
3703               || family == OA_BASEOP_OR_UNOP
3704               || family == OA_FILESTATOP
3705               || family == OA_LOOPEXOP
3706               || family == OA_METHOP
3707               || type == OP_CUSTOM
3708               || type == OP_NULL /* new_logop does this */
3709               );
3710
3711         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3712 #  ifdef PERL_OP_PARENT
3713             if (!OpHAS_SIBLING(kid)) {
3714                 if (has_last)
3715                     assert(kid == cLISTOPo->op_last);
3716                 assert(kid->op_sibparent == o);
3717             }
3718 #  else
3719             if (has_last && !OpHAS_SIBLING(kid))
3720                 assert(kid == cLISTOPo->op_last);
3721 #  endif
3722         }
3723 #endif
3724
3725         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3726             finalize_op(kid);
3727     }
3728 }
3729
3730 /*
3731 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3732
3733 Propagate lvalue ("modifiable") context to an op and its children.
3734 C<type> represents the context type, roughly based on the type of op that
3735 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3736 because it has no op type of its own (it is signalled by a flag on
3737 the lvalue op).
3738
3739 This function detects things that can't be modified, such as C<$x+1>, and
3740 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3741 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3742
3743 It also flags things that need to behave specially in an lvalue context,
3744 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3745
3746 =cut
3747 */
3748
3749 static void
3750 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3751 {
3752     CV *cv = PL_compcv;
3753     PadnameLVALUE_on(pn);
3754     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3755         cv = CvOUTSIDE(cv);
3756         /* RT #127786: cv can be NULL due to an eval within the DB package
3757          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3758          * unless they contain an eval, but calling eval within DB
3759          * pretends the eval was done in the caller's scope.
3760          */
3761         if (!cv)
3762             break;
3763         assert(CvPADLIST(cv));
3764         pn =
3765            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3766         assert(PadnameLEN(pn));
3767         PadnameLVALUE_on(pn);
3768     }
3769 }
3770
3771 static bool
3772 S_vivifies(const OPCODE type)
3773 {
3774     switch(type) {
3775     case OP_RV2AV:     case   OP_ASLICE:
3776     case OP_RV2HV:     case OP_KVASLICE:
3777     case OP_RV2SV:     case   OP_HSLICE:
3778     case OP_AELEMFAST: case OP_KVHSLICE:
3779     case OP_HELEM:
3780     case OP_AELEM:
3781         return 1;
3782     }
3783     return 0;
3784 }
3785
3786 static void
3787 S_lvref(pTHX_ OP *o, I32 type)
3788 {
3789     dVAR;
3790     OP *kid;
3791     switch (o->op_type) {
3792     case OP_COND_EXPR:
3793         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3794              kid = OpSIBLING(kid))
3795             S_lvref(aTHX_ kid, type);
3796         /* FALLTHROUGH */
3797     case OP_PUSHMARK:
3798         return;
3799     case OP_RV2AV:
3800         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3801         o->op_flags |= OPf_STACKED;
3802         if (o->op_flags & OPf_PARENS) {
3803             if (o->op_private & OPpLVAL_INTRO) {
3804                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3805                       "localized parenthesized array in list assignment"));
3806                 return;
3807             }
3808           slurpy:
3809             OpTYPE_set(o, OP_LVAVREF);
3810             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3811             o->op_flags |= OPf_MOD|OPf_REF;
3812             return;
3813         }
3814         o->op_private |= OPpLVREF_AV;
3815         goto checkgv;
3816     case OP_RV2CV:
3817         kid = cUNOPo->op_first;
3818         if (kid->op_type == OP_NULL)
3819             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3820                 ->op_first;
3821         o->op_private = OPpLVREF_CV;
3822         if (kid->op_type == OP_GV)
3823             o->op_flags |= OPf_STACKED;
3824         else if (kid->op_type == OP_PADCV) {
3825             o->op_targ = kid->op_targ;
3826             kid->op_targ = 0;
3827             op_free(cUNOPo->op_first);
3828             cUNOPo->op_first = NULL;
3829             o->op_flags &=~ OPf_KIDS;
3830         }
3831         else goto badref;
3832         break;
3833     case OP_RV2HV:
3834         if (o->op_flags & OPf_PARENS) {
3835           parenhash:
3836             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3837                                  "parenthesized hash in list assignment"));
3838                 return;
3839         }
3840         o->op_private |= OPpLVREF_HV;
3841         /* FALLTHROUGH */
3842     case OP_RV2SV:
3843       checkgv:
3844         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3845         o->op_flags |= OPf_STACKED;
3846         break;
3847     case OP_PADHV:
3848         if (o->op_flags & OPf_PARENS) goto parenhash;
3849         o->op_private |= OPpLVREF_HV;
3850         /* FALLTHROUGH */
3851     case OP_PADSV:
3852         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3853         break;
3854     case OP_PADAV:
3855         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3856         if (o->op_flags & OPf_PARENS) goto slurpy;
3857         o->op_private |= OPpLVREF_AV;
3858         break;
3859     case OP_AELEM:
3860     case OP_HELEM:
3861         o->op_private |= OPpLVREF_ELEM;
3862         o->op_flags   |= OPf_STACKED;
3863         break;
3864     case OP_ASLICE:
3865     case OP_HSLICE:
3866         OpTYPE_set(o, OP_LVREFSLICE);
3867         o->op_private &= OPpLVAL_INTRO;
3868         return;
3869     case OP_NULL:
3870         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3871             goto badref;
3872         else if (!(o->op_flags & OPf_KIDS))
3873             return;
3874         if (o->op_targ != OP_LIST) {
3875             S_lvref(aTHX_ cBINOPo->op_first, type);
3876             return;
3877         }
3878         /* FALLTHROUGH */
3879     case OP_LIST:
3880         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3881             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3882             S_lvref(aTHX_ kid, type);
3883         }
3884         return;
3885     case OP_STUB:
3886         if (o->op_flags & OPf_PARENS)
3887             return;
3888         /* FALLTHROUGH */
3889     default:
3890       badref:
3891         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3892         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3893                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3894                       ? "do block"
3895                       : OP_DESC(o),
3896                      PL_op_desc[type]));
3897         return;
3898     }
3899     OpTYPE_set(o, OP_LVREF);
3900     o->op_private &=
3901         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3902     if (type == OP_ENTERLOOP)
3903         o->op_private |= OPpLVREF_ITER;
3904 }
3905
3906 PERL_STATIC_INLINE bool
3907 S_potential_mod_type(I32 type)
3908 {
3909     /* Types that only potentially result in modification.  */
3910     return type == OP_GREPSTART || type == OP_ENTERSUB
3911         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3912 }
3913
3914 OP *
3915 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3916 {
3917     dVAR;
3918     OP *kid;
3919     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3920     int localize = -1;
3921
3922     if (!o || (PL_parser && PL_parser->error_count))
3923         return o;
3924
3925     if ((o->op_private & OPpTARGET_MY)
3926         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3927     {
3928         return o;
3929     }
3930
3931     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3932
3933     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3934
3935     switch (o->op_type) {
3936     case OP_UNDEF:
3937         PL_modcount++;
3938         return o;
3939     case OP_STUB:
3940         if ((o->op_flags & OPf_PARENS))
3941             break;
3942         goto nomod;
3943     case OP_ENTERSUB:
3944         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3945             !(o->op_flags & OPf_STACKED)) {
3946             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
3947             assert(cUNOPo->op_first->op_type == OP_NULL);
3948             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3949             break;
3950         }
3951         else {                          /* lvalue subroutine call */
3952             o->op_private |= OPpLVAL_INTRO;
3953             PL_modcount = RETURN_UNLIMITED_NUMBER;
3954             if (S_potential_mod_type(type)) {
3955                 o->op_private |= OPpENTERSUB_INARGS;
3956                 break;
3957             }
3958             else {                      /* Compile-time error message: */
3959                 OP *kid = cUNOPo->op_first;
3960                 CV *cv;
3961                 GV *gv;
3962                 SV *namesv;
3963
3964                 if (kid->op_type != OP_PUSHMARK) {
3965                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3966                         Perl_croak(aTHX_
3967                                 "panic: unexpected lvalue entersub "
3968                                 "args: type/targ %ld:%" UVuf,
3969                                 (long)kid->op_type, (UV)kid->op_targ);
3970                     kid = kLISTOP->op_first;
3971                 }
3972                 while (OpHAS_SIBLING(kid))
3973                     kid = OpSIBLING(kid);
3974                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3975                     break;      /* Postpone until runtime */
3976                 }
3977
3978                 kid = kUNOP->op_first;
3979                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3980                     kid = kUNOP->op_first;
3981                 if (kid->op_type == OP_NULL)
3982                     Perl_croak(aTHX_
3983                                "Unexpected constant lvalue entersub "
3984                                "entry via type/targ %ld:%" UVuf,
3985                                (long)kid->op_type, (UV)kid->op_targ);
3986                 if (kid->op_type != OP_GV) {
3987                     break;
3988                 }
3989
3990                 gv = kGVOP_gv;
3991                 cv = isGV(gv)
3992                     ? GvCV(gv)
3993                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3994                         ? MUTABLE_CV(SvRV(gv))
3995                         : NULL;
3996                 if (!cv)
3997                     break;
3998                 if (CvLVALUE(cv))
3999                     break;
4000                 if (flags & OP_LVALUE_NO_CROAK)
4001                     return NULL;
4002
4003                 namesv = cv_name(cv, NULL, 0);
4004                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4005                                      "subroutine call of &%" SVf " in %s",
4006                                      SVfARG(namesv), PL_op_desc[type]),
4007                            SvUTF8(namesv));
4008                 return o;
4009             }
4010         }
4011         /* FALLTHROUGH */
4012     default:
4013       nomod:
4014         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4015         /* grep, foreach, subcalls, refgen */
4016         if (S_potential_mod_type(type))
4017             break;
4018         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4019                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4020                       ? "do block"
4021                       : OP_DESC(o)),
4022                      type ? PL_op_desc[type] : "local"));
4023         return o;
4024
4025     case OP_PREINC:
4026     case OP_PREDEC:
4027     case OP_POW:
4028     case OP_MULTIPLY:
4029     case OP_DIVIDE:
4030     case OP_MODULO:
4031     case OP_ADD:
4032     case OP_SUBTRACT:
4033     case OP_CONCAT:
4034     case OP_LEFT_SHIFT:
4035     case OP_RIGHT_SHIFT:
4036     case OP_BIT_AND:
4037     case OP_BIT_XOR:
4038     case OP_BIT_OR:
4039     case OP_I_MULTIPLY:
4040     case OP_I_DIVIDE:
4041     case OP_I_MODULO:
4042     case OP_I_ADD:
4043     case OP_I_SUBTRACT:
4044         if (!(o->op_flags & OPf_STACKED))
4045             goto nomod;
4046         PL_modcount++;
4047         break;
4048
4049     case OP_REPEAT:
4050         if (o->op_flags & OPf_STACKED) {
4051             PL_modcount++;
4052             break;
4053         }
4054         if (!(o->op_private & OPpREPEAT_DOLIST))
4055             goto nomod;
4056         else {
4057             const I32 mods = PL_modcount;
4058             modkids(cBINOPo->op_first, type);
4059             if (type != OP_AASSIGN)
4060                 goto nomod;
4061             kid = cBINOPo->op_last;
4062             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4063                 const IV iv = SvIV(kSVOP_sv);
4064                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4065                     PL_modcount =
4066                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4067             }
4068             else
4069                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4070         }
4071         break;
4072
4073     case OP_COND_EXPR:
4074         localize = 1;
4075         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4076             op_lvalue(kid, type);
4077         break;
4078
4079     case OP_RV2AV:
4080     case OP_RV2HV:
4081         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4082            PL_modcount = RETURN_UNLIMITED_NUMBER;
4083            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4084               fiable since some contexts need to know.  */
4085            o->op_flags |= OPf_MOD;
4086            return o;
4087         }
4088         /* FALLTHROUGH */
4089     case OP_RV2GV:
4090         if (scalar_mod_type(o, type))
4091             goto nomod;
4092         ref(cUNOPo->op_first, o->op_type);
4093         /* FALLTHROUGH */
4094     case OP_ASLICE:
4095     case OP_HSLICE:
4096         localize = 1;
4097         /* FALLTHROUGH */
4098     case OP_AASSIGN:
4099         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4100         if (type == OP_LEAVESUBLV && (
4101                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4102              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4103            ))
4104             o->op_private |= OPpMAYBE_LVSUB;
4105         /* FALLTHROUGH */
4106     case OP_NEXTSTATE:
4107     case OP_DBSTATE:
4108        PL_modcount = RETURN_UNLIMITED_NUMBER;
4109         break;
4110     case OP_KVHSLICE:
4111     case OP_KVASLICE:
4112     case OP_AKEYS:
4113         if (type == OP_LEAVESUBLV)
4114             o->op_private |= OPpMAYBE_LVSUB;
4115         goto nomod;
4116     case OP_AVHVSWITCH:
4117         if (type == OP_LEAVESUBLV
4118          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4119             o->op_private |= OPpMAYBE_LVSUB;
4120         goto nomod;
4121     case OP_AV2ARYLEN:
4122         PL_hints |= HINT_BLOCK_SCOPE;
4123         if (type == OP_LEAVESUBLV)
4124             o->op_private |= OPpMAYBE_LVSUB;
4125         PL_modcount++;
4126         break;
4127     case OP_RV2SV:
4128         ref(cUNOPo->op_first, o->op_type);
4129         localize = 1;
4130         /* FALLTHROUGH */
4131     case OP_GV:
4132         PL_hints |= HINT_BLOCK_SCOPE;
4133         /* FALLTHROUGH */
4134     case OP_SASSIGN:
4135     case OP_ANDASSIGN:
4136     case OP_ORASSIGN:
4137     case OP_DORASSIGN:
4138         PL_modcount++;
4139         break;
4140
4141     case OP_AELEMFAST:
4142     case OP_AELEMFAST_LEX:
4143         localize = -1;
4144         PL_modcount++;
4145         break;
4146
4147     case OP_PADAV:
4148     case OP_PADHV:
4149        PL_modcount = RETURN_UNLIMITED_NUMBER;
4150         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4151         {
4152            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4153               fiable since some contexts need to know.  */
4154             o->op_flags |= OPf_MOD;
4155             return o;
4156         }
4157         if (scalar_mod_type(o, type))
4158             goto nomod;
4159         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4160           && type == OP_LEAVESUBLV)
4161             o->op_private |= OPpMAYBE_LVSUB;
4162         /* FALLTHROUGH */
4163     case OP_PADSV:
4164         PL_modcount++;
4165         if (!type) /* local() */
4166             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4167                               PNfARG(PAD_COMPNAME(o->op_targ)));
4168         if (!(o->op_private & OPpLVAL_INTRO)
4169          || (  type != OP_SASSIGN && type != OP_AASSIGN
4170             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4171             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4172         break;
4173
4174     case OP_PUSHMARK:
4175         localize = 0;
4176         break;
4177
4178     case OP_KEYS:
4179         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4180             goto nomod;
4181         goto lvalue_func;
4182     case OP_SUBSTR:
4183         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4184             goto nomod;
4185         /* FALLTHROUGH */
4186     case OP_POS:
4187     case OP_VEC:
4188       lvalue_func:
4189         if (type == OP_LEAVESUBLV)
4190             o->op_private |= OPpMAYBE_LVSUB;
4191         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4192             /* substr and vec */
4193             /* If this op is in merely potential (non-fatal) modifiable
4194                context, then apply OP_ENTERSUB context to
4195                the kid op (to avoid croaking).  Other-
4196                wise pass this op’s own type so the correct op is mentioned
4197                in error messages.  */
4198             op_lvalue(OpSIBLING(cBINOPo->op_first),
4199                       S_potential_mod_type(type)
4200                         ? (I32)OP_ENTERSUB
4201                         : o->op_type);
4202         }
4203         break;
4204
4205     case OP_AELEM:
4206     case OP_HELEM:
4207         ref(cBINOPo->op_first, o->op_type);
4208         if (type == OP_ENTERSUB &&
4209              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4210             o->op_private |= OPpLVAL_DEFER;
4211         if (type == OP_LEAVESUBLV)
4212             o->op_private |= OPpMAYBE_LVSUB;
4213         localize = 1;
4214         PL_modcount++;
4215         break;
4216
4217     case OP_LEAVE:
4218     case OP_LEAVELOOP:
4219         o->op_private |= OPpLVALUE;
4220         /* FALLTHROUGH */
4221     case OP_SCOPE:
4222     case OP_ENTER:
4223     case OP_LINESEQ:
4224         localize = 0;
4225         if (o->op_flags & OPf_KIDS)
4226             op_lvalue(cLISTOPo->op_last, type);
4227         break;
4228
4229     case OP_NULL:
4230         localize = 0;
4231         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4232             goto nomod;
4233         else if (!(o->op_flags & OPf_KIDS))
4234             break;
4235
4236         if (o->op_targ != OP_LIST) {
4237             OP *sib = OpSIBLING(cLISTOPo->op_first);
4238             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4239              * that looks like
4240              *
4241              *   null
4242              *      arg
4243              *      trans
4244              *
4245              * compared with things like OP_MATCH which have the argument
4246              * as a child:
4247              *
4248              *   match
4249              *      arg
4250              *
4251              * so handle specially to correctly get "Can't modify" croaks etc
4252              */
4253
4254             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4255             {
4256                 /* this should trigger a "Can't modify transliteration" err */
4257                 op_lvalue(sib, type);
4258             }
4259             op_lvalue(cBINOPo->op_first, type);
4260             break;
4261         }
4262         /* FALLTHROUGH */
4263     case OP_LIST:
4264         localize = 0;
4265         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4266             /* elements might be in void context because the list is
4267                in scalar context or because they are attribute sub calls */
4268             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4269                 op_lvalue(kid, type);
4270         break;
4271
4272     case OP_COREARGS:
4273         return o;
4274
4275     case OP_AND:
4276     case OP_OR:
4277         if (type == OP_LEAVESUBLV
4278          || !S_vivifies(cLOGOPo->op_first->op_type))
4279             op_lvalue(cLOGOPo->op_first, type);
4280         if (type == OP_LEAVESUBLV
4281          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4282             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4283         goto nomod;
4284
4285     case OP_SREFGEN:
4286         if (type == OP_NULL) { /* local */
4287           local_refgen:
4288             if (!FEATURE_MYREF_IS_ENABLED)
4289                 Perl_croak(aTHX_ "The experimental declared_refs "
4290                                  "feature is not enabled");
4291             Perl_ck_warner_d(aTHX_
4292                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4293                     "Declaring references is experimental");
4294             op_lvalue(cUNOPo->op_first, OP_NULL);
4295             return o;
4296         }
4297         if (type != OP_AASSIGN && type != OP_SASSIGN
4298          && type != OP_ENTERLOOP)
4299             goto nomod;
4300         /* Don’t bother applying lvalue context to the ex-list.  */
4301         kid = cUNOPx(cUNOPo->op_first)->op_first;
4302         assert (!OpHAS_SIBLING(kid));
4303         goto kid_2lvref;
4304     case OP_REFGEN:
4305         if (type == OP_NULL) /* local */
4306             goto local_refgen;
4307         if (type != OP_AASSIGN) goto nomod;
4308         kid = cUNOPo->op_first;
4309       kid_2lvref:
4310         {
4311             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4312             S_lvref(aTHX_ kid, type);
4313             if (!PL_parser || PL_parser->error_count == ec) {
4314                 if (!FEATURE_REFALIASING_IS_ENABLED)
4315                     Perl_croak(aTHX_
4316                        "Experimental aliasing via reference not enabled");
4317                 Perl_ck_warner_d(aTHX_
4318                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4319                                 "Aliasing via reference is experimental");
4320             }
4321         }
4322         if (o->op_type == OP_REFGEN)
4323             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4324         op_null(o);
4325         return o;
4326
4327     case OP_SPLIT:
4328         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4329             /* This is actually @array = split.  */
4330             PL_modcount = RETURN_UNLIMITED_NUMBER;
4331             break;
4332         }
4333         goto nomod;
4334
4335     case OP_SCALAR:
4336         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4337         goto nomod;
4338     }
4339
4340     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4341        their argument is a filehandle; thus \stat(".") should not set
4342        it. AMS 20011102 */
4343     if (type == OP_REFGEN &&
4344         PL_check[o->op_type] == Perl_ck_ftst)
4345         return o;
4346
4347     if (type != OP_LEAVESUBLV)
4348         o->op_flags |= OPf_MOD;
4349
4350     if (type == OP_AASSIGN || type == OP_SASSIGN)
4351         o->op_flags |= OPf_SPECIAL
4352                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4353     else if (!type) { /* local() */
4354         switch (localize) {
4355         case 1:
4356             o->op_private |= OPpLVAL_INTRO;
4357             o->op_flags &= ~OPf_SPECIAL;
4358             PL_hints |= HINT_BLOCK_SCOPE;
4359             break;
4360         case 0:
4361             break;
4362         case -1:
4363             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4364                            "Useless localization of %s", OP_DESC(o));
4365         }
4366     }
4367     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4368              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4369         o->op_flags |= OPf_REF;
4370     return o;
4371 }
4372
4373 STATIC bool
4374 S_scalar_mod_type(const OP *o, I32 type)
4375 {
4376     switch (type) {
4377     case OP_POS:
4378     case OP_SASSIGN:
4379         if (o && o->op_type == OP_RV2GV)
4380             return FALSE;
4381         /* FALLTHROUGH */
4382     case OP_PREINC:
4383     case OP_PREDEC:
4384     case OP_POSTINC:
4385     case OP_POSTDEC:
4386     case OP_I_PREINC:
4387     case OP_I_PREDEC:
4388     case OP_I_POSTINC:
4389     case OP_I_POSTDEC:
4390     case OP_POW:
4391     case OP_MULTIPLY:
4392     case OP_DIVIDE:
4393     case OP_MODULO:
4394     case OP_REPEAT:
4395     case OP_ADD:
4396     case OP_SUBTRACT:
4397     case OP_I_MULTIPLY:
4398     case OP_I_DIVIDE:
4399     case OP_I_MODULO:
4400     case OP_I_ADD:
4401     case OP_I_SUBTRACT:
4402     case OP_LEFT_SHIFT:
4403     case OP_RIGHT_SHIFT:
4404     case OP_BIT_AND:
4405     case OP_BIT_XOR:
4406     case OP_BIT_OR:
4407     case OP_NBIT_AND:
4408     case OP_NBIT_XOR:
4409     case OP_NBIT_OR:
4410     case OP_SBIT_AND:
4411     case OP_SBIT_XOR:
4412     case OP_SBIT_OR:
4413     case OP_CONCAT:
4414     case OP_SUBST:
4415     case OP_TRANS:
4416     case OP_TRANSR:
4417     case OP_READ:
4418     case OP_SYSREAD:
4419     case OP_RECV:
4420     case OP_ANDASSIGN:
4421     case OP_ORASSIGN:
4422     case OP_DORASSIGN:
4423     case OP_VEC:
4424     case OP_SUBSTR:
4425         return TRUE;
4426     default:
4427         return FALSE;
4428     }
4429 }
4430
4431 STATIC bool
4432 S_is_handle_constructor(const OP *o, I32 numargs)
4433 {
4434     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4435
4436     switch (o->op_type) {
4437     case OP_PIPE_OP:
4438     case OP_SOCKPAIR:
4439         if (numargs == 2)
4440             return TRUE;
4441         /* FALLTHROUGH */
4442     case OP_SYSOPEN:
4443     case OP_OPEN:
4444     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4445     case OP_SOCKET:
4446     case OP_OPEN_DIR:
4447     case OP_ACCEPT:
4448         if (numargs == 1)
4449             return TRUE;
4450         /* FALLTHROUGH */
4451     default:
4452         return FALSE;
4453     }
4454 }
4455
4456 static OP *
4457 S_refkids(pTHX_ OP *o, I32 type)
4458 {
4459     if (o && o->op_flags & OPf_KIDS) {
4460         OP *kid;
4461         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4462             ref(kid, type);
4463     }
4464     return o;
4465 }
4466
4467 OP *
4468 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4469 {
4470     dVAR;
4471     OP *kid;
4472
4473     PERL_ARGS_ASSERT_DOREF;
4474
4475     if (PL_parser && PL_parser->error_count)
4476         return o;
4477
4478     switch (o->op_type) {
4479     case OP_ENTERSUB:
4480         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4481             !(o->op_flags & OPf_STACKED)) {
4482             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4483             assert(cUNOPo->op_first->op_type == OP_NULL);
4484             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4485             o->op_flags |= OPf_SPECIAL;
4486         }
4487         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4488             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4489                               : type == OP_RV2HV ? OPpDEREF_HV
4490                               : OPpDEREF_SV);
4491             o->op_flags |= OPf_MOD;
4492         }
4493
4494         break;
4495
4496     case OP_COND_EXPR:
4497         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4498             doref(kid, type, set_op_ref);
4499         break;
4500     case OP_RV2SV:
4501         if (type == OP_DEFINED)
4502             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4503         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4504         /* FALLTHROUGH */
4505     case OP_PADSV:
4506         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4507             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4508                               : type == OP_RV2HV ? OPpDEREF_HV
4509                               : OPpDEREF_SV);
4510             o->op_flags |= OPf_MOD;
4511         }
4512         break;
4513
4514     case OP_RV2AV:
4515     case OP_RV2HV:
4516         if (set_op_ref)
4517             o->op_flags |= OPf_REF;
4518         /* FALLTHROUGH */
4519     case OP_RV2GV:
4520         if (type == OP_DEFINED)
4521             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4522         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4523         break;
4524
4525     case OP_PADAV:
4526     case OP_PADHV:
4527         if (set_op_ref)
4528             o->op_flags |= OPf_REF;
4529         break;
4530
4531     case OP_SCALAR:
4532     case OP_NULL:
4533         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4534             break;
4535         doref(cBINOPo->op_first, type, set_op_ref);
4536         break;
4537     case OP_AELEM:
4538     case OP_HELEM:
4539         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4540         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4541             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4542                               : type == OP_RV2HV ? OPpDEREF_HV
4543                               : OPpDEREF_SV);
4544             o->op_flags |= OPf_MOD;
4545         }
4546         break;
4547
4548     case OP_SCOPE:
4549     case OP_LEAVE:
4550         set_op_ref = FALSE;
4551         /* FALLTHROUGH */
4552     case OP_ENTER:
4553     case OP_LIST:
4554         if (!(o->op_flags & OPf_KIDS))
4555             break;
4556         doref(cLISTOPo->op_last, type, set_op_ref);
4557         break;
4558     default:
4559         break;
4560     }
4561     return scalar(o);
4562
4563 }
4564
4565 STATIC OP *
4566 S_dup_attrlist(pTHX_ OP *o)
4567 {
4568     OP *rop;
4569
4570     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4571
4572     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4573      * where the first kid is OP_PUSHMARK and the remaining ones
4574      * are OP_CONST.  We need to push the OP_CONST values.
4575      */
4576     if (o->op_type == OP_CONST)
4577         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4578     else {
4579         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4580         rop = NULL;
4581         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4582             if (o->op_type == OP_CONST)
4583                 rop = op_append_elem(OP_LIST, rop,
4584                                   newSVOP(OP_CONST, o->op_flags,
4585                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4586         }
4587     }
4588     return rop;
4589 }
4590
4591 STATIC void
4592 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4593 {
4594     PERL_ARGS_ASSERT_APPLY_ATTRS;
4595     {
4596         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4597
4598         /* fake up C<use attributes $pkg,$rv,@attrs> */
4599
4600 #define ATTRSMODULE "attributes"
4601 #define ATTRSMODULE_PM "attributes.pm"
4602
4603         Perl_load_module(
4604           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4605           newSVpvs(ATTRSMODULE),
4606           NULL,
4607           op_prepend_elem(OP_LIST,
4608                           newSVOP(OP_CONST, 0, stashsv),
4609                           op_prepend_elem(OP_LIST,
4610                                           newSVOP(OP_CONST, 0,
4611                                                   newRV(target)),
4612                                           dup_attrlist(attrs))));
4613     }
4614 }
4615
4616 STATIC void
4617 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4618 {
4619     OP *pack, *imop, *arg;
4620     SV *meth, *stashsv, **svp;
4621
4622     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4623
4624     if (!attrs)
4625         return;
4626
4627     assert(target->op_type == OP_PADSV ||
4628            target->op_type == OP_PADHV ||
4629            target->op_type == OP_PADAV);
4630
4631     /* Ensure that attributes.pm is loaded. */
4632     /* Don't force the C<use> if we don't need it. */
4633     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4634     if (svp && *svp != &PL_sv_undef)
4635         NOOP;   /* already in %INC */
4636     else
4637         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4638                                newSVpvs(ATTRSMODULE), NULL);
4639
4640     /* Need package name for method call. */
4641     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4642
4643     /* Build up the real arg-list. */
4644     stashsv = newSVhek(HvNAME_HEK(stash));
4645
4646     arg = newOP(OP_PADSV, 0);
4647     arg->op_targ = target->op_targ;
4648     arg = op_prepend_elem(OP_LIST,
4649                        newSVOP(OP_CONST, 0, stashsv),
4650                        op_prepend_elem(OP_LIST,
4651                                     newUNOP(OP_REFGEN, 0,
4652                                             arg),
4653                                     dup_attrlist(attrs)));
4654
4655     /* Fake up a method call to import */
4656     meth = newSVpvs_share("import");
4657     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4658                    op_append_elem(OP_LIST,
4659                                op_prepend_elem(OP_LIST, pack, arg),
4660                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4661
4662     /* Combine the ops. */
4663     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4664 }
4665
4666 /*
4667 =notfor apidoc apply_attrs_string
4668
4669 Attempts to apply a list of attributes specified by the C<attrstr> and
4670 C<len> arguments to the subroutine identified by the C<cv> argument which
4671 is expected to be associated with the package identified by the C<stashpv>
4672 argument (see L<attributes>).  It gets this wrong, though, in that it
4673 does not correctly identify the boundaries of the individual attribute
4674 specifications within C<attrstr>.  This is not really intended for the
4675 public API, but has to be listed here for systems such as AIX which
4676 need an explicit export list for symbols.  (It's called from XS code
4677 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
4678 to respect attribute syntax properly would be welcome.
4679
4680 =cut
4681 */
4682
4683 void
4684 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4685                         const char *attrstr, STRLEN len)
4686 {
4687     OP *attrs = NULL;
4688
4689     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4690
4691     if (!len) {
4692         len = strlen(attrstr);
4693     }
4694
4695     while (len) {
4696         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4697         if (len) {
4698             const char * const sstr = attrstr;
4699             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4700             attrs = op_append_elem(OP_LIST, attrs,
4701                                 newSVOP(OP_CONST, 0,
4702                                         newSVpvn(sstr, attrstr-sstr)));
4703         }
4704     }
4705
4706     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4707                      newSVpvs(ATTRSMODULE),
4708                      NULL, op_prepend_elem(OP_LIST,
4709                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4710                                   op_prepend_elem(OP_LIST,
4711                                                newSVOP(OP_CONST, 0,
4712                                                        newRV(MUTABLE_SV(cv))),
4713                                                attrs)));
4714 }
4715
4716 STATIC void
4717 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4718                         bool curstash)
4719 {
4720     OP *new_proto = NULL;
4721     STRLEN pvlen;
4722     char *pv;
4723     OP *o;
4724
4725     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4726
4727     if (!*attrs)
4728         return;
4729
4730     o = *attrs;
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             new_proto = o;
4739             *attrs = NULL;
4740         }
4741     } else if (o->op_type == OP_LIST) {
4742         OP * lasto;
4743         assert(o->op_flags & OPf_KIDS);
4744         lasto = cLISTOPo->op_first;
4745         assert(lasto->op_type == OP_PUSHMARK);
4746         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4747             if (o->op_type == OP_CONST) {
4748                 pv = SvPV(cSVOPo_sv, pvlen);
4749                 if (memBEGINs(pv, pvlen, "prototype(")) {
4750                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4751                     SV ** const tmpo = cSVOPx_svp(o);
4752                     SvREFCNT_dec(cSVOPo_sv);
4753                     *tmpo = tmpsv;
4754                     if (new_proto && ckWARN(WARN_MISC)) {
4755                         STRLEN new_len;
4756                         const char * newp = SvPV(cSVOPo_sv, new_len);
4757                         Perl_warner(aTHX_ packWARN(WARN_MISC),
4758                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4759                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4760                         op_free(new_proto);
4761                     }
4762                     else if (new_proto)
4763                         op_free(new_proto);
4764                     new_proto = o;
4765                     /* excise new_proto from the list */
4766                     op_sibling_splice(*attrs, lasto, 1, NULL);
4767                     o = lasto;
4768                     continue;
4769                 }
4770             }
4771             lasto = o;
4772         }
4773         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4774            would get pulled in with no real need */
4775         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4776             op_free(*attrs);
4777             *attrs = NULL;
4778         }
4779     }
4780
4781     if (new_proto) {
4782         SV *svname;
4783         if (isGV(name)) {
4784             svname = sv_newmortal();
4785             gv_efullname3(svname, name, NULL);
4786         }
4787         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4788             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4789         else
4790             svname = (SV *)name;
4791         if (ckWARN(WARN_ILLEGALPROTO))
4792             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4793                                  curstash);
4794         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4795             STRLEN old_len, new_len;
4796             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4797             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4798
4799             if (curstash && svname == (SV *)name
4800              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4801                 svname = sv_2mortal(newSVsv(PL_curstname));
4802                 sv_catpvs(svname, "::");
4803                 sv_catsv(svname, (SV *)name);
4804             }
4805
4806             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4807                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4808                 " in %" SVf,
4809                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4810                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4811                 SVfARG(svname));
4812         }
4813         if (*proto)
4814             op_free(*proto);
4815         *proto = new_proto;
4816     }
4817 }
4818
4819 static void
4820 S_cant_declare(pTHX_ OP *o)
4821 {
4822     if (o->op_type == OP_NULL
4823      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4824         o = cUNOPo->op_first;
4825     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4826                              o->op_type == OP_NULL
4827                                && o->op_flags & OPf_SPECIAL
4828                                  ? "do block"
4829                                  : OP_DESC(o),
4830                              PL_parser->in_my == KEY_our   ? "our"   :
4831                              PL_parser->in_my == KEY_state ? "state" :
4832                                                              "my"));
4833 }
4834
4835 STATIC OP *
4836 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4837 {
4838     I32 type;
4839     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4840
4841     PERL_ARGS_ASSERT_MY_KID;
4842
4843     if (!o || (PL_parser && PL_parser->error_count))
4844         return o;
4845
4846     type = o->op_type;
4847
4848     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4849         OP *kid;
4850         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4851             my_kid(kid, attrs, imopsp);
4852         return o;
4853     } else if (type == OP_UNDEF || type == OP_STUB) {
4854         return o;
4855     } else if (type == OP_RV2SV ||      /* "our" declaration */
4856                type == OP_RV2AV ||
4857                type == OP_RV2HV) {
4858         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4859             S_cant_declare(aTHX_ o);
4860         } else if (attrs) {
4861             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4862             assert(PL_parser);
4863             PL_parser->in_my = FALSE;
4864             PL_parser->in_my_stash = NULL;
4865             apply_attrs(GvSTASH(gv),
4866                         (type == OP_RV2SV ? GvSVn(gv) :
4867                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4868                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4869                         attrs);
4870         }
4871         o->op_private |= OPpOUR_INTRO;
4872         return o;
4873     }
4874     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4875         if (!FEATURE_MYREF_IS_ENABLED)
4876             Perl_croak(aTHX_ "The experimental declared_refs "
4877                              "feature is not enabled");
4878         Perl_ck_warner_d(aTHX_
4879              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4880             "Declaring references is experimental");
4881         /* Kid is a nulled OP_LIST, handled above.  */
4882         my_kid(cUNOPo->op_first, attrs, imopsp);
4883         return o;
4884     }
4885     else if (type != OP_PADSV &&
4886              type != OP_PADAV &&
4887              type != OP_PADHV &&
4888              type != OP_PUSHMARK)
4889     {
4890         S_cant_declare(aTHX_ o);
4891         return o;
4892     }
4893     else if (attrs && type != OP_PUSHMARK) {
4894         HV *stash;
4895
4896         assert(PL_parser);
4897         PL_parser->in_my = FALSE;
4898         PL_parser->in_my_stash = NULL;
4899
4900         /* check for C<my Dog $spot> when deciding package */
4901         stash = PAD_COMPNAME_TYPE(o->op_targ);
4902         if (!stash)
4903             stash = PL_curstash;
4904         apply_attrs_my(stash, o, attrs, imopsp);
4905     }
4906     o->op_flags |= OPf_MOD;
4907     o->op_private |= OPpLVAL_INTRO;
4908     if (stately)
4909         o->op_private |= OPpPAD_STATE;
4910     return o;
4911 }
4912
4913 OP *
4914 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4915 {
4916     OP *rops;
4917     int maybe_scalar = 0;
4918
4919     PERL_ARGS_ASSERT_MY_ATTRS;
4920
4921 /* [perl #17376]: this appears to be premature, and results in code such as
4922    C< our(%x); > executing in list mode rather than void mode */
4923 #if 0
4924     if (o->op_flags & OPf_PARENS)
4925         list(o);
4926     else
4927         maybe_scalar = 1;
4928 #else
4929     maybe_scalar = 1;
4930 #endif
4931     if (attrs)
4932         SAVEFREEOP(attrs);
4933     rops = NULL;
4934     o = my_kid(o, attrs, &rops);
4935     if (rops) {
4936         if (maybe_scalar && o->op_type == OP_PADSV) {
4937             o = scalar(op_append_list(OP_LIST, rops, o));
4938             o->op_private |= OPpLVAL_INTRO;
4939         }
4940         else {
4941             /* The listop in rops might have a pushmark at the beginning,
4942                which will mess up list assignment. */
4943             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4944             if (rops->op_type == OP_LIST &&
4945                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4946             {
4947                 OP * const pushmark = lrops->op_first;
4948                 /* excise pushmark */
4949                 op_sibling_splice(rops, NULL, 1, NULL);
4950                 op_free(pushmark);
4951             }
4952             o = op_append_list(OP_LIST, o, rops);
4953         }
4954     }
4955     PL_parser->in_my = FALSE;
4956     PL_parser->in_my_stash = NULL;
4957     return o;
4958 }
4959
4960 OP *
4961 Perl_sawparens(pTHX_ OP *o)
4962 {
4963     PERL_UNUSED_CONTEXT;
4964     if (o)
4965         o->op_flags |= OPf_PARENS;
4966     return o;
4967 }
4968
4969 OP *
4970 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4971 {
4972     OP *o;
4973     bool ismatchop = 0;
4974     const OPCODE ltype = left->op_type;
4975     const OPCODE rtype = right->op_type;
4976
4977     PERL_ARGS_ASSERT_BIND_MATCH;
4978
4979     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4980           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4981     {
4982       const char * const desc
4983           = PL_op_desc[(
4984                           rtype == OP_SUBST || rtype == OP_TRANS
4985                        || rtype == OP_TRANSR
4986                        )
4987                        ? (int)rtype : OP_MATCH];
4988       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4989       SV * const name =
4990         S_op_varname(aTHX_ left);
4991       if (name)
4992         Perl_warner(aTHX_ packWARN(WARN_MISC),
4993              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4994              desc, SVfARG(name), SVfARG(name));
4995       else {
4996         const char * const sample = (isary
4997              ? "@array" : "%hash");
4998         Perl_warner(aTHX_ packWARN(WARN_MISC),
4999              "Applying %s to %s will act on scalar(%s)",
5000              desc, sample, sample);
5001       }
5002     }
5003
5004     if (rtype == OP_CONST &&
5005         cSVOPx(right)->op_private & OPpCONST_BARE &&
5006         cSVOPx(right)->op_private & OPpCONST_STRICT)
5007     {
5008         no_bareword_allowed(right);
5009     }
5010
5011     /* !~ doesn't make sense with /r, so error on it for now */
5012     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5013         type == OP_NOT)
5014         /* diag_listed_as: Using !~ with %s doesn't make sense */
5015         yyerror("Using !~ with s///r doesn't make sense");
5016     if (rtype == OP_TRANSR && type == OP_NOT)
5017         /* diag_listed_as: Using !~ with %s doesn't make sense */
5018         yyerror("Using !~ with tr///r doesn't make sense");
5019
5020     ismatchop = (rtype == OP_MATCH ||
5021                  rtype == OP_SUBST ||
5022                  rtype == OP_TRANS || rtype == OP_TRANSR)
5023              && !(right->op_flags & OPf_SPECIAL);
5024     if (ismatchop && right->op_private & OPpTARGET_MY) {
5025         right->op_targ = 0;
5026         right->op_private &= ~OPpTARGET_MY;
5027     }
5028     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5029         if (left->op_type == OP_PADSV
5030          && !(left->op_private & OPpLVAL_INTRO))
5031         {
5032             right->op_targ = left->op_targ;
5033             op_free(left);
5034             o = right;
5035         }
5036         else {
5037             right->op_flags |= OPf_STACKED;
5038             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5039             ! (rtype == OP_TRANS &&
5040                right->op_private & OPpTRANS_IDENTICAL) &&
5041             ! (rtype == OP_SUBST &&
5042                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5043                 left = op_lvalue(left, rtype);
5044             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5045                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5046             else
5047                 o = op_prepend_elem(rtype, scalar(left), right);
5048         }
5049         if (type == OP_NOT)
5050             return newUNOP(OP_NOT, 0, scalar(o));
5051         return o;
5052     }
5053     else
5054         return bind_match(type, left,
5055                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5056 }
5057
5058 OP *
5059 Perl_invert(pTHX_ OP *o)
5060 {
5061     if (!o)
5062         return NULL;
5063     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5064 }
5065
5066 /*
5067 =for apidoc Amx|OP *|op_scope|OP *o
5068
5069 Wraps up an op tree with some additional ops so that at runtime a dynamic
5070 scope will be created.  The original ops run in the new dynamic scope,
5071 and then, provided that they exit normally, the scope will be unwound.
5072 The additional ops used to create and unwind the dynamic scope will
5073 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5074 instead if the ops are simple enough to not need the full dynamic scope
5075 structure.
5076
5077 =cut
5078 */
5079
5080 OP *
5081 Perl_op_scope(pTHX_ OP *o)
5082 {
5083     dVAR;
5084     if (o) {
5085         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5086             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5087             OpTYPE_set(o, OP_LEAVE);
5088         }
5089         else if (o->op_type == OP_LINESEQ) {
5090             OP *kid;
5091             OpTYPE_set(o, OP_SCOPE);
5092             kid = ((LISTOP*)o)->op_first;
5093             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5094                 op_null(kid);
5095
5096                 /* The following deals with things like 'do {1 for 1}' */
5097                 kid = OpSIBLING(kid);
5098                 if (kid &&
5099                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5100                     op_null(kid);
5101             }
5102         }
5103         else
5104             o = newLISTOP(OP_SCOPE, 0, o, NULL);
5105     }
5106     return o;
5107 }
5108
5109 OP *
5110 Perl_op_unscope(pTHX_ OP *o)
5111 {
5112     if (o && o->op_type == OP_LINESEQ) {
5113         OP *kid = cLISTOPo->op_first;
5114         for(; kid; kid = OpSIBLING(kid))
5115             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5116                 op_null(kid);
5117     }
5118     return o;
5119 }
5120
5121 /*
5122 =for apidoc Am|int|block_start|int full
5123
5124 Handles compile-time scope entry.
5125 Arranges for hints to be restored on block
5126 exit and also handles pad sequence numbers to make lexical variables scope
5127 right.  Returns a savestack index for use with C<block_end>.
5128
5129 =cut
5130 */
5131
5132 int
5133 Perl_block_start(pTHX_ int full)
5134 {
5135     const int retval = PL_savestack_ix;
5136
5137     PL_compiling.cop_seq = PL_cop_seqmax;
5138     COP_SEQMAX_INC;
5139     pad_block_start(full);
5140     SAVEHINTS();
5141     PL_hints &= ~HINT_BLOCK_SCOPE;
5142     SAVECOMPILEWARNINGS();
5143     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5144     SAVEI32(PL_compiling.cop_seq);
5145     PL_compiling.cop_seq = 0;
5146
5147     CALL_BLOCK_HOOKS(bhk_start, full);
5148
5149     return retval;
5150 }
5151
5152 /*
5153 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5154
5155 Handles compile-time scope exit.  C<floor>
5156 is the savestack index returned by
5157 C<block_start>, and C<seq> is the body of the block.  Returns the block,
5158 possibly modified.
5159
5160 =cut
5161 */
5162
5163 OP*
5164 Perl_block_end(pTHX_ I32 floor, OP *seq)
5165 {
5166     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5167     OP* retval = scalarseq(seq);
5168     OP *o;
5169
5170     /* XXX Is the null PL_parser check necessary here? */
5171     assert(PL_parser); /* Let’s find out under debugging builds.  */
5172     if (PL_parser && PL_parser->parsed_sub) {
5173         o = newSTATEOP(0, NULL, NULL);
5174         op_null(o);
5175         retval = op_append_elem(OP_LINESEQ, retval, o);
5176     }
5177
5178     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5179
5180     LEAVE_SCOPE(floor);
5181     if (needblockscope)
5182         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5183     o = pad_leavemy();
5184
5185     if (o) {
5186         /* pad_leavemy has created a sequence of introcv ops for all my
5187            subs declared in the block.  We have to replicate that list with
5188            clonecv ops, to deal with this situation:
5189
5190                sub {
5191                    my sub s1;
5192                    my sub s2;
5193                    sub s1 { state sub foo { \&s2 } }
5194                }->()
5195
5196            Originally, I was going to have introcv clone the CV and turn
5197            off the stale flag.  Since &s1 is declared before &s2, the
5198            introcv op for &s1 is executed (on sub entry) before the one for
5199            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
5200            cloned, since it is a state sub) closes over &s2 and expects
5201            to see it in its outer CV’s pad.  If the introcv op clones &s1,
5202            then &s2 is still marked stale.  Since &s1 is not active, and
5203            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5204            ble will not stay shared’ warning.  Because it is the same stub
5205            that will be used when the introcv op for &s2 is executed, clos-
5206            ing over it is safe.  Hence, we have to turn off the stale flag
5207            on all lexical subs in the block before we clone any of them.
5208            Hence, having introcv clone the sub cannot work.  So we create a
5209            list of ops like this:
5210
5211                lineseq
5212                   |
5213                   +-- introcv
5214                   |
5215                   +-- introcv
5216                   |
5217                   +-- introcv
5218                   |
5219                   .
5220                   .
5221                   .
5222                   |
5223                   +-- clonecv
5224                   |
5225                   +-- clonecv
5226                   |
5227                   +-- clonecv
5228                   |
5229                   .
5230                   .
5231                   .
5232          */
5233         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5234         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5235         for (;; kid = OpSIBLING(kid)) {
5236             OP *newkid = newOP(OP_CLONECV, 0);
5237             newkid->op_targ = kid->op_targ;
5238             o = op_append_elem(OP_LINESEQ, o, newkid);
5239             if (kid == last) break;
5240         }
5241         retval = op_prepend_elem(OP_LINESEQ, o, retval);
5242     }
5243
5244     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5245
5246     return retval;
5247 }
5248
5249 /*
5250 =head1 Compile-time scope hooks
5251
5252 =for apidoc Aox||blockhook_register
5253
5254 Register a set of hooks to be called when the Perl lexical scope changes
5255 at compile time.  See L<perlguts/"Compile-time scope hooks">.
5256
5257 =cut
5258 */
5259
5260 void
5261 Perl_blockhook_register(pTHX_ BHK *hk)
5262 {
5263     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5264
5265     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5266 }
5267
5268 void
5269 Perl_newPROG(pTHX_ OP *o)
5270 {
5271     OP *start;
5272
5273     PERL_ARGS_ASSERT_NEWPROG;
5274
5275     if (PL_in_eval) {
5276         PERL_CONTEXT *cx;
5277         I32 i;
5278         if (PL_eval_root)
5279                 return;
5280         PL_eval_root = newUNOP(OP_LEAVEEVAL,
5281                                ((PL_in_eval & EVAL_KEEPERR)
5282                                 ? OPf_SPECIAL : 0), o);
5283
5284         cx = CX_CUR();
5285         assert(CxTYPE(cx) == CXt_EVAL);
5286
5287         if ((cx->blk_gimme & G_WANT) == G_VOID)
5288             scalarvoid(PL_eval_root);
5289         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5290             list(PL_eval_root);
5291         else
5292             scalar(PL_eval_root);
5293
5294         start = op_linklist(PL_eval_root);
5295         PL_eval_root->op_next = 0;
5296         i = PL_savestack_ix;
5297         SAVEFREEOP(o);
5298         ENTER;
5299         S_process_optree(aTHX_ NULL, PL_eval_root, start);
5300         LEAVE;
5301         PL_savestack_ix = i;
5302     }
5303     else {
5304         if (o->op_type == OP_STUB) {
5305             /* This block is entered if nothing is compiled for the main
5306                program. This will be the case for an genuinely empty main
5307                program, or one which only has BEGIN blocks etc, so already
5308                run and freed.
5309
5310                Historically (5.000) the guard above was !o. However, commit
5311                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5312                c71fccf11fde0068, changed perly.y so that newPROG() is now
5313                called with the output of block_end(), which returns a new
5314                OP_STUB for the case of an empty optree. ByteLoader (and
5315                maybe other things) also take this path, because they set up
5316                PL_main_start and PL_main_root directly, without generating an
5317                optree.
5318
5319                If the parsing the main program aborts (due to parse errors,
5320                or due to BEGIN or similar calling exit), then newPROG()
5321                isn't even called, and hence this code path and its cleanups
5322                are skipped. This shouldn't make a make a difference:
5323                * a non-zero return from perl_parse is a failure, and
5324                  perl_destruct() should be called immediately.
5325                * however, if exit(0) is called during the parse, then
5326                  perl_parse() returns 0, and perl_run() is called. As
5327                  PL_main_start will be NULL, perl_run() will return
5328                  promptly, and the exit code will remain 0.
5329             */
5330
5331             PL_comppad_name = 0;
5332             PL_compcv = 0;
5333             S_op_destroy(aTHX_ o);
5334             return;
5335         }
5336         PL_main_root = op_scope(sawparens(scalarvoid(o)));
5337         PL_curcop = &PL_compiling;
5338         start = LINKLIST(PL_main_root);
5339         PL_main_root->op_next = 0;
5340         S_process_optree(aTHX_ NULL, PL_main_root, start);
5341         cv_forget_slab(PL_compcv);
5342         PL_compcv = 0;
5343
5344         /* Register with debugger */
5345         if (PERLDB_INTER) {
5346             CV * const cv = get_cvs("DB::postponed", 0);
5347             if (cv) {
5348                 dSP;
5349                 PUSHMARK(SP);
5350                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5351                 PUTBACK;
5352                 call_sv(MUTABLE_SV(cv), G_DISCARD);
5353             }
5354         }
5355     }
5356 }
5357
5358 OP *
5359 Perl_localize(pTHX_ OP *o, I32 lex)
5360 {
5361     PERL_ARGS_ASSERT_LOCALIZE;
5362
5363     if (o->op_flags & OPf_PARENS)
5364 /* [perl #17376]: this appears to be premature, and results in code such as
5365    C< our(%x); > executing in list mode rather than void mode */
5366 #if 0
5367         list(o);
5368 #else
5369         NOOP;
5370 #endif
5371     else {
5372         if ( PL_parser->bufptr > PL_parser->oldbufptr
5373             && PL_parser->bufptr[-1] == ','
5374             && ckWARN(WARN_PARENTHESIS))
5375         {
5376             char *s = PL_parser->bufptr;
5377             bool sigil = FALSE;
5378
5379             /* some heuristics to detect a potential error */
5380             while (*s && (strchr(", \t\n", *s)))
5381                 s++;
5382
5383             while (1) {
5384                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5385                        && *++s
5386                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5387                     s++;
5388                     sigil = TRUE;
5389                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5390                         s++;
5391                     while (*s && (strchr(", \t\n", *s)))
5392                         s++;
5393                 }
5394                 else
5395                     break;
5396             }
5397             if (sigil && (*s == ';' || *s == '=')) {
5398                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5399                                 "Parentheses missing around \"%s\" list",
5400                                 lex
5401                                     ? (PL_parser->in_my == KEY_our
5402                                         ? "our"
5403                                         : PL_parser->in_my == KEY_state
5404                                             ? "state"
5405                                             : "my")
5406                                     : "local");
5407             }
5408         }
5409     }
5410     if (lex)
5411         o = my(o);
5412     else
5413         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
5414     PL_parser->in_my = FALSE;
5415     PL_parser->in_my_stash = NULL;
5416     return o;
5417 }
5418
5419 OP *
5420 Perl_jmaybe(pTHX_ OP *o)
5421 {
5422     PERL_ARGS_ASSERT_JMAYBE;
5423
5424     if (o->op_type == OP_LIST) {
5425         OP * const o2
5426             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5427         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5428     }
5429     return o;
5430 }
5431
5432 PERL_STATIC_INLINE OP *
5433 S_op_std_init(pTHX_ OP *o)
5434 {
5435     I32 type = o->op_type;
5436
5437     PERL_ARGS_ASSERT_OP_STD_INIT;
5438
5439     if (PL_opargs[type] & OA_RETSCALAR)
5440         scalar(o);
5441     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5442         o->op_targ = pad_alloc(type, SVs_PADTMP);
5443
5444     return o;
5445 }
5446
5447 PERL_STATIC_INLINE OP *
5448 S_op_integerize(pTHX_ OP *o)
5449 {
5450     I32 type = o->op_type;
5451
5452     PERL_ARGS_ASSERT_OP_INTEGERIZE;
5453
5454     /* integerize op. */
5455     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5456     {
5457         dVAR;
5458         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5459     }
5460
5461     if (type == OP_NEGATE)
5462         /* XXX might want a ck_negate() for this */
5463         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5464
5465     return o;
5466 }
5467
5468 static OP *
5469 S_fold_constants(pTHX_ OP *const o)
5470 {
5471     dVAR;
5472     OP * volatile curop;
5473     OP *newop;
5474     volatile I32 type = o->op_type;
5475     bool is_stringify;
5476     SV * volatile sv = NULL;
5477     int ret = 0;
5478     OP *old_next;
5479     SV * const oldwarnhook = PL_warnhook;
5480     SV * const olddiehook  = PL_diehook;
5481     COP not_compiling;
5482     U8 oldwarn = PL_dowarn;
5483     I32 old_cxix;
5484     dJMPENV;
5485
5486     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5487
5488     if (!(PL_opargs[type] & OA_FOLDCONST))
5489         goto nope;
5490
5491     switch (type) {
5492     case OP_UCFIRST:
5493     case OP_LCFIRST:
5494     case OP_UC:
5495     case OP_LC:
5496     case OP_FC:
5497 #ifdef USE_LOCALE_CTYPE
5498         if (IN_LC_COMPILETIME(LC_CTYPE))
5499             goto nope;
5500 #endif
5501         break;
5502     case OP_SLT:
5503     case OP_SGT:
5504     case OP_SLE:
5505     case OP_SGE:
5506     case OP_SCMP:
5507 #ifdef USE_LOCALE_COLLATE
5508         if (IN_LC_COMPILETIME(LC_COLLATE))
5509             goto nope;
5510 #endif
5511         break;
5512     case OP_SPRINTF:
5513         /* XXX what about the numeric ops? */
5514 #ifdef USE_LOCALE_NUMERIC
5515         if (IN_LC_COMPILETIME(LC_NUMERIC))
5516             goto nope;
5517 #endif
5518         break;
5519     case OP_PACK:
5520         if (!OpHAS_SIBLING(cLISTOPo->op_first)
5521           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5522             goto nope;
5523         {
5524             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5525             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5526             {
5527                 const char *s = SvPVX_const(sv);
5528                 while (s < SvEND(sv)) {
5529                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5530                     s++;
5531                 }
5532             }
5533         }
5534         break;
5535     case OP_REPEAT:
5536         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5537         break;
5538     case OP_SREFGEN:
5539         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5540          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5541             goto nope;
5542     }
5543
5544     if (PL_parser && PL_parser->error_count)
5545         goto nope;              /* Don't try to run w/ errors */
5546
5547     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5548         switch (curop->op_type) {
5549         case OP_CONST:
5550             if (   (curop->op_private & OPpCONST_BARE)
5551                 && (curop->op_private & OPpCONST_STRICT)) {
5552                 no_bareword_allowed(curop);
5553                 goto nope;
5554             }
5555             /* FALLTHROUGH */
5556         case OP_LIST:
5557         case OP_SCALAR:
5558         case OP_NULL:
5559         case OP_PUSHMARK:
5560             /* Foldable; move to next op in list */
5561             break;
5562
5563         default:
5564             /* No other op types are considered foldable */
5565             goto nope;
5566         }
5567     }
5568
5569     curop = LINKLIST(o);
5570     old_next = o->op_next;
5571     o->op_next = 0;
5572     PL_op = curop;
5573
5574     old_cxix = cxstack_ix;
5575     create_eval_scope(NULL, G_FAKINGEVAL);
5576
5577     /* Verify that we don't need to save it:  */
5578     assert(PL_curcop == &PL_compiling);
5579     StructCopy(&PL_compiling, &not_compiling, COP);
5580     PL_curcop = &not_compiling;
5581     /* The above ensures that we run with all the correct hints of the
5582        currently compiling COP, but that IN_PERL_RUNTIME is true. */
5583     assert(IN_PERL_RUNTIME);
5584     PL_warnhook = PERL_WARNHOOK_FATAL;
5585     PL_diehook  = NULL;
5586     JMPENV_PUSH(ret);
5587
5588     /* Effective $^W=1.  */
5589     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5590         PL_dowarn |= G_WARN_ON;
5591
5592     switch (ret) {
5593     case 0:
5594         CALLRUNOPS(aTHX);
5595         sv = *(PL_stack_sp--);
5596         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
5597             pad_swipe(o->op_targ,  FALSE);
5598         }
5599         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
5600             SvREFCNT_inc_simple_void(sv);
5601             SvTEMP_off(sv);
5602         }
5603         else { assert(SvIMMORTAL(sv)); }
5604         break;
5605     case 3:
5606         /* Something tried to die.  Abandon constant folding.  */
5607         /* Pretend the error never happened.  */
5608         CLEAR_ERRSV();
5609         o->op_next = old_next;
5610         break;
5611     default:
5612         JMPENV_POP;
5613         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
5614         PL_warnhook = oldwarnhook;
5615         PL_diehook  = olddiehook;
5616         /* XXX note that this croak may fail as we've already blown away
5617          * the stack - eg any nested evals */
5618         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5619     }
5620     JMPENV_POP;
5621     PL_dowarn   = oldwarn;
5622     PL_warnhook = oldwarnhook;
5623     PL_diehook  = olddiehook;
5624     PL_curcop = &PL_compiling;
5625
5626     /* if we croaked, depending on how we croaked the eval scope
5627      * may or may not have already been popped */
5628     if (cxstack_ix > old_cxix) {
5629         assert(cxstack_ix == old_cxix + 1);
5630         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5631         delete_eval_scope();
5632     }
5633     if (ret)
5634         goto nope;
5635
5636     /* OP_STRINGIFY and constant folding are used to implement qq.
5637        Here the constant folding is an implementation detail that we
5638        want to hide.  If the stringify op is itself already marked
5639        folded, however, then it is actually a folded join.  */
5640     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5641     op_free(o);
5642     assert(sv);
5643     if (is_stringify)
5644         SvPADTMP_off(sv);
5645     else if (!SvIMMORTAL(sv)) {
5646         SvPADTMP_on(sv);
5647         SvREADONLY_on(sv);
5648     }
5649     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5650     if (!is_stringify) newop->op_folded = 1;
5651     return newop;
5652
5653  nope:
5654     return o;
5655 }
5656
5657 static OP *
5658 S_gen_constant_list(pTHX_ OP *o)
5659 {
5660     dVAR;
5661     OP *curop, *old_next;
5662     SV * const oldwarnhook = PL_warnhook;
5663     SV * const olddiehook  = PL_diehook;
5664     COP *old_curcop;
5665     U8 oldwarn = PL_dowarn;
5666     SV **svp;
5667     AV *av;
5668     I32 old_cxix;
5669     COP not_compiling;
5670     int ret = 0;
5671     dJMPENV;
5672     bool op_was_null;
5673
5674     list(o);
5675     if (PL_parser && PL_parser->error_count)
5676         return o;               /* Don't attempt to run with errors */
5677
5678     curop = LINKLIST(o);
5679     old_next = o->op_next;
5680     o->op_next = 0;
5681     op_was_null = o->op_type == OP_NULL;
5682     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5683         o->op_type = OP_CUSTOM;
5684     CALL_PEEP(curop);
5685     if (op_was_null)
5686         o->op_type = OP_NULL;
5687     S_prune_chain_head(&curop);
5688     PL_op = curop;
5689
5690     old_cxix = cxstack_ix;
5691     create_eval_scope(NULL, G_FAKINGEVAL);
5692
5693     old_curcop = PL_curcop;
5694     StructCopy(old_curcop, &not_compiling, COP);
5695     PL_curcop = &not_compiling;
5696     /* The above ensures that we run with all the correct hints of the
5697        current COP, but that IN_PERL_RUNTIME is true. */
5698     assert(IN_PERL_RUNTIME);
5699     PL_warnhook = PERL_WARNHOOK_FATAL;
5700     PL_diehook  = NULL;
5701     JMPENV_PUSH(ret);
5702
5703     /* Effective $^W=1.  */
5704     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5705         PL_dowarn |= G_WARN_ON;
5706
5707     switch (ret) {
5708     case 0:
5709 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5710         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5711 #endif
5712         Perl_pp_pushmark(aTHX);
5713         CALLRUNOPS(aTHX);
5714         PL_op = curop;
5715         assert (!(curop->op_flags & OPf_SPECIAL));
5716         assert(curop->op_type == OP_RANGE);
5717         Perl_pp_anonlist(aTHX);
5718         break;
5719     case 3:
5720         CLEAR_ERRSV();
5721         o->op_next = old_next;
5722         break;
5723     default:
5724         JMPENV_POP;
5725         PL_warnhook = oldwarnhook;
5726         PL_diehook = olddiehook;
5727         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5728             ret);
5729     }
5730
5731     JMPENV_POP;
5732     PL_dowarn = oldwarn;
5733     PL_warnhook = oldwarnhook;
5734     PL_diehook = olddiehook;
5735     PL_curcop = old_curcop;
5736
5737     if (cxstack_ix > old_cxix) {
5738         assert(cxstack_ix == old_cxix + 1);
5739         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5740         delete_eval_scope();
5741     }
5742     if (ret)
5743         return o;
5744
5745     OpTYPE_set(o, OP_RV2AV);
5746     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
5747     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
5748     o->op_opt = 0;              /* needs to be revisited in rpeep() */
5749     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5750
5751     /* replace subtree with an OP_CONST */
5752     curop = ((UNOP*)o)->op_first;
5753     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5754     op_free(curop);
5755
5756     if (AvFILLp(av) != -1)
5757         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5758         {
5759             SvPADTMP_on(*svp);
5760             SvREADONLY_on(*svp);
5761         }
5762     LINKLIST(o);
5763     return list(o);
5764 }
5765
5766 /*
5767 =head1 Optree Manipulation Functions
5768 */
5769
5770 /* List constructors */
5771
5772 /*
5773 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5774
5775 Append an item to the list of ops contained directly within a list-type
5776 op, returning the lengthened list.  C<first> is the list-type op,
5777 and C<last> is the op to append to the list.  C<optype> specifies the
5778 intended opcode for the list.  If C<first> is not already a list of the
5779 right type, it will be upgraded into one.  If either C<first> or C<last>
5780 is null, the other is returned unchanged.
5781
5782 =cut
5783 */
5784
5785 OP *
5786 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5787 {
5788     if (!first)
5789         return last;
5790
5791     if (!last)
5792         return first;
5793
5794     if (first->op_type != (unsigned)type
5795         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5796     {
5797         return newLISTOP(type, 0, first, last);
5798     }
5799
5800     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5801     first->op_flags |= OPf_KIDS;
5802     return first;
5803 }
5804
5805 /*
5806 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5807
5808 Concatenate the lists of ops contained directly within two list-type ops,
5809 returning the combined list.  C<first> and C<last> are the list-type ops
5810 to concatenate.  C<optype> specifies the intended opcode for the list.
5811 If either C<first> or C<last> is not already a list of the right type,
5812 it will be upgraded into one.  If either C<first> or C<last> is null,
5813 the other is returned unchanged.
5814
5815 =cut
5816 */
5817
5818 OP *
5819 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5820 {
5821     if (!first)
5822         return last;
5823
5824     if (!last)
5825         return first;
5826
5827     if (first->op_type != (unsigned)type)
5828         return op_prepend_elem(type, first, last);
5829
5830     if (last->op_type != (unsigned)type)
5831         return op_append_elem(type, first, last);
5832
5833     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5834     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5835     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5836     first->op_flags |= (last->op_flags & OPf_KIDS);
5837
5838     S_op_destroy(aTHX_ last);
5839
5840     return first;
5841 }
5842
5843 /*
5844 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5845
5846 Prepend an item to the list of ops contained directly within a list-type
5847 op, returning the lengthened list.  C<first> is the op to prepend to the
5848 list, and C<last> is the list-type op.  C<optype> specifies the intended
5849 opcode for the list.  If C<last> is not already a list of the right type,
5850 it will be upgraded into one.  If either C<first> or C<last> is null,
5851 the other is returned unchanged.
5852
5853 =cut
5854 */
5855
5856 OP *
5857 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5858 {
5859     if (!first)
5860         return last;
5861
5862     if (!last)
5863         return first;
5864
5865     if (last->op_type == (unsigned)type) {
5866         if (type == OP_LIST) {  /* already a PUSHMARK there */
5867             /* insert 'first' after pushmark */
5868             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5869             if (!(first->op_flags & OPf_PARENS))
5870                 last->op_flags &= ~OPf_PARENS;
5871         }
5872         else
5873             op_sibling_splice(last, NULL, 0, first);
5874         last->op_flags |= OPf_KIDS;
5875         return last;
5876     }
5877
5878     return newLISTOP(type, 0, first, last);
5879 }
5880
5881 /*
5882 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5883
5884 Converts C<o> into a list op if it is not one already, and then converts it
5885 into the specified C<type>, calling its check function, allocating a target if
5886 it needs one, and folding constants.
5887
5888 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5889 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5890 C<op_convert_list> to make it the right type.
5891
5892 =cut
5893 */
5894
5895 OP *
5896 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5897 {
5898     dVAR;
5899     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5900     if (!o || o->op_type != OP_LIST)
5901         o = force_list(o, 0);
5902     else
5903     {
5904         o->op_flags &= ~OPf_WANT;
5905         o->op_private &= ~OPpLVAL_INTRO;
5906     }
5907
5908     if (!(PL_opargs[type] & OA_MARK))
5909         op_null(cLISTOPo->op_first);
5910     else {
5911         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5912         if (kid2 && kid2->op_type == OP_COREARGS) {
5913             op_null(cLISTOPo->op_first);
5914             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5915         }
5916     }
5917
5918     if (type != OP_SPLIT)
5919         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5920          * ck_split() create a real PMOP and leave the op's type as listop
5921          * for now. Otherwise op_free() etc will crash.
5922          */
5923         OpTYPE_set(o, type);
5924
5925     o->op_flags |= flags;
5926     if (flags & OPf_FOLDED)
5927         o->op_folded = 1;
5928
5929     o = CHECKOP(type, o);
5930     if (o->op_type != (unsigned)type)
5931         return o;
5932
5933     return fold_constants(op_integerize(op_std_init(o)));
5934 }
5935
5936 /* Constructors */
5937
5938
5939 /*
5940 =head1 Optree construction
5941
5942 =for apidoc Am|OP *|newNULLLIST
5943
5944 Constructs, checks, and returns a new C<stub> op, which represents an
5945 empty list expression.
5946
5947 =cut
5948 */
5949
5950 OP *
5951 Perl_newNULLLIST(pTHX)
5952 {
5953     return newOP(OP_STUB, 0);
5954 }
5955
5956 /* promote o and any siblings to be a list if its not already; i.e.
5957  *
5958  *  o - A - B
5959  *
5960  * becomes
5961  *
5962  *  list
5963  *    |
5964  *  pushmark - o - A - B
5965  *
5966  * If nullit it true, the list op is nulled.
5967  */
5968
5969 static OP *
5970 S_force_list(pTHX_ OP *o, bool nullit)
5971 {
5972     if (!o || o->op_type != OP_LIST) {
5973         OP *rest = NULL;
5974         if (o) {
5975             /* manually detach any siblings then add them back later */
5976             rest = OpSIBLING(o);
5977             OpLASTSIB_set(o, NULL);
5978         }
5979         o = newLISTOP(OP_LIST, 0, o, NULL);
5980         if (rest)
5981             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5982     }
5983     if (nullit)
5984         op_null(o);
5985     return o;
5986 }
5987
5988 /*
5989 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
5990
5991 Constructs, checks, and returns an op of any list type.  C<type> is
5992 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5993 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5994 supply up to two ops to be direct children of the list op; they are
5995 consumed by this function and become part of the constructed op tree.
5996
5997 For most list operators, the check function expects all the kid ops to be
5998 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5999 appropriate.  What you want to do in that case is create an op of type
6000 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6001 See L</op_convert_list> for more information.
6002
6003
6004 =cut
6005 */
6006
6007 OP *
6008 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6009 {
6010     dVAR;
6011     LISTOP *listop;
6012
6013     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6014         || type == OP_CUSTOM);
6015
6016     NewOp(1101, listop, 1, LISTOP);
6017
6018     OpTYPE_set(listop, type);
6019     if (first || last)
6020         flags |= OPf_KIDS;
6021     listop->op_flags = (U8)flags;
6022
6023     if (!last && first)
6024         last = first;
6025     else if (!first && last)
6026         first = last;
6027     else if (first)
6028         OpMORESIB_set(first, last);
6029     listop->op_first = first;
6030     listop->op_last = last;
6031     if (type == OP_LIST) {
6032         OP* const pushop = newOP(OP_PUSHMARK, 0);
6033         OpMORESIB_set(pushop, first);
6034         listop->op_first = pushop;
6035         listop->op_flags |= OPf_KIDS;
6036         if (!last)
6037             listop->op_last = pushop;
6038     }
6039     if (listop->op_last)
6040         OpLASTSIB_set(listop->op_last, (OP*)listop);
6041
6042     return CHECKOP(type, listop);
6043 }
6044
6045 /*
6046 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6047
6048 Constructs, checks, and returns an op of any base type (any type that
6049 has no extra fields).  C<type> is the opcode.  C<flags> gives the
6050 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6051 of C<op_private>.
6052
6053 =cut
6054 */
6055
6056 OP *
6057 Perl_newOP(pTHX_ I32 type, I32 flags)
6058 {
6059     dVAR;
6060     OP *o;
6061
6062     if (type == -OP_ENTEREVAL) {
6063         type = OP_ENTEREVAL;
6064         flags |= OPpEVAL_BYTES<<8;
6065     }
6066
6067     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6068         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6069         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6070         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6071
6072     NewOp(1101, o, 1, OP);
6073     OpTYPE_set(o, type);
6074     o->op_flags = (U8)flags;
6075
6076     o->op_next = o;
6077     o->op_private = (U8)(0 | (flags >> 8));
6078     if (PL_opargs[type] & OA_RETSCALAR)
6079         scalar(o);
6080     if (PL_opargs[type] & OA_TARGET)
6081         o->op_targ = pad_alloc(type, SVs_PADTMP);
6082     return CHECKOP(type, o);
6083 }
6084
6085 /*
6086 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6087
6088 Constructs, checks, and returns an op of any unary type.  C<type> is
6089 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
6090 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6091 bits, the eight bits of C<op_private>, except that the bit with value 1
6092 is automatically set.  C<first> supplies an optional op to be the direct
6093 child of the unary op; it is consumed by this function and become part
6094 of the constructed op tree.
6095
6096 =cut
6097 */
6098
6099 OP *
6100 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6101 {
6102     dVAR;
6103     UNOP *unop;
6104
6105     if (type == -OP_ENTEREVAL) {
6106         type = OP_ENTEREVAL;
6107         flags |= OPpEVAL_BYTES<<8;
6108     }
6109
6110     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6111         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6112         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6113         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6114         || type == OP_SASSIGN
6115         || type == OP_ENTERTRY
6116         || type == OP_CUSTOM
6117         || type == OP_NULL );
6118
6119     if (!first)
6120         first = newOP(OP_STUB, 0);
6121     if (PL_opargs[type] & OA_MARK)
6122         first = force_list(first, 1);
6123
6124     NewOp(1101, unop, 1, UNOP);
6125     OpTYPE_set(unop, type);
6126     unop->op_first = first;
6127     unop->op_flags = (U8)(flags | OPf_KIDS);
6128     unop->op_private = (U8)(1 | (flags >> 8));
6129
6130     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6131         OpLASTSIB_set(first, (OP*)unop);
6132
6133     unop = (UNOP*) CHECKOP(type, unop);
6134     if (unop->op_next)
6135         return (OP*)unop;
6136
6137     return fold_constants(op_integerize(op_std_init((OP *) unop)));
6138 }
6139
6140 /*
6141 =for apidoc newUNOP_AUX
6142
6143 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6144 initialised to C<aux>
6145
6146 =cut
6147 */
6148
6149 OP *
6150 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6151 {
6152     dVAR;
6153     UNOP_AUX *unop;
6154
6155     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6156         || type == OP_CUSTOM);
6157
6158     NewOp(1101, unop, 1, UNOP_AUX);
6159     unop->op_type = (OPCODE)type;
6160     unop->op_ppaddr = PL_ppaddr[type];
6161     unop->op_first = first;
6162     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6163     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6164     unop->op_aux = aux;
6165
6166     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6167         OpLASTSIB_set(first, (OP*)unop);
6168
6169     unop = (UNOP_AUX*) CHECKOP(type, unop);
6170
6171     return op_std_init((OP *) unop);
6172 }
6173
6174 /*
6175 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6176
6177 Constructs, checks, and returns an op of method type with a method name
6178 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
6179 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6180 and, shifted up eight bits, the eight bits of C<op_private>, except that
6181 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
6182 op which evaluates method name; it is consumed by this function and
6183 become part of the constructed op tree.
6184 Supported optypes: C<OP_METHOD>.
6185
6186 =cut
6187 */
6188
6189 static OP*
6190 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6191     dVAR;
6192     METHOP *methop;
6193
6194     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6195         || type == OP_CUSTOM);
6196
6197     NewOp(1101, methop, 1, METHOP);
6198     if (dynamic_meth) {
6199         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6200         methop->op_flags = (U8)(flags | OPf_KIDS);
6201         methop->op_u.op_first = dynamic_meth;
6202         methop->op_private = (U8)(1 | (flags >> 8));
6203
6204         if (!OpHAS_SIBLING(dynamic_meth))
6205             OpLASTSIB_set(dynamic_meth, (OP*)methop);
6206     }
6207     else {
6208         assert(const_meth);
6209         methop->op_flags = (U8)(flags & ~OPf_KIDS);
6210         methop->op_u.op_meth_sv = const_meth;
6211         methop->op_private = (U8)(0 | (flags >> 8));
6212         methop->op_next = (OP*)methop;
6213     }
6214
6215 #ifdef USE_ITHREADS
6216     methop->op_rclass_targ = 0;
6217 #else
6218     methop->op_rclass_sv = NULL;
6219 #endif
6220
6221     OpTYPE_set(methop, type);
6222     return CHECKOP(type, methop);
6223 }
6224
6225 OP *
6226 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6227     PERL_ARGS_ASSERT_NEWMETHOP;
6228     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6229 }
6230
6231 /*
6232 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6233
6234 Constructs, checks, and returns an op of method type with a constant
6235 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
6236 C<op_flags>, and, shifted up eight bits, the eight bits of
6237 C<op_private>.  C<const_meth> supplies a constant method name;
6238 it must be a shared COW string.
6239 Supported optypes: C<OP_METHOD_NAMED>.
6240
6241 =cut
6242 */
6243
6244 OP *
6245 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6246     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6247     return newMETHOP_internal(type, flags, NULL, const_meth);
6248 }
6249
6250 /*
6251 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6252
6253 Constructs, checks, and returns an op of any binary type.  C<type>
6254 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
6255 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6256 the eight bits of C<op_private>, except that the bit with value 1 or
6257 2 is automatically set as required.  C<first> and C<last> supply up to
6258 two ops to be the direct children of the binary op; they are consumed
6259 by this function and become part of the constructed op tree.
6260
6261 =cut
6262 */
6263
6264 OP *
6265 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6266 {
6267     dVAR;
6268     BINOP *binop;
6269
6270     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6271         || type == OP_NULL || type == OP_CUSTOM);
6272
6273     NewOp(1101, binop, 1, BINOP);
6274
6275     if (!first)
6276         first = newOP(OP_NULL, 0);
6277
6278     OpTYPE_set(binop, type);
6279     binop->op_first = first;
6280     binop->op_flags = (U8)(flags | OPf_KIDS);
6281     if (!last) {
6282         last = first;
6283         binop->op_private = (U8)(1 | (flags >> 8));
6284     }
6285     else {
6286         binop->op_private = (U8)(2 | (flags >> 8));
6287         OpMORESIB_set(first, last);
6288     }
6289
6290     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6291         OpLASTSIB_set(last, (OP*)binop);
6292
6293     binop->op_last = OpSIBLING(binop->op_first);
6294     if (binop->op_last)
6295         OpLASTSIB_set(binop->op_last, (OP*)binop);
6296
6297     binop = (BINOP*)CHECKOP(type, binop);
6298     if (binop->op_next || binop->op_type != (OPCODE)type)
6299         return (OP*)binop;
6300
6301     return fold_constants(op_integerize(op_std_init((OP *)binop)));
6302 }
6303
6304 /* Helper function for S_pmtrans(): comparison function to sort an array
6305  * of codepoint range pairs. Sorts by start point, or if equal, by end
6306  * point */
6307
6308 static int uvcompare(const void *a, const void *b)
6309     __attribute__nonnull__(1)
6310     __attribute__nonnull__(2)
6311     __attribute__pure__;
6312 static int uvcompare(const void *a, const void *b)
6313 {
6314     if (*((const UV *)a) < (*(const UV *)b))
6315         return -1;
6316     if (*((const UV *)a) > (*(const UV *)b))
6317         return 1;
6318     if (*((const UV *)a+1) < (*(const UV *)b+1))
6319         return -1;
6320     if (*((const UV *)a+1) > (*(const UV *)b+1))
6321         return 1;
6322     return 0;
6323 }
6324
6325 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6326  * containing the search and replacement strings, assemble into
6327  * a translation table attached as o->op_pv.
6328  * Free expr and repl.
6329  * It expects the toker to have already set the
6330  *   OPpTRANS_COMPLEMENT
6331  *   OPpTRANS_SQUASH
6332  *   OPpTRANS_DELETE
6333  * flags as appropriate; this function may add
6334  *   OPpTRANS_FROM_UTF
6335  *   OPpTRANS_TO_UTF
6336  *   OPpTRANS_IDENTICAL
6337  *   OPpTRANS_GROWS
6338  * flags
6339  */
6340
6341 static OP *
6342 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6343 {
6344     SV * const tstr = ((SVOP*)expr)->op_sv;
6345     SV * const rstr = ((SVOP*)repl)->op_sv;
6346     STRLEN tlen;
6347     STRLEN rlen;
6348     const U8 *t = (U8*)SvPV_const(tstr, tlen);
6349     const U8 *r = (U8*)SvPV_const(rstr, rlen);
6350     Size_t i, j;
6351     bool grows = FALSE;
6352     OPtrans_map *tbl;
6353     SSize_t struct_size; /* malloced size of table struct */
6354
6355     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6356     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6357     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6358     SV* swash;
6359
6360     PERL_ARGS_ASSERT_PMTRANS;
6361
6362     PL_hints |= HINT_BLOCK_SCOPE;
6363
6364     if (SvUTF8(tstr))
6365         o->op_private |= OPpTRANS_FROM_UTF;
6366
6367     if (SvUTF8(rstr))
6368         o->op_private |= OPpTRANS_TO_UTF;
6369
6370     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6371
6372         /* for utf8 translations, op_sv will be set to point to a swash
6373          * containing codepoint ranges. This is done by first assembling
6374          * a textual representation of the ranges in listsv then compiling
6375          * it using swash_init(). For more details of the textual format,
6376          * see L<perlunicode.pod/"User-Defined Character Properties"> .
6377          */
6378
6379         SV* const listsv = newSVpvs("# comment\n");
6380         SV* transv = NULL;
6381         const U8* tend = t + tlen;
6382         const U8* rend = r + rlen;
6383         STRLEN ulen;
6384         UV tfirst = 1;
6385         UV tlast = 0;
6386         IV tdiff;
6387         STRLEN tcount = 0;
6388         UV rfirst = 1;
6389         UV rlast = 0;
6390         IV rdiff;
6391         STRLEN rcount = 0;
6392         IV diff;
6393         I32 none = 0;
6394         U32 max = 0;
6395         I32 bits;
6396         I32 havefinal = 0;
6397         U32 final = 0;
6398         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
6399         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
6400         U8* tsave = NULL;
6401         U8* rsave = NULL;
6402         const U32 flags = UTF8_ALLOW_DEFAULT;
6403
6404         if (!from_utf) {
6405             STRLEN len = tlen;
6406             t = tsave = bytes_to_utf8(t, &len);
6407             tend = t + len;
6408         }
6409         if (!to_utf && rlen) {
6410             STRLEN len = rlen;
6411             r = rsave = bytes_to_utf8(r, &len);
6412             rend = r + len;
6413         }
6414
6415 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6416  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6417  * odd.  */
6418
6419         if (complement) {
6420             /* utf8 and /c:
6421              * replace t/tlen/tend with a version that has the ranges
6422              * complemented
6423              */
6424             U8 tmpbuf[UTF8_MAXBYTES+1];
6425             UV *cp;
6426             UV nextmin = 0;
6427             Newx(cp, 2*tlen, UV);
6428             i = 0;
6429             transv = newSVpvs("");
6430
6431             /* convert search string into array of (start,end) range
6432              * codepoint pairs stored in cp[]. Most "ranges" will start
6433              * and end at the same char */
6434             while (t < tend) {
6435                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6436                 t += ulen;
6437                 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6438                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6439                     t++;
6440                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6441                     t += ulen;
6442                 }
6443                 else {
6444                  cp[2*i+1] = cp[2*i];
6445                 }
6446                 i++;
6447             }
6448
6449             /* sort the ranges */
6450             qsort(cp, i, 2*sizeof(UV), uvcompare);
6451
6452             /* Create a utf8 string containing the complement of the
6453              * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6454              * then transv will contain the equivalent of:
6455              * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
6456              *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6457              *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6458              * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6459              * end cp.
6460              */
6461             for (j = 0; j < i; j++) {
6462                 UV  val = cp[2*j];
6463                 diff = val - nextmin;
6464                 if (diff > 0) {
6465                     t = uvchr_to_utf8(tmpbuf,nextmin);
6466                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6467                     if (diff > 1) {
6468                         U8  range_mark = ILLEGAL_UTF8_BYTE;
6469                         t = uvchr_to_utf8(tmpbuf, val - 1);
6470                         sv_catpvn(transv, (char *)&range_mark, 1);
6471                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6472                     }
6473                 }
6474                 val = cp[2*j+1];
6475                 if (val >= nextmin)
6476                     nextmin = val + 1;
6477             }
6478
6479             t = uvchr_to_utf8(tmpbuf,nextmin);
6480             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6481             {
6482                 U8 range_mark = ILLEGAL_UTF8_BYTE;
6483                 sv_catpvn(transv, (char *)&range_mark, 1);
6484             }
6485             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6486             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6487             t = (const U8*)SvPVX_const(transv);
6488             tlen = SvCUR(transv);
6489             tend = t + tlen;
6490             Safefree(cp);
6491         }
6492         else if (!rlen && !del) {
6493             r = t; rlen = tlen; rend = tend;
6494         }
6495
6496         if (!squash) {
6497                 if ((!rlen && !del) || t == r ||
6498                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6499                 {
6500                     o->op_private |= OPpTRANS_IDENTICAL;
6501                 }
6502         }
6503
6504         /* extract char ranges from t and r and append them to listsv */
6505
6506         while (t < tend || tfirst <= tlast) {
6507             /* see if we need more "t" chars */
6508             if (tfirst > tlast) {
6509                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6510                 t += ulen;
6511                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
6512                     t++;
6513                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6514                     t += ulen;
6515                 }
6516                 else
6517                     tlast = tfirst;
6518             }
6519
6520             /* now see if we need more "r" chars */
6521             if (rfirst > rlast) {
6522                 if (r < rend) {
6523                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6524                     r += ulen;
6525                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
6526                         r++;
6527                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6528                         r += ulen;
6529                     }
6530                     else
6531                         rlast = rfirst;
6532                 }
6533                 else {
6534                     if (!havefinal++)
6535                         final = rlast;
6536                     rfirst = rlast = 0xffffffff;
6537                 }
6538             }
6539
6540             /* now see which range will peter out first, if either. */
6541             tdiff = tlast - tfirst;
6542             rdiff = rlast - rfirst;
6543             tcount += tdiff + 1;
6544             rcount += rdiff + 1;
6545
6546             if (tdiff <= rdiff)
6547                 diff = tdiff;
6548             else
6549                 diff = rdiff;
6550
6551             if (rfirst == 0xffffffff) {
6552                 diff = tdiff;   /* oops, pretend rdiff is infinite */
6553                 if (diff > 0)
6554                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6555                                    (long)tfirst, (long)tlast);
6556                 else
6557                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6558             }
6559             else {
6560                 if (diff > 0)
6561                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6562                                    (long)tfirst, (long)(tfirst + diff),
6563                                    (long)rfirst);
6564                 else
6565                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6566                                    (long)tfirst, (long)rfirst);
6567
6568                 if (rfirst + diff > max)
6569                     max = rfirst + diff;
6570                 if (!grows)
6571                     grows = (tfirst < rfirst &&
6572                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6573                 rfirst += diff + 1;
6574             }
6575             tfirst += diff + 1;
6576         }
6577
6578         /* compile listsv into a swash and attach to o */
6579
6580         none = ++max;
6581         if (del)
6582             ++max;
6583
6584         if (max > 0xffff)
6585             bits = 32;
6586         else if (max > 0xff)
6587             bits = 16;
6588         else
6589             bits = 8;
6590
6591         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6592 #ifdef USE_ITHREADS
6593         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6594         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6595         PAD_SETSV(cPADOPo->op_padix, swash);
6596         SvPADTMP_on(swash);
6597         SvREADONLY_on(swash);
6598 #else
6599         cSVOPo->op_sv = swash;
6600 #endif
6601         SvREFCNT_dec(listsv);
6602         SvREFCNT_dec(transv);
6603
6604         if (!del && havefinal && rlen)
6605             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6606                            newSVuv((UV)final), 0);
6607
6608         Safefree(tsave);
6609         Safefree(rsave);
6610
6611         tlen = tcount;
6612         rlen = rcount;
6613         if (r < rend)
6614             rlen++;
6615         else if (rlast == 0xffffffff)
6616             rlen = 0;
6617
6618         goto warnins;
6619     }
6620
6621     /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6622      * table. Entries with the value -1 indicate chars not to be
6623      * translated, while -2 indicates a search char without a
6624      * corresponding replacement char under /d.
6625      *
6626      * Normally, the table has 256 slots. However, in the presence of
6627      * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6628      * added, and if there are enough replacement chars to start pairing
6629      * with the \x{100},... search chars, then a larger (> 256) table
6630      * is allocated.
6631      *
6632      * In addition, regardless of whether under /c, an extra slot at the
6633      * end is used to store the final repeating char, or -3 under an empty
6634      * replacement list, or -2 under /d; which makes the runtime code
6635      * easier.
6636      *
6637      * The toker will have already expanded char ranges in t and r.
6638      */
6639
6640     /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6641      * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6642      * The OPtrans_map struct already contains one slot; hence the -1.
6643      */
6644     struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6645     tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6646     tbl->size = 256;
6647     cPVOPo->op_pv = (char*)tbl;
6648
6649     if (complement) {
6650         Size_t excess;
6651
6652         /* in this branch, j is a count of 'consumed' (i.e. paired off
6653          * with a search char) replacement chars (so j <= rlen always)
6654          */
6655         for (i = 0; i < tlen; i++)
6656             tbl->map[t[i]] = -1;
6657
6658         for (i = 0, j = 0; i < 256; i++) {
6659             if (!tbl->map[i]) {
6660                 if (j == rlen) {
6661                     if (del)
6662                         tbl->map[i] = -2;
6663                     else if (rlen)
6664                         tbl->map[i] = r[j-1];
6665                     else
6666                         tbl->map[i] = (short)i;
6667                 }
6668                 else {
6669                     tbl->map[i] = r[j++];
6670                 }
6671                 if (   tbl->map[i] >= 0
6672                     &&  UVCHR_IS_INVARIANT((UV)i)
6673                     && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6674                 )
6675                     grows = TRUE;
6676             }
6677         }
6678
6679         ASSUME(j <= rlen);
6680         excess = rlen - j;
6681
6682         if (excess) {
6683             /* More replacement chars than search chars:
6684              * store excess replacement chars at end of main table.
6685              */
6686
6687             struct_size += excess;
6688             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6689                         struct_size + excess * sizeof(short));
6690             tbl->size += excess;
6691             cPVOPo->op_pv = (char*)tbl;
6692
6693             for (i = 0; i < excess; i++)
6694                 tbl->map[i + 256] = r[j+i];
6695         }
6696         else {
6697             /* no more replacement chars than search chars */
6698             if (!rlen && !del && !squash)
6699                 o->op_private |= OPpTRANS_IDENTICAL;
6700         }
6701
6702         tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6703     }
6704     else {
6705         if (!rlen && !del) {
6706             r = t; rlen = tlen;
6707             if (!squash)
6708                 o->op_private |= OPpTRANS_IDENTICAL;
6709         }
6710         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6711             o->op_private |= OPpTRANS_IDENTICAL;
6712         }
6713
6714         for (i = 0; i < 256; i++)
6715             tbl->map[i] = -1;
6716         for (i = 0, j = 0; i < tlen; i++,j++) {
6717             if (j >= rlen) {
6718                 if (del) {
6719                     if (tbl->map[t[i]] == -1)
6720                         tbl->map[t[i]] = -2;
6721                     continue;
6722                 }
6723                 --j;
6724             }
6725             if (tbl->map[t[i]] == -1) {
6726                 if (     UVCHR_IS_INVARIANT(t[i])
6727                     && ! UVCHR_IS_INVARIANT(r[j]))
6728                     grows = TRUE;
6729                 tbl->map[t[i]] = r[j];
6730             }
6731         }
6732         tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6733     }
6734
6735     /* both non-utf8 and utf8 code paths end up here */
6736
6737   warnins:
6738     if(del && rlen == tlen) {
6739         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6740     } else if(rlen > tlen && !complement) {
6741         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6742     }
6743
6744     if (grows)
6745         o->op_private |= OPpTRANS_GROWS;
6746     op_free(expr);
6747     op_free(repl);
6748
6749     return o;
6750 }
6751
6752
6753 /*
6754 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6755
6756 Constructs, checks, and returns an op of any pattern matching type.
6757 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
6758 and, shifted up eight bits, the eight bits of C<op_private>.
6759
6760 =cut
6761 */
6762
6763 OP *
6764 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6765 {
6766     dVAR;
6767     PMOP *pmop;
6768
6769     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6770         || type == OP_CUSTOM);
6771
6772     NewOp(1101, pmop, 1, PMOP);
6773     OpTYPE_set(pmop, type);
6774     pmop->op_flags = (U8)flags;
6775     pmop->op_private = (U8)(0 | (flags >> 8));
6776     if (PL_opargs[type] & OA_RETSCALAR)
6777         scalar((OP *)pmop);
6778
6779     if (PL_hints & HINT_RE_TAINT)
6780         pmop->op_pmflags |= PMf_RETAINT;
6781 #ifdef USE_LOCALE_CTYPE
6782     if (IN_LC_COMPILETIME(LC_CTYPE)) {
6783         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6784     }
6785     else
6786 #endif
6787          if (IN_UNI_8_BIT) {
6788         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6789     }
6790     if (PL_hints & HINT_RE_FLAGS) {
6791         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6792          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6793         );
6794         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6795         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6796          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6797         );
6798         if (reflags && SvOK(reflags)) {
6799             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6800         }
6801     }
6802
6803
6804 #ifdef USE_ITHREADS
6805     assert(SvPOK(PL_regex_pad[0]));
6806     if (SvCUR(PL_regex_pad[0])) {
6807         /* Pop off the "packed" IV from the end.  */
6808         SV *const repointer_list = PL_regex_pad[0];
6809         const char *p = SvEND(repointer_list) - sizeof(IV);
6810         const IV offset = *((IV*)p);
6811
6812         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6813
6814         SvEND_set(repointer_list, p);
6815
6816         pmop->op_pmoffset = offset;
6817         /* This slot should be free, so assert this:  */
6818         assert(PL_regex_pad[offset] == &PL_sv_undef);
6819     } else {
6820         SV * const repointer = &PL_sv_undef;
6821         av_push(PL_regex_padav, repointer);
6822         pmop->op_pmoffset = av_tindex(PL_regex_padav);
6823         PL_regex_pad = AvARRAY(PL_regex_padav);
6824     }
6825 #endif
6826
6827     return CHECKOP(type, pmop);
6828 }
6829
6830 static void
6831 S_set_haseval(pTHX)
6832 {
6833     PADOFFSET i = 1;
6834     PL_cv_has_eval = 1;
6835     /* Any pad names in scope are potentially lvalues.  */
6836     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6837         PADNAME *pn = PAD_COMPNAME_SV(i);
6838         if (!pn || !PadnameLEN(pn))
6839             continue;
6840         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6841             S_mark_padname_lvalue(aTHX_ pn);
6842     }
6843 }
6844
6845 /* Given some sort of match op o, and an expression expr containing a
6846  * pattern, either compile expr into a regex and attach it to o (if it's
6847  * constant), or convert expr into a runtime regcomp op sequence (if it's
6848  * not)
6849  *
6850  * Flags currently has 2 bits of meaning:
6851  * 1: isreg indicates that the pattern is part of a regex construct, eg
6852  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6853  * split "pattern", which aren't. In the former case, expr will be a list
6854  * if the pattern contains more than one term (eg /a$b/).
6855  * 2: The pattern is for a split.
6856  *
6857  * When the pattern has been compiled within a new anon CV (for
6858  * qr/(?{...})/ ), then floor indicates the savestack level just before
6859  * the new sub was created
6860  */
6861
6862 OP *
6863 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6864 {
6865     PMOP *pm;
6866     LOGOP *rcop;
6867     I32 repl_has_vars = 0;
6868     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6869     bool is_compiletime;
6870     bool has_code;
6871     bool isreg    = cBOOL(flags & 1);
6872     bool is_split = cBOOL(flags & 2);
6873
6874     PERL_ARGS_ASSERT_PMRUNTIME;
6875
6876     if (is_trans) {
6877         return pmtrans(o, expr, repl);
6878     }
6879
6880     /* find whether we have any runtime or code elements;
6881      * at the same time, temporarily set the op_next of each DO block;
6882      * then when we LINKLIST, this will cause the DO blocks to be excluded
6883      * from the op_next chain (and from having LINKLIST recursively
6884      * applied to them). We fix up the DOs specially later */
6885
6886     is_compiletime = 1;
6887     has_code = 0;
6888     if (expr->op_type == OP_LIST) {
6889         OP *o;
6890         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6891             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6892                 has_code = 1;
6893                 assert(!o->op_next);
6894                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6895                     assert(PL_parser && PL_parser->error_count);
6896                     /* This can happen with qr/ (?{(^{})/.  Just fake up
6897                        the op we were expecting to see, to avoid crashing
6898                        elsewhere.  */
6899                     op_sibling_splice(expr, o, 0,
6900                                       newSVOP(OP_CONST, 0, &PL_sv_no));
6901                 }
6902                 o->op_next = OpSIBLING(o);
6903             }
6904             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6905                 is_compiletime = 0;
6906         }
6907     }
6908     else if (expr->op_type != OP_CONST)
6909         is_compiletime = 0;
6910
6911     LINKLIST(expr);
6912
6913     /* fix up DO blocks; treat each one as a separate little sub;
6914      * also, mark any arrays as LIST/REF */
6915
6916     if (expr->op_type == OP_LIST) {
6917         OP *o;
6918         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6919
6920             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6921                 assert( !(o->op_flags  & OPf_WANT));
6922                 /* push the array rather than its contents. The regex
6923                  * engine will retrieve and join the elements later */
6924                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6925                 continue;
6926             }
6927
6928             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6929                 continue;
6930             o->op_next = NULL; /* undo temporary hack from above */
6931             scalar(o);
6932             LINKLIST(o);
6933             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6934                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
6935                 /* skip ENTER */
6936                 assert(leaveop->op_first->op_type == OP_ENTER);
6937                 assert(OpHAS_SIBLING(leaveop->op_first));
6938                 o->op_next = OpSIBLING(leaveop->op_first);
6939                 /* skip leave */
6940                 assert(leaveop->op_flags & OPf_KIDS);
6941                 assert(leaveop->op_last->op_next == (OP*)leaveop);
6942                 leaveop->op_next = NULL; /* stop on last op */
6943                 op_null((OP*)leaveop);
6944             }
6945             else {
6946                 /* skip SCOPE */
6947                 OP *scope = cLISTOPo->op_first;
6948                 assert(scope->op_type == OP_SCOPE);
6949                 assert(scope->op_flags & OPf_KIDS);
6950                 scope->op_next = NULL; /* stop on last op */
6951                 op_null(scope);
6952             }
6953
6954             /* XXX optimize_optree() must be called on o before
6955              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
6956              * currently cope with a peephole-optimised optree.
6957              * Calling optimize_optree() here ensures that condition
6958              * is met, but may mean optimize_optree() is applied
6959              * to the same optree later (where hopefully it won't do any
6960              * harm as it can't convert an op to multiconcat if it's
6961              * already been converted */
6962             optimize_optree(o);
6963
6964             /* have to peep the DOs individually as we've removed it from
6965              * the op_next chain */
6966             CALL_PEEP(o);
6967             S_prune_chain_head(&(o->op_next));
6968             if (is_compiletime)
6969                 /* runtime finalizes as part of finalizing whole tree */
6970                 finalize_optree(o);
6971         }
6972     }
6973     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
6974         assert( !(expr->op_flags  & OPf_WANT));
6975         /* push the array rather than its contents. The regex
6976          * engine will retrieve and join the elements later */
6977         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
6978     }
6979
6980     PL_hints |= HINT_BLOCK_SCOPE;
6981     pm = (PMOP*)o;
6982     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
6983
6984     if (is_compiletime) {
6985         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
6986         regexp_engine const *eng = current_re_engine();
6987
6988         if (is_split) {
6989             /* make engine handle split ' ' specially */
6990             pm->op_pmflags |= PMf_SPLIT;
6991             rx_flags |= RXf_SPLIT;
6992         }
6993
6994         /* Skip compiling if parser found an error for this pattern */
6995         if (pm->op_pmflags & PMf_HAS_ERROR) {
6996             return o;
6997         }
6998
6999         if (!has_code || !eng->op_comp) {
7000             /* compile-time simple constant pattern */
7001
7002             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7003                 /* whoops! we guessed that a qr// had a code block, but we
7004                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7005                  * that isn't required now. Note that we have to be pretty
7006                  * confident that nothing used that CV's pad while the
7007                  * regex was parsed, except maybe op targets for \Q etc.
7008                  * If there were any op targets, though, they should have
7009                  * been stolen by constant folding.
7010                  */
7011 #ifdef DEBUGGING
7012                 SSize_t i = 0;
7013                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7014                 while (++i <= AvFILLp(PL_comppad)) {
7015 #  ifdef USE_PAD_RESET
7016                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7017                      * folded constant with a fresh padtmp */
7018                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7019 #  else
7020                     assert(!PL_curpad[i]);
7021 #  endif
7022                 }
7023 #endif
7024                 /* But we know that one op is using this CV's slab. */
7025                 cv_forget_slab(PL_compcv);
7026                 LEAVE_SCOPE(floor);
7027                 pm->op_pmflags &= ~PMf_HAS_CV;
7028             }
7029
7030             PM_SETRE(pm,
7031                 eng->op_comp
7032                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7033                                         rx_flags, pm->op_pmflags)
7034                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7035                                         rx_flags, pm->op_pmflags)
7036             );
7037             op_free(expr);
7038         }
7039         else {
7040             /* compile-time pattern that includes literal code blocks */
7041             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7042                         rx_flags,
7043                         (pm->op_pmflags |
7044                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7045                     );
7046             PM_SETRE(pm, re);
7047             if (pm->op_pmflags & PMf_HAS_CV) {
7048                 CV *cv;
7049                 /* this QR op (and the anon sub we embed it in) is never
7050                  * actually executed. It's just a placeholder where we can
7051                  * squirrel away expr in op_code_list without the peephole
7052                  * optimiser etc processing it for a second time */
7053                 OP *qr = newPMOP(OP_QR, 0);
7054                 ((PMOP*)qr)->op_code_list = expr;
7055
7056                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7057                 SvREFCNT_inc_simple_void(PL_compcv);
7058                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7059                 ReANY(re)->qr_anoncv = cv;
7060
7061                 /* attach the anon CV to the pad so that
7062                  * pad_fixup_inner_anons() can find it */
7063                 (void)pad_add_anon(cv, o->op_type);
7064                 SvREFCNT_inc_simple_void(cv);
7065             }
7066             else {
7067                 pm->op_code_list = expr;
7068             }
7069         }
7070     }
7071     else {
7072         /* runtime pattern: build chain of regcomp etc ops */
7073         bool reglist;
7074         PADOFFSET cv_targ = 0;
7075
7076         reglist = isreg && expr->op_type == OP_LIST;
7077         if (reglist)
7078             op_null(expr);
7079
7080         if (has_code) {
7081             pm->op_code_list = expr;
7082             /* don't free op_code_list; its ops are embedded elsewhere too */
7083             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7084         }
7085
7086         if (is_split)
7087             /* make engine handle split ' ' specially */
7088             pm->op_pmflags |= PMf_SPLIT;
7089
7090         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7091          * to allow its op_next to be pointed past the regcomp and
7092          * preceding stacking ops;
7093          * OP_REGCRESET is there to reset taint before executing the
7094          * stacking ops */
7095         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7096             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7097
7098         if (pm->op_pmflags & PMf_HAS_CV) {
7099             /* we have a runtime qr with literal code. This means
7100              * that the qr// has been wrapped in a new CV, which
7101              * means that runtime consts, vars etc will have been compiled
7102              * against a new pad. So... we need to execute those ops
7103              * within the environment of the new CV. So wrap them in a call
7104              * to a new anon sub. i.e. for
7105              *
7106              *     qr/a$b(?{...})/,
7107              *
7108              * we build an anon sub that looks like
7109              *
7110              *     sub { "a", $b, '(?{...})' }
7111              *
7112              * and call it, passing the returned list to regcomp.
7113              * Or to put it another way, the list of ops that get executed
7114              * are:
7115              *
7116              *     normal              PMf_HAS_CV
7117              *     ------              -------------------
7118              *                         pushmark (for regcomp)
7119              *                         pushmark (for entersub)
7120              *                         anoncode
7121              *                         srefgen
7122              *                         entersub
7123              *     regcreset                  regcreset
7124              *     pushmark                   pushmark
7125              *     const("a")                 const("a")
7126              *     gvsv(b)                    gvsv(b)
7127              *     const("(?{...})")          const("(?{...})")
7128              *                                leavesub
7129              *     regcomp             regcomp
7130              */
7131
7132             SvREFCNT_inc_simple_void(PL_compcv);
7133             CvLVALUE_on(PL_compcv);
7134             /* these lines are just an unrolled newANONATTRSUB */
7135             expr = newSVOP(OP_ANONCODE, 0,
7136                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7137             cv_targ = expr->op_targ;
7138             expr = newUNOP(OP_REFGEN, 0, expr);
7139
7140             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7141         }
7142
7143         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7144         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7145                            | (reglist ? OPf_STACKED : 0);
7146         rcop->op_targ = cv_targ;
7147
7148         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7149         if (PL_hints & HINT_RE_EVAL)
7150             S_set_haseval(aTHX);
7151
7152         /* establish postfix order */
7153         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7154             LINKLIST(expr);
7155             rcop->op_next = expr;
7156             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7157         }
7158         else {
7159             rcop->op_next = LINKLIST(expr);
7160             expr->op_next = (OP*)rcop;
7161         }
7162
7163         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7164     }
7165
7166     if (repl) {
7167         OP *curop = repl;
7168         bool konst;
7169         /* If we are looking at s//.../e with a single statement, get past
7170            the implicit do{}. */
7171         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7172              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7173              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7174          {
7175             OP *sib;
7176             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7177             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7178              && !OpHAS_SIBLING(sib))
7179                 curop = sib;
7180         }
7181         if (curop->op_type == OP_CONST)
7182             konst = TRUE;
7183         else if (( (curop->op_type == OP_RV2SV ||
7184                     curop->op_type == OP_RV2AV ||
7185                     curop->op_type == OP_RV2HV ||
7186                     curop->op_type == OP_RV2GV)
7187                    && cUNOPx(curop)->op_first
7188                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7189                 || curop->op_type == OP_PADSV
7190                 || curop->op_type == OP_PADAV
7191                 || curop->op_type == OP_PADHV
7192                 || curop->op_type == OP_PADANY) {
7193             repl_has_vars = 1;
7194             konst = TRUE;
7195         }
7196         else konst = FALSE;
7197         if (konst
7198             && !(repl_has_vars
7199                  && (!PM_GETRE(pm)
7200                      || !RX_PRELEN(PM_GETRE(pm))
7201                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7202         {
7203             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
7204             op_prepend_elem(o->op_type, scalar(repl), o);
7205         }
7206         else {
7207             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7208             rcop->op_private = 1;
7209
7210             /* establish postfix order */
7211             rcop->op_next = LINKLIST(repl);
7212             repl->op_next = (OP*)rcop;
7213
7214             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7215             assert(!(pm->op_pmflags & PMf_ONCE));
7216             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7217             rcop->op_next = 0;
7218         }
7219     }
7220
7221     return (OP*)pm;
7222 }
7223
7224 /*
7225 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7226
7227 Constructs, checks, and returns an op of any type that involves an
7228 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7229 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7230 takes ownership of one reference to it.
7231
7232 =cut
7233 */
7234
7235 OP *
7236 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7237 {
7238     dVAR;
7239     SVOP *svop;
7240
7241     PERL_ARGS_ASSERT_NEWSVOP;
7242
7243     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7244         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7245         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7246         || type == OP_CUSTOM);
7247
7248     NewOp(1101, svop, 1, SVOP);
7249     OpTYPE_set(svop, type);
7250     svop->op_sv = sv;
7251     svop->op_next = (OP*)svop;
7252     svop->op_flags = (U8)flags;
7253     svop->op_private = (U8)(0 | (flags >> 8));
7254     if (PL_opargs[type] & OA_RETSCALAR)
7255         scalar((OP*)svop);
7256     if (PL_opargs[type] & OA_TARGET)
7257         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7258     return CHECKOP(type, svop);
7259 }
7260
7261 /*
7262 =for apidoc Am|OP *|newDEFSVOP|
7263
7264 Constructs and returns an op to access C<$_>.
7265
7266 =cut
7267 */
7268
7269 OP *
7270 Perl_newDEFSVOP(pTHX)
7271 {
7272         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7273 }
7274
7275 #ifdef USE_ITHREADS
7276
7277 /*
7278 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7279
7280 Constructs, checks, and returns an op of any type that involves a
7281 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7282 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7283 is populated with C<sv>; this function takes ownership of one reference
7284 to it.
7285
7286 This function only exists if Perl has been compiled to use ithreads.
7287
7288 =cut
7289 */
7290
7291 OP *
7292 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7293 {
7294     dVAR;
7295     PADOP *padop;
7296
7297     PERL_ARGS_ASSERT_NEWPADOP;
7298
7299     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7300         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7301         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7302         || type == OP_CUSTOM);
7303
7304     NewOp(1101, padop, 1, PADOP);
7305     OpTYPE_set(padop, type);
7306     padop->op_padix =
7307         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7308     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7309     PAD_SETSV(padop->op_padix, sv);
7310     assert(sv);
7311     padop->op_next = (OP*)padop;
7312     padop->op_flags = (U8)flags;
7313     if (PL_opargs[type] & OA_RETSCALAR)
7314         scalar((OP*)padop);
7315     if (PL_opargs[type] & OA_TARGET)
7316         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7317     return CHECKOP(type, padop);
7318 }
7319
7320 #endif /* USE_ITHREADS */
7321
7322 /*
7323 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7324
7325 Constructs, checks, and returns an op of any type that involves an
7326 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7327 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7328 reference; calling this function does not transfer ownership of any
7329 reference to it.
7330
7331 =cut
7332 */
7333
7334 OP *
7335 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7336 {
7337     PERL_ARGS_ASSERT_NEWGVOP;
7338
7339 #ifdef USE_ITHREADS
7340     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7341 #else
7342     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7343 #endif
7344 }
7345
7346 /*
7347 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7348
7349 Constructs, checks, and returns an op of any type that involves an
7350 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7351 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7352 Depending on the op type, the memory referenced by C<pv> may be freed
7353 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7354 have been allocated using C<PerlMemShared_malloc>.
7355
7356 =cut
7357 */
7358
7359 OP *
7360 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7361 {
7362     dVAR;
7363     const bool utf8 = cBOOL(flags & SVf_UTF8);
7364     PVOP *pvop;
7365
7366     flags &= ~SVf_UTF8;
7367
7368     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7369         || type == OP_RUNCV || type == OP_CUSTOM
7370         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7371
7372     NewOp(1101, pvop, 1, PVOP);
7373     OpTYPE_set(pvop, type);
7374     pvop->op_pv = pv;
7375     pvop->op_next = (OP*)pvop;
7376     pvop->op_flags = (U8)flags;
7377     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7378     if (PL_opargs[type] & OA_RETSCALAR)
7379         scalar((OP*)pvop);
7380     if (PL_opargs[type] & OA_TARGET)
7381         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7382     return CHECKOP(type, pvop);
7383 }
7384
7385 void
7386 Perl_package(pTHX_ OP *o)
7387 {
7388     SV *const sv = cSVOPo->op_sv;
7389
7390     PERL_ARGS_ASSERT_PACKAGE;
7391
7392     SAVEGENERICSV(PL_curstash);
7393     save_item(PL_curstname);
7394
7395     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7396
7397     sv_setsv(PL_curstname, sv);
7398
7399     PL_hints |= HINT_BLOCK_SCOPE;
7400     PL_parser->copline = NOLINE;
7401
7402     op_free(o);
7403 }
7404
7405 void
7406 Perl_package_version( pTHX_ OP *v )
7407 {
7408     U32 savehints = PL_hints;
7409     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7410     PL_hints &= ~HINT_STRICT_VARS;
7411     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7412     PL_hints = savehints;
7413     op_free(v);
7414 }
7415
7416 void
7417 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7418 {
7419     OP *pack;
7420     OP *imop;
7421     OP *veop;
7422     SV *use_version = NULL;
7423
7424     PERL_ARGS_ASSERT_UTILIZE;
7425
7426     if (idop->op_type != OP_CONST)
7427         Perl_croak(aTHX_ "Module name must be constant");
7428
7429     veop = NULL;
7430
7431     if (version) {
7432         SV * const vesv = ((SVOP*)version)->op_sv;
7433
7434         if (!arg && !SvNIOKp(vesv)) {
7435             arg = version;
7436         }
7437         else {
7438             OP *pack;
7439             SV *meth;
7440
7441             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7442                 Perl_croak(aTHX_ "Version number must be a constant number");
7443
7444             /* Make copy of idop so we don't free it twice */
7445             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7446
7447             /* Fake up a method call to VERSION */
7448             meth = newSVpvs_share("VERSION");
7449             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7450                             op_append_elem(OP_LIST,
7451                                         op_prepend_elem(OP_LIST, pack, version),
7452                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7453         }
7454     }
7455
7456     /* Fake up an import/unimport */
7457     if (arg && arg->op_type == OP_STUB) {
7458         imop = arg;             /* no import on explicit () */
7459     }
7460     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7461         imop = NULL;            /* use 5.0; */
7462         if (aver)
7463             use_version = ((SVOP*)idop)->op_sv;
7464         else
7465             idop->op_private |= OPpCONST_NOVER;
7466     }
7467     else {
7468         SV *meth;
7469
7470         /* Make copy of idop so we don't free it twice */
7471         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7472
7473         /* Fake up a method call to import/unimport */
7474         meth = aver
7475             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7476         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7477                        op_append_elem(OP_LIST,
7478                                    op_prepend_elem(OP_LIST, pack, arg),
7479                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7480                        ));
7481     }
7482
7483     /* Fake up the BEGIN {}, which does its thing immediately. */
7484     newATTRSUB(floor,
7485         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7486         NULL,
7487         NULL,
7488         op_append_elem(OP_LINESEQ,
7489             op_append_elem(OP_LINESEQ,
7490                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7491                 newSTATEOP(0, NULL, veop)),
7492             newSTATEOP(0, NULL, imop) ));
7493
7494     if (use_version) {
7495         /* Enable the
7496          * feature bundle that corresponds to the required version. */
7497         use_version = sv_2mortal(new_version(use_version));
7498         S_enable_feature_bundle(aTHX_ use_version);
7499
7500         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7501         if (vcmp(use_version,
7502                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7503             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7504                 PL_hints |= HINT_STRICT_REFS;
7505             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7506                 PL_hints |= HINT_STRICT_SUBS;
7507             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7508                 PL_hints |= HINT_STRICT_VARS;
7509         }
7510         /* otherwise they are off */
7511         else {
7512             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7513                 PL_hints &= ~HINT_STRICT_REFS;
7514             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7515                 PL_hints &= ~HINT_STRICT_SUBS;
7516             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7517                 PL_hints &= ~HINT_STRICT_VARS;
7518         }
7519     }
7520
7521     /* The "did you use incorrect case?" warning used to be here.
7522      * The problem is that on case-insensitive filesystems one
7523      * might get false positives for "use" (and "require"):
7524      * "use Strict" or "require CARP" will work.  This causes
7525      * portability problems for the script: in case-strict
7526      * filesystems the script will stop working.
7527      *
7528      * The "incorrect case" warning checked whether "use Foo"
7529      * imported "Foo" to your namespace, but that is wrong, too:
7530      * there is no requirement nor promise in the language that
7531      * a Foo.pm should or would contain anything in package "Foo".
7532      *
7533      * There is very little Configure-wise that can be done, either:
7534      * the case-sensitivity of the build filesystem of Perl does not
7535      * help in guessing the case-sensitivity of the runtime environment.
7536      */
7537
7538     PL_hints |= HINT_BLOCK_SCOPE;
7539     PL_parser->copline = NOLINE;
7540     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7541 }
7542
7543 /*
7544 =head1 Embedding Functions
7545
7546 =for apidoc load_module
7547
7548 Loads the module whose name is pointed to by the string part of C<name>.
7549 Note that the actual module name, not its filename, should be given.
7550 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7551 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7552 trailing arguments can be used to specify arguments to the module's C<import()>
7553 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7554 on the flags. The flags argument is a bitwise-ORed collection of any of
7555 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7556 (or 0 for no flags).
7557
7558 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7559 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7560 the trailing optional arguments may be omitted entirely. Otherwise, if
7561 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7562 exactly one C<OP*>, containing the op tree that produces the relevant import
7563 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7564 will be used as import arguments; and the list must be terminated with C<(SV*)
7565 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7566 set, the trailing C<NULL> pointer is needed even if no import arguments are
7567 desired. The reference count for each specified C<SV*> argument is
7568 decremented. In addition, the C<name> argument is modified.
7569
7570 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7571 than C<use>.
7572
7573 =cut */
7574
7575 void
7576 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7577 {
7578     va_list args;
7579
7580     PERL_ARGS_ASSERT_LOAD_MODULE;
7581
7582     va_start(args, ver);
7583     vload_module(flags, name, ver, &args);
7584     va_end(args);
7585 }
7586
7587 #ifdef PERL_IMPLICIT_CONTEXT
7588 void
7589 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7590 {
7591     dTHX;
7592     va_list args;
7593     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7594     va_start(args, ver);
7595     vload_module(flags, name, ver, &args);
7596     va_end(args);
7597 }
7598 #endif
7599
7600 void
7601 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7602 {
7603     OP *veop, *imop;
7604     OP * const modname = newSVOP(OP_CONST, 0, name);
7605
7606     PERL_ARGS_ASSERT_VLOAD_MODULE;
7607
7608     modname->op_private |= OPpCONST_BARE;
7609     if (ver) {
7610         veop = newSVOP(OP_CONST, 0, ver);
7611     }
7612     else
7613         veop = NULL;
7614     if (flags & PERL_LOADMOD_NOIMPORT) {
7615         imop = sawparens(newNULLLIST());
7616     }
7617     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7618         imop = va_arg(*args, OP*);
7619     }
7620     else {
7621         SV *sv;
7622         imop = NULL;
7623         sv = va_arg(*args, SV*);
7624         while (sv) {
7625             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7626             sv = va_arg(*args, SV*);
7627         }
7628     }
7629
7630     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7631      * that it has a PL_parser to play with while doing that, and also
7632      * that it doesn't mess with any existing parser, by creating a tmp
7633      * new parser with lex_start(). This won't actually be used for much,
7634      * since pp_require() will create another parser for the real work.
7635      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
7636
7637     ENTER;
7638     SAVEVPTR(PL_curcop);
7639     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7640     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7641             veop, modname, imop);
7642     LEAVE;
7643 }
7644
7645 PERL_STATIC_INLINE OP *
7646 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7647 {
7648     return newUNOP(OP_ENTERSUB, OPf_STACKED,
7649                    newLISTOP(OP_LIST, 0, arg,
7650                              newUNOP(OP_RV2CV, 0,
7651                                      newGVOP(OP_GV, 0, gv))));
7652 }
7653
7654 OP *
7655 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7656 {
7657     OP *doop;
7658     GV *gv;
7659
7660     PERL_ARGS_ASSERT_DOFILE;
7661
7662     if (!force_builtin && (gv = gv_override("do", 2))) {
7663         doop = S_new_entersubop(aTHX_ gv, term);
7664     }
7665     else {
7666         doop = newUNOP(OP_DOFILE, 0, scalar(term));
7667     }
7668     return doop;
7669 }
7670
7671 /*
7672 =head1 Optree construction
7673
7674 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7675
7676 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
7677 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7678 be set automatically, and, shifted up eight bits, the eight bits of
7679 C<op_private>, except that the bit with value 1 or 2 is automatically
7680 set as required.  C<listval> and C<subscript> supply the parameters of
7681 the slice; they are consumed by this function and become part of the
7682 constructed op tree.
7683
7684 =cut
7685 */
7686
7687 OP *
7688 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7689 {
7690     return newBINOP(OP_LSLICE, flags,
7691             list(force_list(subscript, 1)),
7692             list(force_list(listval,   1)) );
7693 }
7694
7695 #define ASSIGN_LIST   1
7696 #define ASSIGN_REF    2
7697
7698 STATIC I32
7699 S_assignment_type(pTHX_ const OP *o)
7700 {
7701     unsigned type;
7702     U8 flags;
7703     U8 ret;
7704
7705     if (!o)
7706         return TRUE;
7707
7708     if (o->op_type == OP_SREFGEN)
7709     {
7710         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7711         type = kid->op_type;
7712         flags = o->op_flags | kid->op_flags;
7713         if (!(flags & OPf_PARENS)
7714           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7715               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7716             return ASSIGN_REF;
7717         ret = ASSIGN_REF;
7718     } else {
7719         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7720             o = cUNOPo->op_first;
7721         flags = o->op_flags;
7722         type = o->op_type;
7723         ret = 0;
7724     }
7725
7726     if (type == OP_COND_EXPR) {
7727         OP * const sib = OpSIBLING(cLOGOPo->op_first);
7728         const I32 t = assignment_type(sib);
7729         const I32 f = assignment_type(OpSIBLING(sib));
7730
7731         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7732             return ASSIGN_LIST;
7733         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7734             yyerror("Assignment to both a list and a scalar");
7735         return FALSE;
7736     }
7737
7738     if (type == OP_LIST &&
7739         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7740         o->op_private & OPpLVAL_INTRO)
7741         return ret;
7742
7743     if (type == OP_LIST || flags & OPf_PARENS ||
7744         type == OP_RV2AV || type == OP_RV2HV ||
7745         type == OP_ASLICE || type == OP_HSLICE ||
7746         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7747         return TRUE;
7748
7749     if (type == OP_PADAV || type == OP_PADHV)
7750         return TRUE;
7751
7752     if (type == OP_RV2SV)
7753         return ret;
7754
7755     return ret;
7756 }
7757
7758 static OP *
7759 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7760 {
7761     const PADOFFSET target = padop->op_targ;
7762     OP *const other = newOP(OP_PADSV,
7763                             padop->op_flags
7764                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7765     OP *const first = newOP(OP_NULL, 0);
7766     OP *const nullop = newCONDOP(0, first, initop, other);
7767     /* XXX targlex disabled for now; see ticket #124160
7768         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7769      */
7770     OP *const condop = first->op_next;
7771
7772     OpTYPE_set(condop, OP_ONCE);
7773     other->op_targ = target;
7774     nullop->op_flags |= OPf_WANT_SCALAR;
7775
7776     /* Store the initializedness of state vars in a separate
7777        pad entry.  */
7778     condop->op_targ =
7779       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7780     /* hijacking PADSTALE for uninitialized state variables */
7781     SvPADSTALE_on(PAD_SVl(condop->op_targ));
7782
7783     return nullop;
7784 }
7785
7786 /*
7787 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7788
7789 Constructs, checks, and returns an assignment op.  C<left> and C<right>
7790 supply the parameters of the assignment; they are consumed by this
7791 function and become part of the constructed op tree.
7792
7793 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7794 a suitable conditional optree is constructed.  If C<optype> is the opcode
7795 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7796 performs the binary operation and assigns the result to the left argument.
7797 Either way, if C<optype> is non-zero then C<flags> has no effect.
7798
7799 If C<optype> is zero, then a plain scalar or list assignment is
7800 constructed.  Which type of assignment it is is automatically determined.
7801 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7802 will be set automatically, and, shifted up eight bits, the eight bits
7803 of C<op_private>, except that the bit with value 1 or 2 is automatically
7804 set as required.
7805
7806 =cut
7807 */
7808
7809 OP *
7810 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7811 {
7812     OP *o;
7813     I32 assign_type;
7814
7815     if (optype) {
7816         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7817             right = scalar(right);
7818             return newLOGOP(optype, 0,
7819                 op_lvalue(scalar(left), optype),
7820                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7821         }
7822         else {
7823             return newBINOP(optype, OPf_STACKED,
7824                 op_lvalue(scalar(left), optype), scalar(right));
7825         }
7826     }
7827
7828     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7829         OP *state_var_op = NULL;
7830         static const char no_list_state[] = "Initialization of state variables"
7831             " in list currently forbidden";
7832         OP *curop;
7833
7834         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7835             left->op_private &= ~ OPpSLICEWARNING;
7836
7837         PL_modcount = 0;
7838         left = op_lvalue(left, OP_AASSIGN);
7839         curop = list(force_list(left, 1));
7840         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7841         o->op_private = (U8)(0 | (flags >> 8));
7842
7843         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7844         {
7845             OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7846             if (!(left->op_flags & OPf_PARENS) &&
7847                     lop->op_type == OP_PUSHMARK &&
7848                     (vop = OpSIBLING(lop)) &&
7849                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7850                     !(vop->op_flags & OPf_PARENS) &&
7851                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7852                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
7853                     (eop = OpSIBLING(vop)) &&
7854                     eop->op_type == OP_ENTERSUB &&
7855                     !OpHAS_SIBLING(eop)) {
7856                 state_var_op = vop;
7857             } else {
7858                 while (lop) {
7859                     if ((lop->op_type == OP_PADSV ||
7860                          lop->op_type == OP_PADAV ||
7861                          lop->op_type == OP_PADHV ||
7862                          lop->op_type == OP_PADANY)
7863                       && (lop->op_private & OPpPAD_STATE)
7864                     )
7865                         yyerror(no_list_state);
7866                     lop = OpSIBLING(lop);
7867                 }
7868             }
7869         }
7870         else if (  (left->op_private & OPpLVAL_INTRO)
7871                 && (left->op_private & OPpPAD_STATE)
7872                 && (   left->op_type == OP_PADSV
7873                     || left->op_type == OP_PADAV
7874                     || left->op_type == OP_PADHV
7875                     || left->op_type == OP_PADANY)
7876         ) {
7877                 /* All single variable list context state assignments, hence
7878                    state ($a) = ...
7879                    (state $a) = ...
7880                    state @a = ...
7881                    state (@a) = ...
7882                    (state @a) = ...
7883                    state %a = ...
7884                    state (%a) = ...
7885                    (state %a) = ...
7886                 */
7887                 if (left->op_flags & OPf_PARENS)
7888                     yyerror(no_list_state);
7889                 else
7890                     state_var_op = left;
7891         }
7892
7893         /* optimise @a = split(...) into:
7894         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
7895         * @a, my @a, local @a:  split(...)          (where @a is attached to
7896         *                                            the split op itself)
7897         */
7898
7899         if (   right
7900             && right->op_type == OP_SPLIT
7901             /* don't do twice, e.g. @b = (@a = split) */
7902             && !(right->op_private & OPpSPLIT_ASSIGN))
7903         {
7904             OP *gvop = NULL;
7905
7906             if (   (  left->op_type == OP_RV2AV
7907                    && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7908                 || left->op_type == OP_PADAV)
7909             {
7910                 /* @pkg or @lex or local @pkg' or 'my @lex' */
7911                 OP *tmpop;
7912                 if (gvop) {
7913 #ifdef USE_ITHREADS
7914                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7915                         = cPADOPx(gvop)->op_padix;
7916                     cPADOPx(gvop)->op_padix = 0;        /* steal it */
7917 #else
7918                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7919                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7920                     cSVOPx(gvop)->op_sv = NULL; /* steal it */
7921 #endif
7922                     right->op_private |=
7923                         left->op_private & OPpOUR_INTRO;
7924                 }
7925                 else {
7926                     ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7927                     left->op_targ = 0;  /* steal it */
7928                     right->op_private |= OPpSPLIT_LEX;
7929                 }
7930                 right->op_private |= left->op_private & OPpLVAL_INTRO;
7931
7932               detach_split:
7933                 tmpop = cUNOPo->op_first;       /* to list (nulled) */
7934                 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7935                 assert(OpSIBLING(tmpop) == right);
7936                 assert(!OpHAS_SIBLING(right));
7937                 /* detach the split subtreee from the o tree,
7938                  * then free the residual o tree */
7939                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
7940                 op_free(o);                     /* blow off assign */
7941                 right->op_private |= OPpSPLIT_ASSIGN;
7942                 right->op_flags &= ~OPf_WANT;
7943                         /* "I don't know and I don't care." */
7944                 return right;
7945             }
7946             else if (left->op_type == OP_RV2AV) {
7947                 /* @{expr} */
7948
7949                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
7950                 assert(OpSIBLING(pushop) == left);
7951                 /* Detach the array ...  */
7952                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
7953                 /* ... and attach it to the split.  */
7954                 op_sibling_splice(right, cLISTOPx(right)->op_last,
7955                                   0, left);
7956                 right->op_flags |= OPf_STACKED;
7957                 /* Detach split and expunge aassign as above.  */
7958                 goto detach_split;
7959             }
7960             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
7961                     ((LISTOP*)right)->op_last->op_type == OP_CONST)
7962             {
7963                 /* convert split(...,0) to split(..., PL_modcount+1) */
7964                 SV ** const svp =
7965                     &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
7966                 SV * const sv = *svp;
7967                 if (SvIOK(sv) && SvIVX(sv) == 0)
7968                 {
7969                   if (right->op_private & OPpSPLIT_IMPLIM) {
7970                     /* our own SV, created in ck_split */
7971                     SvREADONLY_off(sv);
7972                     sv_setiv(sv, PL_modcount+1);
7973                   }
7974                   else {
7975                     /* SV may belong to someone else */
7976                     SvREFCNT_dec(sv);
7977                     *svp = newSViv(PL_modcount+1);
7978                   }
7979                 }
7980             }
7981         }
7982
7983         if (state_var_op)
7984             o = S_newONCEOP(aTHX_ o, state_var_op);
7985         return o;
7986     }
7987     if (assign_type == ASSIGN_REF)
7988         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
7989     if (!right)
7990         right = newOP(OP_UNDEF, 0);
7991     if (right->op_type == OP_READLINE) {
7992         right->op_flags |= OPf_STACKED;
7993         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
7994                 scalar(right));
7995     }
7996     else {
7997         o = newBINOP(OP_SASSIGN, flags,
7998             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
7999     }
8000     return o;
8001 }
8002
8003 /*
8004 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8005
8006 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8007 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8008 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8009 If C<label> is non-null, it supplies the name of a label to attach to
8010 the state op; this function takes ownership of the memory pointed at by
8011 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8012 for the state op.
8013
8014 If C<o> is null, the state op is returned.  Otherwise the state op is
8015 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8016 is consumed by this function and becomes part of the returned op tree.
8017
8018 =cut
8019 */
8020
8021 OP *
8022 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8023 {
8024     dVAR;
8025     const U32 seq = intro_my();
8026     const U32 utf8 = flags & SVf_UTF8;
8027     COP *cop;
8028
8029     PL_parser->parsed_sub = 0;
8030
8031     flags &= ~SVf_UTF8;
8032
8033     NewOp(1101, cop, 1, COP);
8034     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8035         OpTYPE_set(cop, OP_DBSTATE);
8036     }
8037     else {
8038         OpTYPE_set(cop, OP_NEXTSTATE);
8039     }
8040     cop->op_flags = (U8)flags;
8041     CopHINTS_set(cop, PL_hints);
8042 #ifdef VMS
8043     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8044 #endif
8045     cop->op_next = (OP*)cop;
8046
8047     cop->cop_seq = seq;
8048     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8049     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8050     if (label) {
8051         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8052
8053         PL_hints |= HINT_BLOCK_SCOPE;
8054         /* It seems that we need to defer freeing this pointer, as other parts
8055            of the grammar end up wanting to copy it after this op has been
8056            created. */
8057         SAVEFREEPV(label);
8058     }
8059
8060     if (PL_parser->preambling != NOLINE) {
8061         CopLINE_set(cop, PL_parser->preambling);
8062         PL_parser->copline = NOLINE;
8063     }
8064     else if (PL_parser->copline == NOLINE)
8065         CopLINE_set(cop, CopLINE(PL_curcop));
8066     else {
8067         CopLINE_set(cop, PL_parser->copline);
8068         PL_parser->copline = NOLINE;
8069     }
8070 #ifdef USE_ITHREADS
8071     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
8072 #else
8073     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8074 #endif
8075     CopSTASH_set(cop, PL_curstash);
8076
8077     if (cop->op_type == OP_DBSTATE) {
8078         /* this line can have a breakpoint - store the cop in IV */
8079         AV *av = CopFILEAVx(PL_curcop);
8080         if (av) {
8081             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8082             if (svp && *svp != &PL_sv_undef ) {
8083                 (void)SvIOK_on(*svp);
8084                 SvIV_set(*svp, PTR2IV(cop));
8085             }
8086         }
8087     }
8088
8089     if (flags & OPf_SPECIAL)
8090         op_null((OP*)cop);
8091     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8092 }
8093
8094 /*
8095 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8096
8097 Constructs, checks, and returns a logical (flow control) op.  C<type>
8098 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8099 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8100 the eight bits of C<op_private>, except that the bit with value 1 is
8101 automatically set.  C<first> supplies the expression controlling the
8102 flow, and C<other> supplies the side (alternate) chain of ops; they are
8103 consumed by this function and become part of the constructed op tree.
8104
8105 =cut
8106 */
8107
8108 OP *
8109 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8110 {
8111     PERL_ARGS_ASSERT_NEWLOGOP;
8112
8113     return new_logop(type, flags, &first, &other);
8114 }
8115
8116 STATIC OP *
8117 S_search_const(pTHX_ OP *o)
8118 {
8119     PERL_ARGS_ASSERT_SEARCH_CONST;
8120
8121     switch (o->op_type) {
8122         case OP_CONST:
8123             return o;
8124         case OP_NULL:
8125             if (o->op_flags & OPf_KIDS)
8126                 return search_const(cUNOPo->op_first);
8127             break;
8128         case OP_LEAVE:
8129         case OP_SCOPE:
8130         case OP_LINESEQ:
8131         {
8132             OP *kid;
8133             if (!(o->op_flags & OPf_KIDS))
8134                 return NULL;
8135             kid = cLISTOPo->op_first;
8136             do {
8137                 switch (kid->op_type) {
8138                     case OP_ENTER:
8139                     case OP_NULL:
8140                     case OP_NEXTSTATE:
8141                         kid = OpSIBLING(kid);
8142                         break;
8143                     default:
8144                         if (kid != cLISTOPo->op_last)
8145                             return NULL;
8146                         goto last;
8147                 }
8148             } while (kid);
8149             if (!kid)
8150                 kid = cLISTOPo->op_last;
8151           last:
8152             return search_const(kid);
8153         }
8154     }
8155
8156     return NULL;
8157 }
8158
8159 STATIC OP *
8160 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8161 {
8162     dVAR;
8163     LOGOP *logop;
8164     OP *o;
8165     OP *first;
8166     OP *other;
8167     OP *cstop = NULL;
8168     int prepend_not = 0;
8169
8170     PERL_ARGS_ASSERT_NEW_LOGOP;
8171
8172     first = *firstp;
8173     other = *otherp;
8174
8175     /* [perl #59802]: Warn about things like "return $a or $b", which
8176        is parsed as "(return $a) or $b" rather than "return ($a or
8177        $b)".  NB: This also applies to xor, which is why we do it
8178        here.
8179      */
8180     switch (first->op_type) {
8181     case OP_NEXT:
8182     case OP_LAST:
8183     case OP_REDO:
8184         /* XXX: Perhaps we should emit a stronger warning for these.
8185            Even with the high-precedence operator they don't seem to do
8186            anything sensible.
8187
8188            But until we do, fall through here.
8189          */
8190     case OP_RETURN:
8191     case OP_EXIT:
8192     case OP_DIE:
8193     case OP_GOTO:
8194         /* XXX: Currently we allow people to "shoot themselves in the
8195            foot" by explicitly writing "(return $a) or $b".
8196
8197            Warn unless we are looking at the result from folding or if
8198            the programmer explicitly grouped the operators like this.
8199            The former can occur with e.g.
8200
8201                 use constant FEATURE => ( $] >= ... );
8202                 sub { not FEATURE and return or do_stuff(); }
8203          */
8204         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8205             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8206                            "Possible precedence issue with control flow operator");
8207         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8208            the "or $b" part)?
8209         */
8210         break;
8211     }
8212
8213     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
8214         return newBINOP(type, flags, scalar(first), scalar(other));
8215
8216     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8217         || type == OP_CUSTOM);
8218
8219     scalarboolean(first);
8220
8221     /* search for a constant op that could let us fold the test */
8222     if ((cstop = search_const(first))) {
8223         if (cstop->op_private & OPpCONST_STRICT)
8224             no_bareword_allowed(cstop);
8225         else if ((cstop->op_private & OPpCONST_BARE))
8226                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8227         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
8228             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8229             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8230             /* Elide the (constant) lhs, since it can't affect the outcome */
8231             *firstp = NULL;
8232             if (other->op_type == OP_CONST)
8233                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8234             op_free(first);
8235             if (other->op_type == OP_LEAVE)
8236                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8237             else if (other->op_type == OP_MATCH
8238                   || other->op_type == OP_SUBST
8239                   || other->op_type == OP_TRANSR
8240                   || other->op_type == OP_TRANS)
8241                 /* Mark the op as being unbindable with =~ */
8242                 other->op_flags |= OPf_SPECIAL;
8243
8244             other->op_folded = 1;
8245             return other;
8246         }
8247         else {
8248             /* Elide the rhs, since the outcome is entirely determined by
8249              * the (constant) lhs */
8250
8251             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8252             const OP *o2 = other;
8253             if ( ! (o2->op_type == OP_LIST
8254                     && (( o2 = cUNOPx(o2)->op_first))
8255                     && o2->op_type == OP_PUSHMARK
8256                     && (( o2 = OpSIBLING(o2))) )
8257             )
8258                 o2 = other;
8259             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8260                         || o2->op_type == OP_PADHV)
8261                 && o2->op_private & OPpLVAL_INTRO
8262                 && !(o2->op_private & OPpPAD_STATE))
8263             {
8264                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8265                                 "Deprecated use of my() in false conditional. "
8266                                 "This will be a fatal error in Perl 5.30");
8267             }
8268
8269             *otherp = NULL;
8270             if (cstop->op_type == OP_CONST)
8271                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8272             op_free(other);
8273             return first;
8274         }
8275     }
8276     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8277         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8278     {
8279         const OP * const k1 = ((UNOP*)first)->op_first;
8280         const OP * const k2 = OpSIBLING(k1);
8281         OPCODE warnop = 0;
8282         switch (first->op_type)
8283         {
8284         case OP_NULL:
8285             if (k2 && k2->op_type == OP_READLINE
8286                   && (k2->op_flags & OPf_STACKED)
8287                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8288             {
8289                 warnop = k2->op_type;
8290             }
8291             break;
8292
8293         case OP_SASSIGN:
8294             if (k1->op_type == OP_READDIR
8295                   || k1->op_type == OP_GLOB
8296                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8297                  || k1->op_type == OP_EACH
8298                  || k1->op_type == OP_AEACH)
8299             {
8300                 warnop = ((k1->op_type == OP_NULL)
8301                           ? (OPCODE)k1->op_targ : k1->op_type);
8302             }
8303             break;
8304         }
8305         if (warnop) {
8306             const line_t oldline = CopLINE(PL_curcop);
8307             /* This ensures that warnings are reported at the first line
8308                of the construction, not the last.  */
8309             CopLINE_set(PL_curcop, PL_parser->copline);
8310             Perl_warner(aTHX_ packWARN(WARN_MISC),
8311                  "Value of %s%s can be \"0\"; test with defined()",
8312                  PL_op_desc[warnop],
8313                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8314                   ? " construct" : "() operator"));
8315             CopLINE_set(PL_curcop, oldline);
8316         }
8317     }
8318
8319     /* optimize AND and OR ops that have NOTs as children */
8320     if (first->op_type == OP_NOT
8321         && (first->op_flags & OPf_KIDS)
8322         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8323             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8324         ) {
8325         if (type == OP_AND || type == OP_OR) {
8326             if (type == OP_AND)
8327                 type = OP_OR;
8328             else
8329                 type = OP_AND;
8330             op_null(first);
8331             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8332                 op_null(other);
8333                 prepend_not = 1; /* prepend a NOT op later */
8334             }
8335         }
8336     }
8337
8338     logop = alloc_LOGOP(type, first, LINKLIST(other));
8339     logop->op_flags |= (U8)flags;
8340     logop->op_private = (U8)(1 | (flags >> 8));
8341
8342     /* establish postfix order */
8343     logop->op_next = LINKLIST(first);
8344     first->op_next = (OP*)logop;
8345     assert(!OpHAS_SIBLING(first));
8346     op_sibling_splice((OP*)logop, first, 0, other);
8347
8348     CHECKOP(type,logop);
8349
8350     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8351                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8352                 (OP*)logop);
8353     other->op_next = o;
8354
8355     return o;
8356 }
8357
8358 /*
8359 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8360
8361 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8362 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8363 will be set automatically, and, shifted up eight bits, the eight bits of
8364 C<op_private>, except that the bit with value 1 is automatically set.
8365 C<first> supplies the expression selecting between the two branches,
8366 and C<trueop> and C<falseop> supply the branches; they are consumed by
8367 this function and become part of the constructed op tree.
8368
8369 =cut
8370 */
8371
8372 OP *
8373 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8374 {
8375     dVAR;
8376     LOGOP *logop;
8377     OP *start;
8378     OP *o;
8379     OP *cstop;
8380
8381     PERL_ARGS_ASSERT_NEWCONDOP;
8382
8383     if (!falseop)
8384         return newLOGOP(OP_AND, 0, first, trueop);
8385     if (!trueop)
8386         return newLOGOP(OP_OR, 0, first, falseop);
8387
8388     scalarboolean(first);
8389     if ((cstop = search_const(first))) {
8390         /* Left or right arm of the conditional?  */
8391         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8392         OP *live = left ? trueop : falseop;
8393         OP *const dead = left ? falseop : trueop;
8394         if (cstop->op_private & OPpCONST_BARE &&
8395             cstop->op_private & OPpCONST_STRICT) {
8396             no_bareword_allowed(cstop);
8397         }
8398         op_free(first);
8399         op_free(dead);
8400         if (live->op_type == OP_LEAVE)
8401             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8402         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8403               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8404             /* Mark the op as being unbindable with =~ */
8405             live->op_flags |= OPf_SPECIAL;
8406         live->op_folded = 1;
8407         return live;
8408     }
8409     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8410     logop->op_flags |= (U8)flags;
8411     logop->op_private = (U8)(1 | (flags >> 8));
8412     logop->op_next = LINKLIST(falseop);
8413
8414     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8415             logop);
8416
8417     /* establish postfix order */
8418     start = LINKLIST(first);
8419     first->op_next = (OP*)logop;
8420
8421     /* make first, trueop, falseop siblings */
8422     op_sibling_splice((OP*)logop, first,  0, trueop);
8423     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8424
8425     o = newUNOP(OP_NULL, 0, (OP*)logop);
8426
8427     trueop->op_next = falseop->op_next = o;
8428
8429     o->op_next = start;
8430     return o;
8431 }
8432
8433 /*
8434 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8435
8436 Constructs and returns a C<range> op, with subordinate C<flip> and
8437 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8438 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8439 for both the C<flip> and C<range> ops, except that the bit with value
8440 1 is automatically set.  C<left> and C<right> supply the expressions
8441 controlling the endpoints of the range; they are consumed by this function
8442 and become part of the constructed op tree.
8443
8444 =cut
8445 */
8446
8447 OP *
8448 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8449 {
8450     LOGOP *range;
8451     OP *flip;
8452     OP *flop;
8453     OP *leftstart;
8454     OP *o;
8455
8456     PERL_ARGS_ASSERT_NEWRANGE;
8457
8458     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8459     range->op_flags = OPf_KIDS;
8460     leftstart = LINKLIST(left);
8461     range->op_private = (U8)(1 | (flags >> 8));
8462
8463     /* make left and right siblings */
8464     op_sibling_splice((OP*)range, left, 0, right);
8465
8466     range->op_next = (OP*)range;
8467     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8468     flop = newUNOP(OP_FLOP, 0, flip);
8469     o = newUNOP(OP_NULL, 0, flop);
8470     LINKLIST(flop);
8471     range->op_next = leftstart;
8472
8473     left->op_next = flip;
8474     right->op_next = flop;
8475
8476     range->op_targ =
8477         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8478     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8479     flip->op_targ =
8480         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8481     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8482     SvPADTMP_on(PAD_SV(flip->op_targ));
8483
8484     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8485     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8486
8487     /* check barewords before they might be optimized aways */
8488     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8489         no_bareword_allowed(left);
8490     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8491         no_bareword_allowed(right);
8492
8493     flip->op_next = o;
8494     if (!flip->op_private || !flop->op_private)
8495         LINKLIST(o);            /* blow off optimizer unless constant */
8496
8497     return o;
8498 }
8499
8500 /*
8501 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8502
8503 Constructs, checks, and returns an op tree expressing a loop.  This is
8504 only a loop in the control flow through the op tree; it does not have
8505 the heavyweight loop structure that allows exiting the loop by C<last>
8506 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
8507 top-level op, except that some bits will be set automatically as required.
8508 C<expr> supplies the expression controlling loop iteration, and C<block>
8509 supplies the body of the loop; they are consumed by this function and
8510 become part of the constructed op tree.  C<debuggable> is currently
8511 unused and should always be 1.
8512
8513 =cut
8514 */
8515
8516 OP *
8517 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8518 {
8519     OP* listop;
8520     OP* o;
8521     const bool once = block && block->op_flags & OPf_SPECIAL &&
8522                       block->op_type == OP_NULL;
8523
8524     PERL_UNUSED_ARG(debuggable);
8525
8526     if (expr) {
8527         if (once && (
8528               (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8529            || (  expr->op_type == OP_NOT
8530               && cUNOPx(expr)->op_first->op_type == OP_CONST
8531               && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8532               )
8533            ))
8534             /* Return the block now, so that S_new_logop does not try to
8535                fold it away. */
8536             return block;       /* do {} while 0 does once */
8537         if (expr->op_type == OP_READLINE
8538             || expr->op_type == OP_READDIR
8539             || expr->op_type == OP_GLOB
8540             || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8541             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8542             expr = newUNOP(OP_DEFINED, 0,
8543                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8544         } else if (expr->op_flags & OPf_KIDS) {
8545             const OP * const k1 = ((UNOP*)expr)->op_first;
8546             const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8547             switch (expr->op_type) {
8548               case OP_NULL:
8549                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8550                       && (k2->op_flags & OPf_STACKED)
8551                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8552                     expr = newUNOP(OP_DEFINED, 0, expr);
8553                 break;
8554
8555               case OP_SASSIGN:
8556                 if (k1 && (k1->op_type == OP_READDIR
8557                       || k1->op_type == OP_GLOB
8558                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8559                      || k1->op_type == OP_EACH
8560                      || k1->op_type == OP_AEACH))
8561                     expr = newUNOP(OP_DEFINED, 0, expr);
8562                 break;
8563             }
8564         }
8565     }
8566
8567     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8568      * op, in listop. This is wrong. [perl #27024] */
8569     if (!block)
8570         block = newOP(OP_NULL, 0);
8571     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8572     o = new_logop(OP_AND, 0, &expr, &listop);
8573
8574     if (once) {
8575         ASSUME(listop);
8576     }
8577
8578     if (listop)
8579         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8580
8581     if (once && o != listop)
8582     {
8583         assert(cUNOPo->op_first->op_type == OP_AND
8584             || cUNOPo->op_first->op_type == OP_OR);
8585         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8586     }
8587
8588     if (o == listop)
8589         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
8590
8591     o->op_flags |= flags;
8592     o = op_scope(o);
8593     o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8594     return o;
8595 }
8596
8597 /*
8598 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8599
8600 Constructs, checks, and returns an op tree expressing a C<while> loop.
8601 This is a heavyweight loop, with structure that allows exiting the loop
8602 by C<last> and suchlike.
8603
8604 C<loop> is an optional preconstructed C<enterloop> op to use in the
8605 loop; if it is null then a suitable op will be constructed automatically.
8606 C<expr> supplies the loop's controlling expression.  C<block> supplies the
8607 main body of the loop, and C<cont> optionally supplies a C<continue> block
8608 that operates as a second half of the body.  All of these optree inputs
8609 are consumed by this function and become part of the constructed op tree.
8610
8611 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8612 op and, shifted up eight bits, the eight bits of C<op_private> for
8613 the C<leaveloop> op, except that (in both cases) some bits will be set
8614 automatically.  C<debuggable> is currently unused and should always be 1.
8615 C<has_my> can be supplied as true to force the
8616 loop body to be enclosed in its own scope.
8617
8618 =cut
8619 */
8620
8621 OP *
8622 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8623         OP *expr, OP *block, OP *cont, I32 has_my)
8624 {
8625     dVAR;
8626     OP *redo;
8627     OP *next = NULL;
8628     OP *listop;
8629     OP *o;
8630     U8 loopflags = 0;
8631
8632     PERL_UNUSED_ARG(debuggable);
8633
8634     if (expr) {
8635         if (expr->op_type == OP_READLINE
8636          || expr->op_type == OP_READDIR
8637          || expr->op_type == OP_GLOB
8638          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8639                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8640             expr = newUNOP(OP_DEFINED, 0,
8641                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8642         } else if (expr->op_flags & OPf_KIDS) {
8643             const OP * const k1 = ((UNOP*)expr)->op_first;
8644             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8645             switch (expr->op_type) {
8646               case OP_NULL:
8647                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8648                       && (k2->op_flags & OPf_STACKED)
8649                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8650                     expr = newUNOP(OP_DEFINED, 0, expr);
8651                 break;
8652
8653               case OP_SASSIGN:
8654                 if (k1 && (k1->op_type == OP_READDIR
8655                       || k1->op_type == OP_GLOB
8656                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8657                      || k1->op_type == OP_EACH
8658                      || k1->op_type == OP_AEACH))
8659                     expr = newUNOP(OP_DEFINED, 0, expr);
8660                 break;
8661             }
8662         }
8663     }
8664
8665     if (!block)
8666         block = newOP(OP_NULL, 0);
8667     else if (cont || has_my) {
8668         block = op_scope(block);
8669     }
8670
8671     if (cont) {
8672         next = LINKLIST(cont);
8673     }
8674     if (expr) {
8675         OP * const unstack = newOP(OP_UNSTACK, 0);
8676         if (!next)
8677             next = unstack;
8678         cont = op_append_elem(OP_LINESEQ, cont, unstack);
8679     }
8680
8681     assert(block);
8682     listop = op_append_list(OP_LINESEQ, block, cont);
8683     assert(listop);
8684     redo = LINKLIST(listop);
8685
8686     if (expr) {
8687         scalar(listop);
8688         o = new_logop(OP_AND, 0, &expr, &listop);
8689         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8690             op_free((OP*)loop);
8691             return expr;                /* listop already freed by new_logop */
8692         }
8693         if (listop)
8694             ((LISTOP*)listop)->op_last->op_next =
8695                 (o == listop ? redo : LINKLIST(o));
8696     }
8697     else
8698         o = listop;
8699
8700     if (!loop) {
8701         NewOp(1101,loop,1,LOOP);
8702         OpTYPE_set(loop, OP_ENTERLOOP);
8703         loop->op_private = 0;
8704         loop->op_next = (OP*)loop;
8705     }
8706
8707     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8708
8709     loop->op_redoop = redo;
8710     loop->op_lastop = o;
8711     o->op_private |= loopflags;
8712
8713     if (next)
8714         loop->op_nextop = next;
8715     else
8716         loop->op_nextop = o;
8717
8718     o->op_flags |= flags;
8719     o->op_private |= (flags >> 8);
8720     return o;
8721 }
8722
8723 /*
8724 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8725
8726 Constructs, checks, and returns an op tree expressing a C<foreach>
8727 loop (iteration through a list of values).  This is a heavyweight loop,
8728 with structure that allows exiting the loop by C<last> and suchlike.
8729
8730 C<sv> optionally supplies the variable that will be aliased to each
8731 item in turn; if null, it defaults to C<$_>.
8732 C<expr> supplies the list of values to iterate over.  C<block> supplies
8733 the main body of the loop, and C<cont> optionally supplies a C<continue>
8734 block that operates as a second half of the body.  All of these optree
8735 inputs are consumed by this function and become part of the constructed
8736 op tree.
8737
8738 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8739 op and, shifted up eight bits, the eight bits of C<op_private> for
8740 the C<leaveloop> op, except that (in both cases) some bits will be set
8741 automatically.
8742
8743 =cut
8744 */
8745
8746 OP *
8747 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8748 {
8749     dVAR;
8750     LOOP *loop;
8751     OP *wop;
8752     PADOFFSET padoff = 0;
8753     I32 iterflags = 0;
8754     I32 iterpflags = 0;
8755
8756     PERL_ARGS_ASSERT_NEWFOROP;
8757
8758     if (sv) {
8759         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
8760             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8761             OpTYPE_set(sv, OP_RV2GV);
8762
8763             /* The op_type check is needed to prevent a possible segfault
8764              * if the loop variable is undeclared and 'strict vars' is in
8765              * effect. This is illegal but is nonetheless parsed, so we
8766              * may reach this point with an OP_CONST where we're expecting
8767              * an OP_GV.
8768              */
8769             if (cUNOPx(sv)->op_first->op_type == OP_GV
8770              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8771                 iterpflags |= OPpITER_DEF;
8772         }
8773         else if (sv->op_type == OP_PADSV) { /* private variable */
8774             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8775             padoff = sv->op_targ;
8776             sv->op_targ = 0;
8777             op_free(sv);
8778             sv = NULL;
8779             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8780         }
8781         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8782             NOOP;
8783         else
8784             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8785         if (padoff) {
8786             PADNAME * const pn = PAD_COMPNAME(padoff);
8787             const char * const name = PadnamePV(pn);
8788
8789             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8790                 iterpflags |= OPpITER_DEF;
8791         }
8792     }
8793     else {
8794         sv = newGVOP(OP_GV, 0, PL_defgv);
8795         iterpflags |= OPpITER_DEF;
8796     }
8797
8798     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8799         expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8800         iterflags |= OPf_STACKED;
8801     }
8802     else if (expr->op_type == OP_NULL &&
8803              (expr->op_flags & OPf_KIDS) &&
8804              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8805     {
8806         /* Basically turn for($x..$y) into the same as for($x,$y), but we
8807          * set the STACKED flag to indicate that these values are to be
8808          * treated as min/max values by 'pp_enteriter'.
8809          */
8810         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8811         LOGOP* const range = (LOGOP*) flip->op_first;
8812         OP* const left  = range->op_first;
8813         OP* const right = OpSIBLING(left);
8814         LISTOP* listop;
8815
8816         range->op_flags &= ~OPf_KIDS;
8817         /* detach range's children */
8818         op_sibling_splice((OP*)range, NULL, -1, NULL);
8819
8820         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8821         listop->op_first->op_next = range->op_next;
8822         left->op_next = range->op_other;
8823         right->op_next = (OP*)listop;
8824         listop->op_next = listop->op_first;
8825
8826         op_free(expr);
8827         expr = (OP*)(listop);
8828         op_null(expr);
8829         iterflags |= OPf_STACKED;
8830     }
8831     else {
8832         expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8833     }
8834
8835     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8836                                   op_append_elem(OP_LIST, list(expr),
8837                                                  scalar(sv)));
8838     assert(!loop->op_next);
8839     /* for my  $x () sets OPpLVAL_INTRO;
8840      * for our $x () sets OPpOUR_INTRO */
8841     loop->op_private = (U8)iterpflags;
8842     if (loop->op_slabbed
8843      && DIFF(loop, OpSLOT(loop)->opslot_next)
8844          < SIZE_TO_PSIZE(sizeof(LOOP)))
8845     {
8846         LOOP *tmp;
8847         NewOp(1234,tmp,1,LOOP);
8848         Copy(loop,tmp,1,LISTOP);
8849 #ifdef PERL_OP_PARENT
8850         assert(loop->op_last->op_sibparent == (OP*)loop);
8851         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8852 #endif
8853         S_op_destroy(aTHX_ (OP*)loop);
8854         loop = tmp;
8855     }
8856     else if (!loop->op_slabbed)
8857     {
8858         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8859 #ifdef PERL_OP_PARENT
8860         OpLASTSIB_set(loop->op_last, (OP*)loop);
8861 #endif
8862     }
8863     loop->op_targ = padoff;
8864     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8865     return wop;
8866 }
8867
8868 /*
8869 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8870
8871 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8872 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
8873 determining the target of the op; it is consumed by this function and
8874 becomes part of the constructed op tree.
8875
8876 =cut
8877 */
8878
8879 OP*
8880 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8881 {
8882     OP *o = NULL;
8883
8884     PERL_ARGS_ASSERT_NEWLOOPEX;
8885
8886     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8887         || type == OP_CUSTOM);
8888
8889     if (type != OP_GOTO) {
8890         /* "last()" means "last" */
8891         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8892             o = newOP(type, OPf_SPECIAL);
8893         }
8894     }
8895     else {
8896         /* Check whether it's going to be a goto &function */
8897         if (label->op_type == OP_ENTERSUB
8898                 && !(label->op_flags & OPf_STACKED))
8899             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8900     }
8901
8902     /* Check for a constant argument */
8903     if (label->op_type == OP_CONST) {
8904             SV * const sv = ((SVOP *)label)->op_sv;
8905             STRLEN l;
8906             const char *s = SvPV_const(sv,l);
8907             if (l == strlen(s)) {
8908                 o = newPVOP(type,
8909                             SvUTF8(((SVOP*)label)->op_sv),
8910                             savesharedpv(
8911                                 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8912             }
8913     }
8914
8915     /* If we have already created an op, we do not need the label. */
8916     if (o)
8917                 op_free(label);
8918     else o = newUNOP(type, OPf_STACKED, label);
8919
8920     PL_hints |= HINT_BLOCK_SCOPE;
8921     return o;
8922 }
8923
8924 /* if the condition is a literal array or hash
8925    (or @{ ... } etc), make a reference to it.
8926  */
8927 STATIC OP *
8928 S_ref_array_or_hash(pTHX_ OP *cond)
8929 {
8930     if (cond
8931     && (cond->op_type == OP_RV2AV
8932     ||  cond->op_type == OP_PADAV
8933     ||  cond->op_type == OP_RV2HV
8934     ||  cond->op_type == OP_PADHV))
8935
8936         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8937
8938     else if(cond
8939     && (cond->op_type == OP_ASLICE
8940     ||  cond->op_type == OP_KVASLICE
8941     ||  cond->op_type == OP_HSLICE
8942     ||  cond->op_type == OP_KVHSLICE)) {
8943
8944         /* anonlist now needs a list from this op, was previously used in
8945          * scalar context */
8946         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
8947         cond->op_flags |= OPf_WANT_LIST;
8948
8949         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
8950     }
8951
8952     else
8953         return cond;
8954 }
8955
8956 /* These construct the optree fragments representing given()
8957    and when() blocks.
8958
8959    entergiven and enterwhen are LOGOPs; the op_other pointer
8960    points up to the associated leave op. We need this so we
8961    can put it in the context and make break/continue work.
8962    (Also, of course, pp_enterwhen will jump straight to
8963    op_other if the match fails.)
8964  */
8965
8966 STATIC OP *
8967 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
8968                    I32 enter_opcode, I32 leave_opcode,
8969                    PADOFFSET entertarg)
8970 {
8971     dVAR;
8972     LOGOP *enterop;
8973     OP *o;
8974
8975     PERL_ARGS_ASSERT_NEWGIVWHENOP;
8976     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
8977
8978     enterop = alloc_LOGOP(enter_opcode, block, NULL);
8979     enterop->op_targ = 0;
8980     enterop->op_private = 0;
8981
8982     o = newUNOP(leave_opcode, 0, (OP *) enterop);
8983
8984     if (cond) {
8985         /* prepend cond if we have one */
8986         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
8987
8988         o->op_next = LINKLIST(cond);
8989         cond->op_next = (OP *) enterop;
8990     }
8991     else {
8992         /* This is a default {} block */
8993         enterop->op_flags |= OPf_SPECIAL;
8994         o      ->op_flags |= OPf_SPECIAL;
8995
8996         o->op_next = (OP *) enterop;
8997     }
8998
8999     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9000                                        entergiven and enterwhen both
9001                                        use ck_null() */
9002
9003     enterop->op_next = LINKLIST(block);
9004     block->op_next = enterop->op_other = o;
9005
9006     return o;
9007 }
9008
9009 /* Does this look like a boolean operation? For these purposes
9010    a boolean operation is:
9011      - a subroutine call [*]
9012      - a logical connective
9013      - a comparison operator
9014      - a filetest operator, with the exception of -s -M -A -C
9015      - defined(), exists() or eof()
9016      - /$re/ or $foo =~ /$re/
9017
9018    [*] possibly surprising
9019  */
9020 STATIC bool
9021 S_looks_like_bool(pTHX_ const OP *o)
9022 {
9023     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9024
9025     switch(o->op_type) {
9026         case OP_OR:
9027         case OP_DOR:
9028             return looks_like_bool(cLOGOPo->op_first);
9029
9030         case OP_AND:
9031         {
9032             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9033             ASSUME(sibl);
9034             return (
9035                 looks_like_bool(cLOGOPo->op_first)
9036              && looks_like_bool(sibl));
9037         }
9038
9039         case OP_NULL:
9040         case OP_SCALAR:
9041             return (
9042                 o->op_flags & OPf_KIDS
9043             && looks_like_bool(cUNOPo->op_first));
9044
9045         case OP_ENTERSUB:
9046
9047         case OP_NOT:    case OP_XOR:
9048
9049         case OP_EQ:     case OP_NE:     case OP_LT:
9050         case OP_GT:     case OP_LE:     case OP_GE:
9051
9052         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
9053         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
9054
9055         case OP_SEQ:    case OP_SNE:    case OP_SLT:
9056         case OP_SGT:    case OP_SLE:    case OP_SGE:
9057
9058         case OP_SMARTMATCH:
9059
9060         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9061         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9062         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9063         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9064         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9065         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9066         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9067         case OP_FTTEXT:   case OP_FTBINARY:
9068
9069         case OP_DEFINED: case OP_EXISTS:
9070         case OP_MATCH:   case OP_EOF:
9071
9072         case OP_FLOP:
9073
9074             return TRUE;
9075
9076         case OP_CONST:
9077             /* Detect comparisons that have been optimized away */
9078             if (cSVOPo->op_sv == &PL_sv_yes
9079             ||  cSVOPo->op_sv == &PL_sv_no)
9080
9081                 return TRUE;
9082             else
9083                 return FALSE;
9084
9085         /* FALLTHROUGH */
9086         default:
9087             return FALSE;
9088     }
9089 }
9090
9091 /*
9092 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9093
9094 Constructs, checks, and returns an op tree expressing a C<given> block.
9095 C<cond> supplies the expression to whose value C<$_> will be locally
9096 aliased, and C<block> supplies the body of the C<given> construct; they
9097 are consumed by this function and become part of the constructed op tree.
9098 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9099
9100 =cut
9101 */
9102
9103 OP *
9104 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9105 {
9106     PERL_ARGS_ASSERT_NEWGIVENOP;
9107     PERL_UNUSED_ARG(defsv_off);
9108
9109     assert(!defsv_off);
9110     return newGIVWHENOP(
9111         ref_array_or_hash(cond),
9112         block,
9113         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9114         0);
9115 }
9116
9117 /*
9118 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9119
9120 Constructs, checks, and returns an op tree expressing a C<when> block.
9121 C<cond> supplies the test expression, and C<block> supplies the block
9122 that will be executed if the test evaluates to true; they are consumed
9123 by this function and become part of the constructed op tree.  C<cond>
9124 will be interpreted DWIMically, often as a comparison against C<$_>,
9125 and may be null to generate a C<default> block.
9126
9127 =cut
9128 */
9129
9130 OP *
9131 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9132 {
9133     const bool cond_llb = (!cond || looks_like_bool(cond));
9134     OP *cond_op;
9135
9136     PERL_ARGS_ASSERT_NEWWHENOP;
9137
9138     if (cond_llb)
9139         cond_op = cond;
9140     else {
9141         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9142                 newDEFSVOP(),
9143                 scalar(ref_array_or_hash(cond)));
9144     }
9145
9146     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9147 }
9148
9149 /* must not conflict with SVf_UTF8 */
9150 #define CV_CKPROTO_CURSTASH     0x1
9151
9152 void
9153 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9154                     const STRLEN len, const U32 flags)
9155 {
9156     SV *name = NULL, *msg;
9157     const char * cvp = SvROK(cv)
9158                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9159                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9160                            : ""
9161                         : CvPROTO(cv);
9162     STRLEN clen = CvPROTOLEN(cv), plen = len;
9163
9164     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9165
9166     if (p == NULL && cvp == NULL)
9167         return;
9168
9169     if (!ckWARN_d(WARN_PROTOTYPE))
9170         return;
9171
9172     if (p && cvp) {
9173         p = S_strip_spaces(aTHX_ p, &plen);
9174         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9175         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9176             if (plen == clen && memEQ(cvp, p, plen))
9177                 return;
9178         } else {
9179             if (flags & SVf_UTF8) {
9180                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9181                     return;
9182             }
9183             else {
9184                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9185                     return;
9186             }
9187         }
9188     }
9189
9190     msg = sv_newmortal();
9191
9192     if (gv)
9193     {
9194         if (isGV(gv))
9195             gv_efullname3(name = sv_newmortal(), gv, NULL);
9196         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9197             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9198         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9199             name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9200             sv_catpvs(name, "::");
9201             if (SvROK(gv)) {
9202                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9203                 assert (CvNAMED(SvRV_const(gv)));
9204                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9205             }
9206             else sv_catsv(name, (SV *)gv);
9207         }
9208         else name = (SV *)gv;
9209     }
9210     sv_setpvs(msg, "Prototype mismatch:");
9211     if (name)
9212         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9213     if (cvp)
9214         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9215             UTF8fARG(SvUTF8(cv),clen,cvp)
9216         );
9217     else
9218         sv_catpvs(msg, ": none");
9219     sv_catpvs(msg, " vs ");
9220     if (p)
9221         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9222     else
9223         sv_catpvs(msg, "none");
9224     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9225 }
9226
9227 static void const_sv_xsub(pTHX_ CV* cv);
9228 static void const_av_xsub(pTHX_ CV* cv);
9229
9230 /*
9231
9232 =head1 Optree Manipulation Functions
9233
9234 =for apidoc cv_const_sv
9235
9236 If C<cv> is a constant sub eligible for inlining, returns the constant
9237 value returned by the sub.  Otherwise, returns C<NULL>.
9238
9239 Constant subs can be created with C<newCONSTSUB> or as described in
9240 L<perlsub/"Constant Functions">.
9241
9242 =cut
9243 */
9244 SV *
9245 Perl_cv_const_sv(const CV *const cv)
9246 {
9247     SV *sv;
9248     if (!cv)
9249         return NULL;
9250     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9251         return NULL;
9252     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9253     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9254     return sv;
9255 }
9256
9257 SV *
9258 Perl_cv_const_sv_or_av(const CV * const cv)
9259 {
9260     if (!cv)
9261         return NULL;
9262     if (SvROK(cv)) return SvRV((SV *)cv);
9263     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9264     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9265 }
9266
9267 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9268  * Can be called in 2 ways:
9269  *
9270  * !allow_lex
9271  *      look for a single OP_CONST with attached value: return the value
9272  *
9273  * allow_lex && !CvCONST(cv);
9274  *
9275  *      examine the clone prototype, and if contains only a single
9276  *      OP_CONST, return the value; or if it contains a single PADSV ref-
9277  *      erencing an outer lexical, turn on CvCONST to indicate the CV is
9278  *      a candidate for "constizing" at clone time, and return NULL.
9279  */
9280
9281 static SV *
9282 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9283 {
9284     SV *sv = NULL;
9285     bool padsv = FALSE;
9286
9287     assert(o);
9288     assert(cv);
9289
9290     for (; o; o = o->op_next) {
9291         const OPCODE type = o->op_type;
9292
9293         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9294              || type == OP_NULL
9295              || type == OP_PUSHMARK)
9296                 continue;
9297         if (type == OP_DBSTATE)
9298                 continue;
9299         if (type == OP_LEAVESUB)
9300             break;
9301         if (sv)
9302             return NULL;
9303         if (type == OP_CONST && cSVOPo->op_sv)
9304             sv = cSVOPo->op_sv;
9305         else if (type == OP_UNDEF && !o->op_private) {
9306             sv = newSV(0);
9307             SAVEFREESV(sv);
9308         }
9309         else if (allow_lex && type == OP_PADSV) {
9310                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9311                 {
9312                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9313                     padsv = TRUE;
9314                 }
9315                 else
9316                     return NULL;
9317         }
9318         else {
9319             return NULL;
9320         }
9321     }
9322     if (padsv) {
9323         CvCONST_on(cv);
9324         return NULL;
9325     }
9326     return sv;
9327 }
9328
9329 static void
9330 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9331                         PADNAME * const name, SV ** const const_svp)
9332 {
9333     assert (cv);
9334     assert (o || name);
9335     assert (const_svp);
9336     if (!block) {
9337         if (CvFLAGS(PL_compcv)) {
9338             /* might have had built-in attrs applied */
9339             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9340             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9341              && ckWARN(WARN_MISC))
9342             {
9343                 /* protect against fatal warnings leaking compcv */
9344                 SAVEFREESV(PL_compcv);
9345                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9346                 SvREFCNT_inc_simple_void_NN(PL_compcv);
9347             }
9348             CvFLAGS(cv) |=
9349                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9350                   & ~(CVf_LVALUE * pureperl));
9351         }
9352         return;
9353     }
9354
9355     /* redundant check for speed: */
9356     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9357         const line_t oldline = CopLINE(PL_curcop);
9358         SV *namesv = o
9359             ? cSVOPo->op_sv
9360             : sv_2mortal(newSVpvn_utf8(
9361                 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9362               ));
9363         if (PL_parser && PL_parser->copline != NOLINE)
9364             /* This ensures that warnings are reported at the first
9365                line of a redefinition, not the last.  */
9366             CopLINE_set(PL_curcop, PL_parser->copline);
9367         /* protect against fatal warnings leaking compcv */
9368         SAVEFREESV(PL_compcv);
9369         report_redefined_cv(namesv, cv, const_svp);
9370         SvREFCNT_inc_simple_void_NN(PL_compcv);
9371         CopLINE_set(PL_curcop, oldline);
9372     }
9373     SAVEFREESV(cv);
9374     return;
9375 }
9376
9377 CV *
9378 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9379 {
9380     CV **spot;
9381     SV **svspot;
9382     const char *ps;
9383     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9384     U32 ps_utf8 = 0;
9385     CV *cv = NULL;
9386     CV *compcv = PL_compcv;
9387     SV *const_sv;
9388     PADNAME *name;
9389     PADOFFSET pax = o->op_targ;
9390     CV *outcv = CvOUTSIDE(PL_compcv);
9391     CV *clonee = NULL;
9392     HEK *hek = NULL;
9393     bool reusable = FALSE;
9394     OP *start = NULL;
9395 #ifdef PERL_DEBUG_READONLY_OPS
9396     OPSLAB *slab = NULL;
9397 #endif
9398
9399     PERL_ARGS_ASSERT_NEWMYSUB;
9400
9401     PL_hints |= HINT_BLOCK_SCOPE;
9402
9403     /* Find the pad slot for storing the new sub.
9404        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
9405        need to look in CvOUTSIDE and find the pad belonging to the enclos-
9406        ing sub.  And then we need to dig deeper if this is a lexical from
9407        outside, as in:
9408            my sub foo; sub { sub foo { } }
9409      */
9410   redo:
9411     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9412     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9413         pax = PARENT_PAD_INDEX(name);
9414         outcv = CvOUTSIDE(outcv);
9415         assert(outcv);
9416         goto redo;
9417     }
9418     svspot =
9419         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9420                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9421     spot = (CV **)svspot;
9422
9423     if (!(PL_parser && PL_parser->error_count))
9424         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9425
9426     if (proto) {
9427         assert(proto->op_type == OP_CONST);
9428         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9429         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9430     }
9431     else
9432         ps = NULL;
9433
9434     if (proto)
9435         SAVEFREEOP(proto);
9436     if (attrs)
9437         SAVEFREEOP(attrs);
9438
9439     if (PL_parser && PL_parser->error_count) {
9440         op_free(block);
9441         SvREFCNT_dec(PL_compcv);
9442         PL_compcv = 0;
9443         goto done;
9444     }
9445
9446     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9447         cv = *spot;
9448         svspot = (SV **)(spot = &clonee);
9449     }
9450     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9451         cv = *spot;
9452     else {
9453         assert (SvTYPE(*spot) == SVt_PVCV);
9454         if (CvNAMED(*spot))
9455             hek = CvNAME_HEK(*spot);
9456         else {
9457             dVAR;
9458             U32 hash;
9459             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9460             CvNAME_HEK_set(*spot, hek =
9461                 share_hek(
9462                     PadnamePV(name)+1,
9463                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9464                     hash
9465                 )
9466             );
9467             CvLEXICAL_on(*spot);
9468         }
9469         cv = PadnamePROTOCV(name);
9470         svspot = (SV **)(spot = &PadnamePROTOCV(name));
9471     }
9472
9473     if (block) {
9474         /* This makes sub {}; work as expected.  */
9475         if (block->op_type == OP_STUB) {
9476             const line_t l = PL_parser->copline;
9477             op_free(block);
9478             block = newSTATEOP(0, NULL, 0);
9479             PL_parser->copline = l;
9480         }
9481         block = CvLVALUE(compcv)
9482              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9483                    ? newUNOP(OP_LEAVESUBLV, 0,
9484                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9485                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9486         start = LINKLIST(block);
9487         block->op_next = 0;
9488         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9489             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9490         else
9491             const_sv = NULL;
9492     }
9493     else
9494         const_sv = NULL;
9495
9496     if (cv) {
9497         const bool exists = CvROOT(cv) || CvXSUB(cv);
9498
9499         /* if the subroutine doesn't exist and wasn't pre-declared
9500          * with a prototype, assume it will be AUTOLOADed,
9501          * skipping the prototype check
9502          */
9503         if (exists || SvPOK(cv))
9504             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9505                                  ps_utf8);
9506         /* already defined? */
9507         if (exists) {
9508             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9509             if (block)
9510                 cv = NULL;
9511             else {
9512                 if (attrs)
9513                     goto attrs;
9514                 /* just a "sub foo;" when &foo is already defined */
9515                 SAVEFREESV(compcv);
9516                 goto done;
9517             }
9518         }
9519         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9520             cv = NULL;
9521             reusable = TRUE;
9522         }
9523     }
9524
9525     if (const_sv) {
9526         SvREFCNT_inc_simple_void_NN(const_sv);
9527         SvFLAGS(const_sv) |= SVs_PADTMP;
9528         if (cv) {
9529             assert(!CvROOT(cv) && !CvCONST(cv));
9530             cv_forget_slab(cv);
9531         }
9532         else {
9533             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9534             CvFILE_set_from_cop(cv, PL_curcop);
9535             CvSTASH_set(cv, PL_curstash);
9536             *spot = cv;
9537         }
9538         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
9539         CvXSUBANY(cv).any_ptr = const_sv;
9540         CvXSUB(cv) = const_sv_xsub;
9541         CvCONST_on(cv);
9542         CvISXSUB_on(cv);
9543         PoisonPADLIST(cv);
9544         CvFLAGS(cv) |= CvMETHOD(compcv);
9545         op_free(block);
9546         SvREFCNT_dec(compcv);
9547         PL_compcv = NULL;
9548         goto setname;
9549     }
9550
9551     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9552        determine whether this sub definition is in the same scope as its
9553        declaration.  If this sub definition is inside an inner named pack-
9554        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9555        the package sub.  So check PadnameOUTER(name) too.
9556      */
9557     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9558         assert(!CvWEAKOUTSIDE(compcv));
9559         SvREFCNT_dec(CvOUTSIDE(compcv));
9560         CvWEAKOUTSIDE_on(compcv);
9561     }
9562     /* XXX else do we have a circular reference? */
9563
9564     if (cv) {   /* must reuse cv in case stub is referenced elsewhere */
9565         /* transfer PL_compcv to cv */
9566         if (block) {
9567             cv_flags_t preserved_flags =
9568                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9569             PADLIST *const temp_padl = CvPADLIST(cv);
9570             CV *const temp_cv = CvOUTSIDE(cv);
9571             const cv_flags_t other_flags =
9572                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9573             OP * const cvstart = CvSTART(cv);
9574
9575             SvPOK_off(cv);
9576             CvFLAGS(cv) =
9577                 CvFLAGS(compcv) | preserved_flags;
9578             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9579             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9580             CvPADLIST_set(cv, CvPADLIST(compcv));
9581             CvOUTSIDE(compcv) = temp_cv;
9582             CvPADLIST_set(compcv, temp_padl);
9583             CvSTART(cv) = CvSTART(compcv);
9584             CvSTART(compcv) = cvstart;
9585             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9586             CvFLAGS(compcv) |= other_flags;
9587
9588             if (CvFILE(cv) && CvDYNFILE(cv)) {
9589                 Safefree(CvFILE(cv));
9590             }
9591
9592             /* inner references to compcv must be fixed up ... */
9593             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9594             if (PERLDB_INTER)/* Advice debugger on the new sub. */
9595                 ++PL_sub_generation;
9596         }
9597         else {
9598             /* Might have had built-in attributes applied -- propagate them. */
9599             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9600         }
9601         /* ... before we throw it away */
9602         SvREFCNT_dec(compcv);
9603         PL_compcv = compcv = cv;
9604     }
9605     else {
9606         cv = compcv;
9607         *spot = cv;
9608     }
9609
9610   setname:
9611     CvLEXICAL_on(cv);
9612     if (!CvNAME_HEK(cv)) {
9613         if (hek) (void)share_hek_hek(hek);
9614         else {
9615             dVAR;
9616             U32 hash;
9617             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9618             hek = share_hek(PadnamePV(name)+1,
9619                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9620                       hash);
9621         }
9622         CvNAME_HEK_set(cv, hek);
9623     }
9624
9625     if (const_sv)
9626         goto clone;
9627
9628     CvFILE_set_from_cop(cv, PL_curcop);
9629     CvSTASH_set(cv, PL_curstash);
9630
9631     if (ps) {
9632         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9633         if (ps_utf8)
9634             SvUTF8_on(MUTABLE_SV(cv));
9635     }
9636
9637     if (block) {
9638         /* If we assign an optree to a PVCV, then we've defined a
9639          * subroutine that the debugger could be able to set a breakpoint
9640          * in, so signal to pp_entereval that it should not throw away any
9641          * saved lines at scope exit.  */
9642
9643         PL_breakable_sub_gen++;
9644         CvROOT(cv) = block;
9645         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9646            itself has a refcount. */
9647         CvSLABBED_off(cv);
9648         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9649 #ifdef PERL_DEBUG_READONLY_OPS
9650         slab = (OPSLAB *)CvSTART(cv);
9651 #endif
9652         S_process_optree(aTHX_ cv, block, start);
9653     }
9654
9655   attrs:
9656     if (attrs) {
9657         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9658         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9659     }
9660
9661     if (block) {
9662         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9663             SV * const tmpstr = sv_newmortal();
9664             GV * const db_postponed = gv_fetchpvs("DB::postponed",
9665                                                   GV_ADDMULTI, SVt_PVHV);
9666             HV *hv;
9667             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9668                                           CopFILE(PL_curcop),
9669                                           (long)PL_subline,
9670                                           (long)CopLINE(PL_curcop));
9671             if (HvNAME_HEK(PL_curstash)) {
9672                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9673                 sv_catpvs(tmpstr, "::");
9674             }
9675             else
9676                 sv_setpvs(tmpstr, "__ANON__::");
9677
9678             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9679                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9680             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9681                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9682             hv = GvHVn(db_postponed);
9683             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9684                 CV * const pcv = GvCV(db_postponed);
9685                 if (pcv) {
9686                     dSP;
9687                     PUSHMARK(SP);
9688                     XPUSHs(tmpstr);
9689                     PUTBACK;
9690                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
9691                 }
9692             }
9693         }
9694     }
9695
9696   clone:
9697     if (clonee) {
9698         assert(CvDEPTH(outcv));
9699         spot = (CV **)
9700             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9701         if (reusable)
9702             cv_clone_into(clonee, *spot);
9703         else *spot = cv_clone(clonee);
9704         SvREFCNT_dec_NN(clonee);
9705         cv = *spot;
9706     }
9707
9708     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9709         PADOFFSET depth = CvDEPTH(outcv);
9710         while (--depth) {
9711             SV *oldcv;
9712             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9713             oldcv = *svspot;
9714             *svspot = SvREFCNT_inc_simple_NN(cv);
9715             SvREFCNT_dec(oldcv);
9716         }
9717     }
9718
9719   done:
9720     if (PL_parser)
9721         PL_parser->copline = NOLINE;
9722     LEAVE_SCOPE(floor);
9723 #ifdef PERL_DEBUG_READONLY_OPS
9724     if (slab)
9725         Slab_to_ro(slab);
9726 #endif
9727     op_free(o);
9728     return cv;
9729 }
9730
9731 /*
9732 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9733
9734 Construct a Perl subroutine, also performing some surrounding jobs.
9735
9736 This function is expected to be called in a Perl compilation context,
9737 and some aspects of the subroutine are taken from global variables
9738 associated with compilation.  In particular, C<PL_compcv> represents
9739 the subroutine that is currently being compiled.  It must be non-null
9740 when this function is called, and some aspects of the subroutine being
9741 constructed are taken from it.  The constructed subroutine may actually
9742 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9743
9744 If C<block> is null then the subroutine will have no body, and for the
9745 time being it will be an error to call it.  This represents a forward
9746 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
9747 non-null then it provides the Perl code of the subroutine body, which
9748 will be executed when the subroutine is called.  This body includes
9749 any argument unwrapping code resulting from a subroutine signature or
9750 similar.  The pad use of the code must correspond to the pad attached
9751 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
9752 C<leavesublv> op; this function will add such an op.  C<block> is consumed
9753 by this function and will become part of the constructed subroutine.
9754
9755 C<proto> specifies the subroutine's prototype, unless one is supplied
9756 as an attribute (see below).  If C<proto> is null, then the subroutine
9757 will not have a prototype.  If C<proto> is non-null, it must point to a
9758 C<const> op whose value is a string, and the subroutine will have that
9759 string as its prototype.  If a prototype is supplied as an attribute, the
9760 attribute takes precedence over C<proto>, but in that case C<proto> should
9761 preferably be null.  In any case, C<proto> is consumed by this function.
9762
9763 C<attrs> supplies attributes to be applied the subroutine.  A handful of
9764 attributes take effect by built-in means, being applied to C<PL_compcv>
9765 immediately when seen.  Other attributes are collected up and attached
9766 to the subroutine by this route.  C<attrs> may be null to supply no
9767 attributes, or point to a C<const> op for a single attribute, or point
9768 to a C<list> op whose children apart from the C<pushmark> are C<const>
9769 ops for one or more attributes.  Each C<const> op must be a string,
9770 giving the attribute name optionally followed by parenthesised arguments,
9771 in the manner in which attributes appear in Perl source.  The attributes
9772 will be applied to the sub by this function.  C<attrs> is consumed by
9773 this function.
9774
9775 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9776 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
9777 must point to a C<const> op, which will be consumed by this function,
9778 and its string value supplies a name for the subroutine.  The name may
9779 be qualified or unqualified, and if it is unqualified then a default
9780 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
9781 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9782 by which the subroutine will be named.
9783
9784 If there is already a subroutine of the specified name, then the new
9785 sub will either replace the existing one in the glob or be merged with
9786 the existing one.  A warning may be generated about redefinition.
9787
9788 If the subroutine has one of a few special names, such as C<BEGIN> or
9789 C<END>, then it will be claimed by the appropriate queue for automatic
9790 running of phase-related subroutines.  In this case the relevant glob will
9791 be left not containing any subroutine, even if it did contain one before.
9792 In the case of C<BEGIN>, the subroutine will be executed and the reference
9793 to it disposed of before this function returns.
9794
9795 The function returns a pointer to the constructed subroutine.  If the sub
9796 is anonymous then ownership of one counted reference to the subroutine
9797 is transferred to the caller.  If the sub is named then the caller does
9798 not get ownership of a reference.  In most such cases, where the sub
9799 has a non-phase name, the sub will be alive at the point it is returned
9800 by virtue of being contained in the glob that names it.  A phase-named
9801 subroutine will usually be alive by virtue of the reference owned by the
9802 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
9803 been executed, will quite likely have been destroyed already by the
9804 time this function returns, making it erroneous for the caller to make
9805 any use of the returned pointer.  It is the caller's responsibility to
9806 ensure that it knows which of these situations applies.
9807
9808 =cut
9809 */
9810
9811 /* _x = extended */
9812 CV *
9813 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9814                             OP *block, bool o_is_gv)
9815 {
9816     GV *gv;
9817     const char *ps;
9818     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9819     U32 ps_utf8 = 0;
9820     CV *cv = NULL;     /* the previous CV with this name, if any */
9821     SV *const_sv;
9822     const bool ec = PL_parser && PL_parser->error_count;
9823     /* If the subroutine has no body, no attributes, and no builtin attributes
9824        then it's just a sub declaration, and we may be able to get away with
9825        storing with a placeholder scalar in the symbol table, rather than a
9826        full CV.  If anything is present then it will take a full CV to
9827        store it.  */
9828     const I32 gv_fetch_flags
9829         = ec ? GV_NOADD_NOINIT :
9830         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9831         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9832     STRLEN namlen = 0;
9833     const char * const name =
9834          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9835     bool has_name;
9836     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9837     bool evanescent = FALSE;
9838     OP *start = NULL;
9839 #ifdef PERL_DEBUG_READONLY_OPS
9840     OPSLAB *slab = NULL;
9841 #endif
9842
9843     if (o_is_gv) {
9844         gv = (GV*)o;
9845         o = NULL;
9846         has_name = TRUE;
9847     } else if (name) {
9848         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
9849            hek and CvSTASH pointer together can imply the GV.  If the name
9850            contains a package name, then GvSTASH(CvGV(cv)) may differ from
9851            CvSTASH, so forego the optimisation if we find any.
9852            Also, we may be called from load_module at run time, so
9853            PL_curstash (which sets CvSTASH) may not point to the stash the
9854            sub is stored in.  */
9855         /* XXX This optimization is currently disabled for packages other
9856                than main, since there was too much CPAN breakage.  */
9857         const I32 flags =
9858            ec ? GV_NOADD_NOINIT
9859               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9860                || PL_curstash != PL_defstash
9861                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9862                     ? gv_fetch_flags
9863                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9864         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9865         has_name = TRUE;
9866     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9867         SV * const sv = sv_newmortal();
9868         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9869                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9870                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9871         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9872         has_name = TRUE;
9873     } else if (PL_curstash) {
9874         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9875         has_name = FALSE;
9876     } else {
9877         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9878         has_name = FALSE;
9879     }
9880
9881     if (!ec) {
9882         if (isGV(gv)) {
9883             move_proto_attr(&proto, &attrs, gv, 0);
9884         } else {
9885             assert(cSVOPo);
9886             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9887         }
9888     }
9889
9890     if (proto) {
9891         assert(proto->op_type == OP_CONST);
9892         ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9893         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9894     }
9895     else
9896         ps = NULL;
9897
9898     if (o)
9899         SAVEFREEOP(o);
9900     if (proto)
9901         SAVEFREEOP(proto);
9902     if (attrs)
9903         SAVEFREEOP(attrs);
9904
9905     if (ec) {
9906         op_free(block);
9907
9908         if (name)
9909             SvREFCNT_dec(PL_compcv);
9910         else
9911             cv = PL_compcv;
9912
9913         PL_compcv = 0;
9914         if (name && block) {
9915             const char *s = (char *) my_memrchr(name, ':', namlen);
9916             s = s ? s+1 : name;
9917             if (strEQ(s, "BEGIN")) {
9918                 if (PL_in_eval & EVAL_KEEPERR)
9919                     Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9920                 else {
9921                     SV * const errsv = ERRSV;
9922                     /* force display of errors found but not reported */
9923                     sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9924                     Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9925                 }
9926             }
9927         }
9928         goto done;
9929     }
9930
9931     if (!block && SvTYPE(gv) != SVt_PVGV) {
9932         /* If we are not defining a new sub and the existing one is not a
9933            full GV + CV... */
9934         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
9935             /* We are applying attributes to an existing sub, so we need it
9936                upgraded if it is a constant.  */
9937             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
9938                 gv_init_pvn(gv, PL_curstash, name, namlen,
9939                             SVf_UTF8 * name_is_utf8);
9940         }
9941         else {                  /* Maybe prototype now, and had at maximum
9942                                    a prototype or const/sub ref before.  */
9943             if (SvTYPE(gv) > SVt_NULL) {
9944                 cv_ckproto_len_flags((const CV *)gv,
9945                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
9946                                     ps_len, ps_utf8);
9947             }
9948
9949             if (!SvROK(gv)) {
9950                 if (ps) {
9951                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
9952                     if (ps_utf8)
9953                         SvUTF8_on(MUTABLE_SV(gv));
9954                 }
9955                 else
9956                     sv_setiv(MUTABLE_SV(gv), -1);
9957             }
9958
9959             SvREFCNT_dec(PL_compcv);
9960             cv = PL_compcv = NULL;
9961             goto done;
9962         }
9963     }
9964
9965     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
9966         ? NULL
9967         : isGV(gv)
9968             ? GvCV(gv)
9969             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
9970                 ? (CV *)SvRV(gv)
9971                 : NULL;
9972
9973     if (block) {
9974         assert(PL_parser);
9975         /* This makes sub {}; work as expected.  */
9976         if (block->op_type == OP_STUB) {
9977             const line_t l = PL_parser->copline;
9978             op_free(block);
9979             block = newSTATEOP(0, NULL, 0);
9980             PL_parser->copline = l;
9981         }
9982         block = CvLVALUE(PL_compcv)
9983              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
9984                     && (!isGV(gv) || !GvASSUMECV(gv)))
9985                    ? newUNOP(OP_LEAVESUBLV, 0,
9986                              op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9987                    : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9988         start = LINKLIST(block);
9989         block->op_next = 0;
9990         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
9991             const_sv =
9992                 S_op_const_sv(aTHX_ start, PL_compcv,
9993                                         cBOOL(CvCLONE(PL_compcv)));
9994         else
9995             const_sv = NULL;
9996     }
9997     else
9998         const_sv = NULL;
9999
10000     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10001         cv_ckproto_len_flags((const CV *)gv,
10002                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10003                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10004         if (SvROK(gv)) {
10005             /* All the other code for sub redefinition warnings expects the
10006                clobbered sub to be a CV.  Instead of making all those code
10007                paths more complex, just inline the RV version here.  */
10008             const line_t oldline = CopLINE(PL_curcop);
10009             assert(IN_PERL_COMPILETIME);
10010             if (PL_parser && PL_parser->copline != NOLINE)
10011                 /* This ensures that warnings are reported at the first
10012                    line of a redefinition, not the last.  */
10013                 CopLINE_set(PL_curcop, PL_parser->copline);
10014             /* protect against fatal warnings leaking compcv */
10015             SAVEFREESV(PL_compcv);
10016
10017             if (ckWARN(WARN_REDEFINE)
10018              || (  ckWARN_d(WARN_REDEFINE)
10019                 && (  !const_sv || SvRV(gv) == const_sv
10020                    || sv_cmp(SvRV(gv), const_sv)  ))) {
10021                 assert(cSVOPo);
10022                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10023                           "Constant subroutine %" SVf " redefined",
10024                           SVfARG(cSVOPo->op_sv));
10025             }
10026
10027             SvREFCNT_inc_simple_void_NN(PL_compcv);
10028             CopLINE_set(PL_curcop, oldline);
10029             SvREFCNT_dec(SvRV(gv));
10030         }
10031     }
10032
10033     if (cv) {
10034         const bool exists = CvROOT(cv) || CvXSUB(cv);
10035
10036         /* if the subroutine doesn't exist and wasn't pre-declared
10037          * with a prototype, assume it will be AUTOLOADed,
10038          * skipping the prototype check
10039          */
10040         if (exists || SvPOK(cv))
10041             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10042         /* already defined (or promised)? */
10043         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10044             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10045             if (block)
10046                 cv = NULL;
10047             else {
10048                 if (attrs)
10049                     goto attrs;
10050                 /* just a "sub foo;" when &foo is already defined */
10051                 SAVEFREESV(PL_compcv);
10052                 goto done;
10053             }
10054         }
10055     }
10056
10057     if (const_sv) {
10058         SvREFCNT_inc_simple_void_NN(const_sv);
10059         SvFLAGS(const_sv) |= SVs_PADTMP;
10060         if (cv) {
10061             assert(!CvROOT(cv) && !CvCONST(cv));
10062             cv_forget_slab(cv);
10063             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10064             CvXSUBANY(cv).any_ptr = const_sv;
10065             CvXSUB(cv) = const_sv_xsub;
10066             CvCONST_on(cv);
10067             CvISXSUB_on(cv);
10068             PoisonPADLIST(cv);
10069             CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10070         }
10071         else {
10072             if (isGV(gv) || CvMETHOD(PL_compcv)) {
10073                 if (name && isGV(gv))
10074                     GvCV_set(gv, NULL);
10075                 cv = newCONSTSUB_flags(
10076                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10077                     const_sv
10078                 );
10079                 assert(cv);
10080                 assert(SvREFCNT((SV*)cv) != 0);
10081                 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10082             }
10083             else {
10084                 if (!SvROK(gv)) {
10085                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10086                     prepare_SV_for_RV((SV *)gv);
10087                     SvOK_off((SV *)gv);
10088                     SvROK_on(gv);
10089                 }
10090                 SvRV_set(gv, const_sv);
10091             }
10092         }
10093         op_free(block);
10094         SvREFCNT_dec(PL_compcv);
10095         PL_compcv = NULL;
10096         goto done;
10097     }
10098
10099     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10100     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10101         cv = NULL;
10102
10103     if (cv) {                           /* must reuse cv if autoloaded */
10104         /* transfer PL_compcv to cv */
10105         if (block) {
10106             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10107             PADLIST *const temp_av = CvPADLIST(cv);
10108             CV *const temp_cv = CvOUTSIDE(cv);
10109             const cv_flags_t other_flags =
10110                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10111             OP * const cvstart = CvSTART(cv);
10112
10113             if (isGV(gv)) {
10114                 CvGV_set(cv,gv);
10115                 assert(!CvCVGV_RC(cv));
10116                 assert(CvGV(cv) == gv);
10117             }
10118             else {
10119                 dVAR;
10120                 U32 hash;
10121                 PERL_HASH(hash, name, namlen);
10122                 CvNAME_HEK_set(cv,
10123                                share_hek(name,
10124                                          name_is_utf8
10125                                             ? -(SSize_t)namlen
10126                                             :  (SSize_t)namlen,
10127                                          hash));
10128             }
10129
10130             SvPOK_off(cv);
10131             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10132                                              | CvNAMED(cv);
10133             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10134             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10135             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10136             CvOUTSIDE(PL_compcv) = temp_cv;
10137             CvPADLIST_set(PL_compcv, temp_av);
10138             CvSTART(cv) = CvSTART(PL_compcv);
10139             CvSTART(PL_compcv) = cvstart;
10140             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10141             CvFLAGS(PL_compcv) |= other_flags;
10142
10143             if (CvFILE(cv) && CvDYNFILE(cv)) {
10144                 Safefree(CvFILE(cv));
10145             }
10146             CvFILE_set_from_cop(cv, PL_curcop);
10147             CvSTASH_set(cv, PL_curstash);
10148
10149             /* inner references to PL_compcv must be fixed up ... */
10150             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10151             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10152                 ++PL_sub_generation;
10153         }
10154         else {
10155             /* Might have had built-in attributes applied -- propagate them. */
10156             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10157         }
10158         /* ... before we throw it away */
10159         SvREFCNT_dec(PL_compcv);
10160         PL_compcv = cv;
10161     }
10162     else {
10163         cv = PL_compcv;
10164         if (name && isGV(gv)) {
10165             GvCV_set(gv, cv);
10166             GvCVGEN(gv) = 0;
10167             if (HvENAME_HEK(GvSTASH(gv)))
10168                 /* sub Foo::bar { (shift)+1 } */
10169                 gv_method_changed(gv);
10170         }
10171         else if (name) {
10172             if (!SvROK(gv)) {
10173                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10174                 prepare_SV_for_RV((SV *)gv);
10175                 SvOK_off((SV *)gv);
10176                 SvROK_on(gv);
10177             }
10178             SvRV_set(gv, (SV *)cv);
10179             if (HvENAME_HEK(PL_curstash))
10180                 mro_method_changed_in(PL_curstash);
10181         }
10182     }
10183     assert(cv);
10184     assert(SvREFCNT((SV*)cv) != 0);
10185
10186     if (!CvHASGV(cv)) {
10187         if (isGV(gv))
10188             CvGV_set(cv, gv);
10189         else {
10190             dVAR;
10191             U32 hash;
10192             PERL_HASH(hash, name, namlen);
10193             CvNAME_HEK_set(cv, share_hek(name,
10194                                          name_is_utf8
10195                                             ? -(SSize_t)namlen
10196                                             :  (SSize_t)namlen,
10197                                          hash));
10198         }
10199         CvFILE_set_from_cop(cv, PL_curcop);
10200         CvSTASH_set(cv, PL_curstash);
10201     }
10202
10203     if (ps) {
10204         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10205         if ( ps_utf8 )
10206             SvUTF8_on(MUTABLE_SV(cv));
10207     }
10208
10209     if (block) {
10210         /* If we assign an optree to a PVCV, then we've defined a
10211          * subroutine that the debugger could be able to set a breakpoint
10212          * in, so signal to pp_entereval that it should not throw away any
10213          * saved lines at scope exit.  */
10214
10215         PL_breakable_sub_gen++;
10216         CvROOT(cv) = block;
10217         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10218            itself has a refcount. */
10219         CvSLABBED_off(cv);
10220         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10221 #ifdef PERL_DEBUG_READONLY_OPS
10222         slab = (OPSLAB *)CvSTART(cv);
10223 #endif
10224         S_process_optree(aTHX_ cv, block, start);
10225     }
10226
10227   attrs:
10228     if (attrs) {
10229         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10230         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10231                         ? GvSTASH(CvGV(cv))
10232                         : PL_curstash;
10233         if (!name)
10234             SAVEFREESV(cv);
10235         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10236         if (!name)
10237             SvREFCNT_inc_simple_void_NN(cv);
10238     }
10239
10240     if (block && has_name) {
10241         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10242             SV * const tmpstr = cv_name(cv,NULL,0);
10243             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10244                                                   GV_ADDMULTI, SVt_PVHV);
10245             HV *hv;
10246             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10247                                           CopFILE(PL_curcop),
10248                                           (long)PL_subline,
10249                                           (long)CopLINE(PL_curcop));
10250             (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10251                     SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10252             hv = GvHVn(db_postponed);
10253             if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10254                 CV * const pcv = GvCV(db_postponed);
10255                 if (pcv) {
10256                     dSP;
10257                     PUSHMARK(SP);
10258                     XPUSHs(tmpstr);
10259                     PUTBACK;
10260                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10261                 }
10262             }
10263         }
10264
10265         if (name) {
10266             if (PL_parser && PL_parser->error_count)
10267                 clear_special_blocks(name, gv, cv);
10268             else
10269                 evanescent =
10270                     process_special_blocks(floor, name, gv, cv);
10271         }
10272     }
10273     assert(cv);
10274
10275   done:
10276     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10277     if (PL_parser)
10278         PL_parser->copline = NOLINE;
10279     LEAVE_SCOPE(floor);
10280
10281     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10282     if (!evanescent) {
10283 #ifdef PERL_DEBUG_READONLY_OPS
10284     if (slab)
10285         Slab_to_ro(slab);
10286 #endif
10287     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10288         pad_add_weakref(cv);
10289     }
10290     return cv;
10291 }
10292
10293 STATIC void
10294 S_clear_special_blocks(pTHX_ const char *const fullname,
10295                        GV *const gv, CV *const cv) {
10296     const char *colon;
10297     const char *name;
10298
10299     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10300
10301     colon = strrchr(fullname,':');
10302     name = colon ? colon + 1 : fullname;
10303
10304     if ((*name == 'B' && strEQ(name, "BEGIN"))
10305         || (*name == 'E' && strEQ(name, "END"))
10306         || (*name == 'U' && strEQ(name, "UNITCHECK"))
10307         || (*name == 'C' && strEQ(name, "CHECK"))
10308         || (*name == 'I' && strEQ(name, "INIT"))) {
10309         if (!isGV(gv)) {
10310             (void)CvGV(cv);
10311             assert(isGV(gv));
10312         }
10313         GvCV_set(gv, NULL);
10314         SvREFCNT_dec_NN(MUTABLE_SV(cv));
10315     }
10316 }
10317
10318 /* Returns true if the sub has been freed.  */
10319 STATIC bool
10320 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10321                          GV *const gv,
10322                          CV *const cv)
10323 {
10324     const char *const colon = strrchr(fullname,':');
10325     const char *const name = colon ? colon + 1 : fullname;
10326
10327     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10328
10329     if (*name == 'B') {
10330         if (strEQ(name, "BEGIN")) {
10331             const I32 oldscope = PL_scopestack_ix;
10332             dSP;
10333             (void)CvGV(cv);
10334             if (floor) LEAVE_SCOPE(floor);
10335             ENTER;
10336             PUSHSTACKi(PERLSI_REQUIRE);
10337             SAVECOPFILE(&PL_compiling);
10338             SAVECOPLINE(&PL_compiling);
10339             SAVEVPTR(PL_curcop);
10340
10341             DEBUG_x( dump_sub(gv) );
10342             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10343             GvCV_set(gv,0);             /* cv has been hijacked */
10344             call_list(oldscope, PL_beginav);
10345
10346             POPSTACK;
10347             LEAVE;
10348             return !PL_savebegin;
10349         }
10350         else
10351             return FALSE;
10352     } else {
10353         if (*name == 'E') {
10354             if strEQ(name, "END") {
10355                 DEBUG_x( dump_sub(gv) );
10356                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10357             } else
10358                 return FALSE;
10359         } else if (*name == 'U') {
10360             if (strEQ(name, "UNITCHECK")) {
10361                 /* It's never too late to run a unitcheck block */
10362                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10363             }
10364             else
10365                 return FALSE;
10366         } else if (*name == 'C') {
10367             if (strEQ(name, "CHECK")) {
10368                 if (PL_main_start)
10369                     /* diag_listed_as: Too late to run %s block */
10370                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10371                                    "Too late to run CHECK block");
10372                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10373             }
10374             else
10375                 return FALSE;
10376         } else if (*name == 'I') {
10377             if (strEQ(name, "INIT")) {
10378                 if (PL_main_start)
10379                     /* diag_listed_as: Too late to run %s block */
10380                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10381                                    "Too late to run INIT block");
10382                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10383             }
10384             else
10385                 return FALSE;
10386         } else
10387             return FALSE;
10388         DEBUG_x( dump_sub(gv) );
10389         (void)CvGV(cv);
10390         GvCV_set(gv,0);         /* cv has been hijacked */
10391         return FALSE;
10392     }
10393 }
10394
10395 /*
10396 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10397
10398 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10399 rather than of counted length, and no flags are set.  (This means that
10400 C<name> is always interpreted as Latin-1.)
10401
10402 =cut
10403 */
10404
10405 CV *
10406 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10407 {
10408     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10409 }
10410
10411 /*
10412 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10413
10414 Construct a constant subroutine, also performing some surrounding
10415 jobs.  A scalar constant-valued subroutine is eligible for inlining
10416 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10417 123 }>>.  Other kinds of constant subroutine have other treatment.
10418
10419 The subroutine will have an empty prototype and will ignore any arguments
10420 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
10421 is null, the subroutine will yield an empty list.  If C<sv> points to a
10422 scalar, the subroutine will always yield that scalar.  If C<sv> points
10423 to an array, the subroutine will always yield a list of the elements of
10424 that array in list context, or the number of elements in the array in
10425 scalar context.  This function takes ownership of one counted reference
10426 to the scalar or array, and will arrange for the object to live as long
10427 as the subroutine does.  If C<sv> points to a scalar then the inlining
10428 assumes that the value of the scalar will never change, so the caller
10429 must ensure that the scalar is not subsequently written to.  If C<sv>
10430 points to an array then no such assumption is made, so it is ostensibly
10431 safe to mutate the array or its elements, but whether this is really
10432 supported has not been determined.
10433
10434 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10435 Other aspects of the subroutine will be left in their default state.
10436 The caller is free to mutate the subroutine beyond its initial state
10437 after this function has returned.
10438
10439 If C<name> is null then the subroutine will be anonymous, with its
10440 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10441 subroutine will be named accordingly, referenced by the appropriate glob.
10442 C<name> is a string of length C<len> bytes giving a sigilless symbol
10443 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10444 otherwise.  The name may be either qualified or unqualified.  If the
10445 name is unqualified then it defaults to being in the stash specified by
10446 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10447 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10448 semantics.
10449
10450 C<flags> should not have bits set other than C<SVf_UTF8>.
10451
10452 If there is already a subroutine of the specified name, then the new sub
10453 will replace the existing one in the glob.  A warning may be generated
10454 about the redefinition.
10455
10456 If the subroutine has one of a few special names, such as C<BEGIN> or
10457 C<END>, then it will be claimed by the appropriate queue for automatic
10458 running of phase-related subroutines.  In this case the relevant glob will
10459 be left not containing any subroutine, even if it did contain one before.
10460 Execution of the subroutine will likely be a no-op, unless C<sv> was
10461 a tied array or the caller modified the subroutine in some interesting
10462 way before it was executed.  In the case of C<BEGIN>, the treatment is
10463 buggy: the sub will be executed when only half built, and may be deleted
10464 prematurely, possibly causing a crash.
10465
10466 The function returns a pointer to the constructed subroutine.  If the sub
10467 is anonymous then ownership of one counted reference to the subroutine
10468 is transferred to the caller.  If the sub is named then the caller does
10469 not get ownership of a reference.  In most such cases, where the sub
10470 has a non-phase name, the sub will be alive at the point it is returned
10471 by virtue of being contained in the glob that names it.  A phase-named
10472 subroutine will usually be alive by virtue of the reference owned by
10473 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
10474 destroyed already by the time this function returns, but currently bugs
10475 occur in that case before the caller gets control.  It is the caller's
10476 responsibility to ensure that it knows which of these situations applies.
10477
10478 =cut
10479 */
10480
10481 CV *
10482 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10483                              U32 flags, SV *sv)
10484 {
10485     CV* cv;
10486     const char *const file = CopFILE(PL_curcop);
10487
10488     ENTER;
10489
10490     if (IN_PERL_RUNTIME) {
10491         /* at runtime, it's not safe to manipulate PL_curcop: it may be
10492          * an op shared between threads. Use a non-shared COP for our
10493          * dirty work */
10494          SAVEVPTR(PL_curcop);
10495          SAVECOMPILEWARNINGS();
10496          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10497          PL_curcop = &PL_compiling;
10498     }
10499     SAVECOPLINE(PL_curcop);
10500     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10501
10502     SAVEHINTS();
10503     PL_hints &= ~HINT_BLOCK_SCOPE;
10504
10505     if (stash) {
10506         SAVEGENERICSV(PL_curstash);
10507         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10508     }
10509
10510     /* Protect sv against leakage caused by fatal warnings. */
10511     if (sv) SAVEFREESV(sv);
10512
10513     /* file becomes the CvFILE. For an XS, it's usually static storage,
10514        and so doesn't get free()d.  (It's expected to be from the C pre-
10515        processor __FILE__ directive). But we need a dynamically allocated one,
10516        and we need it to get freed.  */
10517     cv = newXS_len_flags(name, len,
10518                          sv && SvTYPE(sv) == SVt_PVAV
10519                              ? const_av_xsub
10520                              : const_sv_xsub,
10521                          file ? file : "", "",
10522                          &sv, XS_DYNAMIC_FILENAME | flags);
10523     assert(cv);
10524     assert(SvREFCNT((SV*)cv) != 0);
10525     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10526     CvCONST_on(cv);
10527
10528     LEAVE;
10529
10530     return cv;
10531 }
10532
10533 /*
10534 =for apidoc U||newXS
10535
10536 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
10537 static storage, as it is used directly as CvFILE(), without a copy being made.
10538
10539 =cut
10540 */
10541
10542 CV *
10543 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10544 {
10545     PERL_ARGS_ASSERT_NEWXS;
10546     return newXS_len_flags(
10547         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10548     );
10549 }
10550
10551 CV *
10552 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10553                  const char *const filename, const char *const proto,
10554                  U32 flags)
10555 {
10556     PERL_ARGS_ASSERT_NEWXS_FLAGS;
10557     return newXS_len_flags(
10558        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10559     );
10560 }
10561
10562 CV *
10563 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10564 {
10565     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10566     return newXS_len_flags(
10567         name, strlen(name), subaddr, NULL, NULL, NULL, 0
10568     );
10569 }
10570
10571 /*
10572 =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
10573
10574 Construct an XS subroutine, also performing some surrounding jobs.
10575
10576 The subroutine will have the entry point C<subaddr>.  It will have
10577 the prototype specified by the nul-terminated string C<proto>, or
10578 no prototype if C<proto> is null.  The prototype string is copied;
10579 the caller can mutate the supplied string afterwards.  If C<filename>
10580 is non-null, it must be a nul-terminated filename, and the subroutine
10581 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
10582 point directly to the supplied string, which must be static.  If C<flags>
10583 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10584 be taken instead.
10585
10586 Other aspects of the subroutine will be left in their default state.
10587 If anything else needs to be done to the subroutine for it to function
10588 correctly, it is the caller's responsibility to do that after this
10589 function has constructed it.  However, beware of the subroutine
10590 potentially being destroyed before this function returns, as described
10591 below.
10592
10593 If C<name> is null then the subroutine will be anonymous, with its
10594 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
10595 subroutine will be named accordingly, referenced by the appropriate glob.
10596 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10597 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10598 The name may be either qualified or unqualified, with the stash defaulting
10599 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
10600 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10601 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
10602 the stash if necessary, with C<GV_ADDMULTI> semantics.
10603
10604 If there is already a subroutine of the specified name, then the new sub
10605 will replace the existing one in the glob.  A warning may be generated
10606 about the redefinition.  If the old subroutine was C<CvCONST> then the
10607 decision about whether to warn is influenced by an expectation about
10608 whether the new subroutine will become a constant of similar value.
10609 That expectation is determined by C<const_svp>.  (Note that the call to
10610 this function doesn't make the new subroutine C<CvCONST> in any case;
10611 that is left to the caller.)  If C<const_svp> is null then it indicates
10612 that the new subroutine will not become a constant.  If C<const_svp>
10613 is non-null then it indicates that the new subroutine will become a
10614 constant, and it points to an C<SV*> that provides the constant value
10615 that the subroutine will have.
10616
10617 If the subroutine has one of a few special names, such as C<BEGIN> or
10618 C<END>, then it will be claimed by the appropriate queue for automatic
10619 running of phase-related subroutines.  In this case the relevant glob will
10620 be left not containing any subroutine, even if it did contain one before.
10621 In the case of C<BEGIN>, the subroutine will be executed and the reference
10622 to it disposed of before this function returns, and also before its
10623 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
10624 constructed by this function to be ready for execution then the caller
10625 must prevent this happening by giving the subroutine a different name.
10626
10627 The function returns a pointer to the constructed subroutine.  If the sub
10628 is anonymous then ownership of one counted reference to the subroutine
10629 is transferred to the caller.  If the sub is named then the caller does
10630 not get ownership of a reference.  In most such cases, where the sub
10631 has a non-phase name, the sub will be alive at the point it is returned
10632 by virtue of being contained in the glob that names it.  A phase-named
10633 subroutine will usually be alive by virtue of the reference owned by the
10634 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10635 been executed, will quite likely have been destroyed already by the
10636 time this function returns, making it erroneous for the caller to make
10637 any use of the returned pointer.  It is the caller's responsibility to
10638 ensure that it knows which of these situations applies.
10639
10640 =cut
10641 */
10642
10643 CV *
10644 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10645                            XSUBADDR_t subaddr, const char *const filename,
10646                            const char *const proto, SV **const_svp,
10647                            U32 flags)
10648 {
10649     CV *cv;
10650     bool interleave = FALSE;
10651     bool evanescent = FALSE;
10652
10653     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10654
10655     {
10656         GV * const gv = gv_fetchpvn(
10657                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10658                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10659                                 sizeof("__ANON__::__ANON__") - 1,
10660                             GV_ADDMULTI | flags, SVt_PVCV);
10661
10662         if ((cv = (name ? GvCV(gv) : NULL))) {
10663             if (GvCVGEN(gv)) {
10664                 /* just a cached method */
10665                 SvREFCNT_dec(cv);
10666                 cv = NULL;
10667             }
10668             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10669                 /* already defined (or promised) */
10670                 /* Redundant check that allows us to avoid creating an SV
10671                    most of the time: */
10672                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10673                     report_redefined_cv(newSVpvn_flags(
10674                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
10675                                         ),
10676                                         cv, const_svp);
10677                 }
10678                 interleave = TRUE;
10679                 ENTER;
10680                 SAVEFREESV(cv);
10681                 cv = NULL;
10682             }
10683         }
10684
10685         if (cv)                         /* must reuse cv if autoloaded */
10686             cv_undef(cv);
10687         else {
10688             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10689             if (name) {
10690                 GvCV_set(gv,cv);
10691                 GvCVGEN(gv) = 0;
10692                 if (HvENAME_HEK(GvSTASH(gv)))
10693                     gv_method_changed(gv); /* newXS */
10694             }
10695         }
10696         assert(cv);
10697         assert(SvREFCNT((SV*)cv) != 0);
10698
10699         CvGV_set(cv, gv);
10700         if(filename) {
10701             /* XSUBs can't be perl lang/perl5db.pl debugged
10702             if (PERLDB_LINE_OR_SAVESRC)
10703                 (void)gv_fetchfile(filename); */
10704             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10705             if (flags & XS_DYNAMIC_FILENAME) {
10706                 CvDYNFILE_on(cv);
10707                 CvFILE(cv) = savepv(filename);
10708             } else {
10709             /* NOTE: not copied, as it is expected to be an external constant string */
10710                 CvFILE(cv) = (char *)filename;
10711             }
10712         } else {
10713             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10714             CvFILE(cv) = (char*)PL_xsubfilename;
10715         }
10716         CvISXSUB_on(cv);
10717         CvXSUB(cv) = subaddr;
10718 #ifndef PERL_IMPLICIT_CONTEXT
10719         CvHSCXT(cv) = &PL_stack_sp;
10720 #else
10721         PoisonPADLIST(cv);
10722 #endif
10723
10724         if (name)
10725             evanescent = process_special_blocks(0, name, gv, cv);
10726         else
10727             CvANON_on(cv);
10728     } /* <- not a conditional branch */
10729
10730     assert(cv);
10731     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10732
10733     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10734     if (interleave) LEAVE;
10735     assert(evanescent || SvREFCNT((SV*)cv) != 0);
10736     return cv;
10737 }
10738
10739 CV *
10740 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10741 {
10742     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10743     GV *cvgv;
10744     PERL_ARGS_ASSERT_NEWSTUB;
10745     assert(!GvCVu(gv));
10746     GvCV_set(gv, cv);
10747     GvCVGEN(gv) = 0;
10748     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10749         gv_method_changed(gv);
10750     if (SvFAKE(gv)) {
10751         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10752         SvFAKE_off(cvgv);
10753     }
10754     else cvgv = gv;
10755     CvGV_set(cv, cvgv);
10756     CvFILE_set_from_cop(cv, PL_curcop);
10757     CvSTASH_set(cv, PL_curstash);
10758     GvMULTI_on(gv);
10759     return cv;
10760 }
10761
10762 void
10763 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10764 {
10765     CV *cv;
10766     GV *gv;
10767     OP *root;
10768     OP *start;
10769
10770     if (PL_parser && PL_parser->error_count) {
10771         op_free(block);
10772         goto finish;
10773     }
10774
10775     gv = o
10776         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10777         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10778
10779     GvMULTI_on(gv);
10780     if ((cv = GvFORM(gv))) {
10781         if (ckWARN(WARN_REDEFINE)) {
10782             const line_t oldline = CopLINE(PL_curcop);
10783             if (PL_parser && PL_parser->copline != NOLINE)
10784                 CopLINE_set(PL_curcop, PL_parser->copline);
10785             if (o) {
10786                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10787                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10788             } else {
10789                 /* diag_listed_as: Format %s redefined */
10790                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10791                             "Format STDOUT redefined");
10792             }
10793             CopLINE_set(PL_curcop, oldline);
10794         }
10795         SvREFCNT_dec(cv);
10796     }
10797     cv = PL_compcv;
10798     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10799     CvGV_set(cv, gv);
10800     CvFILE_set_from_cop(cv, PL_curcop);
10801
10802
10803     root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10804     CvROOT(cv) = root;
10805     start = LINKLIST(root);
10806     root->op_next = 0;
10807     S_process_optree(aTHX_ cv, root, start);
10808     cv_forget_slab(cv);
10809
10810   finish:
10811     op_free(o);
10812     if (PL_parser)
10813         PL_parser->copline = NOLINE;
10814     LEAVE_SCOPE(floor);
10815     PL_compiling.cop_seq = 0;
10816 }
10817
10818 OP *
10819 Perl_newANONLIST(pTHX_ OP *o)
10820 {
10821     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10822 }
10823
10824 OP *
10825 Perl_newANONHASH(pTHX_ OP *o)
10826 {
10827     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10828 }
10829
10830 OP *
10831 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10832 {
10833     return newANONATTRSUB(floor, proto, NULL, block);
10834 }
10835
10836 OP *
10837 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10838 {
10839     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10840     OP * anoncode =
10841         newSVOP(OP_ANONCODE, 0,
10842                 cv);
10843     if (CvANONCONST(cv))
10844         anoncode = newUNOP(OP_ANONCONST, 0,
10845                            op_convert_list(OP_ENTERSUB,
10846                                            OPf_STACKED|OPf_WANT_SCALAR,
10847                                            anoncode));
10848     return newUNOP(OP_REFGEN, 0, anoncode);
10849 }
10850
10851 OP *
10852 Perl_oopsAV(pTHX_ OP *o)
10853 {
10854     dVAR;
10855
10856     PERL_ARGS_ASSERT_OOPSAV;
10857
10858     switch (o->op_type) {
10859     case OP_PADSV:
10860     case OP_PADHV:
10861         OpTYPE_set(o, OP_PADAV);
10862         return ref(o, OP_RV2AV);
10863
10864     case OP_RV2SV:
10865     case OP_RV2HV:
10866         OpTYPE_set(o, OP_RV2AV);
10867         ref(o, OP_RV2AV);
10868         break;
10869
10870     default:
10871         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10872         break;
10873     }
10874     return o;
10875 }
10876
10877 OP *
10878 Perl_oopsHV(pTHX_ OP *o)
10879 {
10880     dVAR;
10881
10882     PERL_ARGS_ASSERT_OOPSHV;
10883
10884     switch (o->op_type) {
10885     case OP_PADSV:
10886     case OP_PADAV:
10887         OpTYPE_set(o, OP_PADHV);
10888         return ref(o, OP_RV2HV);
10889
10890     case OP_RV2SV:
10891     case OP_RV2AV:
10892         OpTYPE_set(o, OP_RV2HV);
10893         /* rv2hv steals the bottom bit for its own uses */
10894         o->op_private &= ~OPpARG1_MASK;
10895         ref(o, OP_RV2HV);
10896         break;
10897
10898     default:
10899         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10900         break;
10901     }
10902     return o;
10903 }
10904
10905 OP *
10906 Perl_newAVREF(pTHX_ OP *o)
10907 {
10908     dVAR;
10909
10910     PERL_ARGS_ASSERT_NEWAVREF;
10911
10912     if (o->op_type == OP_PADANY) {
10913         OpTYPE_set(o, OP_PADAV);
10914         return o;
10915     }
10916     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10917         Perl_croak(aTHX_ "Can't use an array as a reference");
10918     }
10919     return newUNOP(OP_RV2AV, 0, scalar(o));
10920 }
10921
10922 OP *
10923 Perl_newGVREF(pTHX_ I32 type, OP *o)
10924 {
10925     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10926         return newUNOP(OP_NULL, 0, o);
10927     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10928 }
10929
10930 OP *
10931 Perl_newHVREF(pTHX_ OP *o)
10932 {
10933     dVAR;
10934
10935     PERL_ARGS_ASSERT_NEWHVREF;
10936
10937     if (o->op_type == OP_PADANY) {
10938         OpTYPE_set(o, OP_PADHV);
10939         return o;
10940     }
10941     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
10942         Perl_croak(aTHX_ "Can't use a hash as a reference");
10943     }
10944     return newUNOP(OP_RV2HV, 0, scalar(o));
10945 }
10946
10947 OP *
10948 Perl_newCVREF(pTHX_ I32 flags, OP *o)
10949 {
10950     if (o->op_type == OP_PADANY) {
10951         dVAR;
10952         OpTYPE_set(o, OP_PADCV);
10953     }
10954     return newUNOP(OP_RV2CV, flags, scalar(o));
10955 }
10956
10957 OP *
10958 Perl_newSVREF(pTHX_ OP *o)
10959 {
10960     dVAR;
10961
10962     PERL_ARGS_ASSERT_NEWSVREF;
10963
10964     if (o->op_type == OP_PADANY) {
10965         OpTYPE_set(o, OP_PADSV);
10966         scalar(o);
10967         return o;
10968     }
10969     return newUNOP(OP_RV2SV, 0, scalar(o));
10970 }
10971
10972 /* Check routines. See the comments at the top of this file for details
10973  * on when these are called */
10974
10975 OP *
10976 Perl_ck_anoncode(pTHX_ OP *o)
10977 {
10978     PERL_ARGS_ASSERT_CK_ANONCODE;
10979
10980     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
10981     cSVOPo->op_sv = NULL;
10982     return o;
10983 }
10984
10985 static void
10986 S_io_hints(pTHX_ OP *o)
10987 {
10988 #if O_BINARY != 0 || O_TEXT != 0
10989     HV * const table =
10990         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
10991     if (table) {
10992         SV **svp = hv_fetchs(table, "open_IN", FALSE);
10993         if (svp && *svp) {
10994             STRLEN len = 0;
10995             const char *d = SvPV_const(*svp, len);
10996             const I32 mode = mode_from_discipline(d, len);
10997             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
10998 #  if O_BINARY != 0
10999             if (mode & O_BINARY)
11000                 o->op_private |= OPpOPEN_IN_RAW;
11001 #  endif
11002 #  if O_TEXT != 0
11003             if (mode & O_TEXT)
11004                 o->op_private |= OPpOPEN_IN_CRLF;
11005 #  endif
11006         }
11007
11008         svp = hv_fetchs(table, "open_OUT", FALSE);
11009         if (svp && *svp) {
11010             STRLEN len = 0;
11011             const char *d = SvPV_const(*svp, len);
11012             const I32 mode = mode_from_discipline(d, len);
11013             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11014 #  if O_BINARY != 0
11015             if (mode & O_BINARY)
11016                 o->op_private |= OPpOPEN_OUT_RAW;
11017 #  endif
11018 #  if O_TEXT != 0
11019             if (mode & O_TEXT)
11020                 o->op_private |= OPpOPEN_OUT_CRLF;
11021 #  endif
11022         }
11023     }
11024 #else
11025     PERL_UNUSED_CONTEXT;
11026     PERL_UNUSED_ARG(o);
11027 #endif
11028 }
11029
11030 OP *
11031 Perl_ck_backtick(pTHX_ OP *o)
11032 {
11033     GV *gv;
11034     OP *newop = NULL;
11035     OP *sibl;
11036     PERL_ARGS_ASSERT_CK_BACKTICK;
11037     o = ck_fun(o);
11038     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11039     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11040      && (gv = gv_override("readpipe",8)))
11041     {
11042         /* detach rest of siblings from o and its first child */
11043         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11044         newop = S_new_entersubop(aTHX_ gv, sibl);
11045     }
11046     else if (!(o->op_flags & OPf_KIDS))
11047         newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11048     if (newop) {
11049         op_free(o);
11050         return newop;
11051     }
11052     S_io_hints(aTHX_ o);
11053     return o;
11054 }
11055
11056 OP *
11057 Perl_ck_bitop(pTHX_ OP *o)
11058 {
11059     PERL_ARGS_ASSERT_CK_BITOP;
11060
11061     o->op_private = (U8)(PL_hints & HINT_INTEGER);
11062
11063     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11064             && OP_IS_INFIX_BIT(o->op_type))
11065     {
11066         const OP * const left = cBINOPo->op_first;
11067         const OP * const right = OpSIBLING(left);
11068         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11069                 (left->op_flags & OPf_PARENS) == 0) ||
11070             (OP_IS_NUMCOMPARE(right->op_type) &&
11071                 (right->op_flags & OPf_PARENS) == 0))
11072             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11073                           "Possible precedence problem on bitwise %s operator",
11074                            o->op_type ==  OP_BIT_OR
11075                          ||o->op_type == OP_NBIT_OR  ? "|"
11076                         :  o->op_type ==  OP_BIT_AND
11077                          ||o->op_type == OP_NBIT_AND ? "&"
11078                         :  o->op_type ==  OP_BIT_XOR
11079                          ||o->op_type == OP_NBIT_XOR ? "^"
11080                         :  o->op_type == OP_SBIT_OR  ? "|."
11081                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11082                            );
11083     }
11084     return o;
11085 }
11086
11087 PERL_STATIC_INLINE bool
11088 is_dollar_bracket(pTHX_ const OP * const o)
11089 {
11090     const OP *kid;
11091     PERL_UNUSED_CONTEXT;
11092     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11093         && (kid = cUNOPx(o)->op_first)
11094         && kid->op_type == OP_GV
11095         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11096 }
11097
11098 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11099
11100 OP *
11101 Perl_ck_cmp(pTHX_ OP *o)
11102 {
11103     bool is_eq;
11104     bool neg;
11105     bool reverse;
11106     bool iv0;
11107     OP *indexop, *constop, *start;
11108     SV *sv;
11109     IV iv;
11110
11111     PERL_ARGS_ASSERT_CK_CMP;
11112
11113     is_eq = (   o->op_type == OP_EQ
11114              || o->op_type == OP_NE
11115              || o->op_type == OP_I_EQ
11116              || o->op_type == OP_I_NE);
11117
11118     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11119         const OP *kid = cUNOPo->op_first;
11120         if (kid &&
11121             (
11122                 (   is_dollar_bracket(aTHX_ kid)
11123                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11124                 )
11125              || (   kid->op_type == OP_CONST
11126                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11127                 )
11128            )
11129         )
11130             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11131                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11132     }
11133
11134     /* convert (index(...) == -1) and variations into
11135      *   (r)index/BOOL(,NEG)
11136      */
11137
11138     reverse = FALSE;
11139
11140     indexop = cUNOPo->op_first;
11141     constop = OpSIBLING(indexop);
11142     start = NULL;
11143     if (indexop->op_type == OP_CONST) {
11144         constop = indexop;
11145         indexop = OpSIBLING(constop);
11146         start = constop;
11147         reverse = TRUE;
11148     }
11149
11150     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11151         return o;
11152
11153     /* ($lex = index(....)) == -1 */
11154     if (indexop->op_private & OPpTARGET_MY)
11155         return o;
11156
11157     if (constop->op_type != OP_CONST)
11158         return o;
11159
11160     sv = cSVOPx_sv(constop);
11161     if (!(sv && SvIOK_notUV(sv)))
11162         return o;
11163
11164     iv = SvIVX(sv);
11165     if (iv != -1 && iv != 0)
11166         return o;
11167     iv0 = (iv == 0);
11168
11169     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11170         if (!(iv0 ^ reverse))
11171             return o;
11172         neg = iv0;
11173     }
11174     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11175         if (iv0 ^ reverse)
11176             return o;
11177         neg = !iv0;
11178     }
11179     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11180         if (!(iv0 ^ reverse))
11181             return o;
11182         neg = !iv0;
11183     }
11184     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11185         if (iv0 ^ reverse)
11186             return o;
11187         neg = iv0;
11188     }
11189     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11190         if (iv0)
11191             return o;
11192         neg = TRUE;
11193     }
11194     else {
11195         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11196         if (iv0)
11197             return o;
11198         neg = FALSE;
11199     }
11200
11201     indexop->op_flags &= ~OPf_PARENS;
11202     indexop->op_flags |= (o->op_flags & OPf_PARENS);
11203     indexop->op_private |= OPpTRUEBOOL;
11204     if (neg)
11205         indexop->op_private |= OPpINDEX_BOOLNEG;
11206     /* cut out the index op and free the eq,const ops */
11207     (void)op_sibling_splice(o, start, 1, NULL);
11208     op_free(o);
11209
11210     return indexop;
11211 }
11212
11213
11214 OP *
11215 Perl_ck_concat(pTHX_ OP *o)
11216 {
11217     const OP * const kid = cUNOPo->op_first;
11218
11219     PERL_ARGS_ASSERT_CK_CONCAT;
11220     PERL_UNUSED_CONTEXT;
11221
11222     /* reuse the padtmp returned by the concat child */
11223     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11224             !(kUNOP->op_first->op_flags & OPf_MOD))
11225     {
11226         o->op_flags |= OPf_STACKED;
11227         o->op_private |= OPpCONCAT_NESTED;
11228     }
11229     return o;
11230 }
11231
11232 OP *
11233 Perl_ck_spair(pTHX_ OP *o)
11234 {
11235     dVAR;
11236
11237     PERL_ARGS_ASSERT_CK_SPAIR;
11238
11239     if (o->op_flags & OPf_KIDS) {
11240         OP* newop;
11241         OP* kid;
11242         OP* kidkid;
11243         const OPCODE type = o->op_type;
11244         o = modkids(ck_fun(o), type);
11245         kid    = cUNOPo->op_first;
11246         kidkid = kUNOP->op_first;
11247         newop = OpSIBLING(kidkid);
11248         if (newop) {
11249             const OPCODE type = newop->op_type;
11250             if (OpHAS_SIBLING(newop))
11251                 return o;
11252             if (o->op_type == OP_REFGEN
11253              && (  type == OP_RV2CV
11254                 || (  !(newop->op_flags & OPf_PARENS)
11255                    && (  type == OP_RV2AV || type == OP_PADAV
11256                       || type == OP_RV2HV || type == OP_PADHV))))
11257                 NOOP; /* OK (allow srefgen for \@a and \%h) */
11258             else if (OP_GIMME(newop,0) != G_SCALAR)
11259                 return o;
11260         }
11261         /* excise first sibling */
11262         op_sibling_splice(kid, NULL, 1, NULL);
11263         op_free(kidkid);
11264     }
11265     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11266      * and OP_CHOMP into OP_SCHOMP */
11267     o->op_ppaddr = PL_ppaddr[++o->op_type];
11268     return ck_fun(o);
11269 }
11270
11271 OP *
11272 Perl_ck_delete(pTHX_ OP *o)
11273 {
11274     PERL_ARGS_ASSERT_CK_DELETE;
11275
11276     o = ck_fun(o);
11277     o->op_private = 0;
11278     if (o->op_flags & OPf_KIDS) {
11279         OP * const kid = cUNOPo->op_first;
11280         switch (kid->op_type) {
11281         case OP_ASLICE:
11282             o->op_flags |= OPf_SPECIAL;
11283             /* FALLTHROUGH */
11284         case OP_HSLICE:
11285             o->op_private |= OPpSLICE;
11286             break;
11287         case OP_AELEM:
11288             o->op_flags |= OPf_SPECIAL;
11289             /* FALLTHROUGH */
11290         case OP_HELEM:
11291             break;
11292         case OP_KVASLICE:
11293             o->op_flags |= OPf_SPECIAL;
11294             /* FALLTHROUGH */
11295         case OP_KVHSLICE:
11296             o->op_private |= OPpKVSLICE;
11297             break;
11298         default:
11299             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11300                              "element or slice");
11301         }
11302         if (kid->op_private & OPpLVAL_INTRO)
11303             o->op_private |= OPpLVAL_INTRO;
11304         op_null(kid);
11305     }
11306     return o;
11307 }
11308
11309 OP *
11310 Perl_ck_eof(pTHX_ OP *o)
11311 {
11312     PERL_ARGS_ASSERT_CK_EOF;
11313
11314     if (o->op_flags & OPf_KIDS) {
11315         OP *kid;
11316         if (cLISTOPo->op_first->op_type == OP_STUB) {
11317             OP * const newop
11318                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11319             op_free(o);
11320             o = newop;
11321         }
11322         o = ck_fun(o);
11323         kid = cLISTOPo->op_first;
11324         if (kid->op_type == OP_RV2GV)
11325             kid->op_private |= OPpALLOW_FAKE;
11326     }
11327     return o;
11328 }
11329
11330
11331 OP *
11332 Perl_ck_eval(pTHX_ OP *o)
11333 {
11334     dVAR;
11335
11336     PERL_ARGS_ASSERT_CK_EVAL;
11337
11338     PL_hints |= HINT_BLOCK_SCOPE;
11339     if (o->op_flags & OPf_KIDS) {
11340         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11341         assert(kid);
11342
11343         if (o->op_type == OP_ENTERTRY) {
11344             LOGOP *enter;
11345
11346             /* cut whole sibling chain free from o */
11347             op_sibling_splice(o, NULL, -1, NULL);
11348             op_free(o);
11349
11350             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11351
11352             /* establish postfix order */
11353             enter->op_next = (OP*)enter;
11354
11355             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11356             OpTYPE_set(o, OP_LEAVETRY);
11357             enter->op_other = o;
11358             return o;
11359         }
11360         else {
11361             scalar((OP*)kid);
11362             S_set_haseval(aTHX);
11363         }
11364     }
11365     else {
11366         const U8 priv = o->op_private;
11367         op_free(o);
11368         /* the newUNOP will recursively call ck_eval(), which will handle
11369          * all the stuff at the end of this function, like adding
11370          * OP_HINTSEVAL
11371          */
11372         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11373     }
11374     o->op_targ = (PADOFFSET)PL_hints;
11375     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11376     if ((PL_hints & HINT_LOCALIZE_HH) != 0
11377      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11378         /* Store a copy of %^H that pp_entereval can pick up. */
11379         OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11380                            MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11381         /* append hhop to only child  */
11382         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11383
11384         o->op_private |= OPpEVAL_HAS_HH;
11385     }
11386     if (!(o->op_private & OPpEVAL_BYTES)
11387          && FEATURE_UNIEVAL_IS_ENABLED)
11388             o->op_private |= OPpEVAL_UNICODE;
11389     return o;
11390 }
11391
11392 OP *
11393 Perl_ck_exec(pTHX_ OP *o)
11394 {
11395     PERL_ARGS_ASSERT_CK_EXEC;
11396
11397     if (o->op_flags & OPf_STACKED) {
11398         OP *kid;
11399         o = ck_fun(o);
11400         kid = OpSIBLING(cUNOPo->op_first);
11401         if (kid->op_type == OP_RV2GV)
11402             op_null(kid);
11403     }
11404     else
11405         o = listkids(o);
11406     return o;
11407 }
11408
11409 OP *
11410 Perl_ck_exists(pTHX_ OP *o)
11411 {
11412     PERL_ARGS_ASSERT_CK_EXISTS;
11413
11414     o = ck_fun(o);
11415     if (o->op_flags & OPf_KIDS) {
11416         OP * const kid = cUNOPo->op_first;
11417         if (kid->op_type == OP_ENTERSUB) {
11418             (void) ref(kid, o->op_type);
11419             if (kid->op_type != OP_RV2CV
11420                         && !(PL_parser && PL_parser->error_count))
11421                 Perl_croak(aTHX_
11422                           "exists argument is not a subroutine name");
11423             o->op_private |= OPpEXISTS_SUB;
11424         }
11425         else if (kid->op_type == OP_AELEM)
11426             o->op_flags |= OPf_SPECIAL;
11427         else if (kid->op_type != OP_HELEM)
11428             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11429                              "element or a subroutine");
11430         op_null(kid);
11431     }
11432     return o;
11433 }
11434
11435 OP *
11436 Perl_ck_rvconst(pTHX_ OP *o)
11437 {
11438     dVAR;
11439     SVOP * const kid = (SVOP*)cUNOPo->op_first;
11440
11441     PERL_ARGS_ASSERT_CK_RVCONST;
11442
11443     if (o->op_type == OP_RV2HV)
11444         /* rv2hv steals the bottom bit for its own uses */
11445         o->op_private &= ~OPpARG1_MASK;
11446
11447     o->op_private |= (PL_hints & HINT_STRICT_REFS);
11448
11449     if (kid->op_type == OP_CONST) {
11450         int iscv;
11451         GV *gv;
11452         SV * const kidsv = kid->op_sv;
11453
11454         /* Is it a constant from cv_const_sv()? */
11455         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11456             return o;
11457         }
11458         if (SvTYPE(kidsv) == SVt_PVAV) return o;
11459         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11460             const char *badthing;
11461             switch (o->op_type) {
11462             case OP_RV2SV:
11463                 badthing = "a SCALAR";
11464                 break;
11465             case OP_RV2AV:
11466                 badthing = "an ARRAY";
11467                 break;
11468             case OP_RV2HV:
11469                 badthing = "a HASH";
11470                 break;
11471             default:
11472                 badthing = NULL;
11473                 break;
11474             }
11475             if (badthing)
11476                 Perl_croak(aTHX_
11477                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11478                            SVfARG(kidsv), badthing);
11479         }
11480         /*
11481          * This is a little tricky.  We only want to add the symbol if we
11482          * didn't add it in the lexer.  Otherwise we get duplicate strict
11483          * warnings.  But if we didn't add it in the lexer, we must at
11484          * least pretend like we wanted to add it even if it existed before,
11485          * or we get possible typo warnings.  OPpCONST_ENTERED says
11486          * whether the lexer already added THIS instance of this symbol.
11487          */
11488         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11489         gv = gv_fetchsv(kidsv,
11490                 o->op_type == OP_RV2CV
11491                         && o->op_private & OPpMAY_RETURN_CONSTANT
11492                     ? GV_NOEXPAND
11493                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
11494                 iscv
11495                     ? SVt_PVCV
11496                     : o->op_type == OP_RV2SV
11497                         ? SVt_PV
11498                         : o->op_type == OP_RV2AV
11499                             ? SVt_PVAV
11500                             : o->op_type == OP_RV2HV
11501                                 ? SVt_PVHV
11502                                 : SVt_PVGV);
11503         if (gv) {
11504             if (!isGV(gv)) {
11505                 assert(iscv);
11506                 assert(SvROK(gv));
11507                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11508                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
11509                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11510             }
11511             OpTYPE_set(kid, OP_GV);
11512             SvREFCNT_dec(kid->op_sv);
11513 #ifdef USE_ITHREADS
11514             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11515             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11516             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11517             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11518             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11519 #else
11520             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11521 #endif
11522             kid->op_private = 0;
11523             /* FAKE globs in the symbol table cause weird bugs (#77810) */
11524             SvFAKE_off(gv);
11525         }
11526     }
11527     return o;
11528 }
11529
11530 OP *
11531 Perl_ck_ftst(pTHX_ OP *o)
11532 {
11533     dVAR;
11534     const I32 type = o->op_type;
11535
11536     PERL_ARGS_ASSERT_CK_FTST;
11537
11538     if (o->op_flags & OPf_REF) {
11539         NOOP;
11540     }
11541     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11542         SVOP * const kid = (SVOP*)cUNOPo->op_first;
11543         const OPCODE kidtype = kid->op_type;
11544
11545         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11546          && !kid->op_folded) {
11547             OP * const newop = newGVOP(type, OPf_REF,
11548                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11549             op_free(o);
11550             return newop;
11551         }
11552
11553         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11554             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11555             if (name) {
11556                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11557                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11558                             array_passed_to_stat, name);
11559             }
11560             else {
11561                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11562                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11563             }
11564        }
11565         scalar((OP *) kid);
11566         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11567             o->op_private |= OPpFT_ACCESS;
11568         if (type != OP_STAT && type != OP_LSTAT
11569             && PL_check[kidtype] == Perl_ck_ftst
11570             && kidtype != OP_STAT && kidtype != OP_LSTAT
11571         ) {
11572             o->op_private |= OPpFT_STACKED;
11573             kid->op_private |= OPpFT_STACKING;
11574             if (kidtype == OP_FTTTY && (
11575                    !(kid->op_private & OPpFT_STACKED)
11576                 || kid->op_private & OPpFT_AFTER_t
11577                ))
11578                 o->op_private |= OPpFT_AFTER_t;
11579         }
11580     }
11581     else {
11582         op_free(o);
11583         if (type == OP_FTTTY)
11584             o = newGVOP(type, OPf_REF, PL_stdingv);
11585         else
11586             o = newUNOP(type, 0, newDEFSVOP());
11587     }
11588     return o;
11589 }
11590
11591 OP *
11592 Perl_ck_fun(pTHX_ OP *o)
11593 {
11594     const int type = o->op_type;
11595     I32 oa = PL_opargs[type] >> OASHIFT;
11596
11597     PERL_ARGS_ASSERT_CK_FUN;
11598
11599     if (o->op_flags & OPf_STACKED) {
11600         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11601             oa &= ~OA_OPTIONAL;
11602         else
11603             return no_fh_allowed(o);
11604     }
11605
11606     if (o->op_flags & OPf_KIDS) {
11607         OP *prev_kid = NULL;
11608         OP *kid = cLISTOPo->op_first;
11609         I32 numargs = 0;
11610         bool seen_optional = FALSE;
11611
11612         if (kid->op_type == OP_PUSHMARK ||
11613             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11614         {
11615             prev_kid = kid;
11616             kid = OpSIBLING(kid);
11617         }
11618         if (kid && kid->op_type == OP_COREARGS) {
11619             bool optional = FALSE;
11620             while (oa) {
11621                 numargs++;
11622                 if (oa & OA_OPTIONAL) optional = TRUE;
11623                 oa = oa >> 4;
11624             }
11625             if (optional) o->op_private |= numargs;
11626             return o;
11627         }
11628
11629         while (oa) {
11630             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11631                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11632                     kid = newDEFSVOP();
11633                     /* append kid to chain */
11634                     op_sibling_splice(o, prev_kid, 0, kid);
11635                 }
11636                 seen_optional = TRUE;
11637             }
11638             if (!kid) break;
11639
11640             numargs++;
11641             switch (oa & 7) {
11642             case OA_SCALAR:
11643                 /* list seen where single (scalar) arg expected? */
11644                 if (numargs == 1 && !(oa >> 4)
11645                     && kid->op_type == OP_LIST && type != OP_SCALAR)
11646                 {
11647                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11648                 }
11649                 if (type != OP_DELETE) scalar(kid);
11650                 break;
11651             case OA_LIST:
11652                 if (oa < 16) {
11653                     kid = 0;
11654                     continue;
11655                 }
11656                 else
11657                     list(kid);
11658                 break;
11659             case OA_AVREF:
11660                 if ((type == OP_PUSH || type == OP_UNSHIFT)
11661                     && !OpHAS_SIBLING(kid))
11662                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11663                                    "Useless use of %s with no values",
11664                                    PL_op_desc[type]);
11665
11666                 if (kid->op_type == OP_CONST
11667                       && (  !SvROK(cSVOPx_sv(kid))
11668                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
11669                         )
11670                     bad_type_pv(numargs, "array", o, kid);
11671                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11672                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11673                                          PL_op_desc[type]), 0);
11674                 }
11675                 else {
11676                     op_lvalue(kid, type);
11677                 }
11678                 break;
11679             case OA_HVREF:
11680                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11681                     bad_type_pv(numargs, "hash", o, kid);
11682                 op_lvalue(kid, type);
11683                 break;
11684             case OA_CVREF:
11685                 {
11686                     /* replace kid with newop in chain */
11687                     OP * const newop =
11688                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11689                     newop->op_next = newop;
11690                     kid = newop;
11691                 }
11692                 break;
11693             case OA_FILEREF:
11694                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11695                     if (kid->op_type == OP_CONST &&
11696                         (kid->op_private & OPpCONST_BARE))
11697                     {
11698                         OP * const newop = newGVOP(OP_GV, 0,
11699                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11700                         /* replace kid with newop in chain */
11701                         op_sibling_splice(o, prev_kid, 1, newop);
11702                         op_free(kid);
11703                         kid = newop;
11704                     }
11705                     else if (kid->op_type == OP_READLINE) {
11706                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11707                         bad_type_pv(numargs, "HANDLE", o, kid);
11708                     }
11709                     else {
11710                         I32 flags = OPf_SPECIAL;
11711                         I32 priv = 0;
11712                         PADOFFSET targ = 0;
11713
11714                         /* is this op a FH constructor? */
11715                         if (is_handle_constructor(o,numargs)) {
11716                             const char *name = NULL;
11717                             STRLEN len = 0;
11718                             U32 name_utf8 = 0;
11719                             bool want_dollar = TRUE;
11720
11721                             flags = 0;
11722                             /* Set a flag to tell rv2gv to vivify
11723                              * need to "prove" flag does not mean something
11724                              * else already - NI-S 1999/05/07
11725                              */
11726                             priv = OPpDEREF;
11727                             if (kid->op_type == OP_PADSV) {
11728                                 PADNAME * const pn
11729                                     = PAD_COMPNAME_SV(kid->op_targ);
11730                                 name = PadnamePV (pn);
11731                                 len  = PadnameLEN(pn);
11732                                 name_utf8 = PadnameUTF8(pn);
11733                             }
11734                             else if (kid->op_type == OP_RV2SV
11735                                      && kUNOP->op_first->op_type == OP_GV)
11736                             {
11737                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11738                                 name = GvNAME(gv);
11739                                 len = GvNAMELEN(gv);
11740                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11741                             }
11742                             else if (kid->op_type == OP_AELEM
11743                                      || kid->op_type == OP_HELEM)
11744                             {
11745                                  OP *firstop;
11746                                  OP *op = ((BINOP*)kid)->op_first;
11747                                  name = NULL;
11748                                  if (op) {
11749                                       SV *tmpstr = NULL;
11750                                       const char * const a =
11751                                            kid->op_type == OP_AELEM ?
11752                                            "[]" : "{}";
11753                                       if (((op->op_type == OP_RV2AV) ||
11754                                            (op->op_type == OP_RV2HV)) &&
11755                                           (firstop = ((UNOP*)op)->op_first) &&
11756                                           (firstop->op_type == OP_GV)) {
11757                                            /* packagevar $a[] or $h{} */
11758                                            GV * const gv = cGVOPx_gv(firstop);
11759                                            if (gv)
11760                                                 tmpstr =
11761                                                      Perl_newSVpvf(aTHX_
11762                                                                    "%s%c...%c",
11763                                                                    GvNAME(gv),
11764                                                                    a[0], a[1]);
11765                                       }
11766                                       else if (op->op_type == OP_PADAV
11767                                                || op->op_type == OP_PADHV) {
11768                                            /* lexicalvar $a[] or $h{} */
11769                                            const char * const padname =
11770                                                 PAD_COMPNAME_PV(op->op_targ);
11771                                            if (padname)
11772                                                 tmpstr =
11773                                                      Perl_newSVpvf(aTHX_
11774                                                                    "%s%c...%c",
11775                                                                    padname + 1,
11776                                                                    a[0], a[1]);
11777                                       }
11778                                       if (tmpstr) {
11779                                            name = SvPV_const(tmpstr, len);
11780                                            name_utf8 = SvUTF8(tmpstr);
11781                                            sv_2mortal(tmpstr);
11782                                       }
11783                                  }
11784                                  if (!name) {
11785                                       name = "__ANONIO__";
11786                                       len = 10;
11787                                       want_dollar = FALSE;
11788                                  }
11789                                  op_lvalue(kid, type);
11790                             }
11791                             if (name) {
11792                                 SV *namesv;
11793                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11794                                 namesv = PAD_SVl(targ);
11795                                 if (want_dollar && *name != '$')
11796                                     sv_setpvs(namesv, "$");
11797                                 else
11798                                     SvPVCLEAR(namesv);
11799                                 sv_catpvn(namesv, name, len);
11800                                 if ( name_utf8 ) SvUTF8_on(namesv);
11801                             }
11802                         }
11803                         scalar(kid);
11804                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11805                                     OP_RV2GV, flags);
11806                         kid->op_targ = targ;
11807                         kid->op_private |= priv;
11808                     }
11809                 }
11810                 scalar(kid);
11811                 break;
11812             case OA_SCALARREF:
11813                 if ((type == OP_UNDEF || type == OP_POS)
11814                     && numargs == 1 && !(oa >> 4)
11815                     && kid->op_type == OP_LIST)
11816                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
11817                 op_lvalue(scalar(kid), type);
11818                 break;
11819             }
11820             oa >>= 4;
11821             prev_kid = kid;
11822             kid = OpSIBLING(kid);
11823         }
11824         /* FIXME - should the numargs or-ing move after the too many
11825          * arguments check? */
11826         o->op_private |= numargs;
11827         if (kid)
11828             return too_many_arguments_pv(o,OP_DESC(o), 0);
11829         listkids(o);
11830     }
11831     else if (PL_opargs[type] & OA_DEFGV) {
11832         /* Ordering of these two is important to keep f_map.t passing.  */
11833         op_free(o);
11834         return newUNOP(type, 0, newDEFSVOP());
11835     }
11836
11837     if (oa) {
11838         while (oa & OA_OPTIONAL)
11839             oa >>= 4;
11840         if (oa && oa != OA_LIST)
11841             return too_few_arguments_pv(o,OP_DESC(o), 0);
11842     }
11843     return o;
11844 }
11845
11846 OP *
11847 Perl_ck_glob(pTHX_ OP *o)
11848 {
11849     GV *gv;
11850
11851     PERL_ARGS_ASSERT_CK_GLOB;
11852
11853     o = ck_fun(o);
11854     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11855         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11856
11857     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11858     {
11859         /* convert
11860          *     glob
11861          *       \ null - const(wildcard)
11862          * into
11863          *     null
11864          *       \ enter
11865          *            \ list
11866          *                 \ mark - glob - rv2cv
11867          *                             |        \ gv(CORE::GLOBAL::glob)
11868          *                             |
11869          *                              \ null - const(wildcard)
11870          */
11871         o->op_flags |= OPf_SPECIAL;
11872         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11873         o = S_new_entersubop(aTHX_ gv, o);
11874         o = newUNOP(OP_NULL, 0, o);
11875         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11876         return o;
11877     }
11878     else o->op_flags &= ~OPf_SPECIAL;
11879 #if !defined(PERL_EXTERNAL_GLOB)
11880     if (!PL_globhook) {
11881         ENTER;
11882         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11883                                newSVpvs("File::Glob"), NULL, NULL, NULL);
11884         LEAVE;
11885     }
11886 #endif /* !PERL_EXTERNAL_GLOB */
11887     gv = (GV *)newSV(0);
11888     gv_init(gv, 0, "", 0, 0);
11889     gv_IOadd(gv);
11890     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11891     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11892     scalarkids(o);
11893     return o;
11894 }
11895
11896 OP *
11897 Perl_ck_grep(pTHX_ OP *o)
11898 {
11899     LOGOP *gwop;
11900     OP *kid;
11901     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11902
11903     PERL_ARGS_ASSERT_CK_GREP;
11904
11905     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11906
11907     if (o->op_flags & OPf_STACKED) {
11908         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11909         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11910             return no_fh_allowed(o);
11911         o->op_flags &= ~OPf_STACKED;
11912     }
11913     kid = OpSIBLING(cLISTOPo->op_first);
11914     if (type == OP_MAPWHILE)
11915         list(kid);
11916     else
11917         scalar(kid);
11918     o = ck_fun(o);
11919     if (PL_parser && PL_parser->error_count)
11920         return o;
11921     kid = OpSIBLING(cLISTOPo->op_first);
11922     if (kid->op_type != OP_NULL)
11923         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11924     kid = kUNOP->op_first;
11925
11926     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11927     kid->op_next = (OP*)gwop;
11928     o->op_private = gwop->op_private = 0;
11929     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
11930
11931     kid = OpSIBLING(cLISTOPo->op_first);
11932     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
11933         op_lvalue(kid, OP_GREPSTART);
11934
11935     return (OP*)gwop;
11936 }
11937
11938 OP *
11939 Perl_ck_index(pTHX_ OP *o)
11940 {
11941     PERL_ARGS_ASSERT_CK_INDEX;
11942
11943     if (o->op_flags & OPf_KIDS) {
11944         OP *kid = OpSIBLING(cLISTOPo->op_first);        /* get past pushmark */
11945         if (kid)
11946             kid = OpSIBLING(kid);                       /* get past "big" */
11947         if (kid && kid->op_type == OP_CONST) {
11948             const bool save_taint = TAINT_get;
11949             SV *sv = kSVOP->op_sv;
11950             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
11951                 && SvOK(sv) && !SvROK(sv))
11952             {
11953                 sv = newSV(0);
11954                 sv_copypv(sv, kSVOP->op_sv);
11955                 SvREFCNT_dec_NN(kSVOP->op_sv);
11956                 kSVOP->op_sv = sv;
11957             }
11958             if (SvOK(sv)) fbm_compile(sv, 0);
11959             TAINT_set(save_taint);
11960 #ifdef NO_TAINT_SUPPORT
11961             PERL_UNUSED_VAR(save_taint);
11962 #endif
11963         }
11964     }
11965     return ck_fun(o);
11966 }
11967
11968 OP *
11969 Perl_ck_lfun(pTHX_ OP *o)
11970 {
11971     const OPCODE type = o->op_type;
11972
11973     PERL_ARGS_ASSERT_CK_LFUN;
11974
11975     return modkids(ck_fun(o), type);
11976 }
11977
11978 OP *
11979 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
11980 {
11981     PERL_ARGS_ASSERT_CK_DEFINED;
11982
11983     if ((o->op_flags & OPf_KIDS)) {
11984         switch (cUNOPo->op_first->op_type) {
11985         case OP_RV2AV:
11986         case OP_PADAV:
11987             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
11988                              " (Maybe you should just omit the defined()?)");
11989             NOT_REACHED; /* NOTREACHED */
11990             break;
11991         case OP_RV2HV:
11992         case OP_PADHV:
11993             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
11994                              " (Maybe you should just omit the defined()?)");
11995             NOT_REACHED; /* NOTREACHED */
11996             break;
11997         default:
11998             /* no warning */
11999             break;
12000         }
12001     }
12002     return ck_rfun(o);
12003 }
12004
12005 OP *
12006 Perl_ck_readline(pTHX_ OP *o)
12007 {
12008     PERL_ARGS_ASSERT_CK_READLINE;
12009
12010     if (o->op_flags & OPf_KIDS) {
12011          OP *kid = cLISTOPo->op_first;
12012          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12013     }
12014     else {
12015         OP * const newop
12016             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12017         op_free(o);
12018         return newop;
12019     }
12020     return o;
12021 }
12022
12023 OP *
12024 Perl_ck_rfun(pTHX_ OP *o)
12025 {
12026     const OPCODE type = o->op_type;
12027
12028     PERL_ARGS_ASSERT_CK_RFUN;
12029
12030     return refkids(ck_fun(o), type);
12031 }
12032
12033 OP *
12034 Perl_ck_listiob(pTHX_ OP *o)
12035 {
12036     OP *kid;
12037
12038     PERL_ARGS_ASSERT_CK_LISTIOB;
12039
12040     kid = cLISTOPo->op_first;
12041     if (!kid) {
12042         o = force_list(o, 1);
12043         kid = cLISTOPo->op_first;
12044     }
12045     if (kid->op_type == OP_PUSHMARK)
12046         kid = OpSIBLING(kid);
12047     if (kid && o->op_flags & OPf_STACKED)
12048         kid = OpSIBLING(kid);
12049     else if (kid && !OpHAS_SIBLING(kid)) {              /* print HANDLE; */
12050         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12051          && !kid->op_folded) {
12052             o->op_flags |= OPf_STACKED; /* make it a filehandle */
12053             scalar(kid);
12054             /* replace old const op with new OP_RV2GV parent */
12055             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12056                                         OP_RV2GV, OPf_REF);
12057             kid = OpSIBLING(kid);
12058         }
12059     }
12060
12061     if (!kid)
12062         op_append_elem(o->op_type, o, newDEFSVOP());
12063
12064     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12065     return listkids(o);
12066 }
12067
12068 OP *
12069 Perl_ck_smartmatch(pTHX_ OP *o)
12070 {
12071     dVAR;
12072     PERL_ARGS_ASSERT_CK_SMARTMATCH;
12073     if (0 == (o->op_flags & OPf_SPECIAL)) {
12074         OP *first  = cBINOPo->op_first;
12075         OP *second = OpSIBLING(first);
12076
12077         /* Implicitly take a reference to an array or hash */
12078
12079         /* remove the original two siblings, then add back the
12080          * (possibly different) first and second sibs.
12081          */
12082         op_sibling_splice(o, NULL, 1, NULL);
12083         op_sibling_splice(o, NULL, 1, NULL);
12084         first  = ref_array_or_hash(first);
12085         second = ref_array_or_hash(second);
12086         op_sibling_splice(o, NULL, 0, second);
12087         op_sibling_splice(o, NULL, 0, first);
12088
12089         /* Implicitly take a reference to a regular expression */
12090         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12091             OpTYPE_set(first, OP_QR);
12092         }
12093         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12094             OpTYPE_set(second, OP_QR);
12095         }
12096     }
12097
12098     return o;
12099 }
12100
12101
12102 static OP *
12103 S_maybe_targlex(pTHX_ OP *o)
12104 {
12105     OP * const kid = cLISTOPo->op_first;
12106     /* has a disposable target? */
12107     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12108         && !(kid->op_flags & OPf_STACKED)
12109         /* Cannot steal the second time! */
12110         && !(kid->op_private & OPpTARGET_MY)
12111         )
12112     {
12113         OP * const kkid = OpSIBLING(kid);
12114
12115         /* Can just relocate the target. */
12116         if (kkid && kkid->op_type == OP_PADSV
12117             && (!(kkid->op_private & OPpLVAL_INTRO)
12118                || kkid->op_private & OPpPAD_STATE))
12119         {
12120             kid->op_targ = kkid->op_targ;
12121             kkid->op_targ = 0;
12122             /* Now we do not need PADSV and SASSIGN.
12123              * Detach kid and free the rest. */
12124             op_sibling_splice(o, NULL, 1, NULL);
12125             op_free(o);
12126             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
12127             return kid;
12128         }
12129     }
12130     return o;
12131 }
12132
12133 OP *
12134 Perl_ck_sassign(pTHX_ OP *o)
12135 {
12136     dVAR;
12137     OP * const kid = cBINOPo->op_first;
12138
12139     PERL_ARGS_ASSERT_CK_SASSIGN;
12140
12141     if (OpHAS_SIBLING(kid)) {
12142         OP *kkid = OpSIBLING(kid);
12143         /* For state variable assignment with attributes, kkid is a list op
12144            whose op_last is a padsv. */
12145         if ((kkid->op_type == OP_PADSV ||
12146              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12147               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12148              )
12149             )
12150                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12151                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12152             return S_newONCEOP(aTHX_ o, kkid);
12153         }
12154     }
12155     return S_maybe_targlex(aTHX_ o);
12156 }
12157
12158
12159 OP *
12160 Perl_ck_match(pTHX_ OP *o)
12161 {
12162     PERL_UNUSED_CONTEXT;
12163     PERL_ARGS_ASSERT_CK_MATCH;
12164
12165     return o;
12166 }
12167
12168 OP *
12169 Perl_ck_method(pTHX_ OP *o)
12170 {
12171     SV *sv, *methsv, *rclass;
12172     const char* method;
12173     char* compatptr;
12174     int utf8;
12175     STRLEN len, nsplit = 0, i;
12176     OP* new_op;
12177     OP * const kid = cUNOPo->op_first;
12178
12179     PERL_ARGS_ASSERT_CK_METHOD;
12180     if (kid->op_type != OP_CONST) return o;
12181
12182     sv = kSVOP->op_sv;
12183
12184     /* replace ' with :: */
12185     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12186                                         SvEND(sv) - SvPVX(sv) )))
12187     {
12188         *compatptr = ':';
12189         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12190     }
12191
12192     method = SvPVX_const(sv);
12193     len = SvCUR(sv);
12194     utf8 = SvUTF8(sv) ? -1 : 1;
12195
12196     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12197         nsplit = i+1;
12198         break;
12199     }
12200
12201     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12202
12203     if (!nsplit) { /* $proto->method() */
12204         op_free(o);
12205         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12206     }
12207
12208     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12209         op_free(o);
12210         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12211     }
12212
12213     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12214     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12215         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12216         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12217     } else {
12218         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12219         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12220     }
12221 #ifdef USE_ITHREADS
12222     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12223 #else
12224     cMETHOPx(new_op)->op_rclass_sv = rclass;
12225 #endif
12226     op_free(o);
12227     return new_op;
12228 }
12229
12230 OP *
12231 Perl_ck_null(pTHX_ OP *o)
12232 {
12233     PERL_ARGS_ASSERT_CK_NULL;
12234     PERL_UNUSED_CONTEXT;
12235     return o;
12236 }
12237
12238 OP *
12239 Perl_ck_open(pTHX_ OP *o)
12240 {
12241     PERL_ARGS_ASSERT_CK_OPEN;
12242
12243     S_io_hints(aTHX_ o);
12244     {
12245          /* In case of three-arg dup open remove strictness
12246           * from the last arg if it is a bareword. */
12247          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12248          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
12249          OP *oa;
12250          const char *mode;
12251
12252          if ((last->op_type == OP_CONST) &&             /* The bareword. */
12253              (last->op_private & OPpCONST_BARE) &&
12254              (last->op_private & OPpCONST_STRICT) &&
12255              (oa = OpSIBLING(first)) &&         /* The fh. */
12256              (oa = OpSIBLING(oa)) &&                    /* The mode. */
12257              (oa->op_type == OP_CONST) &&
12258              SvPOK(((SVOP*)oa)->op_sv) &&
12259              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12260              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
12261              (last == OpSIBLING(oa)))                   /* The bareword. */
12262               last->op_private &= ~OPpCONST_STRICT;
12263     }
12264     return ck_fun(o);
12265 }
12266
12267 OP *
12268 Perl_ck_prototype(pTHX_ OP *o)
12269 {
12270     PERL_ARGS_ASSERT_CK_PROTOTYPE;
12271     if (!(o->op_flags & OPf_KIDS)) {
12272         op_free(o);
12273         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12274     }
12275     return o;
12276 }
12277
12278 OP *
12279 Perl_ck_refassign(pTHX_ OP *o)
12280 {
12281     OP * const right = cLISTOPo->op_first;
12282     OP * const left = OpSIBLING(right);
12283     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12284     bool stacked = 0;
12285
12286     PERL_ARGS_ASSERT_CK_REFASSIGN;
12287     assert (left);
12288     assert (left->op_type == OP_SREFGEN);
12289
12290     o->op_private = 0;
12291     /* we use OPpPAD_STATE in refassign to mean either of those things,
12292      * and the code assumes the two flags occupy the same bit position
12293      * in the various ops below */
12294     assert(OPpPAD_STATE == OPpOUR_INTRO);
12295
12296     switch (varop->op_type) {
12297     case OP_PADAV:
12298         o->op_private |= OPpLVREF_AV;
12299         goto settarg;
12300     case OP_PADHV:
12301         o->op_private |= OPpLVREF_HV;
12302         /* FALLTHROUGH */
12303     case OP_PADSV:
12304       settarg:
12305         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12306         o->op_targ = varop->op_targ;
12307         varop->op_targ = 0;
12308         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12309         break;
12310
12311     case OP_RV2AV:
12312         o->op_private |= OPpLVREF_AV;
12313         goto checkgv;
12314         NOT_REACHED; /* NOTREACHED */
12315     case OP_RV2HV:
12316         o->op_private |= OPpLVREF_HV;
12317         /* FALLTHROUGH */
12318     case OP_RV2SV:
12319       checkgv:
12320         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12321         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12322       detach_and_stack:
12323         /* Point varop to its GV kid, detached.  */
12324         varop = op_sibling_splice(varop, NULL, -1, NULL);
12325         stacked = TRUE;
12326         break;
12327     case OP_RV2CV: {
12328         OP * const kidparent =
12329             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12330         OP * const kid = cUNOPx(kidparent)->op_first;
12331         o->op_private |= OPpLVREF_CV;
12332         if (kid->op_type == OP_GV) {
12333             varop = kidparent;
12334             goto detach_and_stack;
12335         }
12336         if (kid->op_type != OP_PADCV)   goto bad;
12337         o->op_targ = kid->op_targ;
12338         kid->op_targ = 0;
12339         break;
12340     }
12341     case OP_AELEM:
12342     case OP_HELEM:
12343         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12344         o->op_private |= OPpLVREF_ELEM;
12345         op_null(varop);
12346         stacked = TRUE;
12347         /* Detach varop.  */
12348         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12349         break;
12350     default:
12351       bad:
12352         /* diag_listed_as: Can't modify reference to %s in %s assignment */
12353         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12354                                 "assignment",
12355                                  OP_DESC(varop)));
12356         return o;
12357     }
12358     if (!FEATURE_REFALIASING_IS_ENABLED)
12359         Perl_croak(aTHX_
12360                   "Experimental aliasing via reference not enabled");
12361     Perl_ck_warner_d(aTHX_
12362                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
12363                     "Aliasing via reference is experimental");
12364     if (stacked) {
12365         o->op_flags |= OPf_STACKED;
12366         op_sibling_splice(o, right, 1, varop);
12367     }
12368     else {
12369         o->op_flags &=~ OPf_STACKED;
12370         op_sibling_splice(o, right, 1, NULL);
12371     }
12372     op_free(left);
12373     return o;
12374 }
12375
12376 OP *
12377 Perl_ck_repeat(pTHX_ OP *o)
12378 {
12379     PERL_ARGS_ASSERT_CK_REPEAT;
12380
12381     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12382         OP* kids;
12383         o->op_private |= OPpREPEAT_DOLIST;
12384         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12385         kids = force_list(kids, 1); /* promote it to a list */
12386         op_sibling_splice(o, NULL, 0, kids); /* and add back */
12387     }
12388     else
12389         scalar(o);
12390     return o;
12391 }
12392
12393 OP *
12394 Perl_ck_require(pTHX_ OP *o)
12395 {
12396     GV* gv;
12397
12398     PERL_ARGS_ASSERT_CK_REQUIRE;
12399
12400     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
12401         SVOP * const kid = (SVOP*)cUNOPo->op_first;
12402         U32 hash;
12403         char *s;
12404         STRLEN len;
12405         if (kid->op_type == OP_CONST) {
12406           SV * const sv = kid->op_sv;
12407           U32 const was_readonly = SvREADONLY(sv);
12408           if (kid->op_private & OPpCONST_BARE) {
12409             dVAR;
12410             const char *end;
12411             HEK *hek;
12412
12413             if (was_readonly) {
12414                     SvREADONLY_off(sv);
12415             }
12416             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12417
12418             s = SvPVX(sv);
12419             len = SvCUR(sv);
12420             end = s + len;
12421             /* treat ::foo::bar as foo::bar */
12422             if (len >= 2 && s[0] == ':' && s[1] == ':')
12423                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12424             if (s == end)
12425                 DIE(aTHX_ "Bareword in require maps to empty filename");
12426
12427             for (; s < end; s++) {
12428                 if (*s == ':' && s[1] == ':') {
12429                     *s = '/';
12430                     Move(s+2, s+1, end - s - 1, char);
12431                     --end;
12432                 }
12433             }
12434             SvEND_set(sv, end);
12435             sv_catpvs(sv, ".pm");
12436             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12437             hek = share_hek(SvPVX(sv),
12438                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12439                             hash);
12440             sv_sethek(sv, hek);
12441             unshare_hek(hek);
12442             SvFLAGS(sv) |= was_readonly;
12443           }
12444           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12445                 && !SvVOK(sv)) {
12446             s = SvPV(sv, len);
12447             if (SvREFCNT(sv) > 1) {
12448                 kid->op_sv = newSVpvn_share(
12449                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12450                 SvREFCNT_dec_NN(sv);
12451             }
12452             else {
12453                 dVAR;
12454                 HEK *hek;
12455                 if (was_readonly) SvREADONLY_off(sv);
12456                 PERL_HASH(hash, s, len);
12457                 hek = share_hek(s,
12458                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12459                                 hash);
12460                 sv_sethek(sv, hek);
12461                 unshare_hek(hek);
12462                 SvFLAGS(sv) |= was_readonly;
12463             }
12464           }
12465         }
12466     }
12467
12468     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12469         /* handle override, if any */
12470      && (gv = gv_override("require", 7))) {
12471         OP *kid, *newop;
12472         if (o->op_flags & OPf_KIDS) {
12473             kid = cUNOPo->op_first;
12474             op_sibling_splice(o, NULL, -1, NULL);
12475         }
12476         else {
12477             kid = newDEFSVOP();
12478         }
12479         op_free(o);
12480         newop = S_new_entersubop(aTHX_ gv, kid);
12481         return newop;
12482     }
12483
12484     return ck_fun(o);
12485 }
12486
12487 OP *
12488 Perl_ck_return(pTHX_ OP *o)
12489 {
12490     OP *kid;
12491
12492     PERL_ARGS_ASSERT_CK_RETURN;
12493
12494     kid = OpSIBLING(cLISTOPo->op_first);
12495     if (PL_compcv && CvLVALUE(PL_compcv)) {
12496         for (; kid; kid = OpSIBLING(kid))
12497             op_lvalue(kid, OP_LEAVESUBLV);
12498     }
12499
12500     return o;
12501 }
12502
12503 OP *
12504 Perl_ck_select(pTHX_ OP *o)
12505 {
12506     dVAR;
12507     OP* kid;
12508
12509     PERL_ARGS_ASSERT_CK_SELECT;
12510
12511     if (o->op_flags & OPf_KIDS) {
12512         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
12513         if (kid && OpHAS_SIBLING(kid)) {
12514             OpTYPE_set(o, OP_SSELECT);
12515             o = ck_fun(o);
12516             return fold_constants(op_integerize(op_std_init(o)));
12517         }
12518     }
12519     o = ck_fun(o);
12520     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12521     if (kid && kid->op_type == OP_RV2GV)
12522         kid->op_private &= ~HINT_STRICT_REFS;
12523     return o;
12524 }
12525
12526 OP *
12527 Perl_ck_shift(pTHX_ OP *o)
12528 {
12529     const I32 type = o->op_type;
12530
12531     PERL_ARGS_ASSERT_CK_SHIFT;
12532
12533     if (!(o->op_flags & OPf_KIDS)) {
12534         OP *argop;
12535
12536         if (!CvUNIQUE(PL_compcv)) {
12537             o->op_flags |= OPf_SPECIAL;
12538             return o;
12539         }
12540
12541         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12542         op_free(o);
12543         return newUNOP(type, 0, scalar(argop));
12544     }
12545     return scalar(ck_fun(o));
12546 }
12547
12548 OP *
12549 Perl_ck_sort(pTHX_ OP *o)
12550 {
12551     OP *firstkid;
12552     OP *kid;
12553     HV * const hinthv =
12554         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12555     U8 stacked;
12556
12557     PERL_ARGS_ASSERT_CK_SORT;
12558
12559     if (hinthv) {
12560             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12561             if (svp) {
12562                 const I32 sorthints = (I32)SvIV(*svp);
12563                 if ((sorthints & HINT_SORT_STABLE) != 0)
12564                     o->op_private |= OPpSORT_STABLE;
12565                 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12566                     o->op_private |= OPpSORT_UNSTABLE;
12567             }
12568     }
12569
12570     if (o->op_flags & OPf_STACKED)
12571         simplify_sort(o);
12572     firstkid = OpSIBLING(cLISTOPo->op_first);           /* get past pushmark */
12573
12574     if ((stacked = o->op_flags & OPf_STACKED)) {        /* may have been cleared */
12575         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
12576
12577         /* if the first arg is a code block, process it and mark sort as
12578          * OPf_SPECIAL */
12579         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12580             LINKLIST(kid);
12581             if (kid->op_type == OP_LEAVE)
12582                     op_null(kid);                       /* wipe out leave */
12583             /* Prevent execution from escaping out of the sort block. */
12584             kid->op_next = 0;
12585
12586             /* provide scalar context for comparison function/block */
12587             kid = scalar(firstkid);
12588             kid->op_next = kid;
12589             o->op_flags |= OPf_SPECIAL;
12590         }
12591         else if (kid->op_type == OP_CONST
12592               && kid->op_private & OPpCONST_BARE) {
12593             char tmpbuf[256];
12594             STRLEN len;
12595             PADOFFSET off;
12596             const char * const name = SvPV(kSVOP_sv, len);
12597             *tmpbuf = '&';
12598             assert (len < 256);
12599             Copy(name, tmpbuf+1, len, char);
12600             off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12601             if (off != NOT_IN_PAD) {
12602                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12603                     SV * const fq =
12604                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12605                     sv_catpvs(fq, "::");
12606                     sv_catsv(fq, kSVOP_sv);
12607                     SvREFCNT_dec_NN(kSVOP_sv);
12608                     kSVOP->op_sv = fq;
12609                 }
12610                 else {
12611                     OP * const padop = newOP(OP_PADCV, 0);
12612                     padop->op_targ = off;
12613                     /* replace the const op with the pad op */
12614                     op_sibling_splice(firstkid, NULL, 1, padop);
12615                     op_free(kid);
12616                 }
12617             }
12618         }
12619
12620         firstkid = OpSIBLING(firstkid);
12621     }
12622
12623     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12624         /* provide list context for arguments */
12625         list(kid);
12626         if (stacked)
12627             op_lvalue(kid, OP_GREPSTART);
12628     }
12629
12630     return o;
12631 }
12632
12633 /* for sort { X } ..., where X is one of
12634  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12635  * elide the second child of the sort (the one containing X),
12636  * and set these flags as appropriate
12637         OPpSORT_NUMERIC;
12638         OPpSORT_INTEGER;
12639         OPpSORT_DESCEND;
12640  * Also, check and warn on lexical $a, $b.
12641  */
12642
12643 STATIC void
12644 S_simplify_sort(pTHX_ OP *o)
12645 {
12646     OP *kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
12647     OP *k;
12648     int descending;
12649     GV *gv;
12650     const char *gvname;
12651     bool have_scopeop;
12652
12653     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12654
12655     kid = kUNOP->op_first;                              /* get past null */
12656     if (!(have_scopeop = kid->op_type == OP_SCOPE)
12657      && kid->op_type != OP_LEAVE)
12658         return;
12659     kid = kLISTOP->op_last;                             /* get past scope */
12660     switch(kid->op_type) {
12661         case OP_NCMP:
12662         case OP_I_NCMP:
12663         case OP_SCMP:
12664             if (!have_scopeop) goto padkids;
12665             break;
12666         default:
12667             return;
12668     }
12669     k = kid;                                            /* remember this node*/
12670     if (kBINOP->op_first->op_type != OP_RV2SV
12671      || kBINOP->op_last ->op_type != OP_RV2SV)
12672     {
12673         /*
12674            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12675            then used in a comparison.  This catches most, but not
12676            all cases.  For instance, it catches
12677                sort { my($a); $a <=> $b }
12678            but not
12679                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12680            (although why you'd do that is anyone's guess).
12681         */
12682
12683        padkids:
12684         if (!ckWARN(WARN_SYNTAX)) return;
12685         kid = kBINOP->op_first;
12686         do {
12687             if (kid->op_type == OP_PADSV) {
12688                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12689                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12690                  && (  PadnamePV(name)[1] == 'a'
12691                     || PadnamePV(name)[1] == 'b'  ))
12692                     /* diag_listed_as: "my %s" used in sort comparison */
12693                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12694                                      "\"%s %s\" used in sort comparison",
12695                                       PadnameIsSTATE(name)
12696                                         ? "state"
12697                                         : "my",
12698                                       PadnamePV(name));
12699             }
12700         } while ((kid = OpSIBLING(kid)));
12701         return;
12702     }
12703     kid = kBINOP->op_first;                             /* get past cmp */
12704     if (kUNOP->op_first->op_type != OP_GV)
12705         return;
12706     kid = kUNOP->op_first;                              /* get past rv2sv */
12707     gv = kGVOP_gv;
12708     if (GvSTASH(gv) != PL_curstash)
12709         return;
12710     gvname = GvNAME(gv);
12711     if (*gvname == 'a' && gvname[1] == '\0')
12712         descending = 0;
12713     else if (*gvname == 'b' && gvname[1] == '\0')
12714         descending = 1;
12715     else
12716         return;
12717
12718     kid = k;                                            /* back to cmp */
12719     /* already checked above that it is rv2sv */
12720     kid = kBINOP->op_last;                              /* down to 2nd arg */
12721     if (kUNOP->op_first->op_type != OP_GV)
12722         return;
12723     kid = kUNOP->op_first;                              /* get past rv2sv */
12724     gv = kGVOP_gv;
12725     if (GvSTASH(gv) != PL_curstash)
12726         return;
12727     gvname = GvNAME(gv);
12728     if ( descending
12729          ? !(*gvname == 'a' && gvname[1] == '\0')
12730          : !(*gvname == 'b' && gvname[1] == '\0'))
12731         return;
12732     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12733     if (descending)
12734         o->op_private |= OPpSORT_DESCEND;
12735     if (k->op_type == OP_NCMP)
12736         o->op_private |= OPpSORT_NUMERIC;
12737     if (k->op_type == OP_I_NCMP)
12738         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12739     kid = OpSIBLING(cLISTOPo->op_first);
12740     /* cut out and delete old block (second sibling) */
12741     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12742     op_free(kid);
12743 }
12744
12745 OP *
12746 Perl_ck_split(pTHX_ OP *o)
12747 {
12748     dVAR;
12749     OP *kid;
12750     OP *sibs;
12751
12752     PERL_ARGS_ASSERT_CK_SPLIT;
12753
12754     assert(o->op_type == OP_LIST);
12755
12756     if (o->op_flags & OPf_STACKED)
12757         return no_fh_allowed(o);
12758
12759     kid = cLISTOPo->op_first;
12760     /* delete leading NULL node, then add a CONST if no other nodes */
12761     assert(kid->op_type == OP_NULL);
12762     op_sibling_splice(o, NULL, 1,
12763         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12764     op_free(kid);
12765     kid = cLISTOPo->op_first;
12766
12767     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12768         /* remove match expression, and replace with new optree with
12769          * a match op at its head */
12770         op_sibling_splice(o, NULL, 1, NULL);
12771         /* pmruntime will handle split " " behavior with flag==2 */
12772         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12773         op_sibling_splice(o, NULL, 0, kid);
12774     }
12775
12776     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12777
12778     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12779       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12780                      "Use of /g modifier is meaningless in split");
12781     }
12782
12783     /* eliminate the split op, and move the match op (plus any children)
12784      * into its place, then convert the match op into a split op. i.e.
12785      *
12786      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
12787      *    |                        |                     |
12788      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
12789      *    |                        |                     |
12790      *    R                        X - Y                 X - Y
12791      *    |
12792      *    X - Y
12793      *
12794      * (R, if it exists, will be a regcomp op)
12795      */
12796
12797     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12798     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12799     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12800     OpTYPE_set(kid, OP_SPLIT);
12801     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
12802     kid->op_private = o->op_private;
12803     op_free(o);
12804     o = kid;
12805     kid = sibs; /* kid is now the string arg of the split */
12806
12807     if (!kid) {
12808         kid = newDEFSVOP();
12809         op_append_elem(OP_SPLIT, o, kid);
12810     }
12811     scalar(kid);
12812
12813     kid = OpSIBLING(kid);
12814     if (!kid) {
12815         kid = newSVOP(OP_CONST, 0, newSViv(0));
12816         op_append_elem(OP_SPLIT, o, kid);
12817         o->op_private |= OPpSPLIT_IMPLIM;
12818     }
12819     scalar(kid);
12820
12821     if (OpHAS_SIBLING(kid))
12822         return too_many_arguments_pv(o,OP_DESC(o), 0);
12823
12824     return o;
12825 }
12826
12827 OP *
12828 Perl_ck_stringify(pTHX_ OP *o)
12829 {
12830     OP * const kid = OpSIBLING(cUNOPo->op_first);
12831     PERL_ARGS_ASSERT_CK_STRINGIFY;
12832     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12833          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
12834          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
12835         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12836     {
12837         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12838         op_free(o);
12839         return kid;
12840     }
12841     return ck_fun(o);
12842 }
12843
12844 OP *
12845 Perl_ck_join(pTHX_ OP *o)
12846 {
12847     OP * const kid = OpSIBLING(cLISTOPo->op_first);
12848
12849     PERL_ARGS_ASSERT_CK_JOIN;
12850
12851     if (kid && kid->op_type == OP_MATCH) {
12852         if (ckWARN(WARN_SYNTAX)) {
12853             const REGEXP *re = PM_GETRE(kPMOP);
12854             const SV *msg = re
12855                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12856                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12857                     : newSVpvs_flags( "STRING", SVs_TEMP );
12858             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12859                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
12860                         SVfARG(msg), SVfARG(msg));
12861         }
12862     }
12863     if (kid
12864      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12865         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12866         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12867            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12868     {
12869         const OP * const bairn = OpSIBLING(kid); /* the list */
12870         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12871          && OP_GIMME(bairn,0) == G_SCALAR)
12872         {
12873             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12874                                      op_sibling_splice(o, kid, 1, NULL));
12875             op_free(o);
12876             return ret;
12877         }
12878     }
12879
12880     return ck_fun(o);
12881 }
12882
12883 /*
12884 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12885
12886 Examines an op, which is expected to identify a subroutine at runtime,
12887 and attempts to determine at compile time which subroutine it identifies.
12888 This is normally used during Perl compilation to determine whether
12889 a prototype can be applied to a function call.  C<cvop> is the op
12890 being considered, normally an C<rv2cv> op.  A pointer to the identified
12891 subroutine is returned, if it could be determined statically, and a null
12892 pointer is returned if it was not possible to determine statically.
12893
12894 Currently, the subroutine can be identified statically if the RV that the
12895 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12896 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
12897 suitable if the constant value must be an RV pointing to a CV.  Details of
12898 this process may change in future versions of Perl.  If the C<rv2cv> op
12899 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12900 the subroutine statically: this flag is used to suppress compile-time
12901 magic on a subroutine call, forcing it to use default runtime behaviour.
12902
12903 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12904 of a GV reference is modified.  If a GV was examined and its CV slot was
12905 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12906 If the op is not optimised away, and the CV slot is later populated with
12907 a subroutine having a prototype, that flag eventually triggers the warning
12908 "called too early to check prototype".
12909
12910 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12911 of returning a pointer to the subroutine it returns a pointer to the
12912 GV giving the most appropriate name for the subroutine in this context.
12913 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12914 (C<CvANON>) subroutine that is referenced through a GV it will be the
12915 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
12916 A null pointer is returned as usual if there is no statically-determinable
12917 subroutine.
12918
12919 =cut
12920 */
12921
12922 /* shared by toke.c:yylex */
12923 CV *
12924 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12925 {
12926     PADNAME *name = PAD_COMPNAME(off);
12927     CV *compcv = PL_compcv;
12928     while (PadnameOUTER(name)) {
12929         assert(PARENT_PAD_INDEX(name));
12930         compcv = CvOUTSIDE(compcv);
12931         name = PadlistNAMESARRAY(CvPADLIST(compcv))
12932                 [off = PARENT_PAD_INDEX(name)];
12933     }
12934     assert(!PadnameIsOUR(name));
12935     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
12936         return PadnamePROTOCV(name);
12937     }
12938     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
12939 }
12940
12941 CV *
12942 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
12943 {
12944     OP *rvop;
12945     CV *cv;
12946     GV *gv;
12947     PERL_ARGS_ASSERT_RV2CV_OP_CV;
12948     if (flags & ~RV2CVOPCV_FLAG_MASK)
12949         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
12950     if (cvop->op_type != OP_RV2CV)
12951         return NULL;
12952     if (cvop->op_private & OPpENTERSUB_AMPER)
12953         return NULL;
12954     if (!(cvop->op_flags & OPf_KIDS))
12955         return NULL;
12956     rvop = cUNOPx(cvop)->op_first;
12957     switch (rvop->op_type) {
12958         case OP_GV: {
12959             gv = cGVOPx_gv(rvop);
12960             if (!isGV(gv)) {
12961                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
12962                     cv = MUTABLE_CV(SvRV(gv));
12963                     gv = NULL;
12964                     break;
12965                 }
12966                 if (flags & RV2CVOPCV_RETURN_STUB)
12967                     return (CV *)gv;
12968                 else return NULL;
12969             }
12970             cv = GvCVu(gv);
12971             if (!cv) {
12972                 if (flags & RV2CVOPCV_MARK_EARLY)
12973                     rvop->op_private |= OPpEARLY_CV;
12974                 return NULL;
12975             }
12976         } break;
12977         case OP_CONST: {
12978             SV *rv = cSVOPx_sv(rvop);
12979             if (!SvROK(rv))
12980                 return NULL;
12981             cv = (CV*)SvRV(rv);
12982             gv = NULL;
12983         } break;
12984         case OP_PADCV: {
12985             cv = find_lexical_cv(rvop->op_targ);
12986             gv = NULL;
12987         } break;
12988         default: {
12989             return NULL;
12990         } NOT_REACHED; /* NOTREACHED */
12991     }
12992     if (SvTYPE((SV*)cv) != SVt_PVCV)
12993         return NULL;
12994     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
12995         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
12996             gv = CvGV(cv);
12997         return (CV*)gv;
12998     }
12999     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13000         if (CvLEXICAL(cv) || CvNAMED(cv))
13001             return NULL;
13002         if (!CvANON(cv) || !gv)
13003             gv = CvGV(cv);
13004         return (CV*)gv;
13005
13006     } else {
13007         return cv;
13008     }
13009 }
13010
13011 /*
13012 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13013
13014 Performs the default fixup of the arguments part of an C<entersub>
13015 op tree.  This consists of applying list context to each of the
13016 argument ops.  This is the standard treatment used on a call marked
13017 with C<&>, or a method call, or a call through a subroutine reference,
13018 or any other call where the callee can't be identified at compile time,
13019 or a call where the callee has no prototype.
13020
13021 =cut
13022 */
13023
13024 OP *
13025 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13026 {
13027     OP *aop;
13028
13029     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13030
13031     aop = cUNOPx(entersubop)->op_first;
13032     if (!OpHAS_SIBLING(aop))
13033         aop = cUNOPx(aop)->op_first;
13034     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13035         /* skip the extra attributes->import() call implicitly added in
13036          * something like foo(my $x : bar)
13037          */
13038         if (   aop->op_type == OP_ENTERSUB
13039             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13040         )
13041             continue;
13042         list(aop);
13043         op_lvalue(aop, OP_ENTERSUB);
13044     }
13045     return entersubop;
13046 }
13047
13048 /*
13049 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13050
13051 Performs the fixup of the arguments part of an C<entersub> op tree
13052 based on a subroutine prototype.  This makes various modifications to
13053 the argument ops, from applying context up to inserting C<refgen> ops,
13054 and checking the number and syntactic types of arguments, as directed by
13055 the prototype.  This is the standard treatment used on a subroutine call,
13056 not marked with C<&>, where the callee can be identified at compile time
13057 and has a prototype.
13058
13059 C<protosv> supplies the subroutine prototype to be applied to the call.
13060 It may be a normal defined scalar, of which the string value will be used.
13061 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13062 that has been cast to C<SV*>) which has a prototype.  The prototype
13063 supplied, in whichever form, does not need to match the actual callee
13064 referenced by the op tree.
13065
13066 If the argument ops disagree with the prototype, for example by having
13067 an unacceptable number of arguments, a valid op tree is returned anyway.
13068 The error is reflected in the parser state, normally resulting in a single
13069 exception at the top level of parsing which covers all the compilation
13070 errors that occurred.  In the error message, the callee is referred to
13071 by the name defined by the C<namegv> parameter.
13072
13073 =cut
13074 */
13075
13076 OP *
13077 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13078 {
13079     STRLEN proto_len;
13080     const char *proto, *proto_end;
13081     OP *aop, *prev, *cvop, *parent;
13082     int optional = 0;
13083     I32 arg = 0;
13084     I32 contextclass = 0;
13085     const char *e = NULL;
13086     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13087     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13088         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13089                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
13090     if (SvTYPE(protosv) == SVt_PVCV)
13091          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13092     else proto = SvPV(protosv, proto_len);
13093     proto = S_strip_spaces(aTHX_ proto, &proto_len);
13094     proto_end = proto + proto_len;
13095     parent = entersubop;
13096     aop = cUNOPx(entersubop)->op_first;
13097     if (!OpHAS_SIBLING(aop)) {
13098         parent = aop;
13099         aop = cUNOPx(aop)->op_first;
13100     }
13101     prev = aop;
13102     aop = OpSIBLING(aop);
13103     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13104     while (aop != cvop) {
13105         OP* o3 = aop;
13106
13107         if (proto >= proto_end)
13108         {
13109             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13110             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13111                                         SVfARG(namesv)), SvUTF8(namesv));
13112             return entersubop;
13113         }
13114
13115         switch (*proto) {
13116             case ';':
13117                 optional = 1;
13118                 proto++;
13119                 continue;
13120             case '_':
13121                 /* _ must be at the end */
13122                 if (proto[1] && !strchr(";@%", proto[1]))
13123                     goto oops;
13124                 /* FALLTHROUGH */
13125             case '$':
13126                 proto++;
13127                 arg++;
13128                 scalar(aop);
13129                 break;
13130             case '%':
13131             case '@':
13132                 list(aop);
13133                 arg++;
13134                 break;
13135             case '&':
13136                 proto++;
13137                 arg++;
13138                 if (    o3->op_type != OP_UNDEF
13139                     && (o3->op_type != OP_SREFGEN
13140                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13141                                 != OP_ANONCODE
13142                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13143                                 != OP_RV2CV)))
13144                     bad_type_gv(arg, namegv, o3,
13145                             arg == 1 ? "block or sub {}" : "sub {}");
13146                 break;
13147             case '*':
13148                 /* '*' allows any scalar type, including bareword */
13149                 proto++;
13150                 arg++;
13151                 if (o3->op_type == OP_RV2GV)
13152                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
13153                 else if (o3->op_type == OP_CONST)
13154                     o3->op_private &= ~OPpCONST_STRICT;
13155                 scalar(aop);
13156                 break;
13157             case '+':
13158                 proto++;
13159                 arg++;
13160                 if (o3->op_type == OP_RV2AV ||
13161                     o3->op_type == OP_PADAV ||
13162                     o3->op_type == OP_RV2HV ||
13163                     o3->op_type == OP_PADHV
13164                 ) {
13165                     goto wrapref;
13166                 }
13167                 scalar(aop);
13168                 break;
13169             case '[': case ']':
13170                 goto oops;
13171
13172             case '\\':
13173                 proto++;
13174                 arg++;
13175             again:
13176                 switch (*proto++) {
13177                     case '[':
13178                         if (contextclass++ == 0) {
13179                             e = (char *) memchr(proto, ']', proto_end - proto);
13180                             if (!e || e == proto)
13181                                 goto oops;
13182                         }
13183                         else
13184                             goto oops;
13185                         goto again;
13186
13187                     case ']':
13188                         if (contextclass) {
13189                             const char *p = proto;
13190                             const char *const end = proto;
13191                             contextclass = 0;
13192                             while (*--p != '[')
13193                                 /* \[$] accepts any scalar lvalue */
13194                                 if (*p == '$'
13195                                  && Perl_op_lvalue_flags(aTHX_
13196                                      scalar(o3),
13197                                      OP_READ, /* not entersub */
13198                                      OP_LVALUE_NO_CROAK
13199                                     )) goto wrapref;
13200                             bad_type_gv(arg, namegv, o3,
13201                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13202                         } else
13203                             goto oops;
13204                         break;
13205                     case '*':
13206                         if (o3->op_type == OP_RV2GV)
13207                             goto wrapref;
13208                         if (!contextclass)
13209                             bad_type_gv(arg, namegv, o3, "symbol");
13210                         break;
13211                     case '&':
13212                         if (o3->op_type == OP_ENTERSUB
13213                          && !(o3->op_flags & OPf_STACKED))
13214                             goto wrapref;
13215                         if (!contextclass)
13216                             bad_type_gv(arg, namegv, o3, "subroutine");
13217                         break;
13218                     case '$':
13219                         if (o3->op_type == OP_RV2SV ||
13220                                 o3->op_type == OP_PADSV ||
13221                                 o3->op_type == OP_HELEM ||
13222                                 o3->op_type == OP_AELEM)
13223                             goto wrapref;
13224                         if (!contextclass) {
13225                             /* \$ accepts any scalar lvalue */
13226                             if (Perl_op_lvalue_flags(aTHX_
13227                                     scalar(o3),
13228                                     OP_READ,  /* not entersub */
13229                                     OP_LVALUE_NO_CROAK
13230                                )) goto wrapref;
13231                             bad_type_gv(arg, namegv, o3, "scalar");
13232                         }
13233                         break;
13234                     case '@':
13235                         if (o3->op_type == OP_RV2AV ||
13236                                 o3->op_type == OP_PADAV)
13237                         {
13238                             o3->op_flags &=~ OPf_PARENS;
13239                             goto wrapref;
13240                         }
13241                         if (!contextclass)
13242                             bad_type_gv(arg, namegv, o3, "array");
13243                         break;
13244                     case '%':
13245                         if (o3->op_type == OP_RV2HV ||
13246                                 o3->op_type == OP_PADHV)
13247                         {
13248                             o3->op_flags &=~ OPf_PARENS;
13249                             goto wrapref;
13250                         }
13251                         if (!contextclass)
13252                             bad_type_gv(arg, namegv, o3, "hash");
13253                         break;
13254                     wrapref:
13255                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13256                                                 OP_REFGEN, 0);
13257                         if (contextclass && e) {
13258                             proto = e + 1;
13259                             contextclass = 0;
13260                         }
13261                         break;
13262                     default: goto oops;
13263                 }
13264                 if (contextclass)
13265                     goto again;
13266                 break;
13267             case ' ':
13268                 proto++;
13269                 continue;
13270             default:
13271             oops: {
13272                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13273                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
13274                                   SVfARG(protosv));
13275             }
13276         }
13277
13278         op_lvalue(aop, OP_ENTERSUB);
13279         prev = aop;
13280         aop = OpSIBLING(aop);
13281     }
13282     if (aop == cvop && *proto == '_') {
13283         /* generate an access to $_ */
13284         op_sibling_splice(parent, prev, 0, newDEFSVOP());
13285     }
13286     if (!optional && proto_end > proto &&
13287         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13288     {
13289         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13290         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13291                                     SVfARG(namesv)), SvUTF8(namesv));
13292     }
13293     return entersubop;
13294 }
13295
13296 /*
13297 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13298
13299 Performs the fixup of the arguments part of an C<entersub> op tree either
13300 based on a subroutine prototype or using default list-context processing.
13301 This is the standard treatment used on a subroutine call, not marked
13302 with C<&>, where the callee can be identified at compile time.
13303
13304 C<protosv> supplies the subroutine prototype to be applied to the call,
13305 or indicates that there is no prototype.  It may be a normal scalar,
13306 in which case if it is defined then the string value will be used
13307 as a prototype, and if it is undefined then there is no prototype.
13308 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13309 that has been cast to C<SV*>), of which the prototype will be used if it
13310 has one.  The prototype (or lack thereof) supplied, in whichever form,
13311 does not need to match the actual callee referenced by the op tree.
13312
13313 If the argument ops disagree with the prototype, for example by having
13314 an unacceptable number of arguments, a valid op tree is returned anyway.
13315 The error is reflected in the parser state, normally resulting in a single
13316 exception at the top level of parsing which covers all the compilation
13317 errors that occurred.  In the error message, the callee is referred to
13318 by the name defined by the C<namegv> parameter.
13319
13320 =cut
13321 */
13322
13323 OP *
13324 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13325         GV *namegv, SV *protosv)
13326 {
13327     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13328     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13329         return ck_entersub_args_proto(entersubop, namegv, protosv);
13330     else
13331         return ck_entersub_args_list(entersubop);
13332 }
13333
13334 OP *
13335 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13336 {
13337     IV cvflags = SvIVX(protosv);
13338     int opnum = cvflags & 0xffff;
13339     OP *aop = cUNOPx(entersubop)->op_first;
13340
13341     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13342
13343     if (!opnum) {
13344         OP *cvop;
13345         if (!OpHAS_SIBLING(aop))
13346             aop = cUNOPx(aop)->op_first;
13347         aop = OpSIBLING(aop);
13348         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13349         if (aop != cvop) {
13350             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13351             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13352                 SVfARG(namesv)), SvUTF8(namesv));
13353         }
13354
13355         op_free(entersubop);
13356         switch(cvflags >> 16) {
13357         case 'F': return newSVOP(OP_CONST, 0,
13358                                         newSVpv(CopFILE(PL_curcop),0));
13359         case 'L': return newSVOP(
13360                            OP_CONST, 0,
13361                            Perl_newSVpvf(aTHX_
13362                              "%" IVdf, (IV)CopLINE(PL_curcop)
13363                            )
13364                          );
13365         case 'P': return newSVOP(OP_CONST, 0,
13366                                    (PL_curstash
13367                                      ? newSVhek(HvNAME_HEK(PL_curstash))
13368                                      : &PL_sv_undef
13369                                    )
13370                                 );
13371         }
13372         NOT_REACHED; /* NOTREACHED */
13373     }
13374     else {
13375         OP *prev, *cvop, *first, *parent;
13376         U32 flags = 0;
13377
13378         parent = entersubop;
13379         if (!OpHAS_SIBLING(aop)) {
13380             parent = aop;
13381             aop = cUNOPx(aop)->op_first;
13382         }
13383
13384         first = prev = aop;
13385         aop = OpSIBLING(aop);
13386         /* find last sibling */
13387         for (cvop = aop;
13388              OpHAS_SIBLING(cvop);
13389              prev = cvop, cvop = OpSIBLING(cvop))
13390             ;
13391         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13392             /* Usually, OPf_SPECIAL on an op with no args means that it had
13393              * parens, but these have their own meaning for that flag: */
13394             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13395             && opnum != OP_DELETE && opnum != OP_EXISTS)
13396                 flags |= OPf_SPECIAL;
13397         /* excise cvop from end of sibling chain */
13398         op_sibling_splice(parent, prev, 1, NULL);
13399         op_free(cvop);
13400         if (aop == cvop) aop = NULL;
13401
13402         /* detach remaining siblings from the first sibling, then
13403          * dispose of original optree */
13404
13405         if (aop)
13406             op_sibling_splice(parent, first, -1, NULL);
13407         op_free(entersubop);
13408
13409         if (cvflags == (OP_ENTEREVAL | (1<<16)))
13410             flags |= OPpEVAL_BYTES <<8;
13411
13412         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13413         case OA_UNOP:
13414         case OA_BASEOP_OR_UNOP:
13415         case OA_FILESTATOP:
13416             return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13417         case OA_BASEOP:
13418             if (aop) {
13419                 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13420                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13421                     SVfARG(namesv)), SvUTF8(namesv));
13422                 op_free(aop);
13423             }
13424             return opnum == OP_RUNCV
13425                 ? newPVOP(OP_RUNCV,0,NULL)
13426                 : newOP(opnum,0);
13427         default:
13428             return op_convert_list(opnum,0,aop);
13429         }
13430     }
13431     NOT_REACHED; /* NOTREACHED */
13432     return entersubop;
13433 }
13434
13435 /*
13436 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13437
13438 Retrieves the function that will be used to fix up a call to C<cv>.
13439 Specifically, the function is applied to an C<entersub> op tree for a
13440 subroutine call, not marked with C<&>, where the callee can be identified
13441 at compile time as C<cv>.
13442
13443 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13444 for it is returned in C<*ckobj_p>, and control flags are returned in
13445 C<*ckflags_p>.  The function is intended to be called in this manner:
13446
13447  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13448
13449 In this call, C<entersubop> is a pointer to the C<entersub> op,
13450 which may be replaced by the check function, and C<namegv> supplies
13451 the name that should be used by the check function to refer
13452 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13453 It is permitted to apply the check function in non-standard situations,
13454 such as to a call to a different subroutine or to a method call.
13455
13456 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
13457 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13458 instead, anything that can be used as the first argument to L</cv_name>.
13459 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13460 check function requires C<namegv> to be a genuine GV.
13461
13462 By default, the check function is
13463 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13464 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13465 flag is clear.  This implements standard prototype processing.  It can
13466 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13467
13468 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13469 indicates that the caller only knows about the genuine GV version of
13470 C<namegv>, and accordingly the corresponding bit will always be set in
13471 C<*ckflags_p>, regardless of the check function's recorded requirements.
13472 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13473 indicates the caller knows about the possibility of passing something
13474 other than a GV as C<namegv>, and accordingly the corresponding bit may
13475 be either set or clear in C<*ckflags_p>, indicating the check function's
13476 recorded requirements.
13477
13478 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13479 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13480 (for which see above).  All other bits should be clear.
13481
13482 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13483
13484 The original form of L</cv_get_call_checker_flags>, which does not return
13485 checker flags.  When using a checker function returned by this function,
13486 it is only safe to call it with a genuine GV as its C<namegv> argument.
13487
13488 =cut
13489 */
13490
13491 void
13492 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13493         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13494 {
13495     MAGIC *callmg;
13496     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13497     PERL_UNUSED_CONTEXT;
13498     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13499     if (callmg) {
13500         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13501         *ckobj_p = callmg->mg_obj;
13502         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13503     } else {
13504         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13505         *ckobj_p = (SV*)cv;
13506         *ckflags_p = gflags & MGf_REQUIRE_GV;
13507     }
13508 }
13509
13510 void
13511 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13512 {
13513     U32 ckflags;
13514     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13515     PERL_UNUSED_CONTEXT;
13516     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13517         &ckflags);
13518 }
13519
13520 /*
13521 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13522
13523 Sets the function that will be used to fix up a call to C<cv>.
13524 Specifically, the function is applied to an C<entersub> op tree for a
13525 subroutine call, not marked with C<&>, where the callee can be identified
13526 at compile time as C<cv>.
13527
13528 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13529 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13530 The function should be defined like this:
13531
13532     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13533
13534 It is intended to be called in this manner:
13535
13536     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13537
13538 In this call, C<entersubop> is a pointer to the C<entersub> op,
13539 which may be replaced by the check function, and C<namegv> supplies
13540 the name that should be used by the check function to refer
13541 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13542 It is permitted to apply the check function in non-standard situations,
13543 such as to a call to a different subroutine or to a method call.
13544
13545 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
13546 CV or other SV instead.  Whatever is passed can be used as the first
13547 argument to L</cv_name>.  You can force perl to pass a GV by including
13548 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13549
13550 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13551 bit currently has a defined meaning (for which see above).  All other
13552 bits should be clear.
13553
13554 The current setting for a particular CV can be retrieved by
13555 L</cv_get_call_checker_flags>.
13556
13557 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13558
13559 The original form of L</cv_set_call_checker_flags>, which passes it the
13560 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
13561 of that flag setting is that the check function is guaranteed to get a
13562 genuine GV as its C<namegv> argument.
13563
13564 =cut
13565 */
13566
13567 void
13568 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13569 {
13570     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13571     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13572 }
13573
13574 void
13575 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13576                                      SV *ckobj, U32 ckflags)
13577 {
13578     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13579     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13580         if (SvMAGICAL((SV*)cv))
13581             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13582     } else {
13583         MAGIC *callmg;
13584         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13585         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13586         assert(callmg);
13587         if (callmg->mg_flags & MGf_REFCOUNTED) {
13588             SvREFCNT_dec(callmg->mg_obj);
13589             callmg->mg_flags &= ~MGf_REFCOUNTED;
13590         }
13591         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13592         callmg->mg_obj = ckobj;
13593         if (ckobj != (SV*)cv) {
13594             SvREFCNT_inc_simple_void_NN(ckobj);
13595             callmg->mg_flags |= MGf_REFCOUNTED;
13596         }
13597         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13598                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13599     }
13600 }
13601
13602 static void
13603 S_entersub_alloc_targ(pTHX_ OP * const o)
13604 {
13605     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13606     o->op_private |= OPpENTERSUB_HASTARG;
13607 }
13608
13609 OP *
13610 Perl_ck_subr(pTHX_ OP *o)
13611 {
13612     OP *aop, *cvop;
13613     CV *cv;
13614     GV *namegv;
13615     SV **const_class = NULL;
13616
13617     PERL_ARGS_ASSERT_CK_SUBR;
13618
13619     aop = cUNOPx(o)->op_first;
13620     if (!OpHAS_SIBLING(aop))
13621         aop = cUNOPx(aop)->op_first;
13622     aop = OpSIBLING(aop);
13623     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13624     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13625     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13626
13627     o->op_private &= ~1;
13628     o->op_private |= (PL_hints & HINT_STRICT_REFS);
13629     if (PERLDB_SUB && PL_curstash != PL_debstash)
13630         o->op_private |= OPpENTERSUB_DB;
13631     switch (cvop->op_type) {
13632         case OP_RV2CV:
13633             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13634             op_null(cvop);
13635             break;
13636         case OP_METHOD:
13637         case OP_METHOD_NAMED:
13638         case OP_METHOD_SUPER:
13639         case OP_METHOD_REDIR:
13640         case OP_METHOD_REDIR_SUPER:
13641             o->op_flags |= OPf_REF;
13642             if (aop->op_type == OP_CONST) {
13643                 aop->op_private &= ~OPpCONST_STRICT;
13644                 const_class = &cSVOPx(aop)->op_sv;
13645             }
13646             else if (aop->op_type == OP_LIST) {
13647                 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13648                 if (sib && sib->op_type == OP_CONST) {
13649                     sib->op_private &= ~OPpCONST_STRICT;
13650                     const_class = &cSVOPx(sib)->op_sv;
13651                 }
13652             }
13653             /* make class name a shared cow string to speedup method calls */
13654             /* constant string might be replaced with object, f.e. bigint */
13655             if (const_class && SvPOK(*const_class)) {
13656                 STRLEN len;
13657                 const char* str = SvPV(*const_class, len);
13658                 if (len) {
13659                     SV* const shared = newSVpvn_share(
13660                         str, SvUTF8(*const_class)
13661                                     ? -(SSize_t)len : (SSize_t)len,
13662                         0
13663                     );
13664                     if (SvREADONLY(*const_class))
13665                         SvREADONLY_on(shared);
13666                     SvREFCNT_dec(*const_class);
13667                     *const_class = shared;
13668                 }
13669             }
13670             break;
13671     }
13672
13673     if (!cv) {
13674         S_entersub_alloc_targ(aTHX_ o);
13675         return ck_entersub_args_list(o);
13676     } else {
13677         Perl_call_checker ckfun;
13678         SV *ckobj;
13679         U32 ckflags;
13680         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13681         if (CvISXSUB(cv) || !CvROOT(cv))
13682             S_entersub_alloc_targ(aTHX_ o);
13683         if (!namegv) {
13684             /* The original call checker API guarantees that a GV will be
13685                be provided with the right name.  So, if the old API was
13686                used (or the REQUIRE_GV flag was passed), we have to reify
13687                the CV’s GV, unless this is an anonymous sub.  This is not
13688                ideal for lexical subs, as its stringification will include
13689                the package.  But it is the best we can do.  */
13690             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13691                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13692                     namegv = CvGV(cv);
13693             }
13694             else namegv = MUTABLE_GV(cv);
13695             /* After a syntax error in a lexical sub, the cv that
13696                rv2cv_op_cv returns may be a nameless stub. */
13697             if (!namegv) return ck_entersub_args_list(o);
13698
13699         }
13700         return ckfun(aTHX_ o, namegv, ckobj);
13701     }
13702 }
13703
13704 OP *
13705 Perl_ck_svconst(pTHX_ OP *o)
13706 {
13707     SV * const sv = cSVOPo->op_sv;
13708     PERL_ARGS_ASSERT_CK_SVCONST;
13709     PERL_UNUSED_CONTEXT;
13710 #ifdef PERL_COPY_ON_WRITE
13711     /* Since the read-only flag may be used to protect a string buffer, we
13712        cannot do copy-on-write with existing read-only scalars that are not
13713        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
13714        that constant, mark the constant as COWable here, if it is not
13715        already read-only. */
13716     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13717         SvIsCOW_on(sv);
13718         CowREFCNT(sv) = 0;
13719 # ifdef PERL_DEBUG_READONLY_COW
13720         sv_buf_to_ro(sv);
13721 # endif
13722     }
13723 #endif
13724     SvREADONLY_on(sv);
13725     return o;
13726 }
13727
13728 OP *
13729 Perl_ck_trunc(pTHX_ OP *o)
13730 {
13731     PERL_ARGS_ASSERT_CK_TRUNC;
13732
13733     if (o->op_flags & OPf_KIDS) {
13734         SVOP *kid = (SVOP*)cUNOPo->op_first;
13735
13736         if (kid->op_type == OP_NULL)
13737             kid = (SVOP*)OpSIBLING(kid);
13738         if (kid && kid->op_type == OP_CONST &&
13739             (kid->op_private & OPpCONST_BARE) &&
13740             !kid->op_folded)
13741         {
13742             o->op_flags |= OPf_SPECIAL;
13743             kid->op_private &= ~OPpCONST_STRICT;
13744         }
13745     }
13746     return ck_fun(o);
13747 }
13748
13749 OP *
13750 Perl_ck_substr(pTHX_ OP *o)
13751 {
13752     PERL_ARGS_ASSERT_CK_SUBSTR;
13753
13754     o = ck_fun(o);
13755     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13756         OP *kid = cLISTOPo->op_first;
13757
13758         if (kid->op_type == OP_NULL)
13759             kid = OpSIBLING(kid);
13760         if (kid)
13761             /* Historically, substr(delete $foo{bar},...) has been allowed
13762                with 4-arg substr.  Keep it working by applying entersub
13763                lvalue context.  */
13764             op_lvalue(kid, OP_ENTERSUB);
13765
13766     }
13767     return o;
13768 }
13769
13770 OP *
13771 Perl_ck_tell(pTHX_ OP *o)
13772 {
13773     PERL_ARGS_ASSERT_CK_TELL;
13774     o = ck_fun(o);
13775     if (o->op_flags & OPf_KIDS) {
13776      OP *kid = cLISTOPo->op_first;
13777      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13778      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13779     }
13780     return o;
13781 }
13782
13783 OP *
13784 Perl_ck_each(pTHX_ OP *o)
13785 {
13786     dVAR;
13787     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13788     const unsigned orig_type  = o->op_type;
13789
13790     PERL_ARGS_ASSERT_CK_EACH;
13791
13792     if (kid) {
13793         switch (kid->op_type) {
13794             case OP_PADHV:
13795             case OP_RV2HV:
13796                 break;
13797             case OP_PADAV:
13798             case OP_RV2AV:
13799                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13800                             : orig_type == OP_KEYS ? OP_AKEYS
13801                             :                        OP_AVALUES);
13802                 break;
13803             case OP_CONST:
13804                 if (kid->op_private == OPpCONST_BARE
13805                  || !SvROK(cSVOPx_sv(kid))
13806                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13807                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
13808                    )
13809                     goto bad;
13810                 /* FALLTHROUGH */
13811             default:
13812                 qerror(Perl_mess(aTHX_
13813                     "Experimental %s on scalar is now forbidden",
13814                      PL_op_desc[orig_type]));
13815                bad:
13816                 bad_type_pv(1, "hash or array", o, kid);
13817                 return o;
13818         }
13819     }
13820     return ck_fun(o);
13821 }
13822
13823 OP *
13824 Perl_ck_length(pTHX_ OP *o)
13825 {
13826     PERL_ARGS_ASSERT_CK_LENGTH;
13827
13828     o = ck_fun(o);
13829
13830     if (ckWARN(WARN_SYNTAX)) {
13831         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13832
13833         if (kid) {
13834             SV *name = NULL;
13835             const bool hash = kid->op_type == OP_PADHV
13836                            || kid->op_type == OP_RV2HV;
13837             switch (kid->op_type) {
13838                 case OP_PADHV:
13839                 case OP_PADAV:
13840                 case OP_RV2HV:
13841                 case OP_RV2AV:
13842                     name = S_op_varname(aTHX_ kid);
13843                     break;
13844                 default:
13845                     return o;
13846             }
13847             if (name)
13848                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13849                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13850                     ")\"?)",
13851                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
13852                 );
13853             else if (hash)
13854      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13855                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13856                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13857             else
13858      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13859                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13860                     "length() used on @array (did you mean \"scalar(@array)\"?)");
13861         }
13862     }
13863
13864     return o;
13865 }
13866
13867
13868
13869 /*
13870    ---------------------------------------------------------
13871
13872    Common vars in list assignment
13873
13874    There now follows some enums and static functions for detecting
13875    common variables in list assignments. Here is a little essay I wrote
13876    for myself when trying to get my head around this. DAPM.
13877
13878    ----
13879
13880    First some random observations:
13881
13882    * If a lexical var is an alias of something else, e.g.
13883        for my $x ($lex, $pkg, $a[0]) {...}
13884      then the act of aliasing will increase the reference count of the SV
13885
13886    * If a package var is an alias of something else, it may still have a
13887      reference count of 1, depending on how the alias was created, e.g.
13888      in *a = *b, $a may have a refcount of 1 since the GP is shared
13889      with a single GvSV pointer to the SV. So If it's an alias of another
13890      package var, then RC may be 1; if it's an alias of another scalar, e.g.
13891      a lexical var or an array element, then it will have RC > 1.
13892
13893    * There are many ways to create a package alias; ultimately, XS code
13894      may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13895      run-time tracing mechanisms are unlikely to be able to catch all cases.
13896
13897    * When the LHS is all my declarations, the same vars can't appear directly
13898      on the RHS, but they can indirectly via closures, aliasing and lvalue
13899      subs. But those techniques all involve an increase in the lexical
13900      scalar's ref count.
13901
13902    * When the LHS is all lexical vars (but not necessarily my declarations),
13903      it is possible for the same lexicals to appear directly on the RHS, and
13904      without an increased ref count, since the stack isn't refcounted.
13905      This case can be detected at compile time by scanning for common lex
13906      vars with PL_generation.
13907
13908    * lvalue subs defeat common var detection, but they do at least
13909      return vars with a temporary ref count increment. Also, you can't
13910      tell at compile time whether a sub call is lvalue.
13911
13912
13913    So...
13914
13915    A: There are a few circumstances where there definitely can't be any
13916      commonality:
13917
13918        LHS empty:  () = (...);
13919        RHS empty:  (....) = ();
13920        RHS contains only constants or other 'can't possibly be shared'
13921            elements (e.g. ops that return PADTMPs):  (...) = (1,2, length)
13922            i.e. they only contain ops not marked as dangerous, whose children
13923            are also not dangerous;
13924        LHS ditto;
13925        LHS contains a single scalar element: e.g. ($x) = (....); because
13926            after $x has been modified, it won't be used again on the RHS;
13927        RHS contains a single element with no aggregate on LHS: e.g.
13928            ($a,$b,$c)  = ($x); again, once $a has been modified, its value
13929            won't be used again.
13930
13931    B: If LHS are all 'my' lexical var declarations (or safe ops, which
13932      we can ignore):
13933
13934        my ($a, $b, @c) = ...;
13935
13936        Due to closure and goto tricks, these vars may already have content.
13937        For the same reason, an element on the RHS may be a lexical or package
13938        alias of one of the vars on the left, or share common elements, for
13939        example:
13940
13941            my ($x,$y) = f(); # $x and $y on both sides
13942            sub f : lvalue { ($x,$y) = (1,2); $y, $x }
13943
13944        and
13945
13946            my $ra = f();
13947            my @a = @$ra;  # elements of @a on both sides
13948            sub f { @a = 1..4; \@a }
13949
13950
13951        First, just consider scalar vars on LHS:
13952
13953            RHS is safe only if (A), or in addition,
13954                * contains only lexical *scalar* vars, where neither side's
13955                  lexicals have been flagged as aliases
13956
13957            If RHS is not safe, then it's always legal to check LHS vars for
13958            RC==1, since the only RHS aliases will always be associated
13959            with an RC bump.
13960
13961            Note that in particular, RHS is not safe if:
13962
13963                * it contains package scalar vars; e.g.:
13964
13965                    f();
13966                    my ($x, $y) = (2, $x_alias);
13967                    sub f { $x = 1; *x_alias = \$x; }
13968
13969                * It contains other general elements, such as flattened or
13970                * spliced or single array or hash elements, e.g.
13971
13972                    f();
13973                    my ($x,$y) = @a; # or $a[0] or @a{@b} etc
13974
13975                    sub f {
13976                        ($x, $y) = (1,2);
13977                        use feature 'refaliasing';
13978                        \($a[0], $a[1]) = \($y,$x);
13979                    }
13980
13981                  It doesn't matter if the array/hash is lexical or package.
13982
13983                * it contains a function call that happens to be an lvalue
13984                  sub which returns one or more of the above, e.g.
13985
13986                    f();
13987                    my ($x,$y) = f();
13988
13989                    sub f : lvalue {
13990                        ($x, $y) = (1,2);
13991                        *x1 = \$x;
13992                        $y, $x1;
13993                    }
13994
13995                    (so a sub call on the RHS should be treated the same
13996                    as having a package var on the RHS).
13997
13998                * any other "dangerous" thing, such an op or built-in that
13999                  returns one of the above, e.g. pp_preinc
14000
14001
14002            If RHS is not safe, what we can do however is at compile time flag
14003            that the LHS are all my declarations, and at run time check whether
14004            all the LHS have RC == 1, and if so skip the full scan.
14005
14006        Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14007
14008            Here the issue is whether there can be elements of @a on the RHS
14009            which will get prematurely freed when @a is cleared prior to
14010            assignment. This is only a problem if the aliasing mechanism
14011            is one which doesn't increase the refcount - only if RC == 1
14012            will the RHS element be prematurely freed.
14013
14014            Because the array/hash is being INTROed, it or its elements
14015            can't directly appear on the RHS:
14016
14017                my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14018
14019            but can indirectly, e.g.:
14020
14021                my $r = f();
14022                my (@a) = @$r;
14023                sub f { @a = 1..3; \@a }
14024
14025            So if the RHS isn't safe as defined by (A), we must always
14026            mortalise and bump the ref count of any remaining RHS elements
14027            when assigning to a non-empty LHS aggregate.
14028
14029            Lexical scalars on the RHS aren't safe if they've been involved in
14030            aliasing, e.g.
14031
14032                use feature 'refaliasing';
14033
14034                f();
14035                \(my $lex) = \$pkg;
14036                my @a = ($lex,3); # equivalent to ($a[0],3)
14037
14038                sub f {
14039                    @a = (1,2);
14040                    \$pkg = \$a[0];
14041                }
14042
14043            Similarly with lexical arrays and hashes on the RHS:
14044
14045                f();
14046                my @b;
14047                my @a = (@b);
14048
14049                sub f {
14050                    @a = (1,2);
14051                    \$b[0] = \$a[1];
14052                    \$b[1] = \$a[0];
14053                }
14054
14055
14056
14057    C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14058        my $a; ($a, my $b) = (....);
14059
14060        The difference between (B) and (C) is that it is now physically
14061        possible for the LHS vars to appear on the RHS too, where they
14062        are not reference counted; but in this case, the compile-time
14063        PL_generation sweep will detect such common vars.
14064
14065        So the rules for (C) differ from (B) in that if common vars are
14066        detected, the runtime "test RC==1" optimisation can no longer be used,
14067        and a full mark and sweep is required
14068
14069    D: As (C), but in addition the LHS may contain package vars.
14070
14071        Since package vars can be aliased without a corresponding refcount
14072        increase, all bets are off. It's only safe if (A). E.g.
14073
14074            my ($x, $y) = (1,2);
14075
14076            for $x_alias ($x) {
14077                ($x_alias, $y) = (3, $x); # whoops
14078            }
14079
14080        Ditto for LHS aggregate package vars.
14081
14082    E: Any other dangerous ops on LHS, e.g.
14083            (f(), $a[0], @$r) = (...);
14084
14085        this is similar to (E) in that all bets are off. In addition, it's
14086        impossible to determine at compile time whether the LHS
14087        contains a scalar or an aggregate, e.g.
14088
14089            sub f : lvalue { @a }
14090            (f()) = 1..3;
14091
14092 * ---------------------------------------------------------
14093 */
14094
14095
14096 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14097  * that at least one of the things flagged was seen.
14098  */
14099
14100 enum {
14101     AAS_MY_SCALAR       = 0x001, /* my $scalar */
14102     AAS_MY_AGG          = 0x002, /* aggregate: my @array or my %hash */
14103     AAS_LEX_SCALAR      = 0x004, /* $lexical */
14104     AAS_LEX_AGG         = 0x008, /* @lexical or %lexical aggregate */
14105     AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14106     AAS_PKG_SCALAR      = 0x020, /* $scalar (where $scalar is pkg var) */
14107     AAS_PKG_AGG         = 0x040, /* package @array or %hash aggregate */
14108     AAS_DANGEROUS       = 0x080, /* an op (other than the above)
14109                                          that's flagged OA_DANGEROUS */
14110     AAS_SAFE_SCALAR     = 0x100, /* produces at least one scalar SV that's
14111                                         not in any of the categories above */
14112     AAS_DEFAV           = 0x200  /* contains just a single '@_' on RHS */
14113 };
14114
14115
14116
14117 /* helper function for S_aassign_scan().
14118  * check a PAD-related op for commonality and/or set its generation number.
14119  * Returns a boolean indicating whether its shared */
14120
14121 static bool
14122 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14123 {
14124     if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14125         /* lexical used in aliasing */
14126         return TRUE;
14127
14128     if (rhs)
14129         return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14130     else
14131         PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14132
14133     return FALSE;
14134 }
14135
14136
14137 /*
14138   Helper function for OPpASSIGN_COMMON* detection in rpeep().
14139   It scans the left or right hand subtree of the aassign op, and returns a
14140   set of flags indicating what sorts of things it found there.
14141   'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14142   set PL_generation on lexical vars; if the latter, we see if
14143   PL_generation matches.
14144   'top' indicates whether we're recursing or at the top level.
14145   'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14146   This fn will increment it by the number seen. It's not intended to
14147   be an accurate count (especially as many ops can push a variable
14148   number of SVs onto the stack); rather it's used as to test whether there
14149   can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14150 */
14151
14152 static int
14153 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14154 {
14155     int flags = 0;
14156     bool kid_top = FALSE;
14157
14158     /* first, look for a solitary @_ on the RHS */
14159     if (   rhs
14160         && top
14161         && (o->op_flags & OPf_KIDS)
14162         && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14163     ) {
14164         OP *kid = cUNOPo->op_first;
14165         if (   (   kid->op_type == OP_PUSHMARK
14166                 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14167             && ((kid = OpSIBLING(kid)))
14168             && !OpHAS_SIBLING(kid)
14169             && kid->op_type == OP_RV2AV
14170             && !(kid->op_flags & OPf_REF)
14171             && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14172             && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14173             && ((kid = cUNOPx(kid)->op_first))
14174             && kid->op_type == OP_GV
14175             && cGVOPx_gv(kid) == PL_defgv
14176         )
14177             flags |= AAS_DEFAV;
14178     }
14179
14180     switch (o->op_type) {
14181     case OP_GVSV:
14182         (*scalars_p)++;
14183         return AAS_PKG_SCALAR;
14184
14185     case OP_PADAV:
14186     case OP_PADHV:
14187         (*scalars_p) += 2;
14188         /* if !top, could be e.g. @a[0,1] */
14189         if (top && (o->op_flags & OPf_REF))
14190             return (o->op_private & OPpLVAL_INTRO)
14191                 ? AAS_MY_AGG : AAS_LEX_AGG;
14192         return AAS_DANGEROUS;
14193
14194     case OP_PADSV:
14195         {
14196             int comm = S_aassign_padcheck(aTHX_ o, rhs)
14197                         ?  AAS_LEX_SCALAR_COMM : 0;
14198             (*scalars_p)++;
14199             return (o->op_private & OPpLVAL_INTRO)
14200                 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14201         }
14202
14203     case OP_RV2AV:
14204     case OP_RV2HV:
14205         (*scalars_p) += 2;
14206         if (cUNOPx(o)->op_first->op_type != OP_GV)
14207             return AAS_DANGEROUS; /* @{expr}, %{expr} */
14208         /* @pkg, %pkg */
14209         /* if !top, could be e.g. @a[0,1] */
14210         if (top && (o->op_flags & OPf_REF))
14211             return AAS_PKG_AGG;
14212         return AAS_DANGEROUS;
14213
14214     case OP_RV2SV:
14215         (*scalars_p)++;
14216         if (cUNOPx(o)->op_first->op_type != OP_GV) {
14217             (*scalars_p) += 2;
14218             return AAS_DANGEROUS; /* ${expr} */
14219         }
14220         return AAS_PKG_SCALAR; /* $pkg */
14221
14222     case OP_SPLIT:
14223         if (o->op_private & OPpSPLIT_ASSIGN) {
14224             /* the assign in @a = split() has been optimised away
14225              * and the @a attached directly to the split op
14226              * Treat the array as appearing on the RHS, i.e.
14227              *    ... = (@a = split)
14228              * is treated like
14229              *    ... = @a;
14230              */
14231
14232             if (o->op_flags & OPf_STACKED)
14233                 /* @{expr} = split() - the array expression is tacked
14234                  * on as an extra child to split - process kid */
14235                 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14236                                         top, scalars_p);
14237
14238             /* ... else array is directly attached to split op */
14239             (*scalars_p) += 2;
14240             if (PL_op->op_private & OPpSPLIT_LEX)
14241                 return (o->op_private & OPpLVAL_INTRO)
14242                     ? AAS_MY_AGG : AAS_LEX_AGG;
14243             else
14244                 return AAS_PKG_AGG;
14245         }
14246         (*scalars_p)++;
14247         /* other args of split can't be returned */
14248         return AAS_SAFE_SCALAR;
14249
14250     case OP_UNDEF:
14251         /* undef counts as a scalar on the RHS:
14252          *   (undef, $x) = ...;         # only 1 scalar on LHS: always safe
14253          *   ($x, $y)    = (undef, $x); # 2 scalars on RHS: unsafe
14254          */
14255         if (rhs)
14256             (*scalars_p)++;
14257         flags = AAS_SAFE_SCALAR;
14258         break;
14259
14260     case OP_PUSHMARK:
14261     case OP_STUB:
14262         /* these are all no-ops; they don't push a potentially common SV
14263          * onto the stack, so they are neither AAS_DANGEROUS nor
14264          * AAS_SAFE_SCALAR */
14265         return 0;
14266
14267     case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14268         break;
14269
14270     case OP_NULL:
14271     case OP_LIST:
14272         /* these do nothing but may have children; but their children
14273          * should also be treated as top-level */
14274         kid_top = top;
14275         break;
14276
14277     default:
14278         if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14279             (*scalars_p) += 2;
14280             flags = AAS_DANGEROUS;
14281             break;
14282         }
14283
14284         if (   (PL_opargs[o->op_type] & OA_TARGLEX)
14285             && (o->op_private & OPpTARGET_MY))
14286         {
14287             (*scalars_p)++;
14288             return S_aassign_padcheck(aTHX_ o, rhs)
14289                 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14290         }
14291
14292         /* if its an unrecognised, non-dangerous op, assume that it
14293          * it the cause of at least one safe scalar */
14294         (*scalars_p)++;
14295         flags = AAS_SAFE_SCALAR;
14296         break;
14297     }
14298
14299     /* XXX this assumes that all other ops are "transparent" - i.e. that
14300      * they can return some of their children. While this true for e.g.
14301      * sort and grep, it's not true for e.g. map. We really need a
14302      * 'transparent' flag added to regen/opcodes
14303      */
14304     if (o->op_flags & OPf_KIDS) {
14305         OP *kid;
14306         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14307             flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14308     }
14309     return flags;
14310 }
14311
14312
14313 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14314    and modify the optree to make them work inplace */
14315
14316 STATIC void
14317 S_inplace_aassign(pTHX_ OP *o) {
14318
14319     OP *modop, *modop_pushmark;
14320     OP *oright;
14321     OP *oleft, *oleft_pushmark;
14322
14323     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14324
14325     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14326
14327     assert(cUNOPo->op_first->op_type == OP_NULL);
14328     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14329     assert(modop_pushmark->op_type == OP_PUSHMARK);
14330     modop = OpSIBLING(modop_pushmark);
14331
14332     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14333         return;
14334
14335     /* no other operation except sort/reverse */
14336     if (OpHAS_SIBLING(modop))
14337         return;
14338
14339     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14340     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14341
14342     if (modop->op_flags & OPf_STACKED) {
14343         /* skip sort subroutine/block */
14344         assert(oright->op_type == OP_NULL);
14345         oright = OpSIBLING(oright);
14346     }
14347
14348     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14349     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14350     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14351     oleft = OpSIBLING(oleft_pushmark);
14352
14353     /* Check the lhs is an array */
14354     if (!oleft ||
14355         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14356         || OpHAS_SIBLING(oleft)
14357         || (oleft->op_private & OPpLVAL_INTRO)
14358     )
14359         return;
14360
14361     /* Only one thing on the rhs */
14362     if (OpHAS_SIBLING(oright))
14363         return;
14364
14365     /* check the array is the same on both sides */
14366     if (oleft->op_type == OP_RV2AV) {
14367         if (oright->op_type != OP_RV2AV
14368             || !cUNOPx(oright)->op_first
14369             || cUNOPx(oright)->op_first->op_type != OP_GV
14370             || cUNOPx(oleft )->op_first->op_type != OP_GV
14371             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14372                cGVOPx_gv(cUNOPx(oright)->op_first)
14373         )
14374             return;
14375     }
14376     else if (oright->op_type != OP_PADAV
14377         || oright->op_targ != oleft->op_targ
14378     )
14379         return;
14380
14381     /* This actually is an inplace assignment */
14382
14383     modop->op_private |= OPpSORT_INPLACE;
14384
14385     /* transfer MODishness etc from LHS arg to RHS arg */
14386     oright->op_flags = oleft->op_flags;
14387
14388     /* remove the aassign op and the lhs */
14389     op_null(o);
14390     op_null(oleft_pushmark);
14391     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14392         op_null(cUNOPx(oleft)->op_first);
14393     op_null(oleft);
14394 }
14395
14396
14397
14398 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14399  * that potentially represent a series of one or more aggregate derefs
14400  * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14401  * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14402  * additional ops left in too).
14403  *
14404  * The caller will have already verified that the first few ops in the
14405  * chain following 'start' indicate a multideref candidate, and will have
14406  * set 'orig_o' to the point further on in the chain where the first index
14407  * expression (if any) begins.  'orig_action' specifies what type of
14408  * beginning has already been determined by the ops between start..orig_o
14409  * (e.g.  $lex_ary[], $pkg_ary->{}, expr->[], etc).
14410  *
14411  * 'hints' contains any hints flags that need adding (currently just
14412  * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14413  */
14414
14415 STATIC void
14416 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14417 {
14418     dVAR;
14419     int pass;
14420     UNOP_AUX_item *arg_buf = NULL;
14421     bool reset_start_targ  = FALSE; /* start->op_targ needs zeroing */
14422     int index_skip         = -1;    /* don't output index arg on this action */
14423
14424     /* similar to regex compiling, do two passes; the first pass
14425      * determines whether the op chain is convertible and calculates the
14426      * buffer size; the second pass populates the buffer and makes any
14427      * changes necessary to ops (such as moving consts to the pad on
14428      * threaded builds).
14429      *
14430      * NB: for things like Coverity, note that both passes take the same
14431      * path through the logic tree (except for 'if (pass)' bits), since
14432      * both passes are following the same op_next chain; and in
14433      * particular, if it would return early on the second pass, it would
14434      * already have returned early on the first pass.
14435      */
14436     for (pass = 0; pass < 2; pass++) {
14437         OP *o                = orig_o;
14438         UV action            = orig_action;
14439         OP *first_elem_op    = NULL;  /* first seen aelem/helem */
14440         OP *top_op           = NULL;  /* highest [ah]elem/exists/del/rv2[ah]v */
14441         int action_count     = 0;     /* number of actions seen so far */
14442         int action_ix        = 0;     /* action_count % (actions per IV) */
14443         bool next_is_hash    = FALSE; /* is the next lookup to be a hash? */
14444         bool is_last         = FALSE; /* no more derefs to follow */
14445         bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14446         UNOP_AUX_item *arg     = arg_buf;
14447         UNOP_AUX_item *action_ptr = arg_buf;
14448
14449         if (pass)
14450             action_ptr->uv = 0;
14451         arg++;
14452
14453         switch (action) {
14454         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14455         case MDEREF_HV_gvhv_helem:
14456             next_is_hash = TRUE;
14457             /* FALLTHROUGH */
14458         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14459         case MDEREF_AV_gvav_aelem:
14460             if (pass) {
14461 #ifdef USE_ITHREADS
14462                 arg->pad_offset = cPADOPx(start)->op_padix;
14463                 /* stop it being swiped when nulled */
14464                 cPADOPx(start)->op_padix = 0;
14465 #else
14466                 arg->sv = cSVOPx(start)->op_sv;
14467                 cSVOPx(start)->op_sv = NULL;
14468 #endif
14469             }
14470             arg++;
14471             break;
14472
14473         case MDEREF_HV_padhv_helem:
14474         case MDEREF_HV_padsv_vivify_rv2hv_helem:
14475             next_is_hash = TRUE;
14476             /* FALLTHROUGH */
14477         case MDEREF_AV_padav_aelem:
14478         case MDEREF_AV_padsv_vivify_rv2av_aelem:
14479             if (pass) {
14480                 arg->pad_offset = start->op_targ;
14481                 /* we skip setting op_targ = 0 for now, since the intact
14482                  * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14483                 reset_start_targ = TRUE;
14484             }
14485             arg++;
14486             break;
14487
14488         case MDEREF_HV_pop_rv2hv_helem:
14489             next_is_hash = TRUE;
14490             /* FALLTHROUGH */
14491         case MDEREF_AV_pop_rv2av_aelem:
14492             break;
14493
14494         default:
14495             NOT_REACHED; /* NOTREACHED */
14496             return;
14497         }
14498
14499         while (!is_last) {
14500             /* look for another (rv2av/hv; get index;
14501              * aelem/helem/exists/delele) sequence */
14502
14503             OP *kid;
14504             bool is_deref;
14505             bool ok;
14506             UV index_type = MDEREF_INDEX_none;
14507
14508             if (action_count) {
14509                 /* if this is not the first lookup, consume the rv2av/hv  */
14510
14511                 /* for N levels of aggregate lookup, we normally expect
14512                  * that the first N-1 [ah]elem ops will be flagged as
14513                  * /DEREF (so they autovivifiy if necessary), and the last
14514                  * lookup op not to be.
14515                  * For other things (like @{$h{k1}{k2}}) extra scope or
14516                  * leave ops can appear, so abandon the effort in that
14517                  * case */
14518                 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14519                     return;
14520
14521                 /* rv2av or rv2hv sKR/1 */
14522
14523                 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14524                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14525                 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14526                     return;
14527
14528                 /* at this point, we wouldn't expect any of these
14529                  * possible private flags:
14530                  * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14531                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14532                  */
14533                 ASSUME(!(o->op_private &
14534                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14535
14536                 hints = (o->op_private & OPpHINT_STRICT_REFS);
14537
14538                 /* make sure the type of the previous /DEREF matches the
14539                  * type of the next lookup */
14540                 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14541                 top_op = o;
14542
14543                 action = next_is_hash
14544                             ? MDEREF_HV_vivify_rv2hv_helem
14545                             : MDEREF_AV_vivify_rv2av_aelem;
14546                 o = o->op_next;
14547             }
14548
14549             /* if this is the second pass, and we're at the depth where
14550              * previously we encountered a non-simple index expression,
14551              * stop processing the index at this point */
14552             if (action_count != index_skip) {
14553
14554                 /* look for one or more simple ops that return an array
14555                  * index or hash key */
14556
14557                 switch (o->op_type) {
14558                 case OP_PADSV:
14559                     /* it may be a lexical var index */
14560                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14561                                             |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14562                     ASSUME(!(o->op_private &
14563                             ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14564
14565                     if (   OP_GIMME(o,0) == G_SCALAR
14566                         && !(o->op_flags & (OPf_REF|OPf_MOD))
14567                         && o->op_private == 0)
14568                     {
14569                         if (pass)
14570                             arg->pad_offset = o->op_targ;
14571                         arg++;
14572                         index_type = MDEREF_INDEX_padsv;
14573                         o = o->op_next;
14574                     }
14575                     break;
14576
14577                 case OP_CONST:
14578                     if (next_is_hash) {
14579                         /* it's a constant hash index */
14580                         if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14581                             /* "use constant foo => FOO; $h{+foo}" for
14582                              * some weird FOO, can leave you with constants
14583                              * that aren't simple strings. It's not worth
14584                              * the extra hassle for those edge cases */
14585                             break;
14586
14587                         if (pass) {
14588                             UNOP *rop = NULL;
14589                             OP * helem_op = o->op_next;
14590
14591                             ASSUME(   helem_op->op_type == OP_HELEM
14592                                    || helem_op->op_type == OP_NULL);
14593                             if (helem_op->op_type == OP_HELEM) {
14594                                 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14595                                 if (   helem_op->op_private & OPpLVAL_INTRO
14596                                     || rop->op_type != OP_RV2HV
14597                                 )
14598                                     rop = NULL;
14599                             }
14600                             S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14601
14602 #ifdef USE_ITHREADS
14603                             /* Relocate sv to the pad for thread safety */
14604                             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14605                             arg->pad_offset = o->op_targ;
14606                             o->op_targ = 0;
14607 #else
14608                             arg->sv = cSVOPx_sv(o);
14609 #endif
14610                         }
14611                     }
14612                     else {
14613                         /* it's a constant array index */
14614                         IV iv;
14615                         SV *ix_sv = cSVOPo->op_sv;
14616                         if (!SvIOK(ix_sv))
14617                             break;
14618                         iv = SvIV(ix_sv);
14619
14620                         if (   action_count == 0
14621                             && iv >= -128
14622                             && iv <= 127
14623                             && (   action == MDEREF_AV_padav_aelem
14624                                 || action == MDEREF_AV_gvav_aelem)
14625                         )
14626                             maybe_aelemfast = TRUE;
14627
14628                         if (pass) {
14629                             arg->iv = iv;
14630                             SvREFCNT_dec_NN(cSVOPo->op_sv);
14631                         }
14632                     }
14633                     if (pass)
14634                         /* we've taken ownership of the SV */
14635                         cSVOPo->op_sv = NULL;
14636                     arg++;
14637                     index_type = MDEREF_INDEX_const;
14638                     o = o->op_next;
14639                     break;
14640
14641                 case OP_GV:
14642                     /* it may be a package var index */
14643
14644                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14645                     ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14646                     if (  (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14647                         || o->op_private != 0
14648                     )
14649                         break;
14650
14651                     kid = o->op_next;
14652                     if (kid->op_type != OP_RV2SV)
14653                         break;
14654
14655                     ASSUME(!(kid->op_flags &
14656                             ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14657                              |OPf_SPECIAL|OPf_PARENS)));
14658                     ASSUME(!(kid->op_private &
14659                                     ~(OPpARG1_MASK
14660                                      |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14661                                      |OPpDEREF|OPpLVAL_INTRO)));
14662                     if(   (kid->op_flags &~ OPf_PARENS)
14663                             != (OPf_WANT_SCALAR|OPf_KIDS)
14664                        || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14665                     )
14666                         break;
14667
14668                     if (pass) {
14669 #ifdef USE_ITHREADS
14670                         arg->pad_offset = cPADOPx(o)->op_padix;
14671                         /* stop it being swiped when nulled */
14672                         cPADOPx(o)->op_padix = 0;
14673 #else
14674                         arg->sv = cSVOPx(o)->op_sv;
14675                         cSVOPo->op_sv = NULL;
14676 #endif
14677                     }
14678                     arg++;
14679                     index_type = MDEREF_INDEX_gvsv;
14680                     o = kid->op_next;
14681                     break;
14682
14683                 } /* switch */
14684             } /* action_count != index_skip */
14685
14686             action |= index_type;
14687
14688
14689             /* at this point we have either:
14690              *   * detected what looks like a simple index expression,
14691              *     and expect the next op to be an [ah]elem, or
14692              *     an nulled  [ah]elem followed by a delete or exists;
14693              *  * found a more complex expression, so something other
14694              *    than the above follows.
14695              */
14696
14697             /* possibly an optimised away [ah]elem (where op_next is
14698              * exists or delete) */
14699             if (o->op_type == OP_NULL)
14700                 o = o->op_next;
14701
14702             /* at this point we're looking for an OP_AELEM, OP_HELEM,
14703              * OP_EXISTS or OP_DELETE */
14704
14705             /* if something like arybase (a.k.a $[ ) is in scope,
14706              * abandon optimisation attempt */
14707             if (  (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14708                && PL_check[o->op_type] != Perl_ck_null)
14709                 return;
14710             /* similarly for customised exists and delete */
14711             if (  (o->op_type == OP_EXISTS)
14712                && PL_check[o->op_type] != Perl_ck_exists)
14713                 return;
14714             if (  (o->op_type == OP_DELETE)
14715                && PL_check[o->op_type] != Perl_ck_delete)
14716                 return;
14717
14718             if (   o->op_type != OP_AELEM
14719                 || (o->op_private &
14720                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14721                 )
14722                 maybe_aelemfast = FALSE;
14723
14724             /* look for aelem/helem/exists/delete. If it's not the last elem
14725              * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14726              * flags; if it's the last, then it mustn't have
14727              * OPpDEREF_AV/HV, but may have lots of other flags, like
14728              * OPpLVAL_INTRO etc
14729              */
14730
14731             if (   index_type == MDEREF_INDEX_none
14732                 || (   o->op_type != OP_AELEM  && o->op_type != OP_HELEM
14733                     && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14734             )
14735                 ok = FALSE;
14736             else {
14737                 /* we have aelem/helem/exists/delete with valid simple index */
14738
14739                 is_deref =    (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14740                            && (   (o->op_private & OPpDEREF) == OPpDEREF_AV
14741                                || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14742
14743                 /* This doesn't make much sense but is legal:
14744                  *    @{ local $x[0][0] } = 1
14745                  * Since scope exit will undo the autovivification,
14746                  * don't bother in the first place. The OP_LEAVE
14747                  * assertion is in case there are other cases of both
14748                  * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14749                  * exit that would undo the local - in which case this
14750                  * block of code would need rethinking.
14751                  */
14752                 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14753 #ifdef DEBUGGING
14754                     OP *n = o->op_next;
14755                     while (n && (  n->op_type == OP_NULL
14756                                 || n->op_type == OP_LIST))
14757                         n = n->op_next;
14758                     assert(n && n->op_type == OP_LEAVE);
14759 #endif
14760                     o->op_private &= ~OPpDEREF;
14761                     is_deref = FALSE;
14762                 }
14763
14764                 if (is_deref) {
14765                     ASSUME(!(o->op_flags &
14766                                  ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14767                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14768
14769                     ok =    (o->op_flags &~ OPf_PARENS)
14770                                == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14771                          && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14772                 }
14773                 else if (o->op_type == OP_EXISTS) {
14774                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14775                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14776                     ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14777                     ok =  !(o->op_private & ~OPpARG1_MASK);
14778                 }
14779                 else if (o->op_type == OP_DELETE) {
14780                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14781                                 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14782                     ASSUME(!(o->op_private &
14783                                     ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14784                     /* don't handle slices or 'local delete'; the latter
14785                      * is fairly rare, and has a complex runtime */
14786                     ok =  !(o->op_private & ~OPpARG1_MASK);
14787                     if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14788                         /* skip handling run-tome error */
14789                         ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14790                 }
14791                 else {
14792                     ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14793                     ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14794                                             |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14795                     ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14796                                     |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14797                     ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14798                 }
14799             }
14800
14801             if (ok) {
14802                 if (!first_elem_op)
14803                     first_elem_op = o;
14804                 top_op = o;
14805                 if (is_deref) {
14806                     next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14807                     o = o->op_next;
14808                 }
14809                 else {
14810                     is_last = TRUE;
14811                     action |= MDEREF_FLAG_last;
14812                 }
14813             }
14814             else {
14815                 /* at this point we have something that started
14816                  * promisingly enough (with rv2av or whatever), but failed
14817                  * to find a simple index followed by an
14818                  * aelem/helem/exists/delete. If this is the first action,
14819                  * give up; but if we've already seen at least one
14820                  * aelem/helem, then keep them and add a new action with
14821                  * MDEREF_INDEX_none, which causes it to do the vivify
14822                  * from the end of the previous lookup, and do the deref,
14823                  * but stop at that point. So $a[0][expr] will do one
14824                  * av_fetch, vivify and deref, then continue executing at
14825                  * expr */
14826                 if (!action_count)
14827                     return;
14828                 is_last = TRUE;
14829                 index_skip = action_count;
14830                 action |= MDEREF_FLAG_last;
14831                 if (index_type != MDEREF_INDEX_none)
14832                     arg--;
14833             }
14834
14835             if (pass)
14836                 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14837             action_ix++;
14838             action_count++;
14839             /* if there's no space for the next action, create a new slot
14840              * for it *before* we start adding args for that action */
14841             if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14842                 action_ptr = arg;
14843                 if (pass)
14844                     arg->uv = 0;
14845                 arg++;
14846                 action_ix = 0;
14847             }
14848         } /* while !is_last */
14849
14850         /* success! */
14851
14852         if (pass) {
14853             OP *mderef;
14854             OP *p, *q;
14855
14856             mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14857             if (index_skip == -1) {
14858                 mderef->op_flags = o->op_flags
14859                         & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14860                 if (o->op_type == OP_EXISTS)
14861                     mderef->op_private = OPpMULTIDEREF_EXISTS;
14862                 else if (o->op_type == OP_DELETE)
14863                     mderef->op_private = OPpMULTIDEREF_DELETE;
14864                 else
14865                     mderef->op_private = o->op_private
14866                         & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14867             }
14868             /* accumulate strictness from every level (although I don't think
14869              * they can actually vary) */
14870             mderef->op_private |= hints;
14871
14872             /* integrate the new multideref op into the optree and the
14873              * op_next chain.
14874              *
14875              * In general an op like aelem or helem has two child
14876              * sub-trees: the aggregate expression (a_expr) and the
14877              * index expression (i_expr):
14878              *
14879              *     aelem
14880              *       |
14881              *     a_expr - i_expr
14882              *
14883              * The a_expr returns an AV or HV, while the i-expr returns an
14884              * index. In general a multideref replaces most or all of a
14885              * multi-level tree, e.g.
14886              *
14887              *     exists
14888              *       |
14889              *     ex-aelem
14890              *       |
14891              *     rv2av  - i_expr1
14892              *       |
14893              *     helem
14894              *       |
14895              *     rv2hv  - i_expr2
14896              *       |
14897              *     aelem
14898              *       |
14899              *     a_expr - i_expr3
14900              *
14901              * With multideref, all the i_exprs will be simple vars or
14902              * constants, except that i_expr1 may be arbitrary in the case
14903              * of MDEREF_INDEX_none.
14904              *
14905              * The bottom-most a_expr will be either:
14906              *   1) a simple var (so padXv or gv+rv2Xv);
14907              *   2) a simple scalar var dereferenced (e.g. $r->[0]):
14908              *      so a simple var with an extra rv2Xv;
14909              *   3) or an arbitrary expression.
14910              *
14911              * 'start', the first op in the execution chain, will point to
14912              *   1),2): the padXv or gv op;
14913              *   3):    the rv2Xv which forms the last op in the a_expr
14914              *          execution chain, and the top-most op in the a_expr
14915              *          subtree.
14916              *
14917              * For all cases, the 'start' node is no longer required,
14918              * but we can't free it since one or more external nodes
14919              * may point to it. E.g. consider
14920              *     $h{foo} = $a ? $b : $c
14921              * Here, both the op_next and op_other branches of the
14922              * cond_expr point to the gv[*h] of the hash expression, so
14923              * we can't free the 'start' op.
14924              *
14925              * For expr->[...], we need to save the subtree containing the
14926              * expression; for the other cases, we just need to save the
14927              * start node.
14928              * So in all cases, we null the start op and keep it around by
14929              * making it the child of the multideref op; for the expr->
14930              * case, the expr will be a subtree of the start node.
14931              *
14932              * So in the simple 1,2 case the  optree above changes to
14933              *
14934              *     ex-exists
14935              *       |
14936              *     multideref
14937              *       |
14938              *     ex-gv (or ex-padxv)
14939              *
14940              *  with the op_next chain being
14941              *
14942              *  -> ex-gv -> multideref -> op-following-ex-exists ->
14943              *
14944              *  In the 3 case, we have
14945              *
14946              *     ex-exists
14947              *       |
14948              *     multideref
14949              *       |
14950              *     ex-rv2xv
14951              *       |
14952              *    rest-of-a_expr
14953              *      subtree
14954              *
14955              *  and
14956              *
14957              *  -> rest-of-a_expr subtree ->
14958              *    ex-rv2xv -> multideref -> op-following-ex-exists ->
14959              *
14960              *
14961              * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
14962              * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
14963              * multideref attached as the child, e.g.
14964              *
14965              *     exists
14966              *       |
14967              *     ex-aelem
14968              *       |
14969              *     ex-rv2av  - i_expr1
14970              *       |
14971              *     multideref
14972              *       |
14973              *     ex-whatever
14974              *
14975              */
14976
14977             /* if we free this op, don't free the pad entry */
14978             if (reset_start_targ)
14979                 start->op_targ = 0;
14980
14981
14982             /* Cut the bit we need to save out of the tree and attach to
14983              * the multideref op, then free the rest of the tree */
14984
14985             /* find parent of node to be detached (for use by splice) */
14986             p = first_elem_op;
14987             if (   orig_action == MDEREF_AV_pop_rv2av_aelem
14988                 || orig_action == MDEREF_HV_pop_rv2hv_helem)
14989             {
14990                 /* there is an arbitrary expression preceding us, e.g.
14991                  * expr->[..]? so we need to save the 'expr' subtree */
14992                 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
14993                     p = cUNOPx(p)->op_first;
14994                 ASSUME(   start->op_type == OP_RV2AV
14995                        || start->op_type == OP_RV2HV);
14996             }
14997             else {
14998                 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
14999                  * above for exists/delete. */
15000                 while (   (p->op_flags & OPf_KIDS)
15001                        && cUNOPx(p)->op_first != start
15002                 )
15003                     p = cUNOPx(p)->op_first;
15004             }
15005             ASSUME(cUNOPx(p)->op_first == start);
15006
15007             /* detach from main tree, and re-attach under the multideref */
15008             op_sibling_splice(mderef, NULL, 0,
15009                     op_sibling_splice(p, NULL, 1, NULL));
15010             op_null(start);
15011
15012             start->op_next = mderef;
15013
15014             mderef->op_next = index_skip == -1 ? o->op_next : o;
15015
15016             /* excise and free the original tree, and replace with
15017              * the multideref op */
15018             p = op_sibling_splice(top_op, NULL, -1, mderef);
15019             while (p) {
15020                 q = OpSIBLING(p);
15021                 op_free(p);
15022                 p = q;
15023             }
15024             op_null(top_op);
15025         }
15026         else {
15027             Size_t size = arg - arg_buf;
15028
15029             if (maybe_aelemfast && action_count == 1)
15030                 return;
15031
15032             arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15033                                 sizeof(UNOP_AUX_item) * (size + 1));
15034             /* for dumping etc: store the length in a hidden first slot;
15035              * we set the op_aux pointer to the second slot */
15036             arg_buf->uv = size;
15037             arg_buf++;
15038         }
15039     } /* for (pass = ...) */
15040 }
15041
15042 /* See if the ops following o are such that o will always be executed in
15043  * boolean context: that is, the SV which o pushes onto the stack will
15044  * only ever be consumed by later ops via SvTRUE(sv) or similar.
15045  * If so, set a suitable private flag on o. Normally this will be
15046  * bool_flag; but see below why maybe_flag is needed too.
15047  *
15048  * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15049  * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15050  * already be taken, so you'll have to give that op two different flags.
15051  *
15052  * More explanation of 'maybe_flag' and 'safe_and' parameters.
15053  * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15054  * those underlying ops) short-circuit, which means that rather than
15055  * necessarily returning a truth value, they may return the LH argument,
15056  * which may not be boolean. For example in $x = (keys %h || -1), keys
15057  * should return a key count rather than a boolean, even though its
15058  * sort-of being used in boolean context.
15059  *
15060  * So we only consider such logical ops to provide boolean context to
15061  * their LH argument if they themselves are in void or boolean context.
15062  * However, sometimes the context isn't known until run-time. In this
15063  * case the op is marked with the maybe_flag flag it.
15064  *
15065  * Consider the following.
15066  *
15067  *     sub f { ....;  if (%h) { .... } }
15068  *
15069  * This is actually compiled as
15070  *
15071  *     sub f { ....;  %h && do { .... } }
15072  *
15073  * Here we won't know until runtime whether the final statement (and hence
15074  * the &&) is in void context and so is safe to return a boolean value.
15075  * So mark o with maybe_flag rather than the bool_flag.
15076  * Note that there is cost associated with determining context at runtime
15077  * (e.g. a call to block_gimme()), so it may not be worth setting (at
15078  * compile time) and testing (at runtime) maybe_flag if the scalar verses
15079  * boolean costs savings are marginal.
15080  *
15081  * However, we can do slightly better with && (compared to || and //):
15082  * this op only returns its LH argument when that argument is false. In
15083  * this case, as long as the op promises to return a false value which is
15084  * valid in both boolean and scalar contexts, we can mark an op consumed
15085  * by && with bool_flag rather than maybe_flag.
15086  * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15087  * than &PL_sv_no for a false result in boolean context, then it's safe. An
15088  * op which promises to handle this case is indicated by setting safe_and
15089  * to true.
15090  */
15091
15092 static void
15093 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15094 {
15095     OP *lop;
15096     U8 flag = 0;
15097
15098     assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15099
15100     /* OPpTARGET_MY and boolean context probably don't mix well.
15101      * If someone finds a valid use case, maybe add an extra flag to this
15102      * function which indicates its safe to do so for this op? */
15103     assert(!(   (PL_opargs[o->op_type] & OA_TARGLEX)
15104              && (o->op_private & OPpTARGET_MY)));
15105
15106     lop = o->op_next;
15107
15108     while (lop) {
15109         switch (lop->op_type) {
15110         case OP_NULL:
15111         case OP_SCALAR:
15112             break;
15113
15114         /* these two consume the stack argument in the scalar case,
15115          * and treat it as a boolean in the non linenumber case */
15116         case OP_FLIP:
15117         case OP_FLOP:
15118             if (   ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15119                 || (lop->op_private & OPpFLIP_LINENUM))
15120             {
15121                 lop = NULL;
15122                 break;
15123             }
15124             /* FALLTHROUGH */
15125         /* these never leave the original value on the stack */
15126         case OP_NOT:
15127         case OP_XOR:
15128         case OP_COND_EXPR:
15129         case OP_GREPWHILE:
15130             flag = bool_flag;
15131             lop = NULL;
15132             break;
15133
15134         /* OR DOR and AND evaluate their arg as a boolean, but then may
15135          * leave the original scalar value on the stack when following the
15136          * op_next route. If not in void context, we need to ensure
15137          * that whatever follows consumes the arg only in boolean context
15138          * too.
15139          */
15140         case OP_AND:
15141             if (safe_and) {
15142                 flag = bool_flag;
15143                 lop = NULL;
15144                 break;
15145             }
15146             /* FALLTHROUGH */
15147         case OP_OR:
15148         case OP_DOR:
15149             if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15150                 flag = bool_flag;
15151                 lop = NULL;
15152             }
15153             else if (!(lop->op_flags & OPf_WANT)) {
15154                 /* unknown context - decide at runtime */
15155                 flag = maybe_flag;
15156                 lop = NULL;
15157             }
15158             break;
15159
15160         default:
15161             lop = NULL;
15162             break;
15163         }
15164
15165         if (lop)
15166             lop = lop->op_next;
15167     }
15168
15169     o->op_private |= flag;
15170 }
15171
15172
15173
15174 /* mechanism for deferring recursion in rpeep() */
15175
15176 #define MAX_DEFERRED 4
15177
15178 #define DEFER(o) \
15179   STMT_START { \
15180     if (defer_ix == (MAX_DEFERRED-1)) { \
15181         OP **defer = defer_queue[defer_base]; \
15182         CALL_RPEEP(*defer); \
15183         S_prune_chain_head(defer); \
15184         defer_base = (defer_base + 1) % MAX_DEFERRED; \
15185         defer_ix--; \
15186     } \
15187     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15188   } STMT_END
15189
15190 #define IS_AND_OP(o)   (o->op_type == OP_AND)
15191 #define IS_OR_OP(o)    (o->op_type == OP_OR)
15192
15193
15194 /* A peephole optimizer.  We visit the ops in the order they're to execute.
15195  * See the comments at the top of this file for more details about when
15196  * peep() is called */
15197
15198 void
15199 Perl_rpeep(pTHX_ OP *o)
15200 {
15201     dVAR;
15202     OP* oldop = NULL;
15203     OP* oldoldop = NULL;
15204     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15205     int defer_base = 0;
15206     int defer_ix = -1;
15207
15208     if (!o || o->op_opt)
15209         return;
15210
15211     assert(o->op_type != OP_FREED);
15212
15213     ENTER;
15214     SAVEOP();
15215     SAVEVPTR(PL_curcop);
15216     for (;; o = o->op_next) {
15217         if (o && o->op_opt)
15218             o = NULL;
15219         if (!o) {
15220             while (defer_ix >= 0) {
15221                 OP **defer =
15222                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15223                 CALL_RPEEP(*defer);
15224                 S_prune_chain_head(defer);
15225             }
15226             break;
15227         }
15228
15229       redo:
15230
15231         /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15232         assert(!oldoldop || oldoldop->op_next == oldop);
15233         assert(!oldop    || oldop->op_next    == o);
15234
15235         /* By default, this op has now been optimised. A couple of cases below
15236            clear this again.  */
15237         o->op_opt = 1;
15238         PL_op = o;
15239
15240         /* look for a series of 1 or more aggregate derefs, e.g.
15241          *   $a[1]{foo}[$i]{$k}
15242          * and replace with a single OP_MULTIDEREF op.
15243          * Each index must be either a const, or a simple variable,
15244          *
15245          * First, look for likely combinations of starting ops,
15246          * corresponding to (global and lexical variants of)
15247          *     $a[...]   $h{...}
15248          *     $r->[...] $r->{...}
15249          *     (preceding expression)->[...]
15250          *     (preceding expression)->{...}
15251          * and if so, call maybe_multideref() to do a full inspection
15252          * of the op chain and if appropriate, replace with an
15253          * OP_MULTIDEREF
15254          */
15255         {
15256             UV action;
15257             OP *o2 = o;
15258             U8 hints = 0;
15259
15260             switch (o2->op_type) {
15261             case OP_GV:
15262                 /* $pkg[..]   :   gv[*pkg]
15263                  * $pkg->[...]:   gv[*pkg]; rv2sv sKM/DREFAV */
15264
15265                 /* Fail if there are new op flag combinations that we're
15266                  * not aware of, rather than:
15267                  *  * silently failing to optimise, or
15268                  *  * silently optimising the flag away.
15269                  * If this ASSUME starts failing, examine what new flag
15270                  * has been added to the op, and decide whether the
15271                  * optimisation should still occur with that flag, then
15272                  * update the code accordingly. This applies to all the
15273                  * other ASSUMEs in the block of code too.
15274                  */
15275                 ASSUME(!(o2->op_flags &
15276                             ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15277                 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15278
15279                 o2 = o2->op_next;
15280
15281                 if (o2->op_type == OP_RV2AV) {
15282                     action = MDEREF_AV_gvav_aelem;
15283                     goto do_deref;
15284                 }
15285
15286                 if (o2->op_type == OP_RV2HV) {
15287                     action = MDEREF_HV_gvhv_helem;
15288                     goto do_deref;
15289                 }
15290
15291                 if (o2->op_type != OP_RV2SV)
15292                     break;
15293
15294                 /* at this point we've seen gv,rv2sv, so the only valid
15295                  * construct left is $pkg->[] or $pkg->{} */
15296
15297                 ASSUME(!(o2->op_flags & OPf_STACKED));
15298                 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15299                             != (OPf_WANT_SCALAR|OPf_MOD))
15300                     break;
15301
15302                 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15303                                     |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15304                 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15305                     break;
15306                 if (   (o2->op_private & OPpDEREF) != OPpDEREF_AV
15307                     && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15308                     break;
15309
15310                 o2 = o2->op_next;
15311                 if (o2->op_type == OP_RV2AV) {
15312                     action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15313                     goto do_deref;
15314                 }
15315                 if (o2->op_type == OP_RV2HV) {
15316                     action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15317                     goto do_deref;
15318                 }
15319                 break;
15320
15321             case OP_PADSV:
15322                 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15323
15324                 ASSUME(!(o2->op_flags &
15325                     ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15326                 if ((o2->op_flags &
15327                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15328                      != (OPf_WANT_SCALAR|OPf_MOD))
15329                     break;
15330
15331                 ASSUME(!(o2->op_private &
15332                                 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15333                 /* skip if state or intro, or not a deref */
15334                 if (      o2->op_private != OPpDEREF_AV
15335                        && o2->op_private != OPpDEREF_HV)
15336                     break;
15337
15338                 o2 = o2->op_next;
15339                 if (o2->op_type == OP_RV2AV) {
15340                     action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15341                     goto do_deref;
15342                 }
15343                 if (o2->op_type == OP_RV2HV) {
15344                     action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15345                     goto do_deref;
15346                 }
15347                 break;
15348
15349             case OP_PADAV:
15350             case OP_PADHV:
15351                 /*    $lex[..]:  padav[@lex:1,2] sR *
15352                  * or $lex{..}:  padhv[%lex:1,2] sR */
15353                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15354                                             OPf_REF|OPf_SPECIAL)));
15355                 if ((o2->op_flags &
15356                         (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15357                      != (OPf_WANT_SCALAR|OPf_REF))
15358                     break;
15359                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15360                     break;
15361                 /* OPf_PARENS isn't currently used in this case;
15362                  * if that changes, let us know! */
15363                 ASSUME(!(o2->op_flags & OPf_PARENS));
15364
15365                 /* at this point, we wouldn't expect any of the remaining
15366                  * possible private flags:
15367                  * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15368                  * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15369                  *
15370                  * OPpSLICEWARNING shouldn't affect runtime
15371                  */
15372                 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15373
15374                 action = o2->op_type == OP_PADAV
15375                             ? MDEREF_AV_padav_aelem
15376                             : MDEREF_HV_padhv_helem;
15377                 o2 = o2->op_next;
15378                 S_maybe_multideref(aTHX_ o, o2, action, 0);
15379                 break;
15380
15381
15382             case OP_RV2AV:
15383             case OP_RV2HV:
15384                 action = o2->op_type == OP_RV2AV
15385                             ? MDEREF_AV_pop_rv2av_aelem
15386                             : MDEREF_HV_pop_rv2hv_helem;
15387                 /* FALLTHROUGH */
15388             do_deref:
15389                 /* (expr)->[...]:  rv2av sKR/1;
15390                  * (expr)->{...}:  rv2hv sKR/1; */
15391
15392                 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15393
15394                 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15395                                 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15396                 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15397                     break;
15398
15399                 /* at this point, we wouldn't expect any of these
15400                  * possible private flags:
15401                  * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15402                  * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15403                  */
15404                 ASSUME(!(o2->op_private &
15405                     ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15406                      |OPpOUR_INTRO)));
15407                 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15408
15409                 o2 = o2->op_next;
15410
15411                 S_maybe_multideref(aTHX_ o, o2, action, hints);
15412                 break;
15413
15414             default:
15415                 break;
15416             }
15417         }
15418
15419
15420         switch (o->op_type) {
15421         case OP_DBSTATE:
15422             PL_curcop = ((COP*)o);              /* for warnings */
15423             break;
15424         case OP_NEXTSTATE:
15425             PL_curcop = ((COP*)o);              /* for warnings */
15426
15427             /* Optimise a "return ..." at the end of a sub to just be "...".
15428              * This saves 2 ops. Before:
15429              * 1  <;> nextstate(main 1 -e:1) v ->2
15430              * 4  <@> return K ->5
15431              * 2    <0> pushmark s ->3
15432              * -    <1> ex-rv2sv sK/1 ->4
15433              * 3      <#> gvsv[*cat] s ->4
15434              *
15435              * After:
15436              * -  <@> return K ->-
15437              * -    <0> pushmark s ->2
15438              * -    <1> ex-rv2sv sK/1 ->-
15439              * 2      <$> gvsv(*cat) s ->3
15440              */
15441             {
15442                 OP *next = o->op_next;
15443                 OP *sibling = OpSIBLING(o);
15444                 if (   OP_TYPE_IS(next, OP_PUSHMARK)
15445                     && OP_TYPE_IS(sibling, OP_RETURN)
15446                     && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15447                     && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15448                        ||OP_TYPE_IS(sibling->op_next->op_next,
15449                                     OP_LEAVESUBLV))
15450                     && cUNOPx(sibling)->op_first == next
15451                     && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15452                     && next->op_next
15453                 ) {
15454                     /* Look through the PUSHMARK's siblings for one that
15455                      * points to the RETURN */
15456                     OP *top = OpSIBLING(next);
15457                     while (top && top->op_next) {
15458                         if (top->op_next == sibling) {
15459                             top->op_next = sibling->op_next;
15460                             o->op_next = next->op_next;
15461                             break;
15462                         }
15463                         top = OpSIBLING(top);
15464                     }
15465                 }
15466             }
15467
15468             /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15469              *
15470              * This latter form is then suitable for conversion into padrange
15471              * later on. Convert:
15472              *
15473              *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15474              *
15475              * into:
15476              *
15477              *   nextstate1 ->     listop     -> nextstate3
15478              *                 /            \
15479              *         pushmark -> padop1 -> padop2
15480              */
15481             if (o->op_next && (
15482                     o->op_next->op_type == OP_PADSV
15483                  || o->op_next->op_type == OP_PADAV
15484                  || o->op_next->op_type == OP_PADHV
15485                 )
15486                 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15487                 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15488                 && o->op_next->op_next->op_next && (
15489                     o->op_next->op_next->op_next->op_type == OP_PADSV
15490                  || o->op_next->op_next->op_next->op_type == OP_PADAV
15491                  || o->op_next->op_next->op_next->op_type == OP_PADHV
15492                 )
15493                 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15494                 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15495                 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15496                 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15497             ) {
15498                 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15499
15500                 pad1 =    o->op_next;
15501                 ns2  = pad1->op_next;
15502                 pad2 =  ns2->op_next;
15503                 ns3  = pad2->op_next;
15504
15505                 /* we assume here that the op_next chain is the same as
15506                  * the op_sibling chain */
15507                 assert(OpSIBLING(o)    == pad1);
15508                 assert(OpSIBLING(pad1) == ns2);
15509                 assert(OpSIBLING(ns2)  == pad2);
15510                 assert(OpSIBLING(pad2) == ns3);
15511
15512                 /* excise and delete ns2 */
15513                 op_sibling_splice(NULL, pad1, 1, NULL);
15514                 op_free(ns2);
15515
15516                 /* excise pad1 and pad2 */
15517                 op_sibling_splice(NULL, o, 2, NULL);
15518
15519                 /* create new listop, with children consisting of:
15520                  * a new pushmark, pad1, pad2. */
15521                 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15522                 newop->op_flags |= OPf_PARENS;
15523                 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15524
15525                 /* insert newop between o and ns3 */
15526                 op_sibling_splice(NULL, o, 0, newop);
15527
15528                 /*fixup op_next chain */
15529                 newpm = cUNOPx(newop)->op_first; /* pushmark */
15530                 o    ->op_next = newpm;
15531                 newpm->op_next = pad1;
15532                 pad1 ->op_next = pad2;
15533                 pad2 ->op_next = newop; /* listop */
15534                 newop->op_next = ns3;
15535
15536                 /* Ensure pushmark has this flag if padops do */
15537                 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15538                     newpm->op_flags |= OPf_MOD;
15539                 }
15540
15541                 break;
15542             }
15543
15544             /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15545                to carry two labels. For now, take the easier option, and skip
15546                this optimisation if the first NEXTSTATE has a label.  */
15547             if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15548                 OP *nextop = o->op_next;
15549                 while (nextop && nextop->op_type == OP_NULL)
15550                     nextop = nextop->op_next;
15551
15552                 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15553                     op_null(o);
15554                     if (oldop)
15555                         oldop->op_next = nextop;
15556                     o = nextop;
15557                     /* Skip (old)oldop assignment since the current oldop's
15558                        op_next already points to the next op.  */
15559                     goto redo;
15560                 }
15561             }
15562             break;
15563
15564         case OP_CONCAT:
15565             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15566                 if (o->op_next->op_private & OPpTARGET_MY) {
15567                     if (o->op_flags & OPf_STACKED) /* chained concats */
15568                         break; /* ignore_optimization */
15569                     else {
15570                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15571                         o->op_targ = o->op_next->op_targ;
15572                         o->op_next->op_targ = 0;
15573                         o->op_private |= OPpTARGET_MY;
15574                     }
15575                 }
15576                 op_null(o->op_next);
15577             }
15578             break;
15579         case OP_STUB:
15580             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15581                 break; /* Scalar stub must produce undef.  List stub is noop */
15582             }
15583             goto nothin;
15584         case OP_NULL:
15585             if (o->op_targ == OP_NEXTSTATE
15586                 || o->op_targ == OP_DBSTATE)
15587             {
15588                 PL_curcop = ((COP*)o);
15589             }
15590             /* XXX: We avoid setting op_seq here to prevent later calls
15591                to rpeep() from mistakenly concluding that optimisation
15592                has already occurred. This doesn't fix the real problem,
15593                though (See 20010220.007 (#5874)). AMS 20010719 */
15594             /* op_seq functionality is now replaced by op_opt */
15595             o->op_opt = 0;
15596             /* FALLTHROUGH */
15597         case OP_SCALAR:
15598         case OP_LINESEQ:
15599         case OP_SCOPE:
15600         nothin:
15601             if (oldop) {
15602                 oldop->op_next = o->op_next;
15603                 o->op_opt = 0;
15604                 continue;
15605             }
15606             break;
15607
15608         case OP_PUSHMARK:
15609
15610             /* Given
15611                  5 repeat/DOLIST
15612                  3   ex-list
15613                  1     pushmark
15614                  2     scalar or const
15615                  4   const[0]
15616                convert repeat into a stub with no kids.
15617              */
15618             if (o->op_next->op_type == OP_CONST
15619              || (  o->op_next->op_type == OP_PADSV
15620                 && !(o->op_next->op_private & OPpLVAL_INTRO))
15621              || (  o->op_next->op_type == OP_GV
15622                 && o->op_next->op_next->op_type == OP_RV2SV
15623                 && !(o->op_next->op_next->op_private
15624                         & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15625             {
15626                 const OP *kid = o->op_next->op_next;
15627                 if (o->op_next->op_type == OP_GV)
15628                    kid = kid->op_next;
15629                 /* kid is now the ex-list.  */
15630                 if (kid->op_type == OP_NULL
15631                  && (kid = kid->op_next)->op_type == OP_CONST
15632                     /* kid is now the repeat count.  */
15633                  && kid->op_next->op_type == OP_REPEAT
15634                  && kid->op_next->op_private & OPpREPEAT_DOLIST
15635                  && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15636                  && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15637                  && oldop)
15638                 {
15639                     o = kid->op_next; /* repeat */
15640                     oldop->op_next = o;
15641                     op_free(cBINOPo->op_first);
15642                     op_free(cBINOPo->op_last );
15643                     o->op_flags &=~ OPf_KIDS;
15644                     /* stub is a baseop; repeat is a binop */
15645                     STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15646                     OpTYPE_set(o, OP_STUB);
15647                     o->op_private = 0;
15648                     break;
15649                 }
15650             }
15651
15652             /* Convert a series of PAD ops for my vars plus support into a
15653              * single padrange op. Basically
15654              *
15655              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15656              *
15657              * becomes, depending on circumstances, one of
15658              *
15659              *    padrange  ----------------------------------> (list) -> rest
15660              *    padrange  --------------------------------------------> rest
15661              *
15662              * where all the pad indexes are sequential and of the same type
15663              * (INTRO or not).
15664              * We convert the pushmark into a padrange op, then skip
15665              * any other pad ops, and possibly some trailing ops.
15666              * Note that we don't null() the skipped ops, to make it
15667              * easier for Deparse to undo this optimisation (and none of
15668              * the skipped ops are holding any resourses). It also makes
15669              * it easier for find_uninit_var(), as it can just ignore
15670              * padrange, and examine the original pad ops.
15671              */
15672         {
15673             OP *p;
15674             OP *followop = NULL; /* the op that will follow the padrange op */
15675             U8 count = 0;
15676             U8 intro = 0;
15677             PADOFFSET base = 0; /* init only to stop compiler whining */
15678             bool gvoid = 0;     /* init only to stop compiler whining */
15679             bool defav = 0;  /* seen (...) = @_ */
15680             bool reuse = 0;  /* reuse an existing padrange op */
15681
15682             /* look for a pushmark -> gv[_] -> rv2av */
15683
15684             {
15685                 OP *rv2av, *q;
15686                 p = o->op_next;
15687                 if (   p->op_type == OP_GV
15688                     && cGVOPx_gv(p) == PL_defgv
15689                     && (rv2av = p->op_next)
15690                     && rv2av->op_type == OP_RV2AV
15691                     && !(rv2av->op_flags & OPf_REF)
15692                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15693                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15694                 ) {
15695                     q = rv2av->op_next;
15696                     if (q->op_type == OP_NULL)
15697                         q = q->op_next;
15698                     if (q->op_type == OP_PUSHMARK) {
15699                         defav = 1;
15700                         p = q;
15701                     }
15702                 }
15703             }
15704             if (!defav) {
15705                 p = o;
15706             }
15707
15708             /* scan for PAD ops */
15709
15710             for (p = p->op_next; p; p = p->op_next) {
15711                 if (p->op_type == OP_NULL)
15712                     continue;
15713
15714                 if ((     p->op_type != OP_PADSV
15715                        && p->op_type != OP_PADAV
15716                        && p->op_type != OP_PADHV
15717                     )
15718                       /* any private flag other than INTRO? e.g. STATE */
15719                    || (p->op_private & ~OPpLVAL_INTRO)
15720                 )
15721                     break;
15722
15723                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15724                  * instead */
15725                 if (   p->op_type == OP_PADAV
15726                     && p->op_next
15727                     && p->op_next->op_type == OP_CONST
15728                     && p->op_next->op_next
15729                     && p->op_next->op_next->op_type == OP_AELEM
15730                 )
15731                     break;
15732
15733                 /* for 1st padop, note what type it is and the range
15734                  * start; for the others, check that it's the same type
15735                  * and that the targs are contiguous */
15736                 if (count == 0) {
15737                     intro = (p->op_private & OPpLVAL_INTRO);
15738                     base = p->op_targ;
15739                     gvoid = OP_GIMME(p,0) == G_VOID;
15740                 }
15741                 else {
15742                     if ((p->op_private & OPpLVAL_INTRO) != intro)
15743                         break;
15744                     /* Note that you'd normally  expect targs to be
15745                      * contiguous in my($a,$b,$c), but that's not the case
15746                      * when external modules start doing things, e.g.
15747                      * Function::Parameters */
15748                     if (p->op_targ != base + count)
15749                         break;
15750                     assert(p->op_targ == base + count);
15751                     /* Either all the padops or none of the padops should
15752                        be in void context.  Since we only do the optimisa-
15753                        tion for av/hv when the aggregate itself is pushed
15754                        on to the stack (one item), there is no need to dis-
15755                        tinguish list from scalar context.  */
15756                     if (gvoid != (OP_GIMME(p,0) == G_VOID))
15757                         break;
15758                 }
15759
15760                 /* for AV, HV, only when we're not flattening */
15761                 if (   p->op_type != OP_PADSV
15762                     && !gvoid
15763                     && !(p->op_flags & OPf_REF)
15764                 )
15765                     break;
15766
15767                 if (count >= OPpPADRANGE_COUNTMASK)
15768                     break;
15769
15770                 /* there's a biggest base we can fit into a
15771                  * SAVEt_CLEARPADRANGE in pp_padrange.
15772                  * (The sizeof() stuff will be constant-folded, and is
15773                  * intended to avoid getting "comparison is always false"
15774                  * compiler warnings. See the comments above
15775                  * MEM_WRAP_CHECK for more explanation on why we do this
15776                  * in a weird way to avoid compiler warnings.)
15777                  */
15778                 if (   intro
15779                     && (8*sizeof(base) >
15780                         8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15781                         ? (Size_t)base
15782                         : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15783                         ) >
15784                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15785                 )
15786                     break;
15787
15788                 /* Success! We've got another valid pad op to optimise away */
15789                 count++;
15790                 followop = p->op_next;
15791             }
15792
15793             if (count < 1 || (count == 1 && !defav))
15794                 break;
15795
15796             /* pp_padrange in specifically compile-time void context
15797              * skips pushing a mark and lexicals; in all other contexts
15798              * (including unknown till runtime) it pushes a mark and the
15799              * lexicals. We must be very careful then, that the ops we
15800              * optimise away would have exactly the same effect as the
15801              * padrange.
15802              * In particular in void context, we can only optimise to
15803              * a padrange if we see the complete sequence
15804              *     pushmark, pad*v, ...., list
15805              * which has the net effect of leaving the markstack as it
15806              * was.  Not pushing onto the stack (whereas padsv does touch
15807              * the stack) makes no difference in void context.
15808              */
15809             assert(followop);
15810             if (gvoid) {
15811                 if (followop->op_type == OP_LIST
15812                         && OP_GIMME(followop,0) == G_VOID
15813                    )
15814                 {
15815                     followop = followop->op_next; /* skip OP_LIST */
15816
15817                     /* consolidate two successive my(...);'s */
15818
15819                     if (   oldoldop
15820                         && oldoldop->op_type == OP_PADRANGE
15821                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15822                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15823                         && !(oldoldop->op_flags & OPf_SPECIAL)
15824                     ) {
15825                         U8 old_count;
15826                         assert(oldoldop->op_next == oldop);
15827                         assert(   oldop->op_type == OP_NEXTSTATE
15828                                || oldop->op_type == OP_DBSTATE);
15829                         assert(oldop->op_next == o);
15830
15831                         old_count
15832                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15833
15834                        /* Do not assume pad offsets for $c and $d are con-
15835                           tiguous in
15836                             my ($a,$b,$c);
15837                             my ($d,$e,$f);
15838                         */
15839                         if (  oldoldop->op_targ + old_count == base
15840                            && old_count < OPpPADRANGE_COUNTMASK - count) {
15841                             base = oldoldop->op_targ;
15842                             count += old_count;
15843                             reuse = 1;
15844                         }
15845                     }
15846
15847                     /* if there's any immediately following singleton
15848                      * my var's; then swallow them and the associated
15849                      * nextstates; i.e.
15850                      *    my ($a,$b); my $c; my $d;
15851                      * is treated as
15852                      *    my ($a,$b,$c,$d);
15853                      */
15854
15855                     while (    ((p = followop->op_next))
15856                             && (  p->op_type == OP_PADSV
15857                                || p->op_type == OP_PADAV
15858                                || p->op_type == OP_PADHV)
15859                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15860                             && (p->op_private & OPpLVAL_INTRO) == intro
15861                             && !(p->op_private & ~OPpLVAL_INTRO)
15862                             && p->op_next
15863                             && (   p->op_next->op_type == OP_NEXTSTATE
15864                                 || p->op_next->op_type == OP_DBSTATE)
15865                             && count < OPpPADRANGE_COUNTMASK
15866                             && base + count == p->op_targ
15867                     ) {
15868                         count++;
15869                         followop = p->op_next;
15870                     }
15871                 }
15872                 else
15873                     break;
15874             }
15875
15876             if (reuse) {
15877                 assert(oldoldop->op_type == OP_PADRANGE);
15878                 oldoldop->op_next = followop;
15879                 oldoldop->op_private = (intro | count);
15880                 o = oldoldop;
15881                 oldop = NULL;
15882                 oldoldop = NULL;
15883             }
15884             else {
15885                 /* Convert the pushmark into a padrange.
15886                  * To make Deparse easier, we guarantee that a padrange was
15887                  * *always* formerly a pushmark */
15888                 assert(o->op_type == OP_PUSHMARK);
15889                 o->op_next = followop;
15890                 OpTYPE_set(o, OP_PADRANGE);
15891                 o->op_targ = base;
15892                 /* bit 7: INTRO; bit 6..0: count */
15893                 o->op_private = (intro | count);
15894                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15895                               | gvoid * OPf_WANT_VOID
15896                               | (defav ? OPf_SPECIAL : 0));
15897             }
15898             break;
15899         }
15900
15901         case OP_RV2AV:
15902             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15903                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15904             break;
15905
15906         case OP_RV2HV:
15907         case OP_PADHV:
15908             /*'keys %h' in void or scalar context: skip the OP_KEYS
15909              * and perform the functionality directly in the RV2HV/PADHV
15910              * op
15911              */
15912             if (o->op_flags & OPf_REF) {
15913                 OP *k = o->op_next;
15914                 U8 want = (k->op_flags & OPf_WANT);
15915                 if (   k
15916                     && k->op_type == OP_KEYS
15917                     && (   want == OPf_WANT_VOID
15918                         || want == OPf_WANT_SCALAR)
15919                     && !(k->op_private & OPpMAYBE_LVSUB)
15920                     && !(k->op_flags & OPf_MOD)
15921                 ) {
15922                     o->op_next     = k->op_next;
15923                     o->op_flags   &= ~(OPf_REF|OPf_WANT);
15924                     o->op_flags   |= want;
15925                     o->op_private |= (o->op_type == OP_PADHV ?
15926                                       OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15927                     /* for keys(%lex), hold onto the OP_KEYS's targ
15928                      * since padhv doesn't have its own targ to return
15929                      * an int with */
15930                     if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
15931                         op_null(k);
15932                 }
15933             }
15934
15935             /* see if %h is used in boolean context */
15936             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15937                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
15938
15939
15940             if (o->op_type != OP_PADHV)
15941                 break;
15942             /* FALLTHROUGH */
15943         case OP_PADAV:
15944             if (   o->op_type == OP_PADAV
15945                 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
15946             )
15947                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15948             /* FALLTHROUGH */
15949         case OP_PADSV:
15950             /* Skip over state($x) in void context.  */
15951             if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
15952              && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
15953             {
15954                 oldop->op_next = o->op_next;
15955                 goto redo_nextstate;
15956             }
15957             if (o->op_type != OP_PADAV)
15958                 break;
15959             /* FALLTHROUGH */
15960         case OP_GV:
15961             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
15962                 OP* const pop = (o->op_type == OP_PADAV) ?
15963                             o->op_next : o->op_next->op_next;
15964                 IV i;
15965                 if (pop && pop->op_type == OP_CONST &&
15966                     ((PL_op = pop->op_next)) &&
15967                     pop->op_next->op_type == OP_AELEM &&
15968                     !(pop->op_next->op_private &
15969                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
15970                     (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
15971                 {
15972                     GV *gv;
15973                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
15974                         no_bareword_allowed(pop);
15975                     if (o->op_type == OP_GV)
15976                         op_null(o->op_next);
15977                     op_null(pop->op_next);
15978                     op_null(pop);
15979                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
15980                     o->op_next = pop->op_next->op_next;
15981                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
15982                     o->op_private = (U8)i;
15983                     if (o->op_type == OP_GV) {
15984                         gv = cGVOPo_gv;
15985                         GvAVn(gv);
15986                         o->op_type = OP_AELEMFAST;
15987                     }
15988                     else
15989                         o->op_type = OP_AELEMFAST_LEX;
15990                 }
15991                 if (o->op_type != OP_GV)
15992                     break;
15993             }
15994
15995             /* Remove $foo from the op_next chain in void context.  */
15996             if (oldop
15997              && (  o->op_next->op_type == OP_RV2SV
15998                 || o->op_next->op_type == OP_RV2AV
15999                 || o->op_next->op_type == OP_RV2HV  )
16000              && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16001              && !(o->op_next->op_private & OPpLVAL_INTRO))
16002             {
16003                 oldop->op_next = o->op_next->op_next;
16004                 /* Reprocess the previous op if it is a nextstate, to
16005                    allow double-nextstate optimisation.  */
16006               redo_nextstate:
16007                 if (oldop->op_type == OP_NEXTSTATE) {
16008                     oldop->op_opt = 0;
16009                     o = oldop;
16010                     oldop = oldoldop;
16011                     oldoldop = NULL;
16012                     goto redo;
16013                 }
16014                 o = oldop->op_next;
16015                 goto redo;
16016             }
16017             else if (o->op_next->op_type == OP_RV2SV) {
16018                 if (!(o->op_next->op_private & OPpDEREF)) {
16019                     op_null(o->op_next);
16020                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16021                                                                | OPpOUR_INTRO);
16022                     o->op_next = o->op_next->op_next;
16023                     OpTYPE_set(o, OP_GVSV);
16024                 }
16025             }
16026             else if (o->op_next->op_type == OP_READLINE
16027                     && o->op_next->op_next->op_type == OP_CONCAT
16028                     && (o->op_next->op_next->op_flags & OPf_STACKED))
16029             {
16030                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16031                 OpTYPE_set(o, OP_RCATLINE);
16032                 o->op_flags |= OPf_STACKED;
16033                 op_null(o->op_next->op_next);
16034                 op_null(o->op_next);
16035             }
16036
16037             break;
16038
16039         case OP_NOT:
16040             break;
16041
16042         case OP_AND:
16043         case OP_OR:
16044         case OP_DOR:
16045             while (cLOGOP->op_other->op_type == OP_NULL)
16046                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16047             while (o->op_next && (   o->op_type == o->op_next->op_type
16048                                   || o->op_next->op_type == OP_NULL))
16049                 o->op_next = o->op_next->op_next;
16050
16051             /* If we're an OR and our next is an AND in void context, we'll
16052                follow its op_other on short circuit, same for reverse.
16053                We can't do this with OP_DOR since if it's true, its return
16054                value is the underlying value which must be evaluated
16055                by the next op. */
16056             if (o->op_next &&
16057                 (
16058                     (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16059                  || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16060                 )
16061                 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16062             ) {
16063                 o->op_next = ((LOGOP*)o->op_next)->op_other;
16064             }
16065             DEFER(cLOGOP->op_other);
16066             o->op_opt = 1;
16067             break;
16068
16069         case OP_GREPWHILE:
16070             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16071                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16072             /* FALLTHROUGH */
16073         case OP_COND_EXPR:
16074         case OP_MAPWHILE:
16075         case OP_ANDASSIGN:
16076         case OP_ORASSIGN:
16077         case OP_DORASSIGN:
16078         case OP_RANGE:
16079         case OP_ONCE:
16080         case OP_ARGDEFELEM:
16081             while (cLOGOP->op_other->op_type == OP_NULL)
16082                 cLOGOP->op_other = cLOGOP->op_other->op_next;
16083             DEFER(cLOGOP->op_other);
16084             break;
16085
16086         case OP_ENTERLOOP:
16087         case OP_ENTERITER:
16088             while (cLOOP->op_redoop->op_type == OP_NULL)
16089                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16090             while (cLOOP->op_nextop->op_type == OP_NULL)
16091                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16092             while (cLOOP->op_lastop->op_type == OP_NULL)
16093                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16094             /* a while(1) loop doesn't have an op_next that escapes the
16095              * loop, so we have to explicitly follow the op_lastop to
16096              * process the rest of the code */
16097             DEFER(cLOOP->op_lastop);
16098             break;
16099
16100         case OP_ENTERTRY:
16101             assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16102             DEFER(cLOGOPo->op_other);
16103             break;
16104
16105         case OP_SUBST:
16106             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16107                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16108             assert(!(cPMOP->op_pmflags & PMf_ONCE));
16109             while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16110                    cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16111                 cPMOP->op_pmstashstartu.op_pmreplstart
16112                     = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16113             DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16114             break;
16115
16116         case OP_SORT: {
16117             OP *oright;
16118
16119             if (o->op_flags & OPf_SPECIAL) {
16120                 /* first arg is a code block */
16121                 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16122                 OP * kid          = cUNOPx(nullop)->op_first;
16123
16124                 assert(nullop->op_type == OP_NULL);
16125                 assert(kid->op_type == OP_SCOPE
16126                  || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16127                 /* since OP_SORT doesn't have a handy op_other-style
16128                  * field that can point directly to the start of the code
16129                  * block, store it in the otherwise-unused op_next field
16130                  * of the top-level OP_NULL. This will be quicker at
16131                  * run-time, and it will also allow us to remove leading
16132                  * OP_NULLs by just messing with op_nexts without
16133                  * altering the basic op_first/op_sibling layout. */
16134                 kid = kLISTOP->op_first;
16135                 assert(
16136                       (kid->op_type == OP_NULL
16137                       && (  kid->op_targ == OP_NEXTSTATE
16138                          || kid->op_targ == OP_DBSTATE  ))
16139                     || kid->op_type == OP_STUB
16140                     || kid->op_type == OP_ENTER
16141                     || (PL_parser && PL_parser->error_count));
16142                 nullop->op_next = kid->op_next;
16143                 DEFER(nullop->op_next);
16144             }
16145
16146             /* check that RHS of sort is a single plain array */
16147             oright = cUNOPo->op_first;
16148             if (!oright || oright->op_type != OP_PUSHMARK)
16149                 break;
16150
16151             if (o->op_private & OPpSORT_INPLACE)
16152                 break;
16153
16154             /* reverse sort ... can be optimised.  */
16155             if (!OpHAS_SIBLING(cUNOPo)) {
16156                 /* Nothing follows us on the list. */
16157                 OP * const reverse = o->op_next;
16158
16159                 if (reverse->op_type == OP_REVERSE &&
16160                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16161                     OP * const pushmark = cUNOPx(reverse)->op_first;
16162                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16163                         && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16164                         /* reverse -> pushmark -> sort */
16165                         o->op_private |= OPpSORT_REVERSE;
16166                         op_null(reverse);
16167                         pushmark->op_next = oright->op_next;
16168                         op_null(oright);
16169                     }
16170                 }
16171             }
16172
16173             break;
16174         }
16175
16176         case OP_REVERSE: {
16177             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16178             OP *gvop = NULL;
16179             LISTOP *enter, *exlist;
16180
16181             if (o->op_private & OPpSORT_INPLACE)
16182                 break;
16183
16184             enter = (LISTOP *) o->op_next;
16185             if (!enter)
16186                 break;
16187             if (enter->op_type == OP_NULL) {
16188                 enter = (LISTOP *) enter->op_next;
16189                 if (!enter)
16190                     break;
16191             }
16192             /* for $a (...) will have OP_GV then OP_RV2GV here.
16193                for (...) just has an OP_GV.  */
16194             if (enter->op_type == OP_GV) {
16195                 gvop = (OP *) enter;
16196                 enter = (LISTOP *) enter->op_next;
16197                 if (!enter)
16198                     break;
16199                 if (enter->op_type == OP_RV2GV) {
16200                   enter = (LISTOP *) enter->op_next;
16201                   if (!enter)
16202                     break;
16203                 }
16204             }
16205
16206             if (enter->op_type != OP_ENTERITER)
16207                 break;
16208
16209             iter = enter->op_next;
16210             if (!iter || iter->op_type != OP_ITER)
16211                 break;
16212
16213             expushmark = enter->op_first;
16214             if (!expushmark || expushmark->op_type != OP_NULL
16215                 || expushmark->op_targ != OP_PUSHMARK)
16216                 break;
16217
16218             exlist = (LISTOP *) OpSIBLING(expushmark);
16219             if (!exlist || exlist->op_type != OP_NULL
16220                 || exlist->op_targ != OP_LIST)
16221                 break;
16222
16223             if (exlist->op_last != o) {
16224                 /* Mmm. Was expecting to point back to this op.  */
16225                 break;
16226             }
16227             theirmark = exlist->op_first;
16228             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16229                 break;
16230
16231             if (OpSIBLING(theirmark) != o) {
16232                 /* There's something between the mark and the reverse, eg
16233                    for (1, reverse (...))
16234                    so no go.  */
16235                 break;
16236             }
16237
16238             ourmark = ((LISTOP *)o)->op_first;
16239             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16240                 break;
16241
16242             ourlast = ((LISTOP *)o)->op_last;
16243             if (!ourlast || ourlast->op_next != o)
16244                 break;
16245
16246             rv2av = OpSIBLING(ourmark);
16247             if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16248                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16249                 /* We're just reversing a single array.  */
16250                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16251                 enter->op_flags |= OPf_STACKED;
16252             }
16253
16254             /* We don't have control over who points to theirmark, so sacrifice
16255                ours.  */
16256             theirmark->op_next = ourmark->op_next;
16257             theirmark->op_flags = ourmark->op_flags;
16258             ourlast->op_next = gvop ? gvop : (OP *) enter;
16259             op_null(ourmark);
16260             op_null(o);
16261             enter->op_private |= OPpITER_REVERSED;
16262             iter->op_private |= OPpITER_REVERSED;
16263
16264             oldoldop = NULL;
16265             oldop    = ourlast;
16266             o        = oldop->op_next;
16267             goto redo;
16268             NOT_REACHED; /* NOTREACHED */
16269             break;
16270         }
16271
16272         case OP_QR:
16273         case OP_MATCH:
16274             if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16275                 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16276             }
16277             break;
16278
16279         case OP_RUNCV:
16280             if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16281              && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16282             {
16283                 SV *sv;
16284                 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16285                 else {
16286                     sv = newRV((SV *)PL_compcv);
16287                     sv_rvweaken(sv);
16288                     SvREADONLY_on(sv);
16289                 }
16290                 OpTYPE_set(o, OP_CONST);
16291                 o->op_flags |= OPf_SPECIAL;
16292                 cSVOPo->op_sv = sv;
16293             }
16294             break;
16295
16296         case OP_SASSIGN:
16297             if (OP_GIMME(o,0) == G_VOID
16298              || (  o->op_next->op_type == OP_LINESEQ
16299                 && (  o->op_next->op_next->op_type == OP_LEAVESUB
16300                    || (  o->op_next->op_next->op_type == OP_RETURN
16301                       && !CvLVALUE(PL_compcv)))))
16302             {
16303                 OP *right = cBINOP->op_first;
16304                 if (right) {
16305                     /*   sassign
16306                     *      RIGHT
16307                     *      substr
16308                     *         pushmark
16309                     *         arg1
16310                     *         arg2
16311                     *         ...
16312                     * becomes
16313                     *
16314                     *  ex-sassign
16315                     *     substr
16316                     *        pushmark
16317                     *        RIGHT
16318                     *        arg1
16319                     *        arg2
16320                     *        ...
16321                     */
16322                     OP *left = OpSIBLING(right);
16323                     if (left->op_type == OP_SUBSTR
16324                          && (left->op_private & 7) < 4) {
16325                         op_null(o);
16326                         /* cut out right */
16327                         op_sibling_splice(o, NULL, 1, NULL);
16328                         /* and insert it as second child of OP_SUBSTR */
16329                         op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16330                                     right);
16331                         left->op_private |= OPpSUBSTR_REPL_FIRST;
16332                         left->op_flags =
16333                             (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16334                     }
16335                 }
16336             }
16337             break;
16338
16339         case OP_AASSIGN: {
16340             int l, r, lr, lscalars, rscalars;
16341
16342             /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16343                Note that we do this now rather than in newASSIGNOP(),
16344                since only by now are aliased lexicals flagged as such
16345
16346                See the essay "Common vars in list assignment" above for
16347                the full details of the rationale behind all the conditions
16348                below.
16349
16350                PL_generation sorcery:
16351                To detect whether there are common vars, the global var
16352                PL_generation is incremented for each assign op we scan.
16353                Then we run through all the lexical variables on the LHS,
16354                of the assignment, setting a spare slot in each of them to
16355                PL_generation.  Then we scan the RHS, and if any lexicals
16356                already have that value, we know we've got commonality.
16357                Also, if the generation number is already set to
16358                PERL_INT_MAX, then the variable is involved in aliasing, so
16359                we also have potential commonality in that case.
16360              */
16361
16362             PL_generation++;
16363             /* scan LHS */
16364             lscalars = 0;
16365             l = S_aassign_scan(aTHX_ cLISTOPo->op_last,  FALSE, 1, &lscalars);
16366             /* scan RHS */
16367             rscalars = 0;
16368             r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16369             lr = (l|r);
16370
16371
16372             /* After looking for things which are *always* safe, this main
16373              * if/else chain selects primarily based on the type of the
16374              * LHS, gradually working its way down from the more dangerous
16375              * to the more restrictive and thus safer cases */
16376
16377             if (   !l                      /* () = ....; */
16378                 || !r                      /* .... = (); */
16379                 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16380                 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16381                 || (lscalars < 2)          /* ($x, undef) = ... */
16382             ) {
16383                 NOOP; /* always safe */
16384             }
16385             else if (l & AAS_DANGEROUS) {
16386                 /* always dangerous */
16387                 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16388                 o->op_private |= OPpASSIGN_COMMON_AGG;
16389             }
16390             else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16391                 /* package vars are always dangerous - too many
16392                  * aliasing possibilities */
16393                 if (l & AAS_PKG_SCALAR)
16394                     o->op_private |= OPpASSIGN_COMMON_SCALAR;
16395                 if (l & AAS_PKG_AGG)
16396                     o->op_private |= OPpASSIGN_COMMON_AGG;
16397             }
16398             else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16399                           |AAS_LEX_SCALAR|AAS_LEX_AGG))
16400             {
16401                 /* LHS contains only lexicals and safe ops */
16402
16403                 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16404                     o->op_private |= OPpASSIGN_COMMON_AGG;
16405
16406                 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16407                     if (lr & AAS_LEX_SCALAR_COMM)
16408                         o->op_private |= OPpASSIGN_COMMON_SCALAR;
16409                     else if (   !(l & AAS_LEX_SCALAR)
16410                              && (r & AAS_DEFAV))
16411                     {
16412                         /* falsely mark
16413                          *    my (...) = @_
16414                          * as scalar-safe for performance reasons.
16415                          * (it will still have been marked _AGG if necessary */
16416                         NOOP;
16417                     }
16418                     else if (r  & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16419                         /* if there are only lexicals on the LHS and no
16420                          * common ones on the RHS, then we assume that the
16421                          * only way those lexicals could also get
16422                          * on the RHS is via some sort of dereffing or
16423                          * closure, e.g.
16424                          *    $r = \$lex;
16425                          *    ($lex, $x) = (1, $$r)
16426                          * and in this case we assume the var must have
16427                          *  a bumped ref count. So if its ref count is 1,
16428                          *  it must only be on the LHS.
16429                          */
16430                         o->op_private |= OPpASSIGN_COMMON_RC1;
16431                 }
16432             }
16433
16434             /* ... = ($x)
16435              * may have to handle aggregate on LHS, but we can't
16436              * have common scalars. */
16437             if (rscalars < 2)
16438                 o->op_private &=
16439                         ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16440
16441             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16442                 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16443             break;
16444         }
16445
16446         case OP_REF:
16447             /* see if ref() is used in boolean context */
16448             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16449                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16450             break;
16451
16452         case OP_LENGTH:
16453             /* see if the op is used in known boolean context,
16454              * but not if OA_TARGLEX optimisation is enabled */
16455             if (   (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16456                 && !(o->op_private & OPpTARGET_MY)
16457             )
16458                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16459             break;
16460
16461         case OP_POS:
16462             /* see if the op is used in known boolean context */
16463             if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16464                 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16465             break;
16466
16467         case OP_CUSTOM: {
16468             Perl_cpeep_t cpeep =
16469                 XopENTRYCUSTOM(o, xop_peep);
16470             if (cpeep)
16471                 cpeep(aTHX_ o, oldop);
16472             break;
16473         }
16474
16475         }
16476         /* did we just null the current op? If so, re-process it to handle
16477          * eliding "empty" ops from the chain */
16478         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16479             o->op_opt = 0;
16480             o = oldop;
16481         }
16482         else {
16483             oldoldop = oldop;
16484             oldop = o;
16485         }
16486     }
16487     LEAVE;
16488 }
16489
16490 void
16491 Perl_peep(pTHX_ OP *o)
16492 {
16493     CALL_RPEEP(o);
16494 }
16495
16496 /*
16497 =head1 Custom Operators
16498
16499 =for apidoc Ao||custom_op_xop
16500 Return the XOP structure for a given custom op.  This macro should be
16501 considered internal to C<OP_NAME> and the other access macros: use them instead.
16502 This macro does call a function.  Prior
16503 to 5.19.6, this was implemented as a
16504 function.
16505
16506 =cut
16507 */
16508
16509 XOPRETANY
16510 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16511 {
16512     SV *keysv;
16513     HE *he = NULL;
16514     XOP *xop;
16515
16516     static const XOP xop_null = { 0, 0, 0, 0, 0 };
16517
16518     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16519     assert(o->op_type == OP_CUSTOM);
16520
16521     /* This is wrong. It assumes a function pointer can be cast to IV,
16522      * which isn't guaranteed, but this is what the old custom OP code
16523      * did. In principle it should be safer to Copy the bytes of the
16524      * pointer into a PV: since the new interface is hidden behind
16525      * functions, this can be changed later if necessary.  */
16526     /* Change custom_op_xop if this ever happens */
16527     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16528
16529     if (PL_custom_ops)
16530         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16531
16532     /* assume noone will have just registered a desc */
16533     if (!he && PL_custom_op_names &&
16534         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16535     ) {
16536         const char *pv;
16537         STRLEN l;
16538
16539         /* XXX does all this need to be shared mem? */
16540         Newxz(xop, 1, XOP);
16541         pv = SvPV(HeVAL(he), l);
16542         XopENTRY_set(xop, xop_name, savepvn(pv, l));
16543         if (PL_custom_op_descs &&
16544             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16545         ) {
16546             pv = SvPV(HeVAL(he), l);
16547             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16548         }
16549         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16550     }
16551     else {
16552         if (!he)
16553             xop = (XOP *)&xop_null;
16554         else
16555             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16556     }
16557     {
16558         XOPRETANY any;
16559         if(field == XOPe_xop_ptr) {
16560             any.xop_ptr = xop;
16561         } else {
16562             const U32 flags = XopFLAGS(xop);
16563             if(flags & field) {
16564                 switch(field) {
16565                 case XOPe_xop_name:
16566                     any.xop_name = xop->xop_name;
16567                     break;
16568                 case XOPe_xop_desc:
16569                     any.xop_desc = xop->xop_desc;
16570                     break;
16571                 case XOPe_xop_class:
16572                     any.xop_class = xop->xop_class;
16573                     break;
16574                 case XOPe_xop_peep:
16575                     any.xop_peep = xop->xop_peep;
16576                     break;
16577                 default:
16578                     NOT_REACHED; /* NOTREACHED */
16579                     break;
16580                 }
16581             } else {
16582                 switch(field) {
16583                 case XOPe_xop_name:
16584                     any.xop_name = XOPd_xop_name;
16585                     break;
16586                 case XOPe_xop_desc:
16587                     any.xop_desc = XOPd_xop_desc;
16588                     break;
16589                 case XOPe_xop_class:
16590                     any.xop_class = XOPd_xop_class;
16591                     break;
16592                 case XOPe_xop_peep:
16593                     any.xop_peep = XOPd_xop_peep;
16594                     break;
16595                 default:
16596                     NOT_REACHED; /* NOTREACHED */
16597                     break;
16598                 }
16599             }
16600         }
16601         /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16602          * op.c: In function 'Perl_custom_op_get_field':
16603          * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16604          * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16605          * expands to assert(0), which expands to ((0) ? (void)0 :
16606          * __assert(...)), and gcc doesn't know that __assert can never return. */
16607         return any;
16608     }
16609 }
16610
16611 /*
16612 =for apidoc Ao||custom_op_register
16613 Register a custom op.  See L<perlguts/"Custom Operators">.
16614
16615 =cut
16616 */
16617
16618 void
16619 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16620 {
16621     SV *keysv;
16622
16623     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16624
16625     /* see the comment in custom_op_xop */
16626     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16627
16628     if (!PL_custom_ops)
16629         PL_custom_ops = newHV();
16630
16631     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16632         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16633 }
16634
16635 /*
16636
16637 =for apidoc core_prototype
16638
16639 This function assigns the prototype of the named core function to C<sv>, or
16640 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
16641 C<NULL> if the core function has no prototype.  C<code> is a code as returned
16642 by C<keyword()>.  It must not be equal to 0.
16643
16644 =cut
16645 */
16646
16647 SV *
16648 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16649                           int * const opnum)
16650 {
16651     int i = 0, n = 0, seen_question = 0, defgv = 0;
16652     I32 oa;
16653 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16654     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16655     bool nullret = FALSE;
16656
16657     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16658
16659     assert (code);
16660
16661     if (!sv) sv = sv_newmortal();
16662
16663 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16664
16665     switch (code < 0 ? -code : code) {
16666     case KEY_and   : case KEY_chop: case KEY_chomp:
16667     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
16668     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
16669     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
16670     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
16671     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
16672     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
16673     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
16674     case KEY_x     : case KEY_xor    :
16675         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16676     case KEY_glob:    retsetpvs("_;", OP_GLOB);
16677     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
16678     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
16679     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
16680     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
16681     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16682         retsetpvs("", 0);
16683     case KEY_evalbytes:
16684         name = "entereval"; break;
16685     case KEY_readpipe:
16686         name = "backtick";
16687     }
16688
16689 #undef retsetpvs
16690
16691   findopnum:
16692     while (i < MAXO) {  /* The slow way. */
16693         if (strEQ(name, PL_op_name[i])
16694             || strEQ(name, PL_op_desc[i]))
16695         {
16696             if (nullret) { assert(opnum); *opnum = i; return NULL; }
16697             goto found;
16698         }
16699         i++;
16700     }
16701     return NULL;
16702   found:
16703     defgv = PL_opargs[i] & OA_DEFGV;
16704     oa = PL_opargs[i] >> OASHIFT;
16705     while (oa) {
16706         if (oa & OA_OPTIONAL && !seen_question && (
16707               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16708         )) {
16709             seen_question = 1;
16710             str[n++] = ';';
16711         }
16712         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16713             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16714             /* But globs are already references (kinda) */
16715             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16716         ) {
16717             str[n++] = '\\';
16718         }
16719         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16720          && !scalar_mod_type(NULL, i)) {
16721             str[n++] = '[';
16722             str[n++] = '$';
16723             str[n++] = '@';
16724             str[n++] = '%';
16725             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16726             str[n++] = '*';
16727             str[n++] = ']';
16728         }
16729         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16730         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16731             str[n-1] = '_'; defgv = 0;
16732         }
16733         oa = oa >> 4;
16734     }
16735     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16736     str[n++] = '\0';
16737     sv_setpvn(sv, str, n - 1);
16738     if (opnum) *opnum = i;
16739     return sv;
16740 }
16741
16742 OP *
16743 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16744                       const int opnum)
16745 {
16746     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16747     OP *o;
16748
16749     PERL_ARGS_ASSERT_CORESUB_OP;
16750
16751     switch(opnum) {
16752     case 0:
16753         return op_append_elem(OP_LINESEQ,
16754                        argop,
16755                        newSLICEOP(0,
16756                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16757                                   newOP(OP_CALLER,0)
16758                        )
16759                );
16760     case OP_EACH:
16761     case OP_KEYS:
16762     case OP_VALUES:
16763         o = newUNOP(OP_AVHVSWITCH,0,argop);
16764         o->op_private = opnum-OP_EACH;
16765         return o;
16766     case OP_SELECT: /* which represents OP_SSELECT as well */
16767         if (code)
16768             return newCONDOP(
16769                          0,
16770                          newBINOP(OP_GT, 0,
16771                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16772                                   newSVOP(OP_CONST, 0, newSVuv(1))
16773                                  ),
16774                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
16775                                     OP_SSELECT),
16776                          coresub_op(coreargssv, 0, OP_SELECT)
16777                    );
16778         /* FALLTHROUGH */
16779     default:
16780         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16781         case OA_BASEOP:
16782             return op_append_elem(
16783                         OP_LINESEQ, argop,
16784                         newOP(opnum,
16785                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
16786                                 ? OPpOFFBYONE << 8 : 0)
16787                    );
16788         case OA_BASEOP_OR_UNOP:
16789             if (opnum == OP_ENTEREVAL) {
16790                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16791                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16792             }
16793             else o = newUNOP(opnum,0,argop);
16794             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16795             else {
16796           onearg:
16797               if (is_handle_constructor(o, 1))
16798                 argop->op_private |= OPpCOREARGS_DEREF1;
16799               if (scalar_mod_type(NULL, opnum))
16800                 argop->op_private |= OPpCOREARGS_SCALARMOD;
16801             }
16802             return o;
16803         default:
16804             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16805             if (is_handle_constructor(o, 2))
16806                 argop->op_private |= OPpCOREARGS_DEREF2;
16807             if (opnum == OP_SUBSTR) {
16808                 o->op_private |= OPpMAYBE_LVSUB;
16809                 return o;
16810             }
16811             else goto onearg;
16812         }
16813     }
16814 }
16815
16816 void
16817 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16818                                SV * const *new_const_svp)
16819 {
16820     const char *hvname;
16821     bool is_const = !!CvCONST(old_cv);
16822     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16823
16824     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16825
16826     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16827         return;
16828         /* They are 2 constant subroutines generated from
16829            the same constant. This probably means that
16830            they are really the "same" proxy subroutine
16831            instantiated in 2 places. Most likely this is
16832            when a constant is exported twice.  Don't warn.
16833         */
16834     if (
16835         (ckWARN(WARN_REDEFINE)
16836          && !(
16837                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16838              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16839              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16840                  strEQ(hvname, "autouse"))
16841              )
16842         )
16843      || (is_const
16844          && ckWARN_d(WARN_REDEFINE)
16845          && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16846         )
16847     )
16848         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16849                           is_const
16850                             ? "Constant subroutine %" SVf " redefined"
16851                             : "Subroutine %" SVf " redefined",
16852                           SVfARG(name));
16853 }
16854
16855 /*
16856 =head1 Hook manipulation
16857
16858 These functions provide convenient and thread-safe means of manipulating
16859 hook variables.
16860
16861 =cut
16862 */
16863
16864 /*
16865 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16866
16867 Puts a C function into the chain of check functions for a specified op
16868 type.  This is the preferred way to manipulate the L</PL_check> array.
16869 C<opcode> specifies which type of op is to be affected.  C<new_checker>
16870 is a pointer to the C function that is to be added to that opcode's
16871 check chain, and C<old_checker_p> points to the storage location where a
16872 pointer to the next function in the chain will be stored.  The value of
16873 C<new_checker> is written into the L</PL_check> array, while the value
16874 previously stored there is written to C<*old_checker_p>.
16875
16876 L</PL_check> is global to an entire process, and a module wishing to
16877 hook op checking may find itself invoked more than once per process,
16878 typically in different threads.  To handle that situation, this function
16879 is idempotent.  The location C<*old_checker_p> must initially (once
16880 per process) contain a null pointer.  A C variable of static duration
16881 (declared at file scope, typically also marked C<static> to give
16882 it internal linkage) will be implicitly initialised appropriately,
16883 if it does not have an explicit initialiser.  This function will only
16884 actually modify the check chain if it finds C<*old_checker_p> to be null.
16885 This function is also thread safe on the small scale.  It uses appropriate
16886 locking to avoid race conditions in accessing L</PL_check>.
16887
16888 When this function is called, the function referenced by C<new_checker>
16889 must be ready to be called, except for C<*old_checker_p> being unfilled.
16890 In a threading situation, C<new_checker> may be called immediately,
16891 even before this function has returned.  C<*old_checker_p> will always
16892 be appropriately set before C<new_checker> is called.  If C<new_checker>
16893 decides not to do anything special with an op that it is given (which
16894 is the usual case for most uses of op check hooking), it must chain the
16895 check function referenced by C<*old_checker_p>.
16896
16897 Taken all together, XS code to hook an op checker should typically look
16898 something like this:
16899
16900     static Perl_check_t nxck_frob;
16901     static OP *myck_frob(pTHX_ OP *op) {
16902         ...
16903         op = nxck_frob(aTHX_ op);
16904         ...
16905         return op;
16906     }
16907     BOOT:
16908         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16909
16910 If you want to influence compilation of calls to a specific subroutine,
16911 then use L</cv_set_call_checker_flags> rather than hooking checking of
16912 all C<entersub> ops.
16913
16914 =cut
16915 */
16916
16917 void
16918 Perl_wrap_op_checker(pTHX_ Optype opcode,
16919     Perl_check_t new_checker, Perl_check_t *old_checker_p)
16920 {
16921     dVAR;
16922
16923     PERL_UNUSED_CONTEXT;
16924     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16925     if (*old_checker_p) return;
16926     OP_CHECK_MUTEX_LOCK;
16927     if (!*old_checker_p) {
16928         *old_checker_p = PL_check[opcode];
16929         PL_check[opcode] = new_checker;
16930     }
16931     OP_CHECK_MUTEX_UNLOCK;
16932 }
16933
16934 #include "XSUB.h"
16935
16936 /* Efficient sub that returns a constant scalar value. */
16937 static void
16938 const_sv_xsub(pTHX_ CV* cv)
16939 {
16940     dXSARGS;
16941     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
16942     PERL_UNUSED_ARG(items);
16943     if (!sv) {
16944         XSRETURN(0);
16945     }
16946     EXTEND(sp, 1);
16947     ST(0) = sv;
16948     XSRETURN(1);
16949 }
16950
16951 static void
16952 const_av_xsub(pTHX_ CV* cv)
16953 {
16954     dXSARGS;
16955     AV * const av = MUTABLE_AV(XSANY.any_ptr);
16956     SP -= items;
16957     assert(av);
16958 #ifndef DEBUGGING
16959     if (!av) {
16960         XSRETURN(0);
16961     }
16962 #endif
16963     if (SvRMAGICAL(av))
16964         Perl_croak(aTHX_ "Magical list constants are not supported");
16965     if (GIMME_V != G_ARRAY) {
16966         EXTEND(SP, 1);
16967         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
16968         XSRETURN(1);
16969     }
16970     EXTEND(SP, AvFILLp(av)+1);
16971     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
16972     XSRETURN(AvFILLp(av)+1);
16973 }
16974
16975
16976 /*
16977  * ex: set ts=8 sts=4 sw=4 et:
16978  */